c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module action  --  total number of each energy term type  ##
c     ##                                                            ##
c     ################################################################
c
c
c     neb     number of bond stretch energy terms computed
c     nea     number of angle bend energy terms computed
c     neba    number of stretch-bend energy terms computed
c     neub    number of Urey-Bradley energy terms computed
c     neaa    number of angle-angle energy terms computed
c     neopb   number of out-of-plane bend energy terms computed
c     neopd   number of out-of-plane distance energy terms computed
c     neid    number of improper dihedral energy terms computed
c     neit    number of improper torsion energy terms computed
c     net     number of torsional energy terms computed
c     nept    number of pi-system torsion energy terms computed
c     nebt    number of stretch-torsion energy terms computed
c     neat    number of angle-torsion energy terms computed
c     nett    number of torsion-torsion energy terms computed
c     nev     number of van der Waals energy terms computed
c     ner     number of Pauli repulsion energy terms computed
c     nedsp   number of dispersion energy terms computed
c     nec     number of charge-charge energy terms computed
c     necd    number of charge-dipole energy terms computed
c     ned     number of dipole-dipole energy terms computed
c     nem     number of multipole energy terms computed
c     nep     number of polarization energy terms computed
c     nect    number of charge transfer energy terms computed
c     new     number of Ewald summation energy terms computed
c     nerxf   number of reaction field energy terms computed
c     nes     number of solvation energy terms computed
c     nelf    number of metal ligand field energy terms computed
c     neg     number of geometric restraint energy terms computed
c     nex     number of extra energy terms computed
c
c
      module action
      implicit none
      integer neb,nea,neba,neub
      integer neaa,neopb,neopd
      integer neid,neit,net,nept
      integer nebt,neat,nett,nev
      integer ner,nedsp,nec,necd
      integer ned,nem,nep,nect
      integer new,nerxf,nes,nelf
      integer neg,nex
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine active  --  set the list of active atoms  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "active" sets the list of atoms that are used during
c     coordinate manipulation or potential energy calculations
c
c
      subroutine active
      use atoms
      use inform
      use iounit
      use keys
      use usage
      implicit none
      integer i,j,next
      integer nmobile,nfixed
      integer center,nsphere
      integer, allocatable :: mobile(:)
      integer, allocatable :: fixed(:)
      real*8 xcenter,ycenter,zcenter
      real*8 radius,radius2,dist2
      character*20 keyword
      character*240 record
      character*240 string
      logical header
c
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(iuse))  deallocate (iuse)
      if (allocated(use))  deallocate (use)
      allocate (iuse(n))
      allocate (use(0:n))
c
c     perform dynamic allocation of some local arrays
c
      allocate (mobile(n))
      allocate (fixed(n))
c
c     set defaults for the numbers and lists of active atoms
c
      nuse = n
      use(0) = .false.
      do i = 1, n
         use(i) = .true.
      end do
      nmobile = 0
      nfixed = 0
      do i = 1, n
         mobile(i) = 0
         fixed(i) = 0
      end do
      nsphere = 0
c
c     get any keywords containing active atom parameters
c
      do j = 1, nkey
         next = 1
         record = keyline(j)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
c
c     get any lists of atoms whose coordinates are active
c
         if (keyword(1:7) .eq. 'ACTIVE ') then
            read (string,*,err=10,end=10)  (mobile(i),i=nmobile+1,n)
   10       continue
            do while (mobile(nmobile+1) .ne. 0)
               nmobile = nmobile + 1
            end do
c
c     get any lists of atoms whose coordinates are inactive
c
         else if (keyword(1:9) .eq. 'INACTIVE ') then
            read (string,*,err=20,end=20)  (fixed(i),i=nfixed+1,n)
   20       continue
            do while (fixed(nfixed+1) .ne. 0)
               nfixed = nfixed + 1
            end do
c
c     get the center and radius of the sphere of active atoms
c
         else if (keyword(1:14) .eq. 'ACTIVE-SPHERE ') then
            center = 0
            xcenter = 0.0d0
            ycenter = 0.0d0
            zcenter = 0.0d0
            radius = 0.0d0
            read (string,*,err=30,end=30)  xcenter,ycenter,
     &                                     zcenter,radius
   30       continue
            if (radius .eq. 0.0d0) then
               read (string,*,err=60,end=60)  center,radius
               xcenter = x(center)
               ycenter = y(center)
               zcenter = z(center)
            end if
            nsphere = nsphere + 1
            if (nsphere .eq. 1) then
               nuse = 0
               do i = 1, n
                  use(i) = .false.
               end do
               if (verbose) then
                  write (iout,40)
   40             format (/,' Spheres used to Select Active Atoms :',
     &                    //,3x,'Atom Center',11x,'Coordinates',
     &                       12x,'Radius',6x,'# Active Atoms')
               end if
            end if
            radius2 = radius * radius
            do i = 1, n
               if (.not. use(i)) then
                  dist2 = (x(i)-xcenter)**2 + (y(i)-ycenter)**2
     &                            + (z(i)-zcenter)**2
                  if (dist2 .le. radius2) then
                     nuse = nuse + 1
                     use(i) = .true.
                  end if
               end if
            end do
            if (verbose) then
               write (iout,50)  center,xcenter,ycenter,
     &                          zcenter,radius,nuse
   50          format (2x,i8,6x,3f9.2,2x,f9.2,7x,i8)
            end if
   60       continue
         end if
      end do
c
c     remove active or inactive atoms not in the system
c
      header = .true.
      do i = 1, n
         if (abs(mobile(i)) .gt. n) then
            mobile(i) = 0
            if (header) then
               header = .false.
               write (iout,70)
   70          format (/,' ACTIVE  --  Warning, Illegal Atom Number',
     &                    ' in ACTIVE Atom List')
            end if
         end if
      end do
      header = .true.
      do i = 1, n
         if (abs(fixed(i)) .gt. n) then
            fixed(i) = 0
            if (header) then
               header = .false.
               write (iout,80)
   80          format (/,' ACTIVE  --  Warning, Illegal Atom Number',
     &                    ' in INACTIVE Atom List')
            end if
         end if
      end do
c
c     set active atoms to those marked as not inactive
c
      i = 1
      do while (fixed(i) .ne. 0)
         if (fixed(i) .gt. 0) then
            j = fixed(i)
            if (use(j)) then
               use(fixed(i)) = .false.
               nuse = nuse - 1
            end if
            i = i + 1
         else
            do j = abs(fixed(i)), abs(fixed(i+1))
               if (use(j)) then
                  use(j) = .false.
                  nuse = nuse - 1
               end if
            end do
            i = i + 2
         end if
      end do
c
c     set active atoms to only those marked as active
c
      i = 1
      do while (mobile(i) .ne. 0)
         if (i .eq. 1) then
            nuse = 0
            do j = 1, n
               use(j) = .false.
            end do
         end if
         if (mobile(i) .gt. 0) then
            j = mobile(i)
            if (.not. use(j)) then
               use(j) = .true.
               nuse = nuse + 1
            end if
            i = i + 1
         else
            do j = abs(mobile(i)), abs(mobile(i+1))
               if (.not. use(j)) then
                  use(j) = .true.
                  nuse = nuse + 1
               end if
            end do
            i = i + 2
         end if
      end do
c
c     use logical array to set the list of active atoms
c
      j = 0
      do i = 1, n
         if (use(i)) then
            j = j + 1
            iuse(j) = i
         end if
      end do
c
c     output the final list of the active atoms
c
      if (debug .and. nuse.gt.0 .and. nuse.lt.n) then
         write (iout,90)
   90    format (/,' List of Active Atoms for Energy',
     &              ' Calculations :',/)
         write (iout,100)  (iuse(i),i=1,nuse)
  100    format (3x,10i7)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mobile)
      deallocate (fixed)
      return
      end
c
c
c     ###############################################################
c     ##  COPYRIGHT (C) 1991 by Shawn Huston & Jay William Ponder  ##
c     ##                    All Rights Reserved                    ##
c     ###############################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  program alchemy  --  perform free energy perturbation  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "alchemy" computes the free energy difference corresponding
c     to a small perturbation by Boltzmann weighting the potential
c     energy difference over a number of sample states; current
c     version (incorrectly) considers the charge energy to be
c     intermolecular in finding the perturbation energies
c
c     variables and parameters:
c
c     nlamb        number of lambda values for energy computation
c     delta        step size for the perturbation in lambda
c     nstep        number of steps over which to calculate averages
c
c     deplus       energy change for postive delta lambda
c     deminus      energy change for negative delta lambda
c     sdep,sdem    accumulated energy changes
c     adep,adem    (running) average energy changes
c     adapb,adamb  average over block averages of free energy changes
c     bdep,bdem    (block) accumulated energy changes
c     badep,badem  (block) average energy changes
c     vdep,vdem    SD of energy changes from variance of subaverages
c     fdep,fdem    fluctuations of perturbation energies
c     se_ap,se_am  standard error of free energy changes
c
c
      program alchemy
      use analyz
      use atoms
      use energi
      use files
      use inform
      use iounit
      use katoms
      use mutant
      use potent
      use units
      use usage
      implicit none
      integer i,j,k,ixyz,start,stop
      integer lext,next,freeunit
      integer istep,ilamb,nlamb
      integer nstep,modstep
      integer nblock,modblock
      real*8 delta,lam0,lamp,lamm
      real*8 rt,e0,energy
      real*8 pos,neg,temp
      real*8 eplus,eminus
      real*8 deplus,deminus
      real*8 sdep,s2dep,sdep2
      real*8 sdem,s2dem,sdem2
      real*8 spos,bpos,sdapb
      real*8 sneg,bneg,sdamb
      real*8 bdep,adep,a2dep,adep2
      real*8 bdem,adem,a2dem,adem2
      real*8 da,dap,dam,adapb,adamb
      real*8 v,vdap,vdam,vdep,vdem
      real*8 fdep,fdem,bda
      real*8 se_ep,se_em,se_ap,se_am
      real*8 eb0,ebpos,ebneg
      real*8 ea0,eapos,eaneg
      real*8 eit0,eitpos,eitneg
      real*8 et0,etpos,etneg
      real*8 ev0,evpos,evneg
      real*8 ec0,ecpos,ecneg
      real*8 sbp,sap,sitp,stp,svp,scp
      real*8 sbm,sam,sitm,stm,svm,scm
      real*8 abp,aap,aitp,atp,avp,acp
      real*8 abm,aam,aitm,atm,avm,acm
      real*8, allocatable :: badep(:)
      real*8, allocatable :: badem(:)
      real*8, allocatable :: bdap(:)
      real*8, allocatable :: bdam(:)
      real*8, allocatable :: nrg(:,:)
      real*8, allocatable :: cb(:,:)
      real*8, allocatable :: ca(:,:)
      real*8, allocatable :: cit(:,:)
      real*8, allocatable :: ct(:,:)
      real*8, allocatable :: cv(:,:)
      real*8, allocatable :: cc(:,:)
      logical dogeom
      character*1 answer
      character*7 ext
      character*240 xyzfile
      character*240 record
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     get the numbers of the files to be used
c
      start = 0
      stop = 0
      write (iout,10)
   10 format (/,' Numbers of First and Last File to Analyze :  ',$)
      read (input,20)  record
   20 format (a240)
      read (record,*,err=30,end=30)  start,stop
   30 continue
      if (start .eq. 0)  start = 1
      if (stop .eq. 0)  stop = start
      nstep = stop - start + 1
c
c     obtain the lambda values to be calculated
c
      delta = 0.0d0
      write (iout,40)
   40 format (/,' Enter the Lambda Increment for FEP :  ',$)
      read (input,50)  delta
   50 format (f7.4)
      nlamb = 3
      lam0 = lambda
      lamp = min(1.0d0,lambda+delta)
      lamm = max(0.0d0,lambda-delta)
c
c     obtain the target temperature value
c
      temp = 0.0d0
      write (iout,60)
   60 format (/,' Enter the System Temperature [300 K] :  ',$)
      read (input,70)  temp
   70 format (f20.0)
      if (temp .eq. 0.0d0)  temp = 300.0d0
      rt = gasconst * temp
c
c     set number of steps for running averages and block averages
c
      nblock = 0
      write (iout,80)
   80 format (/,' Enter Number of Blocks for Sub-Averages [1] :  ',$)
      read (input,90)  nblock
   90 format (i10)
      if (nblock .eq. 0)  nblock = 1
      nblock = nstep / nblock
c
c     decide whether to include the intramolecular energies
c
      dogeom = .true.
      write (iout,100)
  100 format (/,' Consider only Intermolecular Perturbation',
     &           ' Energy [N] :  ',$)
      read (input,110)  record
  110 format (a240)
      next = 1
      call gettext (record,answer,next)
      call upcase (answer)
      if (answer .eq. 'Y')  dogeom = .false.
      if (dogeom) then
         write (iout,120)
  120    format (/,' Calculation will Involve Full Perturbation',
     &              ' Energy ')
      else
         write (iout,130)
  130    format (/,' Calculation will Consider Only Intermolecular',
     &              ' Interactions ')
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (badep(nblock))
      allocate (badem(nblock))
      allocate (bdap(nblock))
      allocate (bdam(nblock))
      allocate (nrg(3,nstep))
      allocate (cb(3,nstep))
      allocate (ca(3,nstep))
      allocate (cit(3,nstep))
      allocate (ct(3,nstep))
      allocate (cv(3,nstep))
      allocate (cc(3,nstep))
c
c     zero out block average potential and free energy changes
c
      do i = 1, nblock
         badep(i) = 0.0d0
         badem(i) = 0.0d0
         bdap(i) = 0.0d0
         bdam(i) = 0.0d0
      end do
c
c     cycle over the coordinate files once per lambda value
c
      do ilamb = 1, nlamb
         i = start
         istep = 0
         if (ilamb .eq. 2)  lambda = lamp
         if (ilamb .eq. 3)  lambda = lamm
         call hybrid
c
c     read in the next molecular dynamics coordinate frame
c
         do while (i.ge.start .and. i.le.stop)
            istep = istep + 1
            lext = 3
            call numeral (i,ext,lext)
            xyzfile = filename(1:leng)//'.'//ext(1:lext)
            call version (xyzfile,'old')
            ixyz = freeunit ()
            open (unit=ixyz,file=xyzfile,status='old',err=160)
            call readxyz (ixyz)
            close (unit=ixyz)
            call hatom
c
c     select interactions for perturbation energy calculation
c
            do j = 1, n
               use(j) = .false.
            end do
            do j = 1, nmut
               use(imut(j)) = .true.
            end do
            if (.not. dogeom) then
               use_bond = .false.
               use_angle = .false.
               use_strbnd = .false.
               use_urey = .false.
               use_imptor = .false.
               use_tors = .false.
               use_strtor = .false.
            end if
c
c     compute and store energy components for the current lambda
c
            nrg(ilamb,istep) = energy ()
            cb(ilamb,istep) = eb
            ca(ilamb,istep) = ea
            cit(ilamb,istep) = eit
            ct(ilamb,istep) = et
            cv(ilamb,istep) = ev
            cc(ilamb,istep) = ec
            if (verbose) then
               if (istep .eq. 1) then
                  write (iout,140)
  140             format (/,2x,'Step',7x,'EB',9x,'EA',8x,'EIT',
     &                       9x,'ET',10x,'EV',10x,'EC',/)
               end if
               write (iout,150)  istep,eb,ea,eit,et,ev,ec
  150          format (i6,4f11.4,2f12.4)
            end if
  160       continue
            i = i + 1
         end do
      end do
      nstep = istep
c
c     get free energy change by averaging over all frames
c
      do istep = 1, nstep
         e0 = nrg(1,istep)
         eplus = nrg(2,istep)
         eminus = nrg(3,istep)
         ev0 = cv(1,istep)
         evpos = cv(2,istep)
         evneg = cv(3,istep)
         ec0 = cc(1,istep)
         ecpos = cc(2,istep)
         ecneg = cc(3,istep)
         if (dogeom) then
            eb0 = cb(1,istep)
            ebpos = cb(2,istep)
            ebneg = cb(3,istep)
            ea0 = ca(1,istep)
            eapos = ca(2,istep)
            eaneg = ca(3,istep)
            eit0 = cit(1,istep)
            eitpos = cit(2,istep)
            eitneg = cit(3,istep)
            et0 = ct(1,istep)
            etpos = ct(2,istep)
            etneg = ct(3,istep)
         end if
         modstep = mod(istep-1,nstep)
         modblock = mod(istep-1,nblock)
c
c     zero out summation variables for new running average
c
         if (modstep .eq. 0) then
            sdep = 0.0d0
            s2dep = 0.0d0
            sdep2 = 0.0d0
            sdem = 0.0d0
            s2dem = 0.0d0
            sdem2 = 0.0d0
            spos = 0.0d0
            sneg = 0.0d0
            sdapb = 0.0d0
            sdamb = 0.0d0
            sbp = 0.0d0
            sbm = 0.0d0
            sap = 0.0d0
            sam = 0.0d0
            sitp = 0.0d0
            sitm = 0.0d0
            stp = 0.0d0
            stm = 0.0d0
            svp = 0.0d0
            svm = 0.0d0
            scp = 0.0d0
            scm = 0.0d0
            fdep = 0.0d0
            fdem = 0.0d0
            vdep = 0.0d0
            vdem = 0.0d0
            vdap = 0.0d0
            vdam = 0.0d0
            k = 0
         end if
c
c     zero out summation variables for new block average
c
         if (modblock .eq. 0) then
            bdep = 0.0d0
            bdem = 0.0d0
            bpos = 0.0d0
            bneg = 0.0d0
         end if
         modstep = mod(istep,nstep)
         modblock = mod(istep,nblock)
c
c     accumulate statistics
c
         deplus = eplus - e0
         deminus = eminus - e0
         if (verbose) then
            if (modblock.eq.1 .or. nblock.eq.1) then
               write (iout,170)
  170          format (/,2x,'Step',12x,'E0',11x,'EP',11x,'EM',
     &                    11x,'DEP',10x,'DEM',/)
            end if
            write (iout,180)  istep,e0,eplus,eminus,deplus,deminus
  180       format (i6,3x,5f13.4)
         end if
         pos = exp(-deplus/rt)
         neg = exp(-deminus/rt)
         bdep = bdep + deplus
         bdem = bdem + deminus
         bpos = bpos + pos
         bneg = bneg + neg
         sdep = sdep + deplus
         sdem = sdem + deminus
         s2dep = s2dep + deplus*deplus
         s2dem = s2dem + deminus*deminus
         spos = spos + pos
         sneg = sneg + neg
         svp = svp + evpos - ev0
         svm = svm + evneg - ev0
         scp = scp + ecpos - ec0
         scm = scm + ecneg - ec0
         if (dogeom) then
            sbp = sbp + ebpos - eb0
            sbm = sbm + ebneg - eb0
            sap = sap + eapos - ea0
            sam = sam + eaneg - ea0
            sitp = sitp + eitpos - eit0
            sitm = sitm + eitneg - eit0
            stp = stp + etpos - et0
            stm = stm + etneg - et0
         end if
c
c     calculate block averages
c
         if (modblock .eq. 0) then
            k = k + 1
            badep(k) = bdep / dble(nblock)
            badem(k) = bdem / dble(nblock)
            bda = bpos / dble(nblock)
            bda = -rt * log(bda)
            bdap(k) = bdap(k) +  bda
            bda = bneg / dble(nblock)
            bda = -rt * log(bda)
            bdam(k) = bdam(k) + bda
            sdapb = sdapb + bdap(k)
            sdamb = sdamb + bdam(k)
            if (verbose .or. k.eq.1) then
               write (iout,190)
  190          format (/,2x,'Block',9x,'NStep',9x,'BADEP',
     &                    8x,'BADEM',9x,'BDAP',9x,'BDAM',/)
            end if
            write (iout,200)  k,istep,badep(k),badem(k),
     &                        bdap(k),bdam(k)
  200       format (i6,8x,i6,2x,4f13.4)
         end if
c
c     calculate running averages for potential energy
c
         if (modstep .eq. 0) then
            adep = sdep / dble(nstep)
            adem = sdem / dble(nstep)
            a2dep = s2dep / dble(nstep)
            a2dem = s2dem / dble(nstep)
            adep2 = adep * adep
            adem2 = adem * adem
            fdep = sqrt(a2dep - adep2)
            fdem = sqrt(a2dem - adem2)
            do k = 1, nstep / nblock
               v = (badep(k) - adep)**2
               vdep = vdep + v
               v = (badem(k) - adem)**2
               vdem = vdem + v
            end do
            vdep = vdep / dble(nstep/nblock)
            se_ep = sqrt(vdep / dble(nstep/nblock))
            vdem = vdem / dble(nstep/nblock)
            se_em = sqrt(vdem / dble(nstep/nblock))
c
c     calculate running averages for free energy
c
            da = spos / dble(nstep)
            da = -rt * log (da)
            dap = da
            da = sneg / dble(nstep)
            da = -rt * log (da)
            dam = da
            adapb = sdapb / dble(nstep/nblock)
            adamb = sdamb / dble(nstep/nblock)
            do k = 1, nstep/nblock
               v = (bdap(k) - adapb)**2
               vdap = vdap + v
               v = (bdam(k) - adamb)**2
               vdam = vdam + v
            end do
            vdap = vdap / dble(nstep/nblock)
            se_ap = sqrt(vdap / dble(nstep/nblock))
            vdam = vdam / dble(nstep/nblock)
            se_am = sqrt(vdam / dble(nstep/nblock))
c
c     calculate running averages for energy components
c
            avp = svp / dble(nstep)
            avm = svm / dble(nstep)
            acp = scp / dble(nstep)
            acm = scm / dble(nstep)
            if (dogeom) then
               abp = sbp / dble(nstep)
               abm = sbm / dble(nstep)
               aap = sap / dble(nstep)
               aam = sam / dble(nstep)
               aitp = sitp / dble(nstep)
               aitm = sitm / dble(nstep)
               atp = stp / dble(nstep)
               atm = stm / dble(nstep)
            end if
            sdep = 0.0d0
            sdem = 0.0d0
c
c     write information about running averages and block averages
c
            write (iout,210)  nstep,nstep/nblock
  210       format (/,' Running Averages over',i5,' Steps',
     &                 ' with Std Error from',i4,' Blocks :')
            write (iout,220)
  220       format (/,' Free Energy :')
            write (iout,230)  dap,se_ap
  230       format (/,' DA(+) =',f12.4,' with Std Error',f10.4)
            write (iout,240)  dam,se_am
  240       format (' DA(-) =',f12.4,' with Std Error',f10.4)
            write (iout,250)
  250       format (/,' Potential Energy :')
            write (iout,260)  adep,fdep,se_ep
  260       format (/,' DE(+) =',f12.4,' with Fluct',f10.4,
     &                 ' and Std Error',f10.4)
            write (iout,270)  adem,fdem,se_em
  270       format (' DE(-) =',f12.4,' with Fluct',f10.4,
     &                 ' and Std Error',f10.4)
            write (iout,280)
  280       format (/,' Component Energies :',/)
            if (dogeom) then
               write (iout,290)  abp,abm
  290          format (' BOND  +/- :',f12.4,5x,f12.4)
               write (iout,300)  aap,aam
  300          format (' ANGLE +/- :',f12.4,5x,f12.4)
               write (iout,310)  aitp,aitm
  310          format (' IMPT  +/- :',f12.4,5x,f12.4)
               write (iout,320)  atp,atm
  320          format (' TORS  +/- :',f12.4,5x,f12.4)
            end if
            write (iout,330)  avp,avm
  330       format (' VDW   +/- :',f12.4,5x,f12.4)
            write (iout,340)  acp,acm
  340       format (' CHG   +/- :',f12.4,5x,f12.4)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (badep)
      deallocate (badem)
      deallocate (bdap)
      deallocate (bdam)
      deallocate (nrg)
      deallocate (cb)
      deallocate (ca)
      deallocate (cit)
      deallocate (ct)
      deallocate (cv)
      deallocate (cc)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     #########################################################
c     ##  COPYRIGHT (C) 2024 by Moses Chung & Jay W. Ponder  ##
c     ##                 All Rights Reserved                 ##
c     #########################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module alfmol  --  AlphaMol area and volume information  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     alfthread  number of OpenMP threads to use for AlphaMol2
c     delcxeps   eps value for AlphaMol Delaunay triangulation
c     alfhydro   logical flag to include hydrogen atoms in AlphaMol
c     alfsosgmp  logical flag governing use of SoS GMP in AlphaMol
c     alfmethod  set AlphaMol1 or AlphaMol2 (SINGLE or MULTI threaded)
c     alfsort    set sort method (NONE, SORT3D, BRIO, SPLIT, KDTREE)
c
c
      module alfmol
      implicit none
      integer alfthread
      real*8 delcxeps
      logical alfhydro
      logical alfsosgmp
      character*6 alfmethod
      character*6 alfsort
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module align  --  information for structure superposition  ##
c     ##                                                             ##
c     #################################################################
c
c
c     nfit    number of atoms to use in superimposing two structures
c     ifit    atom numbers of pairs of atoms to be superimposed
c     wfit    weights assigned to atom pairs during superposition
c
c
      module align
      implicit none
      integer nfit
      integer, allocatable :: ifit(:,:)
      real*8, allocatable :: wfit(:)
      save
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2020 by Chengwen Liu & Jay W. Ponder  ##
c     ##                 All Rights Reserved                  ##
c     ##########################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine alterchg  --  modification of partial charges  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "alterchg" calculates the change in atomic partial charge or
c     monopole values due to bond and angle charge flux coupling
c
c     literature reference:
c
c     C. Liu, J.-P. Piquemal and P. Ren, "Implementation of Geometry-
c     Dependent Charge Flux into the Polarizable AMOEBA+ Potential",
c     Journal of Physical Chemistry Letters, 11, 419-426 (2020)
c
c
      subroutine alterchg
      use atoms
      use charge
      use chgpen
      use inform
      use iounit
      use mplpot
      use mpole
      implicit none
      integer i,ii
      real*8, allocatable :: pdelta(:)
      logical header
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (pdelta(n))
c
c     zero out the change in charge value at each site
c
      do i = 1, n
         pdelta(i) = 0.0d0
      end do
c
c     find charge modifications due to charge flux
c
      call bndchg (pdelta)
      call angchg (pdelta)
c
c     alter atomic partial charge values for charge flux
c
      header = .true.
      do ii = 1, nion
         i = iion(ii)
         pchg(i) = pchg0(i) + pdelta(i)
         if (debug .and. pdelta(i).ne.0.0d0) then
            if (header) then
               header = .false.
               write (iout,10)
   10          format (/,' Charge Flux Modification of Partial',
     &                    ' Charges :',
     &                 //,4x,'Atom',14x,'Base Value',7x,'Actual',/)
            end if
            write (iout,20)  i,pchg0(i),pchg(i)
   20       format (i8,9x,2f14.5)
         end if
      end do
c
c     alter monopoles and charge penetration for charge flux
c
      header = .true.
      do ii = 1, npole
         i = ipole(ii)
         pole(1,i) = mono0(i) + pdelta(i)
         if (use_chgpen)  pval(i) = pval0(i) + pdelta(i)
         if (debug .and. pdelta(i).ne.0.0d0) then
            if (header) then
               header = .false.
               write (iout,30)
   30          format (/,' Charge Flux Modification of Atomic',
     &                    ' Monopoles :',
     &                 //,4x,'Atom',14x,'Base Value',7x,'Actual',/)
            end if
            write (iout,40)  i,mono0(i),pole(1,i)
   40       format (i8,9x,2f14.5)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (pdelta)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine bndchg  --  charge flux bond stretch coupling  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "bndchg" computes modifications to atomic partial charges or
c     monopoles due to bond stretch using a charge flux formulation
c
c
      subroutine bndchg (pdelta)
      use sizes
      use atoms
      use bndstr
      use bound
      use cflux
      implicit none
      integer i,ia,ib
      real*8 xab,yab,zab
      real*8 rab,rab0
      real*8 pb,dq
      real*8 pdelta(*)
c
c
c     loop over all the bond distances in the system
c
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         pb = bflx(i)
c
c     compute the bond length value for the current bond
c
         xab = x(ia) - x(ib)
         yab = y(ia) - y(ib)
         zab = z(ia) - z(ib)
         if (use_polymer)  call image (xab,yab,zab)
         rab = sqrt(xab*xab + yab*yab + zab*zab)
c
c     find the charge flux increment for the current bond
c
         rab0 = bl(i)
         dq = pb * (rab-rab0)
         pdelta(ia) = pdelta(ia) - dq
         pdelta(ib) = pdelta(ib) + dq
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine angchg  --  charge flux angle bend coupling  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "angchg" computes modifications to atomic partial charges or
c     monopoles due to angle bending using a charge flux formulation
c
c
      subroutine angchg (pdelta)
      use sizes
      use angbnd
      use atmlst
      use atoms
      use bndstr
      use bound
      use cflux
      use math
      implicit none
      integer i,ia,ib,ic
      real*8 angle,eps
      real*8 rab,rcb
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 dot,cosine
      real*8 pa1,pa2
      real*8 pb1,pb2
      real*8 theta0
      real*8 rab0,rcb0
      real*8 dq1,dq2
      real*8 pdelta(*)
c
c
c     loop over all the bond angles in the system
c
      eps = 0.0001d0
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         pa1 = aflx(1,i)
         pa2 = aflx(2,i)
         pb1 = abflx(1,i)
         pb2 = abflx(2,i)
c
c     calculate the angle values and included bond lengths
c
         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)
         xab = xia - xib
         yab = yia - yib
         zab = zia - zib
         xcb = xic - xib
         ycb = yic - yib
         zcb = zic - zib
         if (use_polymer) then
            call image (xab,yab,zab)
            call image (xcb,ycb,zcb)
         end if
         rab = sqrt(max(xab*xab+yab*yab+zab*zab,eps))
         rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
         dot = xab*xcb + yab*ycb + zab*zcb
         cosine = dot / (rab*rcb)
         cosine = min(1.0d0,max(-1.0d0,cosine))
         angle = radian * acos(cosine)
c
c     find the charge flux increment for the current angle
c
         theta0 = anat(i)
         rab0 = bl(balist(1,i))
         rcb0 = bl(balist(2,i))
         dq1 = pb1*(rcb-rcb0) + pa1*(angle-theta0)/radian
         dq2 = pb2*(rab-rab0) + pa2*(angle-theta0)/radian
         pdelta(ia) = pdelta(ia) + dq1
         pdelta(ib) = pdelta(ib) - dq1 - dq2
         pdelta(ic) = pdelta(ic) + dq2
      end do
      return
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2022 by Moses Chung, Zhi Wang & Jay Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine alterpol  --  variable polarizability scaling  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "alterpol" computes the variable polarizability scaling for
c     use with exchange polarization
c
c     literature reference:
c
c     M. K. J. Chung, Z. Wang, J. A. Rackers and J. W. Ponder,
c     "Classical Exchange Polarization: An Anisotropic Variable
c     Polarizability Model", Journal of Physical Chemistry B,
c     submitted, June 2022
c
c
      subroutine alterpol
      use limits
      use mpole
      implicit none
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_mlist) then
         call altpol0b
      else
         call altpol0a
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine altpol0a  --  variable polarizability via loop  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "altpol0a" computes the variable polarizability values due to
c     exchange polarization using a double loop
c
c
      subroutine altpol0a
      use atoms
      use bound
      use cell
      use couple
      use expol
      use mpole
      use polgrp
      use polpot
      use shunt
      implicit none
      integer i,j,k,m
      integer ii,kk
      integer jcell
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4,r5
      real*8 sizi,sizk,sizik
      real*8 alphai,alphak
      real*8 springi,springk
      real*8 s2,ds2
      real*8 p33i, p33k
      real*8 ks2i(3,3)
      real*8 ks2k(3,3)
      real*8 taper
      real*8, allocatable :: pscale(:)
      logical epli,eplk
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     set the switching function coefficients
c
      mode = 'REPULS'
      call switch (mode)
c
c     set polarizability tensor scaling to the identity matrix
c
      do ii = 1, npole
         i = ipole(ii)
         polscale(1,1,i) = 1.0d0
         polscale(2,1,i) = 0.0d0
         polscale(3,1,i) = 0.0d0
         polscale(1,2,i) = 0.0d0
         polscale(2,2,i) = 1.0d0
         polscale(3,2,i) = 0.0d0
         polscale(1,3,i) = 0.0d0
         polscale(2,3,i) = 0.0d0
         polscale(3,3,i) = 1.0d0
      end do
c
c     set array needed to scale atom and group interactions
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     find variable polarizability scale matrix at each site
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         springi = kpep(i)
         sizi = prepep(i)
         alphai = dmppep(i)
         epli = lpep(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            eplk = lpep(k)
            if (epli .or. eplk) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  springk = kpep(k)
                  sizk = prepep(k)
                  alphak = dmppep(k)
                  sizik = sizi * sizk
                  call dampexpl (r,sizik,alphai,alphak,s2,ds2)
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     s2 = s2 * taper
                  end if
                  p33i = springi * s2 * pscale(k)
                  p33k = springk * s2 * pscale(k)
                  call rotexpl (r,xr,yr,zr,p33i,p33k,ks2i,ks2k)
                  do j = 1, 3
                     do m = 1, 3
                        polscale(j,m,i) = polscale(j,m,i) + ks2i(j,m)
                        polscale(j,m,k) = polscale(j,m,k) + ks2k(j,m)
                     end do
                  end do
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction energy with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            springi = kpep(i)
            sizi = prepep(i)
            alphai = dmppep(i)
            epli = lpep(i)
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               eplk = lpep(k)
               if (epli .or. eplk) then
                  do jcell = 2, ncell
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     call imager (xr,yr,zr,jcell)
                     r2 = xr*xr + yr*yr + zr*zr
                     if (r2 .le. off2) then
                        r = sqrt(r2)
                        springk = kpep(k)
                        sizk = prepep(k)
                        alphak = dmppep(k)
                        sizik = sizi * sizk
                        call dampexpl (r,sizik,alphai,alphak,s2,ds2)
c
c     use energy switching if near the cutoff distance
c
                        if (r2 .gt. cut2) then
                           r3 = r2 * r
                           r4 = r2 * r2
                           r5 = r2 * r3
                           taper = c5*r5 + c4*r4 + c3*r3
     &                                + c2*r2 + c1*r + c0
                           s2 = s2 * taper
                        end if
c
c     interaction of an atom with its own image counts half
c
                        if (i .eq. k)  s2 = 0.5d0 * s2
                        p33i = springi * s2 * pscale(k)
                        p33k = springk * s2 * pscale(k)
                        call rotexpl (r,xr,yr,zr,p33i,p33k,ks2i,ks2k)
                        do j = 1, 3
                           do m = 1, 3
                              polscale(j,m,i) = polscale(j,m,i)
     &                                             + ks2i(j,m)
                              polscale(j,m,k) = polscale(j,m,k)
     &                                             + ks2k(j,m)
                           end do
                        end do
                     end if
                  end do
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     find inverse of the polarizability scaling matrix
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            do m = 1, 3
               polinv(j,m,i) = polscale(j,m,i)
            end do
         end do
         call invert (3,polinv(1,1,i))
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine altpol0b  --  variable polarizability via list  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "altpol0b" computes variable polarizability values due to
c     exchange polarization using a neighbor list
c
c
      subroutine altpol0b
      use atoms
      use bound
      use couple
      use expol
      use mpole
      use neigh
      use polgrp
      use polpot
      use shunt
      implicit none
      integer i,j,k,m
      integer ii,kk,kkk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4,r5
      real*8 sizi,sizk,sizik
      real*8 alphai,alphak
      real*8 springi,springk
      real*8 s2,ds2
      real*8 p33i, p33k
      real*8 ks2i(3,3)
      real*8 ks2k(3,3)
      real*8 taper
      real*8, allocatable :: pscale(:)
      logical epli,eplk
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     set the switching function coefficients
c
      mode = 'REPULS'
      call switch (mode)
c
c     set polarizability tensor scaling to the identity matrix
c
      do ii = 1, npole
         i = ipole(ii)
         polscale(1,1,i) = 1.0d0
         polscale(2,1,i) = 0.0d0
         polscale(3,1,i) = 0.0d0
         polscale(1,2,i) = 0.0d0
         polscale(2,2,i) = 1.0d0
         polscale(3,2,i) = 0.0d0
         polscale(1,3,i) = 0.0d0
         polscale(2,3,i) = 0.0d0
         polscale(3,3,i) = 1.0d0
      end do
c
c     set array needed to scale atom and group interactions
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,x,y,z,kpep,prepep,dmppep,lpep,np11,ip11,n12,
!$OMP& i12,n13,i13,n14,i14,n15,i15,p2scale,p3scale,p4scale,p5scale,
!$OMP& p2iscale,p3iscale,p4iscale,p5iscale,nelst,elst,use_bounds,
!$OMP& cut2,off2,c0,c1,c2,c3,c4,c5,polinv)
!$OMP& firstprivate(pscale)
!$OMP& shared (polscale)
!$OMP DO reduction(+:polscale)
c
c     find the variable polarizability
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         springi = kpep(i)
         sizi = prepep(i)
         alphai = dmppep(i)
         epli = lpep(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            eplk = lpep(k)
            if (epli .or. eplk) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  springk = kpep(k)
                  sizk = prepep(k)
                  alphak = dmppep(k)
                  sizik = sizi * sizk
                  call dampexpl (r,sizik,alphai,alphak,s2,ds2)
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     s2 = s2 * taper
                  end if
                  p33i = springi * s2 * pscale(k)
                  p33k = springk * s2 * pscale(k)
                  call rotexpl (r,xr,yr,zr,p33i,p33k,ks2i,ks2k)
                  do j = 1, 3
                     do m = 1, 3
                        polscale(j,m,i) = polscale(j,m,i) + ks2i(j,m)
                        polscale(j,m,k) = polscale(j,m,k) + ks2k(j,m)
                     end do
                  end do
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
!$OMP END DO
c
c     find inverse of the polarizability scaling matrix
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            do m = 1, 3
               polinv(j,m,i) = polscale(j,m,i)
            end do
         end do
         call invert (3,polinv(1,1,i))
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine rotexpl  --  rotation matrix for overlap  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "rotexpl" finds and applies rotation matrices for the
c     overlap tensor used in computing exchange polarization
c
c
      subroutine rotexpl (r,xr,yr,zr,p33i,p33k,ks2i,ks2k)
      implicit none
      integer i,j
      real*8 r,xr,yr,zr
      real*8 p33i,p33k
      real*8 a(3)
      real*8 ks2i(3,3)
      real*8 ks2k(3,3)
c
c
c     compute only needed rotation matrix elements
c
      a(1) = xr / r
      a(2) = yr / r
      a(3) = zr / r
c
c     rotate the vector from global to local frame
c
      do i = 1, 3
         do j = 1, 3
            ks2i(i,j) = p33i * a(i) * a(j)
            ks2k(i,j) = p33k * a(i) * a(j)
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine analysis  --  energy components and analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "analysis" calls the series of routines needed to calculate
c     the potential energy and perform energy partitioning analysis
c     in terms of type of interaction or atom number
c
c
      subroutine analysis (energy)
      use analyz
      use atoms
      use energi
      use group
      use inter
      use iounit
      use limits
      use potent
      use vdwpot
      implicit none
      integer i
      real*8 energy
      real*8 cutoff
c
c
c     zero out each of the potential energy components
c
      esum = 0.0d0
      eb = 0.0d0
      ea = 0.0d0
      eba = 0.0d0
      eub = 0.0d0
      eaa = 0.0d0
      eopb = 0.0d0
      eopd = 0.0d0
      eid = 0.0d0
      eit = 0.0d0
      et = 0.0d0
      ept = 0.0d0
      ebt = 0.0d0
      eat = 0.0d0
      ett = 0.0d0
      ev = 0.0d0
      er = 0.0d0
      edsp = 0.0d0
      ec = 0.0d0
      ecd = 0.0d0
      ed = 0.0d0
      em = 0.0d0
      ep = 0.0d0
      ect = 0.0d0
      erxf = 0.0d0
      es = 0.0d0
      elf = 0.0d0
      eg = 0.0d0
      ex = 0.0d0
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(aesum)) then
         if (size(aesum) .lt. n) then
            deallocate (aesum)
            deallocate (aeb)
            deallocate (aea)
            deallocate (aeba)
            deallocate (aeub)
            deallocate (aeaa)
            deallocate (aeopb)
            deallocate (aeopd)
            deallocate (aeid)
            deallocate (aeit)
            deallocate (aet)
            deallocate (aept)
            deallocate (aebt)
            deallocate (aeat)
            deallocate (aett)
            deallocate (aev)
            deallocate (aer)
            deallocate (aedsp)
            deallocate (aec)
            deallocate (aecd)
            deallocate (aed)
            deallocate (aem)
            deallocate (aep)
            deallocate (aect)
            deallocate (aerxf)
            deallocate (aes)
            deallocate (aelf)
            deallocate (aeg)
            deallocate (aex)
         end if
      end if
      if (.not. allocated(aesum)) then
         allocate (aesum(n))
         allocate (aeb(n))
         allocate (aea(n))
         allocate (aeba(n))
         allocate (aeub(n))
         allocate (aeaa(n))
         allocate (aeopb(n))
         allocate (aeopd(n))
         allocate (aeid(n))
         allocate (aeit(n))
         allocate (aet(n))
         allocate (aept(n))
         allocate (aebt(n))
         allocate (aeat(n))
         allocate (aett(n))
         allocate (aev(n))
         allocate (aer(n))
         allocate (aedsp(n))
         allocate (aec(n))
         allocate (aecd(n))
         allocate (aed(n))
         allocate (aem(n))
         allocate (aep(n))
         allocate (aect(n))
         allocate (aerxf(n))
         allocate (aes(n))
         allocate (aelf(n))
         allocate (aeg(n))
         allocate (aex(n))
      end if
c
c     zero out energy partitioning components for each atom
c
      do i = 1, n
         aesum(i) = 0.0d0
         aeb(i) = 0.0d0
         aea(i) = 0.0d0
         aeba(i) = 0.0d0
         aeub(i) = 0.0d0
         aeaa(i) = 0.0d0
         aeopb(i) = 0.0d0
         aeopd(i) = 0.0d0
         aeid(i) = 0.0d0
         aeit(i) = 0.0d0
         aet(i) = 0.0d0
         aept(i) = 0.0d0
         aebt(i) = 0.0d0
         aeat(i) = 0.0d0
         aett(i) = 0.0d0
         aev(i) = 0.0d0
         aer(i) = 0.0d0
         aedsp(i) = 0.0d0
         aec(i) = 0.0d0
         aecd(i) = 0.0d0
         aed(i) = 0.0d0
         aem(i) = 0.0d0
         aep(i) = 0.0d0
         aect(i) = 0.0d0
         aerxf(i) = 0.0d0
         aes(i) = 0.0d0
         aelf(i) = 0.0d0
         aeg(i) = 0.0d0
         aex(i) = 0.0d0
      end do
c
c     zero out the total intermolecular energy
c
      einter = 0.0d0
c
c     remove any previous use of the replicates method
c
      cutoff = 0.0d0
      call replica (cutoff)
c
c     update the pairwise interaction neighbor lists
c
      if (use_list)  call nblist
c
c     many implicit solvation models require Born radii
c
      if (use_born)  call born
c
c     alter partial charges and multipoles for charge flux
c
      if (use_chgflx)  call alterchg
c
c     modify bond and torsion constants for pisystem
c
      if (use_orbit)  call picalc
c
c     call the local geometry energy component routines
c
      if (use_bond)  call ebond3
      if (use_angle)  call eangle3
      if (use_strbnd)  call estrbnd3
      if (use_urey)  call eurey3
      if (use_angang)  call eangang3
      if (use_opbend)  call eopbend3
      if (use_opdist)  call eopdist3
      if (use_improp)  call eimprop3
      if (use_imptor)  call eimptor3
      if (use_tors)  call etors3
      if (use_pitors)  call epitors3
      if (use_strtor)  call estrtor3
      if (use_angtor)  call eangtor3
      if (use_tortor)  call etortor3
c
c     call the electrostatic energy component routines
c
      if (use_charge)  call echarge3
      if (use_chgdpl)  call echgdpl3
      if (use_dipole)  call edipole3
      if (use_mpole)  call empole3
      if (use_polar)  call epolar3
      if (use_chgtrn)  call echgtrn3
      if (use_rxnfld)  call erxnfld3
c
c     call the van der Waals energy component routines
c
      if (use_vdw) then
         if (vdwtyp .eq. 'LENNARD-JONES')  call elj3
         if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck3
         if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb3
         if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal3
         if (vdwtyp .eq. 'GAUSSIAN')  call egauss3
      end if
      if (use_repel)  call erepel3
      if (use_disp)  call edisp3
c
c     call any miscellaneous energy component routines
c
      if (use_solv)  call esolv3
      if (use_metal)  call emetal3
      if (use_geom)  call egeom3
      if (use_extra)  call extra3
c
c     sum up to give the total potential energy
c
      esum = eb + ea + eba + eub + eaa + eopb + eopd + eid + eit
     &          + et + ept + ebt + eat + ett + ev + er + edsp
     &          + ec + ecd + ed + em + ep + ect + erxf + es + elf
     &          + eg + ex
      energy = esum
c
c     sum up to give the total potential energy per atom
c
      do i = 1, n
         aesum(i) = aeb(i) + aea(i) + aeba(i) + aeub(i) + aeaa(i)
     &                 + aeopb(i) + aeopd(i) + aeid(i) + aeit(i)
     &                 + aet(i) + aept(i) + aebt(i) + aeat(i) + aett(i)
     &                 + aev(i) + aer(i) + aedsp(i) + aec(i) + aecd(i)
     &                 + aed(i) + aem(i) + aep(i) + aect(i) + aerxf(i)
     &                 + aes(i) + aelf(i) + aeg(i) + aex(i)
      end do
c
c     check for an illegal value for the total energy
c
c     if (isnan(esum)) then
      if (esum .ne. esum) then
         write (iout,10)
   10    format (/,' ANALYSIS  --  Illegal Value for the Total',
     &              ' Potential Energy')
         call fatal
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module analyz  --  energy components partitioned to atoms  ##
c     ##                                                             ##
c     #################################################################
c
c
c     aesum   total potential energy partitioned over atoms
c     aeb     bond stretch energy partitioned over atoms
c     aea     angle bend energy partitioned over atoms
c     aeba    stretch-bend energy partitioned over atoms
c     aeub    Urey-Bradley energy partitioned over atoms
c     aeaa    angle-angle energy partitioned over atoms
c     aeopb   out-of-plane bend energy partitioned over atoms
c     aeopd   out-of-plane distance energy partitioned over atoms
c     aeid    improper dihedral energy partitioned over atoms
c     aeit    improper torsion energy partitioned over atoms
c     aet     torsional energy partitioned over atoms
c     aept    pi-system torsion energy partitioned over atoms
c     aebt    stretch-torsion energy partitioned over atoms
c     aeat    angle-torsion energy partitioned over atoms
c     aett    torsion-torsion energy partitioned over atoms
c     aev     van der Waals energy partitioned over atoms
c     aer     Pauli repulsion energy partitioned over atoms
c     aedsp   damped dispersion energy partitioned over atoms
c     aec     charge-charge energy partitioned over atoms
c     aecd    charge-dipole energy partitioned over atoms
c     aed     dipole-dipole energy partitioned over atoms
c     aem     multipole energy partitioned over atoms
c     aep     polarization energy partitioned over atoms
c     aect    charge transfer energy partitioned over atoms
c     aerxf   reaction field energy partitioned over atoms
c     aes     solvation energy partitioned over atoms
c     aelf    metal ligand field energy partitioned over atoms
c     aeg     geometric restraint energy partitioned over atoms
c     aex     extra energy term partitioned over atoms
c
c
      module analyz
      implicit none
      real*8, allocatable :: aesum(:)
      real*8, allocatable :: aeb(:)
      real*8, allocatable :: aea(:)
      real*8, allocatable :: aeba(:)
      real*8, allocatable :: aeub(:)
      real*8, allocatable :: aeaa(:)
      real*8, allocatable :: aeopb(:)
      real*8, allocatable :: aeopd(:)
      real*8, allocatable :: aeid(:)
      real*8, allocatable :: aeit(:)
      real*8, allocatable :: aet(:)
      real*8, allocatable :: aept(:)
      real*8, allocatable :: aebt(:)
      real*8, allocatable :: aeat(:)
      real*8, allocatable :: aett(:)
      real*8, allocatable :: aev(:)
      real*8, allocatable :: aer(:)
      real*8, allocatable :: aedsp(:)
      real*8, allocatable :: aec(:)
      real*8, allocatable :: aecd(:)
      real*8, allocatable :: aed(:)
      real*8, allocatable :: aem(:)
      real*8, allocatable :: aep(:)
      real*8, allocatable :: aect(:)
      real*8, allocatable :: aerxf(:)
      real*8, allocatable :: aes(:)
      real*8, allocatable :: aelf(:)
      real*8, allocatable :: aeg(:)
      real*8, allocatable :: aex(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  program analyze  --  energy partitioning and analysis  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "analyze" computes and displays the total potential energy;
c     options are provided to display system and force field info,
c     partition the energy by atom or by potential function type,
c     show force field parameters by atom; output the large energy
c     interactions and find electrostatic and inertial properties
c
c
      program analyze
      use atoms
      use boxes
      use files
      use inform
      use iounit
      use output
      implicit none
      integer i,j,ixyz
      integer frame
      integer nlist,nold
      integer freeunit
      integer trimtext
      integer, allocatable :: list(:)
      real*8 energy
      real*8, allocatable :: told(:)
      real*8, allocatable :: derivs(:,:)
      logical dosystem,doparam
      logical doenergy,doatom
      logical dolarge,dodetail
      logical domoment,dovirial
      logical doconect,dosave
      logical exist,first
      logical, allocatable :: active(:)
      character*1 letter
      character*240 record
      character*240 string
      character*240 xyzfile
c
c
c     set up the structure and mechanics calculation
c
      ixyz = 0
      call initial
      call getcart (ixyz)
      call mechanic
      xyzfile = filename
c
c     get the desired types of analysis to be performed
c
      call nextarg (string,exist)
      if (.not. exist) then
         write (iout,10)
   10    format (/,' The Tinker Energy Analysis Utility Can :',
     &           //,' General System and Force Field Information [G]',
     &           /,' Force Field Parameters for Interactions [P]',
     &           /,' Total Potential Energy and its Components [E]',
     &           /,' Energy Breakdown over Each of the Atoms [A]',
     &           /,' List of the Large Individual Interactions [L]',
     &           /,' Details for All Individual Interactions [D]',
     &           /,' Electrostatic Moments and Principle Axes [M]',
     &           /,' Internal Virial & Instantaneous Pressure [V]',
     &           /,' Connectivity Lists for Each of the Atoms [C]')
   20    continue
         write (iout,30)
   30    format (/,' Enter the Desired Analysis Types',
     &              ' [G,P,E,A,L,D,M,V,C] :  ',$)
         read (input,40,err=20)  string
   40    format (a240)
      end if
c
c     set option control flags based desired analysis types
c
      dosystem = .false.
      doparam = .false.
      doenergy = .false.
      doatom = .false.
      dolarge = .false.
      dodetail = .false.
      domoment = .false.
      dovirial = .false.
      doconect = .false.
      call upcase (string)
      do i = 1, trimtext(string)
         letter = string(i:i)
         if (letter .eq. 'G')  dosystem = .true.
         if (letter .eq. 'P')  doparam = .true.
         if (letter .eq. 'E')  doenergy = .true.
         if (letter .eq. 'A')  doatom = .true.
         if (letter .eq. 'L')  dolarge = .true.
         if (letter .eq. 'D')  dodetail = .true.
         if (letter .eq. 'M')  domoment = .true.
         if (letter .eq. 'V')  dovirial = .true.
         if (letter .eq. 'C')  doconect = .true.
      end do
c
c     set option control flag to save forces or induced dipoles
c
      dosave = .false.
      call optinit
      if (frcsave .or. uindsave)  dosave = .true.
c
c     perform dynamic allocation of some local arrays
c
      nlist = 40
      allocate (list(nlist))
      allocate (active(n))
      allocate (told(n))
c
c     get the list of atoms for which output is desired
c
      if (doatom .or. doparam .or. doconect) then
         do i = 1, nlist
            list(i) = 0
         end do
         if (exist) then
            do i = 1, nlist
               call nextarg (string,exist)
               if (.not. exist)  goto 50
               read (string,*,err=50,end=50)  list(i)
            end do
   50       continue
            if (list(1) .eq. 0) then
               list(1) = -1
               list(2) = n
            end if
         else
            write (iout,60)
   60       format (/,' List Atoms for which Output is Desired',
     &                 ' [ALL] :  '/,'    >  ',$)
            read (input,70)  record
   70       format (a240)
            read (record,*,err=80,end=80)  (list(i),i=1,nlist)
   80       continue
         end if
         do i = 1, n
            active(i) = .true.
         end do
         i = 1
         do while (list(i) .ne. 0)
            if (i .eq. 1) then
               do j = 1, n
                  active(j) = .false.
               end do
            end if
            if (list(i) .gt. 0) then
               active(list(i)) = .true.
               i = i + 1
            else
               do j = abs(list(i)), abs(list(i+1))
                  active(j) = .true.
               end do
               i = i + 2
            end if
         end do
      end if
c
c     setup to write out the large individual energy terms
c
      if (dolarge) then
         verbose = .true.
      end if
c
c     setup to write out all of the individual energy terms
c
      if (dodetail) then
         doenergy = .true.
         verbose = .true.
         debug = .true.
      else
         debug = .false.
      end if
c
c     get parameters used for molecular mechanics potentials
c
      if (doparam .and. doconect) then
         call amberyze (active)
      else if (doparam) then
         call paramyze (active)
      end if
c
c     provide connectivity lists for the individual atoms
c
      if (doconect)  call connyze (active)
c
c     decide whether to perform analysis of individual frames
c
      abort = .true.
      if (dosystem .or. doenergy .or. doatom .or. dolarge .or.
     &       domoment .or. dovirial .or. dosave)  abort = .false.
c
c     perform analysis for each successive coordinate structure
c
      frame = 0
      do while (.not. abort)
         frame = frame + 1
         if (frame .gt. 1) then
            write (iout,90)  frame
   90       format (/,' Analysis for Archive Structure :',8x,i8)
            if (nold .ne. n) then
               call mechanic
            else
               do i = 1, n
                  if (type(i) .ne. told(i)) then
                     call mechanic
                     goto 100
                  end if
               end do
  100          continue
            end if
         end if
c
c     get info on the molecular system and force field
c
         if (dosystem)  call systyze
c
c     make the call to compute the potential energy
c
         if (doenergy .or. doatom .or. dolarge)  call enrgyze
c
c     energy partitioning by potential energy components
c
         if (doenergy)  call partyze
c
c     get the various electrostatic and inertial moments
c
         if (domoment) then
            debug = .false.
            call momyze
            if (dodetail)  debug = .true.
         end if
c
c     energy partitioning over the individual atoms
c
         if (doatom)  call atomyze (active)
c
c     compute the gradient if force or virial is requested
c
         if (dovirial .or. frcsave) then
            allocate (derivs(3,n))
            call gradient (energy,derivs)
            deallocate (derivs)
         end if
c
c     get and test the internal virial and pressure values
c
         if (dovirial) then
            debug = .false.
            call viriyze
            if (dodetail)  debug = .true.
         end if
c
c     save output files with forces or induced dipoles
c
         if (dosave)  call saveyze (frame)
c
c     attempt to read next structure from the coordinate file
c
         if (size(told) .lt. n) then
            deallocate (told)
            allocate (told(n))
         end if
         nold = n
         do i = 1, nold
            told(i) = type(i)
         end do
         first = .false.
         call readcart (ixyz,first)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (active)
      deallocate (told)
c
c     perform any final tasks before program exit
c
      close (unit=ixyz)
      if (dodetail)  debug = .false.
      call final
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine systyze  --  system & force field information  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "systyze" is an auxiliary routine for the analyze program
c     that prints general information about the molecular system
c     and the force field model
c
c
      subroutine systyze
      use atoms
      use bound
      use boxes
      use ewald
      use fields
      use iounit
      use limits
      use molcul
      use mplpot
      use pme
      use polpot
      use potent
      use units
      use vdwpot
      implicit none
      integer i
      real*8 dens
      character*20 value
      character*20 label(5)
c
c
c     info on number of atoms, molecules and mass
c
      if (n .ne. 0) then
         write (iout,10)  n,nmol,totmass
   10    format (/,' Overall System Contents :',
     &           //,' Number of Atoms',25x,i8,
     &           /,' Number of Molecules',21x,i8,
     &           /,' Total System Mass',15x,f16.4)
         if (use_bounds) then
            dens = (1.0d24/volbox) * (totmass/avogadro)
            write (iout,20)  dens
   20       format (' System Density',22x,f12.4)
         end if
      end if
c
c     periodic box dimensions and crystal lattice type
c
      if (use_bounds) then
         value = 'ORTHOGONAL'
         if (monoclinic)  value = 'MONOCLINIC'
         if (triclinic)  value = 'TRICLINIC'
         if (octahedron)  value = 'TRUNCATED OCTAHEDRON'
         if (dodecadron)  value = 'RHOMBIC DODECAHEDRON'
         call justify (value)
         write (iout,30)  xbox,ybox,zbox,alpha,beta,gamma,volbox,value
   30    format (/,' Periodic Boundary Box :',
     &           //,' a-Axis Length',23x,f12.4,
     &           /,' b-Axis Length',23x,f12.4,
     &           /,' c-Axis Length',23x,f12.4,
     &           /,' Alpha Angle',25x,f12.4,
     &           /,' Beta Angle',26x,f12.4,
     &           /,' Gamma Angle',25x,f12.4,
     &           /,' Cell Volume',21x,f16.4,
     &           /,' Lattice Type',16x,a20)
         write (iout,40)  (lvec(1,i),i=1,3),(lvec(2,i),i=1,3),
     &                    (lvec(3,i),i=1,3)
   40    format (/,' Lattice Vectors :',
     &           //,3x,'a',3x,3f14.4,
     &           /,3x,'b',3x,3f14.4,
     &           /,3x,'c',3x,3f14.4)
         if (spacegrp .ne. '          ') then
            value = spacegrp
            call justify (value)
            write (iout,50)  value
   50       format (' Space Group',17x,a20)
         end if
      end if
c
c     info on force field potential energy function
c
      value = forcefield
      call justify (value)
      write (iout,60)  value
   60 format (/,' Force Field Name :',10x,a20)
c
c     details of vdw potential energy functional form
c
      if (use_vdw .or. use_repel .or. use_disp) then
         write (iout,70)
   70    format ()
      end if
      if (use_vdw) then
         label(1) = vdwtyp
         label(2) = radtyp
         label(3) = radsiz
         label(4) = radrule
         label(5) = epsrule
         do i = 1, 5
            call justify (label(i))
         end do
         write (iout,80)  (label(i),i=1,5)
   80    format (' VDW Function',16x,a20,
     &              /,' Size Descriptor',13x,a20,
     &              /,' Size Unit Type',14x,a20,
     &              /,' Size Combining Rule',9x,a20,
     &              /,' Well Depth Rule',13x,a20)
         if (vdwcut .le. 1000.0d0) then
            write (iout,90)  vdwcut
   90       format (' VDW Cutoff',26x,f12.4)
         end if
      end if
      if (use_repel) then
         value = 'PAULI REPULSION'
         call justify (value)
         write (iout,100)  value
  100    format (' VDW Function',16x,a20)
      end if
      if (use_disp) then
         value = 'DAMPED DISPERSION'
         call justify (value)
         write (iout,110)  value
  110    format (' VDW Function',16x,a20)
      end if
c
c     details of dispersion particle mesh Ewald calculation
c
      if (use_dewald) then
         write (iout,120)  adewald,dewaldcut,ndfft1,
     &                     ndfft2,ndfft3,bsdorder
  120    format (/,' PME for Dispersion :',
     &           //,' Ewald Coefficient',19x,f12.4,
     &           /,' Real-Space Cutoff',19x,f12.4,
     &           /,' Grid Dimensions',21x,3i4,
     &           /,' B-Spline Order',26x,i8)
      end if
c
c     details of electrostatic energy functional form
c
      if (use_charge .or. use_dipole .or. use_mpole .or. use_polar) then
         write (iout,130)
  130    format ()
      end if
      if (use_charge) then
         value = 'PARTIAL CHARGE'
         call justify (value)
         write (iout,140)  value
  140    format (' Electrostatics',14x,a20)
      end if
      if (use_dipole) then
         value = 'BOND DIPOLE'
         call justify (value)
         write (iout,150)  value
  150    format (' Electrostatics',14x,a20)
      end if
      if (use_mpole) then
         value = 'ATOMIC MULTIPOLE'
         call justify (value)
         write (iout,160)  value
  160    format (' Electrostatics',14x,a20)
      end if
      if (use_chgpen) then
         value = 'CHARGE PENETRATION'
         call justify (value)
         write (iout,170)  value
  170    format (' Electrostatics',14x,a20)
      end if
      if (use_chgtrn) then
         value = 'CHARGE TRANSFER'
         call justify (value)
         write (iout,180)  value
  180    format (' Induction',19x,a20)
      end if
      if (use_polar) then
         value = 'INDUCED DIPOLE'
         call justify (value)
         write (iout,190)  value
  190    format (' Induction',19x,a20)
         value = poltyp
         call justify (value)
         write (iout,200)  value
  200    format (' Polarization',16x,a20)
         if (use_thole) then
            value = 'THOLE DAMPING'
            call justify (value)
            write (iout,210)  value
  210       format (' Polarization',16x,a20)
         end if
         if (use_chgpen) then
            value = 'CHGPEN DAMPING'
            call justify (value)
            write (iout,220)  value
  220       format (' Polarization',16x,a20)
         end if
      end if
c
c     details of electrostatic particle mesh Ewald calculation
c
      if (use_ewald) then
         value = boundary
         call justify (value)
         write (iout,230)  aeewald,ewaldcut,nefft1,nefft2,
     &                     nefft3,bseorder,value
  230    format (/,' PME for Electrostatics :',
     &           //,' Ewald Coefficient',19x,f12.4,
     &           /,' Real-Space Cutoff',19x,f12.4,
     &           /,' Grid Dimensions',21x,3i4,
     &           /,' B-Spline Order',26x,i8,
     &           /,' Boundary Condition',10x,a20)
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine enrgyze  --  compute & report energy analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "enrgyze" is an auxiliary routine for the analyze program
c     that performs the energy analysis and prints the total and
c     intermolecular energies
c
c
      subroutine enrgyze
      use atoms
      use inform
      use inter
      use iounit
      use limits
      use molcul
      implicit none
      real*8 energy
      character*56 fstr
c
c
c     perform the energy analysis by atom and component
c
      call analysis (energy)
c
c     intermolecular energy for systems with multiple molecules
c
      fstr = '(/,'' Intermolecular Energy :'',9x,f16.4,'' Kcal/mole'')'
      if (digits .ge. 6)  fstr(31:38) = '7x,f18.6'
      if (digits .ge. 8)  fstr(31:38) = '5x,f20.8'
      if (abs(einter) .ge. 1.0d10)  fstr(34:34) = 'd'
      if (nmol.gt.1 .and. nmol.lt.n .and. .not.use_ewald) then
         write (iout,fstr)  einter
      end if
c
c     print out the total potential energy of the system
c
      fstr = '(/,'' Total Potential Energy :'',8x,f16.4,'' Kcal/mole'')'
      if (digits .ge. 6)  fstr(32:39) = '6x,f18.6'
      if (digits .ge. 8)  fstr(32:39) = '4x,f20.8'
      if (abs(energy) .ge. 1.0d10)  fstr(35:35) = 'd'
      write (iout,fstr)  energy
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine partyze  --  energy component decomposition  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "partyze" prints the energy component and number of
c     interactions for each of the potential energy terms
c
c
      subroutine partyze
      use action
      use energi
      use inform
      use iounit
      use limits
      use potent
      implicit none
      character*12 form1
      character*12 form2
      character*240 fstr
c
c
c     write out each energy component to the desired precision
c
      form1 = '5x,f16.4,i17'
      if (digits .ge. 6)  form1 = '3x,f18.6,i17'
      if (digits .ge. 8)  form1 = '1x,f20.8,i17'
      form2 = form1(1:3)//'d'//form1(5:12)
      fstr = '(/,'' Energy Component Breakdown :'',
     &          11x,''Kcal/mole'',8x,''Interactions'',/)'
      write (iout,fstr)
      if (use_bond .and. (neb.ne.0.or.eb.ne.0.0d0)) then
         fstr = '('' Bond Stretching'',12x,'//form1//')'
         write (iout,fstr)  eb,neb
      end if
      if (use_angle .and. (nea.ne.0.or.ea.ne.0.0d0)) then
         fstr = '('' Angle Bending'',14x,'//form1//')'
         write (iout,fstr)  ea,nea
      end if
      if (use_strbnd .and. (neba.ne.0.or.eba.ne.0.0d0)) then
         fstr = '('' Stretch-Bend'',15x,'//form1//')'
         write (iout,fstr)  eba,neba
      end if
      if (use_urey .and. (neub.ne.0.or.eub.ne.0.0d0)) then
         fstr = '('' Urey-Bradley'',15x,'//form1//')'
         write (iout,fstr)  eub,neub
      end if
      if (use_angang .and. (neaa.ne.0.or.eaa.ne.0.0d0)) then
         fstr = '('' Angle-Angle'',16x,'//form1//')'
         write (iout,fstr)  eaa,neaa
      end if
      if (use_opbend .and. (neopb.ne.0.or.eopb.ne.0.0d0)) then
         fstr = '('' Out-of-Plane Bend'',10x,'//form1//')'
         write (iout,fstr)  eopb,neopb
      end if
      if (use_opdist .and. (neopd.ne.0.or.eopd.ne.0.0d0)) then
         fstr = '('' Out-of-Plane Distance'',6x,'//form1//')'
         write (iout,fstr)  eopd,neopd
      end if
      if (use_improp .and. (neid.ne.0.or.eid.ne.0.0d0)) then
         fstr = '('' Improper Dihedral'',10x,'//form1//')'
         write (iout,fstr)  eid,neid
      end if
      if (use_imptor .and. (neit.ne.0.or.eit.ne.0.0d0)) then
         fstr = '('' Improper Torsion'',11x,'//form1//')'
         write (iout,fstr)  eit,neit
      end if
      if (use_tors .and. (net.ne.0.or.et.ne.0.0d0)) then
         fstr = '('' Torsional Angle'',12x,'//form1//')'
         write (iout,fstr)  et,net
      end if
      if (use_pitors .and. (nept.ne.0.or.ept.ne.0.0d0)) then
         fstr = '('' Pi-Orbital Torsion'',9x,'//form1//')'
         write (iout,fstr)  ept,nept
      end if
      if (use_strtor .and. (nebt.ne.0.or.ebt.ne.0.0d0)) then
         fstr = '('' Stretch-Torsion'',12x,'//form1//')'
         write (iout,fstr)  ebt,nebt
      end if
      if (use_angtor .and. (neat.ne.0.or.eat.ne.0.0d0)) then
         fstr = '('' Angle-Torsion'',14x,'//form1//')'
         write (iout,fstr)  eat,neat
      end if
      if (use_tortor .and. (nett.ne.0.or.ett.ne.0.0d0)) then
         fstr = '('' Torsion-Torsion'',12x,'//form1//')'
         write (iout,fstr)  ett,nett
      end if
      if (use_vdw .and. (nev.ne.0.or.ev.ne.0.0d0)) then
         if (abs(ev) .lt. 1.0d10) then
            fstr = '('' Van der Waals'',14x,'//form1//')'
         else
            fstr = '('' Van der Waals'',14x,'//form2//')'
         end if
         write (iout,fstr)  ev,nev
      end if
      if (use_repel .and. (ner.ne.0.or.er.ne.0.0d0)) then
         if (abs(er) .lt. 1.0d10) then
            fstr = '('' Repulsion'',18x,'//form1//')'
         else
            fstr = '('' Repulsion'',18x,'//form2//')'
         end if
         write (iout,fstr)  er,ner
      end if
      if (use_disp .and. (nedsp.ne.0.or.edsp.ne.0.0d0)) then
         fstr = '('' Dispersion'',17x,'//form1//')'
         write (iout,fstr)  edsp,nedsp
      end if
      if (use_charge .and. (nec.ne.0.or.ec.ne.0.0d0)) then
         if (abs(ec) .lt. 1.0d10) then
            fstr = '('' Charge-Charge'',14x,'//form1//')'
         else
            fstr = '('' Charge-Charge'',14x,'//form2//')'
         end if
         write (iout,fstr)  ec,nec
      end if
      if (use_chgdpl .and. (necd.ne.0.or.ecd.ne.0.0d0)) then
         if (abs(ecd) .lt. 1.0d10) then
            fstr = '('' Charge-Dipole'',14x,'//form1//')'
         else
            fstr = '('' Charge-Dipole'',14x,'//form2//')'
         end if
         write (iout,fstr)  ecd,necd
      end if
      if (use_dipole .and. (ned.ne.0.or.ed.ne.0.0d0)) then
         if (abs(ed) .lt. 1.0d10) then
            fstr = '('' Dipole-Dipole'',14x,'//form1//')'
         else
            fstr = '('' Dipole-Dipole'',14x,'//form2//')'
         end if
         write (iout,fstr)  ed,ned
      end if
      if (use_mpole .and. (nem.ne.0.or.em.ne.0.0d0)) then
         if (abs(em) .lt. 1.0d10) then
            fstr = '('' Atomic Multipoles'',10x,'//form1//')'
         else
            fstr = '('' Atomic Multipoles'',10x,'//form2//')'
         end if
         write (iout,fstr)  em,nem
      end if
      if (use_polar .and. (nep.ne.0.or.ep.ne.0.0d0)) then
         if (abs(ep) .lt. 1.0d10) then
            fstr = '('' Polarization'',15x,'//form1//')'
         else
            fstr = '('' Polarization'',15x,'//form2//')'
         end if
         write (iout,fstr)  ep,nep
      end if
      if (use_chgtrn .and. (nect.ne.0.or.ect.ne.0.0d0)) then
         if (abs(ect) .lt. 1.0d10) then
            fstr = '('' Charge Transfer'',12x,'//form1//')'
         else
            fstr = '('' Charge Transfer'',12x,'//form2//')'
         end if
         write (iout,fstr)  ect,nect
      end if
      if (use_rxnfld .and. (nerxf.ne.0.or.erxf.ne.0.0d0)) then
         fstr = '('' Reaction Field'',13x,'//form1//')'
         write (iout,fstr)  erxf,nerxf
      end if
      if (use_solv .and. (nes.ne.0.or.es.ne.0.0d0)) then
         fstr = '('' Implicit Solvation'',9x,'//form1//')'
         write (iout,fstr)  es,nes
      end if
      if (use_metal .and. (nelf.ne.0.or.elf.ne.0.0d0)) then
         fstr = '('' Metal Ligand Field'',9x,'//form1//')'
         write (iout,fstr)  elf,nelf
      end if
      if (use_geom .and. (neg.ne.0.or.eg.ne.0.0d0)) then
         fstr = '('' Geometric Restraints'',7x,'//form1//')'
         write (iout,fstr)  eg,neg
      end if
      if (use_extra .and. (nex.ne.0.or.ex.ne.0.0d0)) then
         fstr = '('' Extra Energy Terms'',9x,'//form1//')'
         write (iout,fstr)  ex,nex
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine momyze  --  electrostatic & inertial analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "momyze" finds and prints the total charge, dipole moment
c     components, radius of gyration and moments of inertia
c
c
      subroutine momyze
      use chgpot
      use iounit
      use moment
      implicit none
      real*8 rg
      character*6 mode
c
c
c     get the electrostatic moments over the active atoms
c
      mode = 'ACTIVE'
      call moments (mode)
c
c     print the total charge, dipole and quadrupole moments
c
      write (iout,10)  netchg
   10 format (/,' Total Electric Charge :',12x,f13.5,' Electrons')
      write (iout,20)  netdpl,xdpl,ydpl,zdpl
   20 format (/,' Dipole Moment Magnitude :',10x,f13.3,' Debye',
     &        //,' Dipole X,Y,Z-Components :',10x,3f13.3)
      write (iout,30)  xxqpl,xyqpl,xzqpl,yxqpl,yyqpl,
     &                 yzqpl,zxqpl,zyqpl,zzqpl
   30 format (/,' Quadrupole Moment Tensor :',9x,3f13.3,
     &        /,6x,'(Buckinghams)',17x,3f13.3,
     &        /,36x,3f13.3)
      write (iout,40)  netqpl(1),netqpl(2),netqpl(3)
   40 format (/,' Principal Axes Quadrupole :',8x,3f13.3)
      if (dielec .ne. 1.0d0) then
         write (iout,50)  dielec
   50    format (/,' Dielectric Constant :',14x,f13.3)
         write (iout,60)  netchg/sqrt(dielec)
   60    format (' Effective Total Charge :',11x,f13.5,' Electrons')
         write (iout,70)  netdpl/sqrt(dielec)
   70    format (' Effective Dipole Moment :',10x,f13.3,' Debye')
      end if
c
c     get the radius of gyration and moments of inertia
c
      call gyrate (rg)
      write (iout,80)  rg
   80 format (/,' Radius of Gyration :',15x,f13.3,' Angstroms')
      call inertia (1)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine atomyze  --  individual atom energy analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "atomyze" prints the potential energy components broken
c     down by atom and to a choice of precision
c
c
      subroutine atomyze (active)
      use analyz
      use atoms
      use inform
      use iounit
      implicit none
      integer i
      logical active(*)
      character*240 fstr
c
c
c     energy partitioning over the individual atoms
c
      fstr = '(/,'' Potential Energy Breakdown over Atoms :'')'
      write (iout,fstr)
      if (digits .ge. 8) then
         write (iout,10)
   10    format (/,'  Atom',9x,'EB',14x,'EA',14x,'EBA',13x,'EUB',
     &           /,15x,'EAA',13x,'EOPB',12x,'EOPD',12x,'EID',
     &           /,15x,'EIT',13x,'ET',14x,'EPT',13x,'EBT',
     &           /,15x,'EAT',13x,'ETT',13x,'EV',14x,'ER',
     &           /,15x,'EDSP',12x,'EC',14x,'ECD',13x,'ED',
     &           /,15x,'EM',14x,'EP',14x,'ECT',13x,'ERXF',
     &           /,15x,'ES',14x,'ELF',13x,'EG',14x,'EX')
      else if (digits .ge. 6) then
         write (iout,20)
   20    format (/,'  Atom',8x,'EB',12x,'EA',12x,'EBA',11x,'EUB',
     &              11x,'EAA',
     &           /,14x,'EOPB',10x,'EOPD',10x,'EID',11x,'EIT',11x,'ET',
     &           /,14x,'EPT',11x,'EBT',11x,'EAT',11x,'ETT',11x,'EV',
     &           /,14x,'ER',12x,'EDSP',10x,'EC',12x,'ECD',11x,'ED',
     &           /,14x,'EM',12x,'EP',12x,'ECT',11x,'ERXF',10x,'ES',
     &           /,14x,'ELF',11x,'EG',12x,'EX')
      else
         write (iout,30)
   30    format (/,'  Atom',8x,'EB',10x,'EA',10x,'EBA',9x,'EUB',
     &              9x,'EAA',9x,'EOPB',
     &           /,14x,'EOPD',8x,'EID',9x,'EIT',9x,'ET',10x,'EPT',
     &              9x,'EBT',
     &           /,14x,'EAT',9x,'ETT',9x,'EV',10x,'ER',10x,'EDSP',
     &              8x,'EC',
     &           /,14x,'ECD',9x,'ED',10x,'EM',10x,'EP',10x,'ECT',
     &              9x,'ERXF',
     &           /,14x,'ES',10x,'ELF',9x,'EG',10x,'EX')
      end if
      if (digits .ge. 8) then
         fstr = '(/,i6,4f16.8,/,6x,4f16.8,/,6x,4f16.8,'//
     &             '/,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8,'//
     &             '/,6x,4f16.8)'
      else if (digits .ge. 6) then
         fstr = '(/,i6,5f14.6,/,6x,5f14.6,/,6x,5f14.6,'//
     &             '/,6x,5f14.6,/,6x,5f14.6,/,6x,3f14.6)'
      else
         fstr = '(/,i6,6f12.4,/,6x,6f12.4,/,6x,6f12.4,'//
     &             '/,6x,6f12.4,/,6x,4f12.4)'
      end if
      do i = 1, n
         if (active(i)) then
            write (iout,fstr)  i,aeb(i),aea(i),aeba(i),aeub(i),aeaa(i),
     &                         aeopb(i),aeopd(i),aeid(i),aeit(i),aet(i),
     &                         aept(i),aebt(i),aeat(i),aett(i),aev(i),
     &                         aer(i),aedsp(i),aec(i),aecd(i),aed(i),
     &                         aem(i),aep(i),aect(i),aerxf(i),aes(i),
     &                         aelf(i),aeg(i),aex(i)
         end if
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine viriyze  --  inertial virial & pressure values  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "propyze" finds and prints the internal virial, the dE/dV value
c     and an estimate of the pressure
c
c
      subroutine viriyze
      use atoms
      use bath
      use bound
      use boxes
      use iounit
      use units
      use virial
      implicit none
      integer i
      real*8 temp,pres,dedv
c
c
c     print out the components of the internal virial
c
      write (iout,10)  (vir(1,i),vir(2,i),vir(3,i),i=1,3)
   10 format (/,' Internal Virial Tensor :',11x,3f13.3,
     &        /,36x,3f13.3,/,36x,3f13.3)
c
c     compute the dE/dV value and construct isotropic pressure
c
      if (use_bounds) then
         temp = kelvin
         if (temp .eq. 0.0d0)  temp = 298.0d0
         dedv = (vir(1,1)+vir(2,2)+vir(3,3)) / (3.0d0*volbox)
         pres = prescon * (dble(n)*gasconst*temp/volbox-dedv)
         write (iout,20)  nint(temp),pres
   20    format (/,' Pressure (Temp',i4,' K) :',12x,f13.3,
     &              ' Atmospheres')
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine saveyze  --  save forces or induced dipoles  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "saveyze" prints the atomic forces and/or the induced dipoles
c     to separate external files
c
c
      subroutine saveyze (frame)
      use atomid
      use atoms
      use deriv
      use files
      use iounit
      use output
      use mpole
      use polar
      use potent
      use units
      use titles
      implicit none
      integer i,j,ii
      integer frame,lext
      integer ifrc,iind
      integer freeunit
      integer trimtext
      logical exist
      character*7 ext
      character*240 frcfile
      character*240 indfile
c
c
c     save the force vector components for the current frame
c
      if (frcsave) then
         ifrc = freeunit ()
         if (archive) then
            frcfile = filename(1:leng)
            call suffix (frcfile,'frc','old')
            inquire (file=frcfile,exist=exist)
            if (exist) then
               call openend (ifrc,frcfile)
            else
               open (unit=ifrc,file=frcfile,status='new')
            end if
         else
            lext = 3
            call numeral (frame,ext,lext)
            frcfile = filename(1:leng)//'.'//ext(1:lext)//'f'
            call version (frcfile,'new')
            open (unit=ifrc,file=frcfile,status='new')
         end if
         write (ifrc,10)  n,title(1:ltitle)
   10    format (i6,2x,a)
         do i = 1, n
            write (ifrc,20)  i,name(i),(-desum(j,i),j=1,3)
   20       format (i6,2x,a3,3x,d13.6,3x,d13.6,3x,d13.6)
         end do
         close (unit=ifrc)
         write (iout,30)  frcfile(1:trimtext(frcfile))
   30    format (/,' Force Components Written To :  ',a)
      end if
c
c     save the induced dipole moments for the current frame
c
      if (uindsave .and. use_polar) then
         iind = freeunit ()
         if (archive) then
            indfile = filename(1:leng)
            call suffix (indfile,'uind','old')
            inquire (file=indfile,exist=exist)
            if (exist) then
               call openend (iind,indfile)
            else
               open (unit=iind,file=indfile,status='new')
            end if
         else
            lext = 3
            call numeral (frame,ext,lext)
            indfile = filename(1:leng)//'.'//ext(1:lext)//'u'
            call version (indfile,'new')
            open (unit=iind,file=indfile,status='new')
         end if
         write (iind,40)  n,title(1:ltitle)
   40    format (i6,2x,a)
         do ii = 1, npole
            i = ipole(ii)
            if (polarity(i) .ne. 0.0d0) then
               write (iind,50)  i,name(i),(debye*uind(j,i),j=1,3)
   50          format (i6,2x,a3,3f12.6)
            end if
         end do
         close (unit=iind)
         write (iout,60)  indfile(1:trimtext(indfile))
   60    format (/,' Induced Dipoles Written To :  ',a)
      end if
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine connyze  --  connected atom list analysis  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "connyze" prints information onconnected atoms as lists
c     of all atom pairs that are 1-2 through 1-5 interactions
c
c
      subroutine connyze (active)
      use atoms
      use couple
      use iounit
      implicit none
      integer i,j,k
      integer ntot
      integer ntot2,ntot3
      integer ntot4,ntot5
      logical active(*)
c
c
c     count the number of 1-2 through 1-5 interatomic pairs
c
      ntot2 = 0
      ntot3 = 0
      ntot4 = 0
      ntot5 = 0
      do i = 1, n
         ntot2 = ntot2 + n12(i)
         ntot3 = ntot3 + n13(i)
         ntot4 = ntot4 + n14(i)
         ntot5 = ntot5 + n15(i)
      end do
      ntot2 = ntot2 / 2
      ntot3 = ntot3 / 2
      ntot4 = ntot4 / 2
      ntot5 = ntot5 / 2
      ntot = ntot2 + ntot3 + ntot4 + ntot5
      if (ntot .ne. 0) then
         write (iout,10)
   10    format (/,' Total Number of Pairwise Atomic Interactions :',/)
      end if
      if (ntot2 .ne. 0) then
         write (iout,20)  ntot2
   20    format (' Number of 1-2 Pairs',7x,i15)
      end if
      if (ntot3 .ne. 0) then
         write (iout,30)  ntot3
   30    format (' Number of 1-3 Pairs',7x,i15)
      end if
      if (ntot4 .ne. 0) then
         write (iout,40)  ntot4
   40    format (' Number of 1-4 Pairs',7x,i15)
      end if
      if (ntot5 .ne. 0) then
         write (iout,50)  ntot5
   50    format (' Number of 1-5 Pairs',7x,i15)
      end if
c
c     generate and print the 1-2 connected atomic interactions
c
      if (ntot2 .ne. 0) then
         write (iout,60)
   60    format (/,' List of 1-2 Connected Atomic Interactions :',/)
         do i = 1, n
            if (active(i)) then
               do j = 1, n12(i)
                  k = i12(j,i)
                  if (active(k)) then
                     if (i .lt. k) then
                        write (iout,70)  i,k
   70                   format (2i8)
                     end if
                  end if
               end do
            end if
         end do
      end if
c
c     generate and print the 1-3 connected atomic interactions
c
      if (ntot3 .ne. 0) then
         write (iout,80)
   80    format (/,' List of 1-3 Connected Atomic Interactions :',/)
         do i = 1, n
            if (active(i)) then
               do j = 1, n13(i)
                  k = i13(j,i)
                  if (active(k)) then
                     if (i .lt. k) then
                        write (iout,90)  i,k
   90                   format (2i8)
                     end if
                  end if
               end do
            end if
         end do
      end if
c
c     generate and print the 1-4 connected atomic interactions
c
      if (ntot4 .ne. 0) then
         write (iout,100)
  100    format (/,' List of 1-4 Connected Atomic Interactions :',/)
         do i = 1, n
            if (active(i)) then
               do j = 1, n14(i)
                  k = i14(j,i)
                  if (active(k)) then
                     if (i .lt. k) then
                        write (iout,110)  i,k
  110                   format (2i8)
                     end if
                  end if
               end do
            end if
         end do
      end if
c
c     generate and print the 1-5 connected atomic interactions
c
      if (ntot5 .ne. 0) then
         write (iout,120)
  120    format (/,' List of 1-5 Connected Atomic Interactions :',/)
         do i = 1, n
            if (active(i)) then
               do j = 1, n15(i)
                  k = i15(j,i)
                  if (active(k)) then
                     if (i .lt. k) then
                        write (iout,130)  i,k
  130                   format (2i8)
                     end if
                  end if
               end do
            end if
         end do
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine paramyze  --  force field parameter analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "paramyze" prints the force field parameters used in the
c     computation of each of the potential energy terms
c
c
      subroutine paramyze (active)
      use angang
      use angbnd
      use angpot
      use angtor
      use atomid
      use atoms
      use bitor
      use bndstr
      use cflux
      use charge
      use chgpen
      use chgtrn
      use dipole
      use disp
      use improp
      use imptor
      use iounit
      use korbs
      use ktrtor
      use kvdws
      use math
      use mplpot
      use mpole
      use opbend
      use opdist
      use piorbs
      use pistuf
      use pitors
      use polar
      use polgrp
      use polpot
      use potent
      use repel
      use solpot
      use solute
      use strbnd
      use strtor
      use tors
      use tortor
      use units
      use urey
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ia,ib,ic
      integer id,ie,ig
      integer ixaxe
      integer iyaxe
      integer izaxe
      integer fold(9)
      real*8 bla,blc
      real*8 radj,rad4j
      real*8 ampli(9)
      real*8 phase(9)
      real*8 mpl(13)
      logical header
      logical active(*)
c
c
c     number of each type of interaction and site
c
      if (n .ne. 0) then
         write (iout,10)
   10    format (/,' Interactions and Sites :',/)
         write (iout,20)  n
   20    format (' Atomic Sites',21x,i15)
      end if
      if (use_bond .and. nbond.ne.0) then
         write (iout,30)  nbond
   30    format (' Bond Stretches',19x,i15)
      end if
      if (use_angle .and. nangle.ne.0) then
         write (iout,40)  nangle
   40    format (' Angle Bends',22x,i15)
      end if
      if (use_strbnd .and. nstrbnd.ne.0) then
         write (iout,50)  nstrbnd
   50    format (' Stretch-Bends',20x,i15)
      end if
      if (use_urey .and. nurey.ne.0) then
         write (iout,60)  nurey
   60    format (' Urey-Bradley',21x,i15)
      end if
      if (use_angang .and. nangang.ne.0) then
         write (iout,70)  nangang
   70    format (' Angle-Angles',21x,i15)
      end if
      if (use_opbend .and. nopbend.ne.0) then
         write (iout,80)  nopbend
   80    format (' Out-of-Plane Bends',15x,i15)
      end if
      if (use_opdist .and. nopdist.ne.0) then
         write (iout,90)  nopdist
   90    format (' Out-of-Plane Distances',11x,i15)
      end if
      if (use_improp .and. niprop.ne.0) then
         write (iout,100)  niprop
  100    format (' Improper Dihedrals',15x,i15)
      end if
      if (use_imptor .and. nitors.ne.0) then
         write (iout,110)  nitors
  110    format (' Improper Torsions',16x,i15)
      end if
      if (use_tors .and. ntors.ne.0) then
         write (iout,120)  ntors
  120    format (' Torsional Angles',17x,i15)
      end if
      if (use_pitors .and. npitors.ne.0) then
         write (iout,130)  npitors
  130    format (' Pi-Orbital Torsions',14x,i15)
      end if
      if (use_strtor .and. nstrtor.ne.0) then
         write (iout,140)  nstrtor
  140    format (' Stretch-Torsions',17x,i15)
      end if
      if (use_angtor .and. nangtor.ne.0) then
         write (iout,150)  nangtor
  150    format (' Angle-Torsions',19x,i15)
      end if
      if (use_tortor .and. ntortor.ne.0) then
         write (iout,160)  ntortor
  160    format (' Torsion-Torsions',17x,i15)
      end if
      if (use_vdw .and. nvdw.ne.0) then
         write (iout,170)  nvdw
  170    format (' Van der Waals Sites',14x,i15)
      end if
      if (use_repel .and. nrep.ne.0) then
         write (iout,180)  nrep
  180    format (' Repulsion Sites',18x,i15)
      end if
      if (use_disp .and. ndisp.ne.0) then
         write (iout,190)  ndisp
  190    format (' Dispersion Sites',17x,i15)
      end if
      if (use_charge .and. nion.ne.0) then
         write (iout,200)  nion
  200    format (' Atomic Partial Charges',11x,i15)
      end if
      if (use_dipole .and. ndipole.ne.0) then
         write (iout,210)  ndipole
  210    format (' Bond Dipole Moments',14x,i15)
      end if
      if (use_mpole .and. npole.ne.0) then
         write (iout,220)  npole
  220    format (' Atomic Multipoles',16x,i15)
      end if
      if (use_chgpen .and. ncp.ne.0) then
         write (iout,230)  ncp
  230    format (' Charge Penetration',15x,i15)
      end if
      if (use_polar .and. npolar.ne.0) then
         write (iout,240)  npolar
  240    format (' Polarizable Sites',16x,i15)
      end if
      if (use_chgtrn .and. nct.ne.0) then
         write (iout,250)  nct
  250    format (' Charge Transfer Sites',12x,i15)
      end if
      if (use_chgflx .and. nbflx.ne.0) then
         write (iout,260)  nbflx
  260    format (' Bond Charge Flux',17x,i15)
      end if
      if (use_chgflx .and. naflx.ne.0) then
         write (iout,270)  naflx
  270    format (' Angle Charge Flux',16x,i15)
      end if
      if (use_orbit .and. norbit.ne.0) then
         write (iout,280)  norbit
  280    format (' Pisystem Atoms',19x,i15)
      end if
      if (use_orbit .and. nbpi.ne.0) then
         write (iout,290)  nbpi
  290    format (' Conjugated Pi-Bonds',14x,i15)
      end if
c
c     parameters used for molecular mechanics atom types
c
      header = .true.
      do i = 1, n
         if (active(i)) then
            if (header) then
               header = .false.
               write (iout,300)
  300          format (/,' Atom Definition Parameters :',
     &                 //,3x,'Atom',2x,'Symbol',2x,'Type',
     &                    2x,'Class',2x,'Atomic',3x,'Mass',
     &                    2x,'Valence',2x,'Description',/)
            end if
            write (iout,310)  i,name(i),type(i),class(i),atomic(i),
     &                        mass(i),valnum(i),story(i)
  310       format (i6,5x,a3,2i7,i6,f10.3,i5,5x,a24)
         end if
      end do
c
c     parameters used for bond stretching interactions
c
      if (use_bond) then
         header = .true.
         do i = 1, nbond
            ia = ibnd(1,i)
            ib = ibnd(2,i)
            if (active(ia) .or. active(ib)) then
               if (header) then
                  header = .false.
                  write (iout,320)
  320             format (/,' Bond Stretching Parameters :',
     &                    //,10x,'Atom Numbers',25x,'KS',7x,'Bond',/)
               end if
               write (iout,330)  i,ia,ib,bk(i),bl(i)
  330          format (i6,3x,2i6,19x,f10.3,f10.4)
            end if
         end do
      end if
c
c     parameters used for angle bending interactions
c
      if (use_angle) then
         header = .true.
         do i = 1, nangle
            ia = iang(1,i)
            ib = iang(2,i)
            ic = iang(3,i)
            if (active(ia) .or. active(ib) .or. active(ic)) then
               if (header) then
                  header = .false.
                  write (iout,340)
  340             format (/,' Angle Bending Parameters :',
     &                    //,13x,'Atom Numbers',22x,'KB',
     &                       6x,'Angle',3x,'Fold',4x,'Type',/)
               end if
               if (angtyp(i) .eq. 'HARMONIC') then
                  write (iout,350)  i,ia,ib,ic,ak(i),anat(i)
  350             format (i6,3x,3i6,13x,2f10.3)
               else if (angtyp(i) .eq. 'IN-PLANE') then
                  write (iout,360)  i,ia,ib,ic,ak(i),anat(i)
  360             format (i6,3x,3i6,13x,2f10.3,9x,'In-Plane')
               else if (angtyp(i) .eq. 'LINEAR') then
                  write (iout,370)  i,ia,ib,ic,ak(i),anat(i)
  370             format (i6,3x,3i6,13x,2f10.3,9x,'Linear')
               else if (angtyp(i) .eq. 'FOURIER ') then
                  write (iout,380)  i,ia,ib,ic,ak(i),anat(i),afld(i)
  380             format (i6,3x,3i6,13x,2f10.3,f7.1,2x,'Fourier')
               end if
            end if
         end do
      end if
c
c     parameters used for stretch-bend interactions
c
      if (use_strbnd) then
         header = .true.
         do i = 1, nstrbnd
            k = isb(1,i)
            ia = iang(1,k)
            ib = iang(2,k)
            ic = iang(3,k)
            if (active(ia) .or. active(ib) .or. active(ic)) then
               if (header) then
                  header = .false.
                  write (iout,390)
  390             format (/,' Stretch-Bend Parameters :',
     &                    //,13x,'Atom Numbers',8x,'KSB 1',5x,'KSB 2',
     &                       6x,'Angle',3x,'Bond 1',3x,'Bond 2',/)
               end if
               bla = 0.0d0
               blc = 0.0d0
               if (isb(2,i) .ne. 0)  bla = bl(isb(2,i))
               if (isb(3,i) .ne. 0)  blc = bl(isb(3,i))
               write (iout,400)  i,ia,ib,ic,sbk(1,i),sbk(2,i),
     &                           anat(k),bla,blc
  400          format (i6,3x,3i6,1x,2f10.3,2x,f9.3,2f9.4)
            end if
         end do
      end if
c
c     parameters used for Urey-Bradley interactions
c
      if (use_urey) then
         header = .true.
         do i = 1, nurey
            ia = iury(1,i)
            ib = iury(2,i)
            ic = iury(3,i)
            if (active(ia) .or. active(ic)) then
               if (header) then
                  header = .false.
                  write (iout,410)
  410             format (/,' Urey-Bradley Parameters :',
     &                    //,13x,'Atom Numbers',21x,'KUB',
     &                       4x,'Distance',/)
               end if
               write (iout,420)  i,ia,ib,ic,uk(i),ul(i)
  420          format (i6,3x,3i6,13x,f10.3,f10.4)
            end if
         end do
      end if
c
c     parameters used for out-of-plane bend interactions
c
      if (use_opbend) then
         header = .true.
         do i = 1, nopbend
            k = iopb(i)
            ia = iang(1,k)
            ib = iang(2,k)
            ic = iang(3,k)
            id = iang(4,k)
            if (active(ia) .or. active(ib) .or.
     &             active(ic) .or. active(id)) then
               if (header) then
                  header = .false.
                  write (iout,430)
  430             format (/,' Out-of-Plane Bend Parameters :',
     &                    //,17x,'Atom Numbers',19x,'KOPB',/)
               end if
               write (iout,440)  i,id,ib,ia,ic,opbk(i)
  440          format (i6,3x,4i6,9x,f10.3)
            end if
         end do
      end if
c
c     parameters used for out-of-plane distance interactions
c
      if (use_opdist) then
         header = .true.
         do i = 1, nopdist
            ia = iopd(1,i)
            ib = iopd(2,i)
            ic = iopd(3,i)
            id = iopd(4,i)
            if (active(ia) .or. active(ib) .or.
     &             active(ic) .or. active(id)) then
               if (header) then
                  header = .false.
                  write (iout,450)
  450             format (/,' Out-of-Plane Distance Parameters :',
     &                    //,17x,'Atom Numbers',19x,'KOPD',/)
               end if
               write (iout,460)  i,ia,ib,ic,id,opdk(i)
  460          format (i6,3x,4i6,9x,f10.3)
            end if
         end do
      end if
c
c     parameters used for improper dihedral interactions
c
      if (use_improp) then
         header = .true.
         do i = 1, niprop
            ia = iiprop(1,i)
            ib = iiprop(2,i)
            ic = iiprop(3,i)
            id = iiprop(4,i)
            if (active(ia) .or. active(ib) .or.
     &             active(ic) .or. active(id)) then
               if (header) then
                  header = .false.
                  write (iout,470)
  470             format (/,' Improper Dihedral Parameters :',
     &                    //,17x,'Atom Numbers',19x,'KID',
     &                       4x,'Dihedral',/)
               end if
               write (iout,480)  i,ia,ib,ic,id,kprop(i),vprop(i)
  480          format (i6,3x,4i6,9x,2f10.4)
            end if
         end do
      end if
c
c     parameters used for improper torsion interactions
c
      if (use_imptor) then
         header = .true.
         do i = 1, nitors
            ia = iitors(1,i)
            ib = iitors(2,i)
            ic = iitors(3,i)
            id = iitors(4,i)
            if (active(ia) .or. active(ib) .or.
     &             active(ic) .or. active(id)) then
               if (header) then
                  header = .false.
                  write (iout,490)
  490             format (/,' Improper Torsion Parameters :',
     &                    //,17x,'Atom Numbers',11x,
     &                       'Amplitude, Phase and Periodicity',/)
               end if
               j = 0
               if (itors1(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 1
                  ampli(j) = itors1(1,i)
                  phase(j) = itors1(2,i)
               end if
               if (itors2(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 2
                  ampli(j) = itors2(1,i)
                  phase(j) = itors2(2,i)
               end if
               if (itors3(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 3
                  ampli(j) = itors3(1,i)
                  phase(j) = itors3(2,i)
               end if
               if (j .eq. 0) then
                  write (iout,500)  i,ia,ib,ic,id
  500             format (i6,3x,4i6)
               else if (j .eq. 1) then
                  write (iout,510)  i,ia,ib,ic,id,
     &                              ampli(1),phase(1),fold(1)
  510             format (i6,3x,4i6,10x,f10.3,f8.1,i4)
               else if (j .eq. 2) then
                  write (iout,520)  i,ia,ib,ic,id,(ampli(k),
     &                              phase(k),fold(k),k=1,j)
  520             format (i6,3x,4i6,2x,2(f10.3,f6.1,i4))
               else
                  write (iout,530)  i,ia,ib,ic,id,(ampli(k),
     &                              nint(phase(k)),fold(k),k=1,j)
  530             format (i6,3x,4i6,4x,3(f8.3,i4,'/',i1))
               end if
            end if
         end do
      end if
c
c     parameters used for torsional interactions
c
      if (use_tors) then
         header = .true.
         do i = 1, ntors
            ia = itors(1,i)
            ib = itors(2,i)
            ic = itors(3,i)
            id = itors(4,i)
            if (active(ia) .or. active(ib) .or.
     &             active(ic) .or. active(id)) then
               if (header) then
                  header = .false.
                  write (iout,540)
  540             format (/,' Torsional Angle Parameters :',
     &                    //,17x,'Atom Numbers',11x,
     &                       'Amplitude, Phase and Periodicity',/)
               end if
               j = 0
               if (tors1(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 1
                  ampli(j) = tors1(1,i)
                  phase(j) = tors1(2,i)
               end if
               if (tors2(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 2
                  ampli(j) = tors2(1,i)
                  phase(j) = tors2(2,i)
               end if
               if (tors3(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 3
                  ampli(j) = tors3(1,i)
                  phase(j) = tors3(2,i)
               end if
               if (tors4(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 4
                  ampli(j) = tors4(1,i)
                  phase(j) = tors4(2,i)
               end if
               if (tors5(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 5
                  ampli(j) = tors5(1,i)
                  phase(j) = tors5(2,i)
               end if
               if (tors6(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 6
                  ampli(j) = tors6(1,i)
                  phase(j) = tors6(2,i)
               end if
               if (j .eq. 0) then
                  write (iout,550)  i,ia,ib,ic,id
  550             format (i6,3x,4i6)
               else
                  write (iout,560)  i,ia,ib,ic,id,(ampli(k),
     &                              nint(phase(k)),fold(k),k=1,j)
  560             format (i6,3x,4i6,4x,6(f8.3,i4,'/',i1))
               end if
            end if
         end do
      end if
c
c     parameters used for pi-system torsion interactions
c
      if (use_pitors) then
         header = .true.
         do i = 1, npitors
            ia = ipit(1,i)
            ib = ipit(2,i)
            ic = ipit(3,i)
            id = ipit(4,i)
            ie = ipit(5,i)
            ig = ipit(6,i)
            if (active(ia) .or. active(ib) .or. active(ic) .or.
     &             active(id) .or. active(ie) .or. active(ig)) then
               if (header) then
                  header = .false.
                  write (iout,570)
  570             format (/,' Pi-Orbital Torsion Parameters :',
     &                    //,10x,'Atom Numbers',19x,'Amplitude',/)
               end if
               write (iout,580)  i,ic,id,kpit(i)
  580          format (i6,3x,2i6,19x,f10.4)
            end if
         end do
      end if
c
c     parameters used for stretch-torsion interactions
c
      if (use_strtor) then
         header = .true.
         do i = 1, nstrtor
            k = ist(1,i)
            ia = itors(1,k)
            ib = itors(2,k)
            ic = itors(3,k)
            id = itors(4,k)
            if (active(ia) .or. active(ib) .or.
     &             active(ic) .or. active(id)) then
               if (header) then
                  header = .false.
                  write (iout,590)
  590             format (/,' Stretch-Torsion Parameters :',
     &                    //,17x,'Atom Numbers',10x,'Bond',
     &                       5x,'Amplitude and Phase (1-3 Fold)',/)
               end if
               ampli(1) = kst(1,i)
               phase(1) = tors1(2,k)
               ampli(2) = kst(2,i)
               phase(2) = tors2(2,k)
               ampli(3) = kst(3,i)
               phase(3) = tors3(2,k)
               ampli(4) = kst(4,i)
               phase(4) = tors1(2,k)
               ampli(5) = kst(5,i)
               phase(5) = tors2(2,k)
               ampli(6) = kst(6,i)
               phase(6) = tors3(2,k)
               ampli(7) = kst(7,i)
               phase(7) = tors1(2,k)
               ampli(8) = kst(8,i)
               phase(8) = tors2(2,k)
               ampli(9) = kst(9,i)
               phase(9) = tors3(2,k)
               write (iout,600)  i,ia,ib,ic,id,
     &                           '1st',(ampli(k),nint(phase(k)),k=1,3),
     &                           '2nd',(ampli(k),nint(phase(k)),k=4,6),
     &                           '3rd',(ampli(k),nint(phase(k)),k=7,9)
  600          format (i6,3x,4i6,7x,a3,3x,3(f7.3,i4),
     &                 /,40x,a3,3x,3(f7.3,i4),
     &                 /,40x,a3,3x,3(f7.3,i4))
            end if
         end do
      end if
c
c     parameters used for angle-torsion interactions
c
      if (use_angtor) then
         header = .true.
         do i = 1, nangtor
            k = iat(1,i)
            ia = itors(1,k)
            ib = itors(2,k)
            ic = itors(3,k)
            id = itors(4,k)
            if (active(ia) .or. active(ib) .or.
     &             active(ic) .or. active(id)) then
               if (header) then
                  header = .false.
                  write (iout,610)
  610             format (/,' Angle-Torsion Parameters :',
     &                    //,17x,'Atom Numbers',10x,'Angle',
     &                       4x,'Amplitude and Phase (1-3 Fold)',/)
               end if
               ampli(1) = kant(1,i)
               phase(1) = tors1(2,k)
               ampli(2) = kant(2,i)
               phase(2) = tors2(2,k)
               ampli(3) = kant(3,i)
               phase(3) = tors3(2,k)
               ampli(4) = kant(4,i)
               phase(4) = tors1(2,k)
               ampli(5) = kant(5,i)
               phase(5) = tors2(2,k)
               ampli(6) = kant(6,i)
               phase(6) = tors3(2,k)
               write (iout,620)  i,ia,ib,ic,id,
     &                           '1st',(ampli(k),nint(phase(k)),k=1,3),
     &                           '2nd',(ampli(k),nint(phase(k)),k=4,6)
  620          format (i6,3x,4i6,7x,a3,3x,3(f7.3,i4),
     &                 /,40x,a3,3x,3(f7.3,i4))
            end if
         end do
      end if
c
c     parameters used for torsion-torsion interactions
c
      if (use_tortor) then
         header = .true.
         do i = 1, ntortor
            k = itt(1,i)
            ia = ibitor(1,k)
            ib = ibitor(2,k)
            ic = ibitor(3,k)
            id = ibitor(4,k)
            ie = ibitor(5,k)
            if (active(ia) .or. active(ib) .or. active(ic) .or.
     &                active(id) .or. active(ie)) then
               if (header) then
                  header = .false.
                  write (iout,630)
  630             format (/,' Torsion-Torsion Parameters :',
     &                    //,20x,'Atom Numbers',15x,'Spline Grid',
     &                       6x,'Tier',/)
               end if
               j = itt(2,i)
               write (iout,640)  i,ia,ib,ic,id,ie,tnx(j),tny(j),ttier(j)
  640          format (i6,3x,5i6,7x,2i6,7x,a3)
            end if
         end do
      end if
c
c     parameters used for van der Waals interactions
c
      if (use_vdw) then
         header = .true.
         k = 0
         do i = 1, n
            if (active(i)) then
               k = k + 1
               if (header) then
                  header = .false.
                  write (iout,650)
  650             format (/,' Van der Waals Parameters :',
     &                    //,10x,'Atom Number',7x,'Size',
     &                       3x,'Epsilon',3x,'Size 1-4',
     &                       3x,'Eps 1-4',3x,'Reduction',/)
               end if
               j = class(i)
               if (vdwindex .eq. 'TYPE')  j = type(i)
               if (rad(j).eq.rad4(j) .and. eps(j).eq.eps4(j)) then
                  radj = rad(j)
                  if (radsiz .eq. 'DIAMETER')  radj = 2.0d0 * radj
                  if (radtyp .eq. 'SIGMA')  radj = radj / twosix
                  if (reduct(j) .eq. 0.0d0) then
                     write (iout,660)  k,i,radj,eps(j)
  660                format (i6,3x,i6,7x,2f10.4)
                  else
                     write (iout,670)  k,i,radj,eps(j),reduct(j)
  670                format (i6,3x,i6,7x,2f10.4,22x,f10.4)
                  end if
               else
                  radj = rad(j)
                  rad4j = rad4(j)
                  if (radsiz .eq. 'DIAMETER') then
                     radj = 2.0d0 * radj
                     rad4j = 2.0d0 * rad4j
                  end if
                  if (radtyp .eq. 'SIGMA') then
                     radj = radj / twosix
                     rad4j = rad4j / twosix
                  end if
                  if (reduct(j) .eq. 0.0d0) then
                     write (iout,680)  k,i,radj,eps(j),rad4j,eps4(j)
  680                format (i6,3x,i6,7x,2f10.4,1x,2f10.4)
                  else
                     write (iout,690)  k,i,radj,eps(j),rad4j,
     &                                eps4(j),reduct(j)
  690                format (i6,3x,i6,7x,2f10.4,1x,2f10.4,1x,f10.4)
                  end if
               end if
            end if
         end do
      end if
c
c     parameters used for Pauli repulsion interactions
c
      if (use_repel) then
         header = .true.
         do i = 1, nrep
            ia = irep(i)
            if (active(ia)) then
               if (header) then
                  header = .false.
                  write (iout,700)
  700             format (/,' Pauli Repulsion Parameters :',
     &                    //,10x,'Atom Number',25x,'Size',6x,'Damp',
     &                       3x,'Valence',/)
               end if
               write (iout,710)  i,ia,sizpr(i),dmppr(i),elepr(i)
  710          format (i6,3x,i6,25x,2f10.4,f10.3)
            end if
         end do
      end if
c
c     parameters used for damped dispersion interactions
c
      if (use_disp) then
         header = .true.
         do i = 1, ndisp
            ia = idisp(i)
            if (active(ia)) then
               if (header) then
                  header = .false.
                  write (iout,720)
  720             format (/,' Damped Dispersion Parameters :',
     &                    //,10x,'Atom Number',26x,'C6',7x,'Damp',/)
               end if
               write (iout,730)  i,ia,csix(i),adisp(i)
  730          format (i6,3x,i6,25x,f10.3,f10.4)
            end if
         end do
      end if
c
c     parameters used for atomic partial charges
c
      if (use_charge .or. use_chgdpl) then
         header = .true.
         do i = 1, nion
            ia = iion(i)
            ib = jion(ia)
            ic = kion(ia)
            if (active(ia) .or. active(ic)) then
               if (header) then
                  header = .false.
                  write (iout,740)
  740             format (/,' Atomic Partial Charge Parameters :',
     &                    /,45x,'Neighbor',3x,'Cutoff',
     &                    /,10x,'Atom Number',13x,'Charge',
     &                       7x,'Site',6x,'Site',/)
               end if
               if (ia.eq.ib .and. ia.eq.ic) then
                  write (iout,750)  i,ia,pchg(ia)
  750             format (i6,3x,i6,15x,f10.4)
               else
                  write (iout,760)  i,ia,pchg(ia),ib,ic
  760             format (i6,3x,i6,15x,f10.4,5x,i6,4x,i6)
               end if
            end if
         end do
      end if
c
c     parameters used for bond dipole moments
c
      if (use_dipole .or. use_chgdpl) then
         header = .true.
         do i = 1, ndipole
            ia = idpl(1,i)
            ib = idpl(2,i)
            if (active(ia) .or. active(ib)) then
               if (header) then
                  header = .false.
                  write (iout,770)
  770             format (/,' Bond Dipole Moment Parameters :',
     &                    //,10x,'Atom Numbers',22x,'Dipole',
     &                       3x,'Position',/)
               end if
               write (iout,780)  i,ia,ib,bdpl(i),sdpl(i)
  780          format (i6,3x,2i6,19x,f10.4,f10.3)
            end if
         end do
      end if
c
c     parameters used for atomic multipole moments
c
      if (use_mpole) then
         header = .true.
         do i = 1, npole
            ia = ipole(i)
            if (active(ia)) then
               if (header) then
                  header = .false.
                  write (iout,790)
  790             format (/,' Atomic Multipole Parameters :',
     &                    //,11x,'Atom',3x,'Z-Axis',1x,'X-Axis',
     &                       1x,'Y-Axis',2x,
     &                       'Frame',11x,'Multipole Moments',/)
               end if
               izaxe = zaxis(ia)
               ixaxe = xaxis(ia)
               iyaxe = yaxis(ia)
               if (iyaxe .lt. 0)  iyaxe = -iyaxe
               mpl(1) = pole(1,ia)
               do j = 2, 4
                  mpl(j) = pole(j,ia) / bohr
               end do
               do j = 5, 13
                  mpl(j) = 3.0d0 * pole(j,ia) / bohr**2
               end do
               if (izaxe .eq. 0) then
                  write (iout,800)  i,ia,polaxe(i),
     &                              (mpl(j),j=1,5),mpl(8),mpl(9),
     &                              (mpl(j),j=11,13)
  800             format (i6,3x,i6,25x,a8,2x,f9.5,/,50x,3f9.5,
     &                    /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5)
               else if (ixaxe .eq. 0) then
                  write (iout,810)  i,ia,izaxe,polaxe(i),
     &                              (mpl(j),j=1,5),mpl(8),mpl(9),
     &                              (mpl(j),j=11,13)
  810             format (i6,3x,i6,1x,i7,17x,a8,2x,f9.5,/,50x,3f9.5,
     &                    /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5)
               else  if (iyaxe .eq. 0) then
                  write (iout,820)  i,ia,izaxe,ixaxe,polaxe(i),
     &                              (mpl(j),j=1,5),mpl(8),mpl(9),
     &                              (mpl(j),j=11,13)
  820             format (i6,3x,i6,1x,2i7,10x,a8,2x,f9.5,/,50x,3f9.5,
     &                    /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5)
               else
                  write (iout,830)  i,ia,izaxe,ixaxe,iyaxe,polaxe(i),
     &                              (mpl(j),j=1,5),mpl(8),mpl(9),
     &                              (mpl(j),j=11,13)
  830             format (i6,3x,i6,1x,3i7,3x,a8,2x,f9.5,/,50x,3f9.5,
     &                    /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5)
               end if
            end if
         end do
      end if
c
c     parameters used for charge penetration damping
c
      if (use_chgpen) then
         header = .true.
         do i = 1, npole
            ia = ipole(i)
            if (active(ia)) then
               if (header) then
                  header = .false.
                  write (iout,840)
  840             format (/,' Charge Penetration Parameters :',
     &                    //,10x,'Atom Number',25x,'Core',3x,'Valence',
     &                       6x,'Damp',/)
               end if
               write (iout,850)  i,ia,pcore(ia),pval(ia),palpha(ia)
  850          format (i6,3x,i6,25x,2f10.3,f10.4)
            end if
         end do
      end if
c
c     parameters used for dipole polarizability
c
      if (use_polar) then
         header = .true.
         do i = 1, npole
            ia = ipole(i)
            if (active(ia)) then
               if (header) then
                  header = .false.
                  if (use_tholed) then
                     write (iout,860)
  860                format (/,' Dipole Polarizability Parameters :',
     &                       //,10x,'Atom Number',5x,'Alpha',4x,'Thole',
     &                          3x,'TholeD',6x,'Polarization Group',/)
                  else if (use_thole) then
                     write (iout,870)
  870                format (/,' Dipole Polarizability Parameters :',
     &                       //,10x,'Atom Number',5x,'Alpha',4x,'Thole',
     &                          6x,'Polarization Group',/)
                  else
                     write (iout,880)
  880                format (/,' Dipole Polarizability Parameters :',
     &                       //,10x,'Atom Number',5x,'Alpha',
     &                          6x,'Polarization Group',/)
                  end if
               end if
               if (use_tholed) then
                  write (iout,890)  i,ia,polarity(ia),thole(ia),
     &                              tholed(ia),(ip11(j,ia),j=1,np11(ia))
  890             format (i6,3x,i6,6x,f10.4,2f9.3,3x,120i6)
               else if (use_thole) then
                  write (iout,900)  i,ia,polarity(ia),thole(ia),
     &                              (ip11(j,ia),j=1,np11(ia))
  900             format (i6,3x,i6,6x,f10.4,f9.3,3x,120i6)
               else
                  write (iout,910)  i,ia,polarity(ia),
     &                              (ip11(j,ia),j=1,np11(ia))
  910             format (i6,3x,i6,6x,f10.4,3x,120i6)
               end if
            end if
         end do
      end if
c
c     parameters used for charge transfer interactions
c
      if (use_chgtrn) then
         header = .true.
         do i = 1, npole
            ia = ipole(i)
            if (active(ia)) then
               if (header) then
                  header = .false.
                  write (iout,920)
  920             format (/,' Charge Transfer Parameters :',
     &                    //,10x,'Atom Number',23x,'Charge',
     &                       6x,'Damp',/)
               end if
               write (iout,930)  i,ia,chgct(ia),dmpct(ia)
  930          format (i6,3x,i6,25x,f10.3,f10.4)
            end if
         end do
      end if
c
c     parameters used for bond charge flux interactions
c
      if (use_chgflx) then
         k = 0
         header = .true.
         do i = 1, nbond
            if (bflx(i) .ne. 0.0d0) then
               ia = ibnd(1,i)
               ib = ibnd(2,i)
               if (active(ia) .or. active(ib)) then
                  if (header) then
                     header = .false.
                     write (iout,940)
  940                format (/,' Bond Charge Flux Parameters :',
     &                       //,10x,'Atom Numbers',24x,'KCFB',/)
                  end if
                  k = k + 1
                  write (iout,950)  k,ia,ib,bflx(i)
  950             format (i6,3x,2i6,19x,f10.4)
               end if
            end if
         end do
      end if
c
c     parameters used for angle charge flux interactions
c
      if (use_chgflx) then
         k = 0
         header = .true.
         do i = 1, nangle
            if (aflx(1,i).ne.0.0d0 .or. aflx(2,i).ne.0.0d0 .or.
     &          abflx(1,i).ne.0.0d0 .or. abflx(2,i).ne.0.0d0) then
               ia = iang(1,i)
               ib = iang(2,i)
               ic = iang(3,i)
               if (active(ia) .or. active(ib) .or. active(ic)) then
                  if (header) then
                     header = .false.
                     write (iout,960)
  960                format (/,' Angle Charge Flux Parameters :',
     &                       //,13x,'Atom Numbers',17x,'KACF1',
     &                          5x,'KACF2',5x,'KBCF1',5x,'KBCF2',/)
                  end if
                  k = k + 1
                  write (iout,970)  k,ia,ib,ic,aflx(1,i),aflx(2,i),
     &                              abflx(1,i),abflx(2,i)
  970             format (i6,3x,3i6,10x,4f10.4)
               end if
            end if
         end do
      end if
c
c     parameters used for implicit solvation models
c
      if (use_solv) then
         header = .true.
         k = 0
         do i = 1, n
            if (active(i)) then
               k = k + 1
               if (header) then
                  header = .false.
                  if (solvtyp(1:2).eq.'GK') then
                     write (iout,980)
  980                format (/,' Implicit Solvation Parameters :',
     &                       //,10x,'Atom Number',11x,'Rsolv',
     &                          4x,'Rdescr',5x,'S-HCT',4x,'S-Neck',
     &                          3x,'Surface',/)
                  else if (solvtyp(1:2).eq.'PB') then
                     write (iout,990)
  990                format (/,' Implicit Solvation Parameters :',
     &                       //,10x,'Atom Number',10x,'Radius',
     &                          5x,'S-HCT',4x,'S-Neck',3x,'Surface',/)
                  else
                     write (iout,1000)
 1000                format (/,' Implicit Solvation Parameters :',
     &                       //,10x,'Atom Number',10x,'Radius',
     &                          3x,'Surface',/)
                  end if
               end if
               if (solvtyp(1:2).eq.'GK') then
                  write (iout,1010)  k,i,rsolv(i),rdescr(i),shct(i),
     &                               sneck(i),asolv(i)
 1010             format (i6,3x,i6,12x,5f10.4)
               else if (solvtyp(1:2).eq.'PB') then
                  write (iout,1020)  k,i,rsolv(i),shct(i),sneck(i),
     &                               asolv(i)
 1020             format (i6,3x,i6,12x,4f10.4)
               else
                  write (iout,1030)  k,i,rsolv(i),asolv(i)
 1030             format (i6,3x,i6,12x,2f10.4)
               end if
            end if
         end do
      end if
c
c     parameters used for conjugated pisystem atoms
c
      if (use_orbit) then
         header = .true.
         do i = 1, norbit
            ia = iorbit(i)
            j = class(ia)
            if (header) then
               header = .false.
               write (iout,1040)
 1040          format (/,' Conjugated Pi-Atom Parameters :',
     &                 //,10x,'Atom Number',14x,'Nelect',
     &                    6x,'Ionize',4x,'Repulsion',/)
            end if
            write (iout,1050)  i,ia,electron(j),ionize(j),repulse(j)
 1050       format (i6,3x,i6,17x,f8.1,3x,f10.4,2x,f10.4)
         end do
      end if
c
c     parameters used for conjugated pibond interactions
c
      if (use_orbit) then
         header = .true.
         do i = 1, nbpi
            ia = ibpi(2,i)
            ib = ibpi(3,i)
            if (header) then
               header = .false.
               write (iout,1060)
 1060          format (/,' Conjugated Pi-Bond Parameters :',
     &                 //,10x,'Atom Numbers',21x,'K Slope',
     &                    3x,'L Slope',/)
            end if
            write (iout,1070)  i,ia,ib,kslope(i),lslope(i)
 1070       format (i6,3x,2i6,19x,2f10.4)
         end do
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine amberyze  --  parameter format for Amber setup  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "amberyze" prints the force field parameters in a format needed
c     by the Amber setup protocol for using AMOEBA within Amber
c
c
      subroutine amberyze (active)
      use angang
      use angbnd
      use angpot
      use angtor
      use atomid
      use atoms
      use bitor
      use bndstr
      use iounit
      use ktrtor
      use kvdws
      use math
      use mpole
      use opbend
      use pitors
      use polar
      use polgrp
      use potent
      use strbnd
      use strtor
      use tors
      use tortor
      use units
      use urey
      use vdw
      use vdwpot
      implicit none
      integer i,j,k,m
      integer ia,ib,ic
      integer id,ie,ig
      integer itx,ity
      integer ixaxe
      integer iyaxe
      integer izaxe
      integer fold(6)
      real*8 bla,blc
      real*8 sbavg
      real*8 radj,rad4j
      real*8 ampli(6)
      real*8 phase(6)
      real*8 mpl(13)
      logical header
      logical active(*)
c
c
c     number of each type of AMOEBA interaction and site
c
      if (n .ne. 0) then
         write (iout,10)
   10    format (/,' Total Numbers of Atoms and Interactions :')
         write (iout,20)  n
   20    format (/,' Atoms in System',11x,i15)
      end if
      if (nbond .ne. 0) then
         write (iout,30)  nbond
   30    format (' Bond Stretches',12x,i15)
      end if
      if (nangle .ne. 0) then
         write (iout,40)  nangle
   40    format (' Angle Bends',15x,i15)
      end if
      if (nstrbnd .ne. 0) then
         write (iout,50)  nstrbnd
   50    format (' Stretch-Bends',13x,i15)
      end if
      if (nurey .ne. 0) then
         write (iout,60)  nurey
   60    format (' Urey-Bradley',14x,i15)
      end if
      if (nangang .ne. 0) then
         write (iout,70)  nangang
   70    format (' Angle-Angles',14x,i15)
      end if
      if (nopbend .ne. 0) then
         write (iout,80)  nopbend
   80    format (' Out-of-Plane Bends',8x,i15)
      end if
      if (ntors .ne. 0) then
         write (iout,90)  ntors
   90    format (' Torsional Angles',10x,i15)
      end if
      if (npitors .ne. 0) then
         write (iout,100)  npitors
  100    format (' Pi-Orbital Torsions',7x,i15)
      end if
      if (nstrtor .ne. 0) then
         write (iout,110)  nstrtor
  110    format (' Stretch-Torsions',10x,i15)
      end if
      if (nangtor .ne. 0) then
         write (iout,120)  nangtor
  120    format (' Angle-Torsions',12x,i15)
      end if
      if (ntortor .ne. 0) then
         write (iout,130)  ntortor
  130    format (' Torsion-Torsions',10x,i15)
      end if
      if (npole .ne. 0) then
         write (iout,140)  npole
  140    format (' Polarizable Multipoles',4x,i15)
      end if
c
c     parameters used for molecular mechanics atom types
c
      header = .true.
      do i = 1, n
         if (active(i)) then
            if (header) then
               header = .false.
               write (iout,150)
  150          format (/,' Atom Definition Parameters :',
     &                 //,3x,'Atom',2x,'Symbol',2x,'Type',
     &                    2x,'Class',2x,'Atomic',3x,'Mass',
     &                    2x,'Valence',2x,'Description',/)
            end if
            write (iout,160)  i,name(i),type(i),class(i),atomic(i),
     &                        mass(i),valnum(i),story(i)
  160       format (i6,5x,a3,2i7,i6,f10.3,i5,5x,a24)
         end if
      end do
c
c     parameters used for van der Waals interactions
c
      if (use_vdw) then
         header = .true.
         k = 0
         do i = 1, n
            if (active(i)) then
               k = k + 1
               if (header) then
                  header = .false.
                  write (iout,170)
  170             format (/,' Van der Waals Parameters :',
     &                    //,10x,'Atom Number',7x,'Radius',
     &                       3x,'Epsilon',3x,'Rad 1-4',
     &                       3x,'Eps 1-4',3x,'Reduction',/)
               end if
               j = class(i)
               if (vdwindex .eq. 'TYPE')  j = type(i)
               if (rad(j).eq.rad4(j) .and. eps(j).eq.eps4(j)) then
                  radj = rad(j)
                  if (radtyp .eq. 'SIGMA')  radj = radj / twosix
                  if (reduct(j) .eq. 0.0d0) then
                     write (iout,180)  k,i,radj,eps(j)
  180                format (i6,3x,i6,7x,2f10.4)
                  else
                     write (iout,190)  k,i,radj,eps(j),reduct(j)
  190                format (i6,3x,i6,7x,2f10.4,22x,f10.4)
                  end if
               else
                  radj = rad(j)
                  rad4j = rad4(j)
                  if (radtyp .eq. 'SIGMA') then
                     radj = radj / twosix
                     rad4j = rad4j / twosix
                  end if
                  if (reduct(j) .eq. 0.0d0) then
                     write (iout,200)  k,i,radj,eps(j),rad4j,eps4(j)
  200                format (i6,3x,i6,7x,2f10.4,1x,2f10.4)
                  else
                     write (iout,210)  k,i,radj,eps(j),rad4j,
     &                                eps4(j),reduct(j)
  210                format (i6,3x,i6,7x,2f10.4,1x,2f10.4,1x,f10.4)
                  end if
               end if
            end if
         end do
      end if
c
c     parameters used for bond stretching interactions
c
      if (use_bond) then
         header = .true.
         do i = 1, nbond
            ia = ibnd(1,i)
            ib = ibnd(2,i)
            if (active(ia) .or. active(ib)) then
               if (header) then
                  header = .false.
                  write (iout,220)
  220             format (/,' Bond Stretching Parameters :',
     &                    //,10x,'Atom Numbers',25x,'KS',7x,'Length',/)
               end if
               write (iout,230)  i,ia,ib,bk(i),bl(i)
  230          format (i6,3x,2i6,19x,f10.3,f10.4)
            end if
         end do
      end if
c
c     parameters used for angle bending interactions
c
      if (use_angle) then
         header = .true.
         do i = 1, nangle
            ia = iang(1,i)
            ib = iang(2,i)
            ic = iang(3,i)
            if (active(ia) .or. active(ib) .or. active(ic)) then
               if (header) then
                  header = .false.
                  write (iout,240)
  240             format (/,' Angle Bending Parameters :',
     &                    //,13x,'Atom Numbers',22x,'KB',
     &                       6x,'Angle',3x,'Fold',4x,'Type',/)
               end if
               if (angtyp(i) .eq. 'HARMONIC') then
                  write (iout,250)  i,ia,ib,ic,ak(i),anat(i)
  250             format (i6,3x,3i6,13x,2f10.3)
               else if (angtyp(i) .eq. 'IN-PLANE') then
                  write (iout,260)  i,ia,ib,ic,ak(i),anat(i)
  260             format (i6,3x,3i6,13x,2f10.3,9x,'In-Plane')
               else if (angtyp(i) .eq. 'IN-PLANE') then
                  write (iout,270)  i,ia,ib,ic,ak(i),anat(i)
  270             format (i6,3x,3i6,13x,2f10.3,9x,'Linear')
               else if (angtyp(i) .eq. 'FOURIER ') then
                  write (iout,280)  i,ia,ib,ic,ak(i),anat(i),afld(i)
  280             format (i6,3x,3i6,13x,2f10.3,f7.1,2x,'Fourier')
               end if
            end if
         end do
      end if
c
c     parameters used for stretch-bend interactions
c
      if (use_strbnd) then
         header = .true.
         do i = 1, nstrbnd
            k = isb(1,i)
            ia = iang(1,k)
            ib = iang(2,k)
            ic = iang(3,k)
            if (active(ia) .or. active(ib) .or. active(ic)) then
               if (header) then
                  header = .false.
                  write (iout,290)
  290             format (/,' Stretch-Bend Parameters :',
     &                    //,13x,'Atom Numbers',11x,'KSB',
     &                       6x,'Angle',3x,'Length1',3x,'Length2',/)
               end if
               bla = 0.0d0
               blc = 0.0d0
               if (isb(2,i) .ne. 0)  bla = bl(isb(2,i))
               if (isb(3,i) .ne. 0)  blc = bl(isb(3,i))
               sbavg = (sbk(1,i)+sbk(2,i)) * 0.5d0
               write (iout,300)  i,ia,ib,ic,sbavg,anat(k),bla,blc
  300          format (i6,3x,3i6,f13.4,3f10.4)
            end if
         end do
      end if
c
c     parameters used for Urey-Bradley interactions
c
      if (use_urey) then
         header = .true.
         do i = 1, nurey
            ia = iury(1,i)
            ic = iury(3,i)
            if (active(ia) .or. active(ic)) then
               if (header) then
                  header = .false.
                  write (iout,310)
  310             format (/,' Urey-Bradley Parameters :',
     &                    //,10x,'Atom Numbers',24x,'KUB',
     &                       4x,'Distance',/)
               end if
               write (iout,320)  i,ia,ic,uk(i),ul(i)
  320          format (i6,3x,2i6,13x,f16.4,f10.4)
            end if
         end do
      end if
c
c     parameters used for out-of-plane bend interactions
c
      if (use_opbend) then
         header = .true.
         do i = 1, nopbend
            k = iopb(i)
            ia = iang(1,k)
            ib = iang(2,k)
            ic = iang(3,k)
            id = iang(4,k)
            if (active(ia) .or. active(ib) .or.
     &             active(ic) .or. active(id)) then
               if (header) then
                  header = .false.
                  write (iout,330)
  330             format (/,' Out-of-Plane Bending Parameters :',
     &                    //,17x,'Atom Numbers',19x,'KOPB',/)
               end if
               opbk(i) = opbk(i) * (opbunit/0.02191418d0)
               write (iout,340)  i,id,ib,ia,ic,opbk(i)
  340          format (i6,3x,4i6,9x,f10.4)
            end if
         end do
      end if
c
c     parameters used for torsional interactions
c
      if (use_tors) then
         header = .true.
         do i = 1, ntors
            ia = itors(1,i)
            ib = itors(2,i)
            ic = itors(3,i)
            id = itors(4,i)
            if (active(ia) .or. active(ib) .or.
     &             active(ic) .or. active(id)) then
               if (header) then
                  header = .false.
                  write (iout,350)
  350             format (/,' Torsional Angle Parameters :',
     &                    //,17x,'Atom Numbers',11x,
     &                       'Amplitude, Phase and Periodicity',/)
               end if
               j = 0
               if (tors1(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 1
                  ampli(j) = tors1(1,i)
                  phase(j) = tors1(2,i)
               end if
               if (tors2(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 2
                  ampli(j) = tors2(1,i)
                  phase(j) = tors2(2,i)
               end if
               if (tors3(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 3
                  ampli(j) = tors3(1,i)
                  phase(j) = tors3(2,i)
               end if
               if (tors4(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 4
                  ampli(j) = tors4(1,i)
                  phase(j) = tors4(2,i)
               end if
               if (tors5(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 5
                  ampli(j) = tors5(1,i)
                  phase(j) = tors5(2,i)
               end if
               if (tors6(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 6
                  ampli(j) = tors6(1,i)
                  phase(j) = tors6(2,i)
               end if
               if (j .eq. 0) then
                  write (iout,360)  i,ia,ib,ic,id
  360             format (i6,3x,4i6)
               else
                  write (iout,370)  i,ia,ib,ic,id,(ampli(k),
     &                              nint(phase(k)),fold(k),k=1,j)
  370             format (i6,3x,4i6,4x,6(f8.3,i4,'/',i1))
               end if
            end if
         end do
      end if
c
c     parameters used for pi-system torsion interactions
c
      if (use_pitors) then
         header = .true.
         do i = 1, npitors
            ia = ipit(1,i)
            ib = ipit(2,i)
            ic = ipit(3,i)
            id = ipit(4,i)
            ie = ipit(5,i)
            ig = ipit(6,i)
            if (active(ia) .or. active(ib) .or. active(ic) .or.
     &             active(id) .or. active(ie) .or. active(ig)) then
               if (header) then
                  header = .false.
                  write (iout,380)
  380             format (/,' Pi-Orbital Torsion Parameters :',
     &                    //,10x,'Atom Numbers',19x,'Amplitude',/)
               end if
               write (iout,390)  i,ic,id,kpit(i)
  390          format (i6,3x,2i6,19x,f10.4)
            end if
         end do
      end if
c
c     parameters used for stretch-torsion interactions; this is
c     the "old" stretch-torsion format for central bond only
c
      if (use_strtor) then
         header = .true.
         do i = 1, nstrtor
            k = ist(1,i)
            ia = itors(1,k)
            ib = itors(2,k)
            ic = itors(3,k)
            id = itors(4,k)
            if (active(ia) .or. active(ib) .or.
     &             active(ic) .or. active(id)) then
               if (header) then
                  header = .false.
                  write (iout,400)
  400             format (/,' Stretch-Torsion Parameters :',
     &                    //,17x,'Atom Numbers',10x,'Length',
     &                       5x,'Torsion Terms',/)
               end if
               j = 0
               if (kst(4,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 1
                  ampli(j) = kst(4,i)
                  phase(j) = tors1(2,k)
               end if
               if (kst(5,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 2
                  ampli(j) = kst(5,i)
                  phase(j) = tors2(2,k)
               end if
               if (kst(6,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 3
                  ampli(j) = kst(6,i)
                  phase(j) = tors3(2,k)
               end if
               write (iout,410)  i,ia,ib,ic,id,bl(ist(3,i)),
     &                           (ampli(k),nint(phase(k)),
     &                           fold(k),k=1,j)
  410          format (i6,3x,4i6,2x,f10.4,1x,3(f8.3,i4,'/',i1))
            end if
         end do
      end if
c
c     parameters used for angle-torsion interactions; this term
c     is currently not implemented in Amber
c
      if (use_angtor) then
         header = .true.
         do i = 1, nangtor
            k = iat(1,i)
            ia = itors(1,k)
            ib = itors(2,k)
            ic = itors(3,k)
            id = itors(4,k)
            if (active(ia) .or. active(ib) .or.
     &             active(ic) .or. active(id)) then
               if (header) then
                  header = .false.
                  write (iout,420)
  420             format (/,' Angle-Torsion Parameters :',
     &                    //,17x,'Atom Numbers',10x,'Length',
     &                       5x,'Torsion Terms',/)
               end if
               write (iout,430)  i,ia,ib,ic,id
  430          format (i6,3x,4i6)
            end if
         end do
      end if
c
c     parameters used for torsion-torsion interactions
c
      if (use_tortor) then
         header = .true.
         do i = 1, ntortor
            k = itt(1,i)
            ia = ibitor(1,k)
            ib = ibitor(2,k)
            ic = ibitor(3,k)
            id = ibitor(4,k)
            ie = ibitor(5,k)
            if (active(ia) .or. active(ib) .or. active(ic) .or.
     &                active(id) .or. active(ie)) then
               if (header) then
                  header = .false.
                  write (iout,440)
  440             format (/,' Torsion-Torsion Parameters :',
     &                    //,20x,'Atom Numbers',18x,'Spline Grid',/)
               end if
               j = itt(2,i)
               write (iout,450)  i,ia,ib,ic,id,ie,tnx(j),tny(j)
  450          format (i6,3x,5i6,10x,2i6)
               do m = 1, tnx(j)*tny(j)
                  itx = (m-1)/tnx(j) + 1
                  ity = m - (itx-1)*tny(j)
                  write (iout,460)  ttx(itx,j),tty(ity,j),tbf(m,j)
  460             format (9x,2f12.1,5x,f12.5)
               end do
            end if
         end do
      end if
c
c     parameters used for atomic multipole moments
c
      if (use_mpole) then
         header = .true.
         do i = 1, npole
            ia = ipole(i)
            if (active(ia)) then
               if (header) then
                  header = .false.
                  write (iout,470)
  470             format (/,' Atomic Multipole Parameters :',
     &                    //,12x,'Atom',4x,'Coordinate Frame',
     &                       ' Definition',7x,'Multipole Moments',/)
               end if
               izaxe = zaxis(ia)
               ixaxe = xaxis(ia)
               iyaxe = yaxis(ia)
               if (iyaxe .lt. 0)  iyaxe = -iyaxe
               mpl(1) = pole(1,ia)
               do j = 2, 4
                  mpl(j) = pole(j,ia) / bohr
               end do
               do j = 5, 13
                  mpl(j) = 3.0d0 * pole(j,ia) / bohr**2
               end do
               if (izaxe .eq. 0) then
                  write (iout,480)  i,ia,0,0,polaxe(ia),
     &                              (mpl(j),j=1,5),mpl(8),mpl(9),
     &                              (mpl(j),j=11,13)
  480             format (i6,3x,i6,1x,2i7,10x,a8,2x,f9.5,/,50x,3f9.5,
     &                    /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5)
               else if (ixaxe .eq. 0) then
                  write (iout,490)  i,ia,izaxe,0,polaxe(ia),
     &                              (mpl(j),j=1,5),mpl(8),mpl(9),
     &                              (mpl(j),j=11,13)
  490             format (i6,3x,i6,1x,2i7,10x,a8,2x,f9.5,/,50x,3f9.5,
     &                    /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5)
               else  if (iyaxe .eq. 0) then
                  write (iout,500)  i,ia,izaxe,ixaxe,polaxe(ia),
     &                              (mpl(j),j=1,5),mpl(8),mpl(9),
     &                              (mpl(j),j=11,13)
  500             format (i6,3x,i6,1x,2i7,10x,a8,2x,f9.5,/,50x,3f9.5,
     &                    /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5)
               else
                  write (iout,510)  i,ia,izaxe,ixaxe,iyaxe,polaxe(ia),
     &                              (mpl(j),j=1,5),mpl(8),mpl(9),
     &                              (mpl(j),j=11,13)
  510             format (i6,3x,i6,1x,3i7,3x,a8,2x,f9.5,/,50x,3f9.5,
     &                    /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5)
               end if
            end if
         end do
      end if
c
c     parameters used for dipole polarizability
c
      if (use_polar) then
         header = .true.
         do i = 1, npole
            ia = ipole(i)
            if (active(ia)) then
               if (header) then
                  header = .false.
                  write (iout,520)
  520             format (/,' Dipole Polarizability Parameters :',
     &                    //,10x,'Atom Number',9x,'Alpha',8x,
     &                       'Polarization Group',/)
               end if
               write (iout,530)  i,ia,polarity(ia),
     &                           (ip11(j,ia),j=1,np11(ia))
  530          format (i6,3x,i6,10x,f10.4,5x,20i6)
            end if
         end do
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module angang  --  angle-angles in current structure  ##
c     ##                                                        ##
c     ############################################################
c
c
c     nangang   total number of angle-angle interactions
c     iaa       angle numbers used in each angle-angle term
c     kaa       force constant for angle-angle cross terms
c
c
      module angang
      implicit none
      integer nangang
      integer, allocatable :: iaa(:,:)
      real*8, allocatable :: kaa(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module angbnd  --  bond angle bends in current structure  ##
c     ##                                                            ##
c     ################################################################
c
c
c     nangle   total number of angle bends in the system
c     iang     numbers of the atoms in each angle bend
c     ak       harmonic angle force constant (kcal/mole/rad**2)
c     anat     ideal bond angle or phase shift angle (degrees)
c     afld     periodicity for Fourier angle bending term
c
c
      module angbnd
      implicit none
      integer nangle
      integer, allocatable :: iang(:,:)
      real*8, allocatable :: ak(:)
      real*8, allocatable :: anat(:)
      real*8, allocatable :: afld(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine angles  --  locate and store bond angles  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "angles" finds the total number of bond angles and stores
c     the atom numbers of the atoms defining each angle; for
c     each angle to a trivalent central atom, the third bonded
c     atom is stored for use in out-of-plane bending
c
c
      subroutine angles
      use angbnd
      use atmlst
      use atoms
      use couple
      implicit none
      integer i,j,k,m
      integer ia,ib,ic
c
c
c     initial count of the total number of bond angles
c
      nangle = 0
      do i = 1, n
         m = 0
         do j = 1, n12(i)-1
            do k = j+1, n12(i)
               nangle = nangle + 1
            end do
         end do
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(iang))  deallocate (iang)
      if (allocated(balist))  deallocate (balist)
      if (allocated(anglist))  deallocate (anglist)
      allocate (iang(4,nangle))
      allocate (balist(2,nangle))
      allocate (anglist(maxval*(maxval-1)/2,n))
c
c     store the list of atoms involved in each bond angle
c
      nangle = 0
      do i = 1, n
         m = 0
         do j = 1, n12(i)-1
            do k = j+1, n12(i)
               nangle = nangle + 1
               m = m + 1
               anglist(m,i) = nangle
               iang(1,nangle) = i12(j,i)
               iang(2,nangle) = i
               iang(3,nangle) = i12(k,i)
               iang(4,nangle) = 0
            end do
         end do
c
c     set the out-of-plane atom for angles at trivalent centers
c
         if (n12(i) .eq. 3) then
            iang(4,nangle) = i12(1,i)
            iang(4,nangle-1) = i12(2,i)
            iang(4,nangle-2) = i12(3,i)
         end if
      end do
c
c     store the numbers of the bonds comprising each bond angle
c
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         do k = 1, n12(ib)
            if (i12(k,ib) .eq. ia)  balist(1,i) = bndlist(k,ib)
            if (i12(k,ib) .eq. ic)  balist(2,i) = bndlist(k,ib)
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module angpot  --  angle bend functional form details  ##
c     ##                                                         ##
c     #############################################################
c
c
c     angunit    convert angle bending energy to kcal/mole
c     stbnunit   convert stretch-bend energy to kcal/mole
c     aaunit     convert angle-angle energy to kcal/mole
c     opbunit    convert out-of-plane bend energy to kcal/mole
c     opdunit    convert out-of-plane distance energy to kcal/mole
c     cang       cubic coefficient in angle bending potential
c     qang       quartic coefficient in angle bending potential
c     pang       quintic coefficient in angle bending potential
c     sang       sextic coefficient in angle bending potential
c     copb       cubic coefficient in out-of-plane bend potential
c     qopb       quartic coefficient in out-of-plane bend potential
c     popb       quintic coefficient in out-of-plane bend potential
c     sopb       sextic coefficient in out-of-plane bend potential
c     copd       cubic coefficient in out-of-plane distance potential
c     qopd       quartic coefficient in out-of-plane distance potential
c     popd       quintic coefficient in out-of-plane distance potential
c     sopd       sextic coefficient in out-of-plane distance potential
c     opbtyp     type of out-of-plane bend potential energy function
c     angtyp     type of angle bending function for each bond angle
c
c
      module angpot
      implicit none
      real*8 angunit,stbnunit
      real*8 aaunit,opbunit
      real*8 opdunit
      real*8 cang,qang
      real*8 pang,sang
      real*8 copb,qopb
      real*8 popb,sopb
      real*8 copd,qopd
      real*8 popd,sopd
      character*8 opbtyp
      character*8, allocatable :: angtyp(:)
      save
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder  ##
c     ##                 All Rights Reserved                  ##
c     ##########################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module angtor  --  angle-torsions in current structure  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     nangtor   total number of angle-torsion interactions
c     iat       torsion and angle numbers used in angle-torsion
c     kant      1-, 2- and 3-fold angle-torsion force constants
c
c
      module angtor
      implicit none
      integer nangtor
      integer, allocatable :: iat(:,:)
      real*8, allocatable :: kant(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  program anneal  --  molecular dynamics simulated annealing  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "anneal" performs a simulated annealing protocol by means of
c     variable temperature molecular dynamics using either linear,
c     exponential or sigmoidal cooling schedules
c
c
      program anneal
      use atomid
      use atoms
      use bath
      use bndstr
      use bound
      use inform
      use iounit
      use mdstuf
      use potent
      use solute
      use usage
      use warp
      implicit none
      integer i,next,nequil
      integer istep,nstep
      real*8 logmass,factor
      real*8 ratio,sigmoid
      real*8 dt,dtsave
      real*8 hot,cold
      real*8 fuzzy,sharp
      real*8 loose,tight
      logical exist
      character*1 answer
      character*8 cooltyp
      character*240 record
      character*240 string
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     get choice of statistical ensemble for periodic system
c
      hot = -1.0d0
      cold = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  hot
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  cold
   10 continue
      do while (hot.lt.0.0d0 .or. cold.lt.0.0d0)
         hot = -1.0d0
         cold = -1.0d0
         write (iout,20)
   20    format (/,' Enter the Initial and Final Temperatures in',
     &              ' Degrees K [1000,0] :  ',$)
         read (input,30)  record
   30    format (a240)
         read (record,*,err=40,end=40)  hot,cold
   40    continue
         if (hot .le. 0.0d0)  hot = 1000.0d0
         if (cold .le. 0.0d0)  cold = 0.0d0
      end do
c
c     set the number of steps of initial equilibration
c
      nequil = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=50,end=50)  nequil
   50 continue
      do while (nequil .lt. 0)
         write (iout,60)
   60    format (/,' Enter the Number of Equilibration Steps [0] :  ',$)
         read (input,70,err=80)  nequil
   70    format (i10)
         if (nequil .lt. 0)  nequil = 0
   80    continue
      end do
c
c     set the number of dynamics steps for the cooling protocol
c
      nstep = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=90,end=90)  nstep
   90 continue
      do while (nstep .lt. 0)
         write (iout,100)
  100    format (/,' Enter the Number of Cooling Protocol Steps',
     &              ' [2000] :  ',$)
         read (input,110,err=120)  nstep
  110    format (i10)
         if (nstep .lt. 0)  nstep = 2000
  120    continue
      end do
c
c     decide which annealing cooling protocol to use
c
      cooltyp = 'LINEAR'
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,130)
  130    format (/,' Use Linear, Sigmoidal or Exponential Cooling',
     &              ' Protocol ([L], S or E) :  ',$)
         read (input,140)  record
  140    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'S')  cooltyp = 'SIGMOID'
      if (answer .eq. 'E')  cooltyp = 'EXPONENT'
c
c     get the length of the dynamics time step in picoseconds
c
      dt = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=150,end=150)  dt
  150 continue
      do while (dt .lt. 0.0d0)
         write (iout,160)
  160    format (/,' Enter the Time Step Length in Femtoseconds',
     &              ' [1.0] :  ',$)
         read (input,170,err=180)  dt
  170    format (f20.0)
         if (dt .le. 0.0d0)  dt = 1.0d0
  180    continue
      end do
      dt = 0.001d0 * dt
c
c     set the time between trajectory snapshot coordinate saves
c
      dtsave = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=190,end=190)  dtsave
  190 continue
      do while (dtsave .lt. 0.0d0)
         write (iout,200)
  200    format (/,' Enter Time between Saves in Picoseconds',
     &              ' [0.1] :  ',$)
         read (input,210,err=220)  dtsave
  210    format (f20.0)
         if (dtsave .le. 0.0d0)  dtsave = 0.1d0
  220    continue
      end do
      iwrite = nint(dtsave/dt)
c
c     get factor by which atomic weights are to be increased
c
      logmass = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=230,end=230)  logmass
  230 continue
      do while (logmass .lt. 0.0d0)
         write (iout,240)
  240    format (/,' Increase Atomic Weights by a Factor of',
     &              ' 10^x [x=0.0] :  ',$)
         read (input,250,err=260)  logmass
  250    format (f20.0)
         if (logmass .le. 0.0d0)  logmass = 0.0d0
  260    continue
      end do
      if (logmass .gt. 0.0d0) then
         factor = 10.0d0**(logmass)
         do i = 1, n
            mass(i) = mass(i) * factor
         end do
      end if
c
c     rate of deformation change for potential surface smoothing
c
      if (use_smooth) then
         sharp = -1.0d0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=270,end=270)  sharp
  270    continue
         do while (sharp .lt. 0.0d0)
            write (iout,280)
  280       format (/,' Enter Final Desired Deformation Parameter',
     &                 ' [0.0] :  ',$)
            read (input,290,err=300)  sharp
  290       format (f20.0)
            if (sharp .le. 0.0d0)  sharp = 0.0d0
  300       continue
         end do
         fuzzy = deform - sharp
         if (fuzzy .le. 0.0d0)  fuzzy = 0.0d0
      end if
c
c     set values for temperature, pressure and coupling baths
c
      isothermal = .true.
      isobaric = .false.
      loose = 100.0d0 * dt
      tight = 10.0d0 * dt
      kelvin = hot
      tautemp = loose
c
c     perform the setup functions needed to run dynamics
c
      call mdinit (dt)
c
c     print out a header lines for the equilibration phase
c
      if (nequil .ne. 0) then
         write (iout,310)
  310    format (/,' Simulated Annealing Equilibration Phase')
         write (iout,320)  nequil,dt,logmass,hot,hot
  320    format (/,' Steps:',i6,3x,'Time/Step:',f6.3,' ps',3x,
     &              'LogMass:',f5.2,3x,'Temp:',f7.1,' to',f7.1)
         flush (iout)
      end if
c
c     take the dynamics steps for the equilibration phase
c
      do istep = 1, nequil
         if (integrate .eq. 'VERLET') then
            call verlet (istep,dt)
         else if (integrate .eq. 'BEEMAN') then
            call beeman (istep,dt)
         else if (integrate .eq. 'BAOAB') then
            call baoab (istep,dt)
         else if (integrate .eq. 'OBABO') then
            call obabo (istep,dt)
         else if (integrate .eq. 'NOSE-HOOVER') then
            call nose (istep,dt)
         else if (integrate .eq. 'STOCHASTIC') then
            call sdstep (istep,dt)
         else if (integrate .eq. 'GHMC') then
            call ghmcstep (istep,dt)
         else if (integrate .eq. 'RIGIDBODY') then
            call rgdstep (istep,dt)
         else if (integrate .eq. 'VRESPA') then
            call vrespa (istep,dt)
         else if (integrate .eq. 'BRESPA') then
            call brespa (istep,dt)
         else if (integrate .eq. 'SRESPA') then
            call srespa (istep,dt)
         else
            call beeman (istep,dt)
         end if
      end do
c
c     start the cooling phase from the end of equilibration phase
c
      if (nequil .ne. 0)  call mdinit (dt)
c
c     print out a header lines for the cooling protocol
c
      write (iout,330)
  330 format (/,' Simulated Annealing Cooling Protocol')
      write (iout,340)  nstep,dt,logmass,hot,cold
  340 format (/,' Steps:',i6,3x,'Time/Step:',f6.3,' ps',3x,
     &           'LogMass:',f5.2,3x,'Temp:',f7.1,' to',f7.1)
      flush (iout)
c
c     set target temperature using the desired cooling protocol
c
      do istep = 1, nstep
         ratio = dble(istep) / dble(nstep)
         if (cooltyp .eq. 'SIGMOID') then
            ratio = sigmoid (3.5d0,ratio)
         else if (cooltyp .eq. 'EXPONENT') then
            ratio = 1.0d0 - exp(-5.0d0*ratio)
         end if
         kelvin = hot*(1.0d0-ratio) + cold*ratio
         tautemp = loose*(1.0d0-ratio) + tight*ratio
c
c     set the deformation value if potential smoothing is used
c
         if (use_smooth) then
            ratio = (1.0d0-dble(istep)/dble(nstep))**3
            deform = sharp + ratio*fuzzy
         end if
c
c     integrate equations of motion to take a time step
c
         if (integrate .eq. 'VERLET') then
            call verlet (istep,dt)
         else if (integrate .eq. 'BEEMAN') then
            call beeman (istep,dt)
         else if (integrate .eq. 'BAOAB') then
            call baoab (istep,dt)
         else if (integrate .eq. 'OBABO') then
            call obabo (istep,dt)
         else if (integrate .eq. 'NOSE-HOOVER') then
            call nose (istep,dt)
         else if (integrate .eq. 'STOCHASTIC') then
            call sdstep (istep,dt)
         else if (integrate .eq. 'GHMC') then
            call ghmcstep (istep,dt)
         else if (integrate .eq. 'RIGIDBODY') then
            call rgdstep (istep,dt)
         else if (integrate .eq. 'VRESPA') then
            call vrespa (istep,dt)
         else if (integrate .eq. 'BRESPA') then
            call brespa (istep,dt)
         else if (integrate .eq. 'SRESPA') then
            call srespa (istep,dt)
         else
            call beeman (istep,dt)
         end if
      end do
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  program arcedit  --  create or extract from an archive  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "arcedit" is a utility program for coordinate files which
c     concatenates multiple coordinate sets into a new archive or
c     performs any of several manipulations on an existing archive
c
c
      program arcedit
      use atoms
      use bound
      use files
      use inform
      use iounit
      use output
      use usage
      implicit none
      integer i,j,k,nask
      integer iarc,ixyz,idcd
      integer start,stop
      integer step,size
      integer nmode,mode
      integer leng1,leng2
      integer lext,now
      integer freeunit
      integer, allocatable :: list(:)
      real*8 xr,yr,zr
      real*8, allocatable :: xold(:)
      real*8, allocatable :: yold(:)
      real*8, allocatable :: zold(:)
      logical exist,query
      logical first,opened
      character*1 letter
      character*7 ext,modtyp
      character*240 arcfile
      character*240 dcdfile
      character*240 xyzfile
      character*240 record
      character*240 string
c
c
c     initialization and set number of archive modifications
c
      call initial
      nmode = 8
c
c     try to get a filename from the command line arguments
c
      call nextarg (arcfile,exist)
      if (exist) then
         call basefile (arcfile)
         call suffix (arcfile,'arc','old')
         inquire (file=arcfile,exist=exist)
      end if
c
c     ask for the user specified input archive filename
c
      nask = 0
      do while (.not.exist .and. nask.lt.maxask)
         nask = nask + 1
         write (iout,10)
   10    format (/,' Enter Coordinate Archive File Name :  ',$)
         read (input,20)  arcfile
   20    format (a240)
         call basefile (arcfile)
         call suffix (arcfile,'arc','old')
         inquire (file=arcfile,exist=exist)
      end do
      if (.not. exist)  call fatal
c
c     open the file and get format by inspecting first character
c
      coordtype = 'CARTESIAN'
      iarc = freeunit ()
      open (unit=iarc,file=arcfile,status='old')
      rewind (unit=iarc)
      read (iarc,30)  letter
   30 format (a1)
      archive = .false.
      if (letter .eq. ' ')  archive = .true.
      if (letter.ge.'0' .and. letter.le.'9')  archive = .true.
      binary = (.not. archive)
      close (unit=iarc)
c
c     find out which archive modification to perform
c
      mode = -1
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=40,end=40)  mode
         if (mode.ge.0 .and. mode.le.nmode)  query = .false.
      end if
   40 continue
      if (query) then
         write (iout,50)
   50    format (/,' The Tinker Archive File Utility Can :',
     &           //,4x,'(1) Create an Archive from Individual Frames',
     &           /,4x,'(2) Extract Individual Frames from an Archive',
     &           /,4x,'(3) Trim an Archive to Remove Atoms or Frames',
     &           /,4x,'(4) Enforce Periodic Boundaries for a Trajectory'
     &           /,4x,'(5) Unfold Periodic Boundaries for a Trajectory',
     &           /,4x,'(6) Remove Periodic Box Size from a Trajectory',
     &           /,4x,'(7) Convert Tinker Archive to Binary DCD File',
     &           /,4x,'(8) Convert Binary DCD File to Tinker Archive')
         do while (mode.lt.0 .or. mode.gt.nmode)
            mode = -1
            write (iout,60)
   60       format (/,' Enter the Number of the Desired Choice :  ',$)
            read (input,70,err=80,end=80)  mode
   70       format (i10)
   80       continue
         end do
      end if
c
c     set code for the type of procedure to be performed
c
      if (mode .eq. 0)  modtyp = 'EXIT'
      if (mode .eq. 1)  modtyp = 'CREATE'
      if (mode .eq. 2)  modtyp = 'EXTRACT'
      if (mode .eq. 3)  modtyp = 'TRIM'
      if (mode .eq. 4)  modtyp = 'FOLD'
      if (mode .eq. 5)  modtyp = 'UNFOLD'
      if (mode .eq. 6)  modtyp = 'UNBOUND'
      if (mode .eq. 7)  modtyp = 'ARCDCD'
      if (mode .eq. 8)  modtyp = 'DCDARC'
c
c     create and open a new Tinker formatted archive file
c
      if (modtyp .eq. 'CREATE') then
         iarc = freeunit ()
         call basefile (arcfile)
         call suffix (arcfile,'arc','new')
         open (unit=iarc,file=arcfile,status='new')
c
c     open an existing Tinker archive file for processing
c
      else if (archive) then
         iarc = freeunit ()
         call basefile (arcfile)
         call suffix (arcfile,'arc','old')
         inquire (file=arcfile,exist=exist)
         do while (.not. exist)
            write (iout,90)
   90       format (/,' Enter Coordinate Archive File Name :  ',$)
            read (input,100)  arcfile
  100       format (a240)
            call basefile (arcfile)
            call suffix (arcfile,'arc','old')
            inquire (file=arcfile,exist=exist)
         end do
         open (unit=iarc,file=arcfile,status='old')
         rewind (unit=iarc)
         call readxyz (iarc)
         rewind (unit=iarc)
c
c     open an existing binary DCD trajectory file for processing
c
      else if (binary) then
         idcd = freeunit ()
         dcdfile = arcfile
         call basefile (dcdfile)
         call suffix (dcdfile,'dcd','old')
         inquire (file=dcdfile,exist=exist)
         do while (.not. exist)
            write (iout,110)
  110       format (/,' Enter DCD Binary Archive File Name :  ',$)
            read (input,120)  dcdfile
  120       format (a240)
            call basefile (dcdfile)
            call suffix (dcdfile,'dcd','old')
            inquire (file=dcdfile,exist=exist)
         end do
         call nextarg (xyzfile,exist)
         if (exist) then
            call basefile (xyzfile)
            call suffix (xyzfile,'xyz','old')
            inquire (file=xyzfile,exist=exist)
         end if
         nask = 0
         do while (.not.exist .and. nask.lt.maxask)
            nask = nask + 1
            write (iout,130)
  130       format (/,' Enter Formatted Coordinate File Name :  ',$)
            read (input,140)  xyzfile
  140       format (a240)
            call basefile (xyzfile)
            call suffix (xyzfile,'xyz','old')
            inquire (file=xyzfile,exist=exist)
         end do
         if (.not. exist)  call fatal
         ixyz = freeunit ()
         open (unit=ixyz,file=xyzfile,status='old')
         rewind (unit=ixyz)
         call readxyz (ixyz)
         close (unit=ixyz)
         open (unit=idcd,file=dcdfile,form='unformatted',status='old')
         rewind (unit=idcd)
         first = .true.
         call readdcd (idcd,first)
         rewind (unit=idcd)
         first = .true.
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(iuse))  deallocate (iuse)
      if (allocated(use))  deallocate (use)
      allocate (iuse(n))
      allocate (use(0:n))
c
c     set all atoms in the system to be treated as active 
c
      nuse = n
      do i = 1, n
         iuse(i) = i
         use(i) = .true.
      end do
c
c     combine individual files into a single archive file
c
      if (modtyp .eq. 'CREATE') then
         modtyp = 'EXIT'
         start = 0
         stop = 0
         step = 0
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=150,end=150)  start
            query = .false.
         end if
         call nextarg (string,exist)
         if (exist)  read (string,*,err=150,end=150)  stop
         call nextarg (string,exist)
         if (exist)  read (string,*,err=150,end=150)  step
  150    continue
         if (query) then
            write (iout,160)
  160       format (/,' Numbers of First & Last File and Step',
     &                 ' Increment :  ',$)
            read (input,170)  record
  170       format (a240)
            read (record,*,err=180,end=180)  start,stop,step
  180       continue
         end if
         if (stop .eq. 0)  stop = start
         if (step .eq. 0)  step = 1
c
c     cycle over the user specified coordinate files
c
         i = start
         do while (i.ge.start .and. i.le.stop)
            ixyz = freeunit ()
            lext = 3
            call numeral (i,ext,lext)
            xyzfile = filename(1:leng)//'.'//ext(1:lext)
            call version (xyzfile,'old')
            inquire (file=xyzfile,exist=exist)
            if (.not.exist .and. i.lt.100) then
               lext = 2
               call numeral (i,ext,lext)
               xyzfile = filename(1:leng)//'.'//ext(1:lext)
               call version (xyzfile,'old')
               inquire (file=xyzfile,exist=exist)
            end if
            if (.not.exist .and. i.lt.10) then
               lext = 1
               call numeral (i,ext,lext)
               xyzfile = filename(1:leng)//'.'//ext(1:lext)
               call version (xyzfile,'old')
               inquire (file=xyzfile,exist=exist)
            end if
            if (exist) then
               open (unit=ixyz,file=xyzfile,status='old')
               rewind (unit=ixyz)
               call readxyz (ixyz)
               close (unit=ixyz)
               nuse = n
               do j = 1, n
                  use(j) = .true.
               end do
               first = .true.
               call prtarc (iarc,first)
            end if
            i = i + step
         end do
      end if
c
c     perform dynamic allocation of some local arrays
c
      if (modtyp .eq. 'TRIM') then
         size = 40
         allocate (list(size))
      end if
c
c     decide whether atoms are to be removed from each frame
c
      if (modtyp .eq. 'TRIM') then
         call active
         if (nuse .eq. n) then
            do i = 1, size
               list(i) = 0
            end do
            i = 1
            query = .true.
            call nextarg (string,exist)
            if (exist) then
               do while (i .le. size)
                  read (string,*,err=190,end=190)  list(i)
                  if (list(i) .eq. 0)  goto 190
                  i = i + 1
                  call nextarg (string,exist)
               end do
  190          continue
               query = .false.
            end if
            if (query) then
               write (iout,200)
  200          format (/,' Numbers of the Atoms to be Removed :  ',$)
               read (input,210)  record
  210          format (a240)
               read (record,*,err=220,end=220)  (list(i),i=1,size)
  220          continue
            end if
            i = 1
            do while (list(i) .ne. 0)
               list(i) = max(-n,min(n,list(i)))
               if (list(i) .gt. 0) then
                  k = list(i)
                  if (use(k)) then
                     use(k) = .false.
                     nuse = nuse - 1
                  end if
                  i = i + 1
               else
                  list(i+1) = max(-n,min(n,list(i+1)))
                  do k = abs(list(i)), abs(list(i+1))
                     if (use(k)) then
                        use(k) = .false.
                        nuse = nuse - 1
                     end if
                  end do
                  i = i + 2
               end if
            end do
c
c     store index to use in renumbering the untrimmed atoms
c
            k = 0
            do i = 1, n
               iuse(i) = 0
               if (use(i)) then
                  k = k + 1
                  iuse(i) = k
               end if
            end do
         end if
c
c     perform deallocation of some local arrays
c
         deallocate (list)
      end if
c
c     convert Tinker archive to binary DCD trajectory file
c
      if (modtyp .eq. 'ARCDCD') then
         modtyp = 'EXIT'
         archive = .false.
         binary = .true.
         first = .true.
         idcd = freeunit ()
         dcdfile = filename(1:leng)//'.dcd'
         call version (dcdfile,'new')
         open (unit=idcd,file=dcdfile,form='unformatted',status='new')
         do while (.true.)
            call readxyz (iarc)
            if (abort)  goto 230
            call prtarc (idcd,first)
         end do
  230    continue
         close (unit=idcd)
      end if
c
c     convert binary DCD trajectory file to Tinker archive
c
      if (modtyp .eq. 'DCDARC') then
         modtyp = 'EXIT'
         archive = .true.
         binary = .false.
         first = .true.
         iarc = freeunit ()
         arcfile = filename(1:leng)//'.arc'
         call version (arcfile,'new')
         open (unit=iarc,file=arcfile,status='new')
         do while (.true.)
            call readdcd (idcd,first)
            if (abort)  goto 240
            call prtarc (iarc,first)
         end do
  240    continue
         close (unit=iarc)
      end if
c
c     perform dynamic allocation of some local arrays
c
      if (modtyp .ne. 'EXIT') then
         allocate (xold(n))
         allocate (yold(n))
         allocate (zold(n))
      end if
c
c     get the initial and final coordinate frames to process
c
      if (modtyp .ne. 'EXIT') then
         now = 1
         leng1 = 1
         leng2 = leng
         do i = 1, leng
            if (filename(i:i) .eq. '/')  leng1 = i+1
            if (filename(i:i) .eq. ']')  leng1 = i+1
            if (filename(i:i) .eq. ':')  leng1 = i+1
         end do
         do i = leng, leng1, -1
            if (filename(i:i) .eq. '.')  leng2 = i-1
         end do
         leng = leng2 - leng1 + 1
         filename(1:leng) = filename(leng1:leng2)
         start = 0
         stop = 0
         step = 0
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=250,end=250)  start
            query = .false.
         end if
         call nextarg (string,exist)
         if (exist)  read (string,*,err=250,end=250)  stop
         call nextarg (string,exist)
         if (exist)  read (string,*,err=250,end=250)  step
  250    continue
         if (query) then
            write (iout,260)
  260       format (/,' Numbers of First & Last File and Step',
     &                 ' [<Enter>=Exit] :  ',$)
            read (input,270)  record
  270       format (a240)
            read (record,*,err=280,end=280)  start,stop,step
  280       continue
         end if
         if (stop .eq. 0)  stop = start
         if (step .eq. 0)  step = 1
c
c     loop over the individual coordinate files to be extracted
c
         do while (start .ne. 0)
            if (start .le. now) then
               now = 1
               first = .true.
               if (archive)  rewind (unit=iarc)
               if (binary)  rewind (unit=idcd)
            end if
            do k = 1, start-now
               call readcart (iarc,first)
            end do
            i = start
            if (modtyp .eq. 'EXTRACT') then
               do while (i.ge.start .and. i.le.stop)
                  lext = 3
                  call numeral (i,ext,lext)
                  call readcart (iarc,first)
                  if (abort)  goto 290
                  nuse = n
                  do j = 1, n
                     use(j) = .true.
                  end do
                  ixyz = freeunit ()
                  xyzfile = filename(1:leng)//'.'//ext(1:lext)
                  call version (xyzfile,'new')
                  if (archive) then
                     open (unit=ixyz,file=xyzfile,status='new')
                  else if (binary) then
                     open (unit=ixyz,file=xyzfile,form='unformatted',
     &                        status='new')
                  end if
                  first = .true.
                  call prtarc (ixyz,first)
                  close (unit=ixyz)
                  i = i + step
                  do k = 1, step-1
                     call readcart (iarc,first)
                  end do
               end do
            else
               ixyz = freeunit ()
               xyzfile = filename(1:leng)
               call suffix (xyzfile,'arc','new')
               if (archive) then
                  open (unit=ixyz,file=xyzfile,status='new')
               else if (binary) then
                  open (unit=ixyz,file=xyzfile,form='unformatted',
     &                     status='new')
               end if
               do while (i.ge.start .and. i.le.stop)
                  if (modtyp .eq. 'UNBOUND')  use_bounds = .true.
                  call readcart (iarc,first)
                  if (abort)  goto 290
                  if (modtyp .eq. 'FOLD') then
                     call unitcell
                     if (use_bounds) then
                        call lattice
                        call molecule
                        call bounds
                     end if
                  else if (modtyp .eq. 'UNFOLD') then
                     nuse = n
                     do j = 1, n
                        use(j) = .true.
                     end do
                     if (i .eq. start) then
                        call unitcell
                        do j = 1, n
                           xold(j) = x(j)
                           yold(j) = y(j)
                           zold(j) = z(j)
                        end do
                     end if
                     call lattice
                     do j = 1, n
                        xr = x(j) - xold(j)
                        yr = y(j) - yold(j)
                        zr = z(j) - zold(j)
                        if (use_bounds)  call image (xr,yr,zr)
                        x(j) = xold(j) + xr
                        y(j) = yold(j) + yr
                        z(j) = zold(j) + zr
                        xold(j) = x(j)
                        yold(j) = y(j)
                        zold(j) = z(j)
                     end do
                  end if
                  if (i .eq. start)  first = .true.
                  if (modtyp .eq. 'UNBOUND')  use_bounds = .false.
                  call prtarc (ixyz,first)
                  i = i + step
                  do k = 1, step-1
                     call readcart (iarc,first)
                  end do
               end do
               close (unit=ixyz)
            end if
  290       continue
            now = stop
            start = 0
            stop = 0
            step = 0
            query = .true.
            call nextarg (string,exist)
            if (exist) then
               read (string,*,err=300,end=300)  start
               query = .false.
            end if
            call nextarg (string,exist)
            if (exist)  read (string,*,err=300,end=300)  stop
            call nextarg (string,exist)
            if (exist)  read (string,*,err=300,end=300)  step
  300       continue
            if (query) then
               write (iout,310)
  310          format (/,' Numbers of First & Last File and Step',
     &                    ' [<Enter>=Exit] :  ',$)
               read (input,320)  record
  320          format (a240)
               read (record,*,err=330,end=330)  start,stop,step
  330          continue
            end if
            if (stop .eq. 0)  stop = start
            if (step .eq. 0)  step = 1
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (xold)
         deallocate (yold)
         deallocate (zold)
      end if
c
c     perform any final tasks before program exit
c
      inquire (unit=iarc,opened=opened)
      if (opened)  close (unit=iarc)
      inquire (unit=idcd,opened=opened)
      if (opened)  close (unit=idcd)
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module argue  --  command line arguments at run time  ##
c     ##                                                        ##
c     ############################################################
c
c
c     maxarg    maximum number of command line arguments
c
c     narg      number of command line arguments to the program
c     listarg   flag to mark available command line arguments
c     arg       strings containing the command line arguments
c
c
      module argue
      implicit none
      integer maxarg
      parameter (maxarg=20)
      integer narg
      logical listarg(0:maxarg)
      character*240 arg(0:maxarg)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2004  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module ascii  --  selected ASCII character code values  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     null         decimal value of ASCII code for null (0)
c     tab          decimal value of ASCII code for tab (9)
c     linefeed     decimal value of ASCII code for linefeed (10)
c     formfeed     decimal value of ASCII code for formfeed (12)
c     carriage     decimal value of ASCII code for carriage return (13)
c     escape       decimal value of ASCII code for escape (27)
c     space        decimal value of ASCII code for blank space (32)
c     exclamation  decimal value of ASCII code for exclamation (33)
c     quote        decimal value of ASCII code for double quote (34)
c     pound        decimal value of ASCII code for pound sign (35)
c     dollar       decimal value of ASCII code for dollar sign (36)
c     percent      decimal value of ASCII code for percent sign (37)
c     ampersand    decimal value of ASCII code for ampersand (38)
c     apostrophe   decimal value of ASCII code for single quote (39)
c     asterisk     decimal value of ASCII code for asterisk (42)
c     plus         decimal value of ASCII code for plus sign (43)
c     comma        decimal value of ASCII code for comma (44)
c     minus        decimal value of ASCII code for minus/dash sign (45)
c     dash         decimal value of ASCII code for minus/dash sign (45)
c     period       decimal value of ASCII code for period (46)
c     frontslash   decimal value of ASCII codd for frontslash (47)
c     colon        decimal value of ASCII code for colon (58)
c     semicolon    decimal value of ASCII code for semicolon (59)
c     equal        decimal value of ASCII code for equal sign (61)
c     question     decimal value of ASCII code for question mark (63)
c     atsign       decimal value of ASCII code for at sign (64)
c     backslash    decimal value of ASCII code for backslash (92)
c     caret        decimal value of ASCII code for caret (94)
c     underbar     decimal value of ASCII code for underbar (95)
c     vertical     decimal value of ASCII code for vertical bar (124)
c     tilde        decimal value of ASCII code for tilde (126)
c     nbsp         decimal value of ASCII code for nobreak space (255)
c
c
      module ascii
      implicit none
      integer null,tab
      integer linefeed,formfeed
      integer carriage,escape
      integer space,exclamation
      integer quote,pound
      integer dollar,percent
      integer ampersand
      integer apostrophe
      integer asterisk,plus
      integer comma,minus
      integer dash,period
      integer frontslash,colon
      integer semicolon,equal
      integer question,atsign
      integer backslash,caret
      integer underbar,vertical
      integer tilde,nbsp
      parameter (null=0)
      parameter (tab=9)
      parameter (linefeed=10)
      parameter (formfeed=12)
      parameter (carriage=13)
      parameter (escape=27)
      parameter (space=32)
      parameter (exclamation=33)
      parameter (quote=34)
      parameter (pound=35)
      parameter (dollar=36)
      parameter (percent=37)
      parameter (ampersand=38)
      parameter (apostrophe=39)
      parameter (asterisk=42)
      parameter (plus=43)
      parameter (comma=44)
      parameter (minus=45)
      parameter (dash=45)
      parameter (period=46)
      parameter (frontslash=47)
      parameter (colon=58)
      parameter (semicolon=59)
      parameter (equal=61)
      parameter (question=63)
      parameter (atsign=64)
      parameter (backslash=92)
      parameter (caret=94)
      parameter (underbar=95)
      parameter (vertical=124)
      parameter (tilde=126)
      parameter (nbsp=255)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module atmlst  --  bond and angle local geometry indices  ##
c     ##                                                            ##
c     ################################################################
c
c
c     bndlist   numbers of the bonds involving each atom
c     anglist   numbers of the angles centered on each atom
c     balist    numbers of the bonds comprising each angle
c
c
      module atmlst
      implicit none
      integer, allocatable :: bndlist(:,:)
      integer, allocatable :: anglist(:,:)
      integer, allocatable :: balist(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module atomid  --  atomic properties for current atoms  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     tag       integer atom labels from input coordinates file
c     class     atom class number for each atom in the system
c     atomic    atomic number for each atom in the system
c     valnum    expected valence for each atom in the system
c     mass      atomic weight for each atom in the system
c     name      atom name for each atom in the system
c     tier      tier name (residue, motif, etc.) for each atom
c     story     descriptive type for each atom in the system
c
c
      module atomid
      use sizes
      implicit none
      integer tag(maxatm)
      integer class(maxatm)
      integer atomic(maxatm)
      integer valnum(maxatm)
      real*8 mass(maxatm)
      character*3 name(maxatm)
      character*3 tier(maxatm)
      character*24 story(maxatm)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module atoms  --  number, position and type of atoms  ##
c     ##                                                        ##
c     ############################################################
c
c
c     n       total number of atoms in the current system
c     type    atom type number for each atom in the system
c     x       current x-coordinate for each atom in the system
c     y       current y-coordinate for each atom in the system
c     z       current z-coordinate for each atom in the system
c
c
      module atoms
      use sizes
      implicit none
      integer n
      integer type(maxatm)
      real*8 x(maxatm)
      real*8 y(maxatm)
      real*8 z(maxatm)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine attach  --  setup of connectivity arrays  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "attach" generates lists of 1-3, 1-4 and 1-5 connectivities
c     starting from the previously determined list of attached
c     atoms (ie, 1-2 connectivity)
c
c
      subroutine attach
      use atoms
      use couple
      use iounit
      implicit none
      integer i,j,k,m
      integer jj,kk
      integer maxn13
      integer maxn14
      integer maxn15
c
c
c     perform dynamic allocation of some global arrays
c
      maxn13 = 3 * maxval
      maxn14 = 9 * maxval
      maxn15 = 27 * maxval
      if (allocated(n13))  deallocate (n13)
      if (allocated(n14))  deallocate (n14)
      if (allocated(n15))  deallocate (n15)
      if (allocated(i13))  deallocate (i13)
      if (allocated(i14))  deallocate (i14)
      if (allocated(i15))  deallocate (i15)
      allocate (n13(n))
      allocate (n14(n))
      allocate (n15(n))
      allocate (i13(maxn13,n))
      allocate (i14(maxn14,n))
      allocate (i15(maxn15,n))
c
c     loop over all atoms finding all the 1-3 relationships;
c     note "n12" and "i12" have already been setup elsewhere
c
      do i = 1, n
         n13(i) = 0
         do j = 1, n12(i)
            jj = i12(j,i)
            do k = 1, n12(jj)
               kk = i12(k,jj)
               if (kk .eq. i)  goto 10
               do m = 1, n12(i)
                  if (kk .eq. i12(m,i))  goto 10
               end do
               n13(i) = n13(i) + 1
               i13(n13(i),i) = kk
   10          continue
            end do
         end do
         if (n13(i) .gt. maxn13) then
            write (iout,20)  i
   20       format (/,' ATTACH  --  Too many 1-3 Connected Atoms',
     &                 ' Attached to Atom',i6)
            call fatal
         end if
         call sort8 (n13(i),i13(1,i))
      end do
c
c     loop over all atoms finding all the 1-4 relationships
c
      do i = 1, n
         n14(i) = 0
         do j = 1, n13(i)
            jj = i13(j,i)
            do k = 1, n12(jj)
               kk = i12(k,jj)
               if (kk .eq. i)  goto 30
               do m = 1, n12(i)
                  if (kk .eq. i12(m,i))  goto 30
               end do
               do m = 1, n13(i)
                  if (kk .eq. i13(m,i))  goto 30
               end do
               n14(i) = n14(i) + 1
               i14(n14(i),i) = kk
   30          continue
            end do
         end do
         if (n14(i) .gt. maxn14) then
            write (iout,40)  i
   40       format (/,' ATTACH  --  Too many 1-4 Connected Atoms',
     &                 ' Attached to Atom',i6)
            call fatal
         end if
         call sort8 (n14(i),i14(1,i))
      end do
c
c     loop over all atoms finding all the 1-5 relationships
c
      do i = 1, n
         n15(i) = 0
         do j = 1, n14(i)
            jj = i14(j,i)
            do k = 1, n12(jj)
               kk = i12(k,jj)
               if (kk .eq. i)  goto 50
               do m = 1, n12(i)
                  if (kk .eq. i12(m,i))  goto 50
               end do
               do m = 1, n13(i)
                  if (kk .eq. i13(m,i))  goto 50
               end do
               do m = 1, n14(i)
                  if (kk .eq. i14(m,i))  goto 50
               end do
               n15(i) = n15(i) + 1
               i15(n15(i),i) = kk
   50          continue
            end do
         end do
         if (n15(i) .gt. maxn15) then
            write (iout,60)  i
   60       format (/,' ATTACH  --  Too many 1-5 Connected Atoms',
     &                 ' Attached to Atom',i6)
            call fatal
         end if
         call sort8 (n15(i),i15(1,i))
      end do
      return
      end
c
c
c     ###############################################################
c     ##  COPYRIGHT (C) 2016 by Charles Matthews & Ben Leimkuhler  ##
c     ##        COPYRIGHT (C)  2017  by  Jay William Ponder        ##
c     ##                    All Rights Reserved                    ##
c     ###############################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine baoab  --  BAOAB stochastic dynamics step  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "baoab" performs a stochastic dynamics time step using a
c     geodesic BAOAB scheme with optional holonomic constraints
c
c     literature reference:
c
c     B. Leimkuhler and C. Matthews, "Efficient Molecular Dynamics
c     Using Geodesic Integration and Solvent-Solute Splitting",
c     Proceedings of the Royal Society A, 472, 20160138 (2016)
c
c     J. Jung and Y. Sugita, "Langevin Integration for Isothermal-
c     Isobaric Condition with a Large Time Step", Journal of Chemical
c     Physics, 162, 104108 (2025)
c
c
      subroutine baoab (istep,dt)
      use atomid
      use atoms
      use freeze
      use moldyn
      use units
      use usage
      use virial
      implicit none
      integer i,j,k
      integer istep
      integer nrattle
      real*8 dt,dt_2,dtr_2
      real*8 etot,epot
      real*8 eksum
      real*8 temp,pres
      real*8 drattle
      real*8 ekin(3,3)
      real*8 stress(3,3)
      real*8 virrat(3,3)
      real*8, allocatable :: xold(:)
      real*8, allocatable :: yold(:)
      real*8, allocatable :: zold(:)
      real*8, allocatable :: vfric(:)
      real*8, allocatable :: vrand(:,:)
      real*8, allocatable :: derivs(:,:)
c
c
c     set some time values for the dynamics integration
c
      nrattle = 1
      if (use_freeze)  nrattle = 3
      drattle = dble(nrattle)
      dt_2 = 0.5d0 * dt
      dtr_2 = dt_2 / drattle
c
c     perform dynamic allocation of some local arrays
c
      allocate (xold(n))
      allocate (yold(n))
      allocate (zold(n))
      allocate (vfric(n))
      allocate (vrand(3,n))
      allocate (derivs(3,n))
c
c     use a first B step to find the half-step velocities
c 
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            v(j,k) = v(j,k) + a(j,k)*dt_2
         end do
      end do
c
c     take the first A step to get the half-step positions
c
      do j = 1, nrattle
         do i = 1, nuse
            k = iuse(i)
            xold(k) = x(k)
            yold(k) = y(k)
            zold(k) = z(k)
            x(k) = x(k) + v(1,k)*dtr_2
            y(k) = y(k) + v(2,k)*dtr_2
            z(k) = z(k) + v(3,k)*dtr_2
         end do
         if (use_freeze) then
            call rattle (dtr_2,xold,yold,zold)
            call rattle2 (dtr_2)
            do i = 1, 3
               do k = 1, 3
                  vir(k,i) = 0.0d0
               end do
            end do
         end if
      end do
c
c     use an O step to get frictional and random components
c
      call oprep (dt,vfric,vrand)
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3 
            v(j,k) = v(j,k)*vfric(k) + vrand(j,k)
         end do
      end do
      if (use_freeze) then
         call rattle2 (dt)
         do i = 1, 3
            do j = 1, 3
               virrat(j,i) = vir(j,i)
               vir(j,i) = 0.0d0
            end do
         end do
      end if
c
c     take a second A step to get the full-step positions
c
      do j = 1, nrattle
         do i = 1, nuse
            k = iuse(i)
            xold(k) = x(k)
            yold(k) = y(k)
            zold(k) = z(k)
            x(k) = x(k) + v(1,k)*dtr_2
            y(k) = y(k) + v(2,k)*dtr_2
            z(k) = z(k) + v(3,k)*dtr_2
         end do
         if (use_freeze) then
            call rattle (dtr_2,xold,yold,zold)
            call rattle2 (dtr_2)
            do i = 1, 3
               do k = 1, 3
                  virrat(k,i) = virrat(k,i) + vir(k,i)/drattle
                  vir(k,i) = 0.0d0
               end do
            end do
         end if
      end do
c
c     get the potential energy and atomic forces
c 
      call gradient (epot,derivs)
c
c     compute the kinetic energy from half-step velocities
c
      call kinetic (eksum,ekin,temp)
c
c     second B step for accelerations and full-step velocities
c
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            a(j,k) = -ekcal * derivs(j,k) / mass(k)
            v(j,k) = v(j,k) + a(j,k)*dt_2
         end do
      end do 
      if (use_freeze) then
         call rattle2 (dt)
         do i = 1, 3
            do j = 1, 3
               vir(j,i) = vir(j,i) + virrat(j,i)
            end do
         end do
         do i = 1, nuse
            k = iuse(i)
            xold(k) = x(k)
            yold(k) = y(k)
            zold(k) = z(k)
         end do
      end if
c
c     compute full-step kinetic energy and pressure correction;
c     prior kinetic energy gives better pressure control
c
c     call kinetic (eksum,ekin,temp)
      call pressure (dt,ekin,pres,stress)
      call pressure2 (epot,temp)
c
c     final constraint step to enforce position convergence
c
      if (use_freeze)  call shake (xold,yold,zold)
c
c     perform deallocation of some local arrays
c
      deallocate (xold)
      deallocate (yold)
      deallocate (zold)
      deallocate (vfric)
      deallocate (vrand)
      deallocate (derivs)
c
c     total energy is sum of kinetic and potential energies
c
      etot = eksum + epot
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,eksum,temp,pres)
      call mdsave (istep,dt,epot,eksum)
      call mdrest (istep)
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine obabo  --  OBABO stochastic dynamics step  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "obabo" performs a stochastic dynamics time step using a
c     geodesic OBABO scheme with optional holonomic constraints
c
c     literature reference:
c
c     B. Leimkuhler and C. Matthews, "Efficient Molecular Dynamics
c     Using Geodesic Integration and Solvent-Solute Splitting",
c     Proceedings of the Royal Society A, 472, 20160138 (2016)
c
c     G. Bussi and M. Parrinello, "Accurate Sampling Using Langevin
c     Dynamics", Physical Review E, 75, 056707 (2007)
c
c
      subroutine obabo (istep,dt)
      use atomid
      use atoms
      use freeze
      use moldyn
      use units
      use usage
      use virial
      implicit none
      integer i,j,k
      integer istep
      integer nrattle
      real*8 dt,dt_2,dtr
      real*8 etot,epot
      real*8 eksum
      real*8 temp,pres
      real*8 drattle
      real*8 ekin(3,3)
      real*8 stress(3,3)
      real*8 virrat(3,3)
      real*8, allocatable :: xold(:)
      real*8, allocatable :: yold(:)
      real*8, allocatable :: zold(:)
      real*8, allocatable :: vfric(:)
      real*8, allocatable :: vrand(:,:)
      real*8, allocatable :: derivs(:,:)
c
c
c     set some time values for the dynamics integration
c
      nrattle = 1
      if (use_freeze)  nrattle = 3
      drattle = dble(nrattle)
      dt_2 = 0.5d0 * dt
      dtr = dt / drattle
c
c     perform dynamic allocation of some local arrays
c
      allocate (xold(n))
      allocate (yold(n))
      allocate (zold(n))
      allocate (vfric(n)) 
      allocate (vrand(3,n))
      allocate (derivs(3,n))
c
c     take first O step for frictional and random components
c
      call oprep (dt_2,vfric,vrand)
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            v(j,k) = v(j,k)*vfric(k) + vrand(j,k)
         end do
      end do
      if (use_freeze) then
         do i = 1, 3
            do j = 1, 3
               vir(j,i) = 0.0d0
            end do
         end do
         call rattle2 (dt_2)
         do i = 1, 3
            do j = 1, 3
               virrat(j,i) = vir(j,i)
               vir(j,i) = 0.0d0
            end do
         end do
      end if
c
c     use a first B step to find the half-step velocities
c 
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            v(j,k) = v(j,k) + a(j,k)*dt_2
         end do
      end do
c
c     take full-step A step according to the BAOAB sequence
c
      do j = 1, nrattle
         do i = 1, nuse
            k = iuse(i)
            xold(k) = x(k)
            yold(k) = y(k)
            zold(k) = z(k)
            x(k) = x(k) + v(1,k)*dtr
            y(k) = y(k) + v(2,k)*dtr
            z(k) = z(k) + v(3,k)*dtr
         end do
         if (use_freeze) then
            call rattle (dtr,xold,yold,zold)
            call rattle2 (dtr)
            do i = 1, 3
               do k = 1, 3
                  virrat(k,i) = virrat(k,i) + vir(k,i)/drattle
                  vir(k,i) = 0.0d0
               end do
            end do
         end if
      end do
c
c     get the potential energy and atomic forces
c 
      call gradient (epot,derivs)
c
c     compute the kinetic energy from half-step velocities
c
c     call kinetic (eksum,ekin,temp)
c
c     second B step for accelerations and full-step velocities
c
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            a(j,k) = -ekcal * derivs(j,k) / mass(k)
            v(j,k) = v(j,k) + a(j,k)*dt_2
         end do
      end do 
      if (use_freeze)  call rattle2 (dt)
c
c     use second O step for frictional and random components
c
      call oprep (dt_2,vfric,vrand)
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3 
            v(j,k) = v(j,k)*vfric(k) + vrand(j,k)
         end do
      end do
      if (use_freeze) then
         call rattle2 (dt_2)
         do i = 1, 3
            do j = 1, 3
               vir(j,i) = vir(j,i) + virrat(j,i)
            end do
         end do
         do i = 1, nuse
            k = iuse(i)
            xold(k) = x(k)
            yold(k) = y(k)
            zold(k) = z(k)
         end do
      end if
c
c     compute the kinetic energy and control the pressure
c
      call kinetic (eksum,ekin,temp)
      call pressure (dt,ekin,pres,stress)
      call pressure2 (epot,temp)
c
c     final constraint step to enforce position convergence
c
      if (use_freeze)  call shake (xold,yold,zold)
c
c     perform deallocation of some local arrays
c
      deallocate (xold)
      deallocate (yold)
      deallocate (zold)
      deallocate (vfric) 
      deallocate (vrand)
      deallocate (derivs)
c
c     total energy is sum of kinetic and potential energies
c
      etot = eksum + epot 
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,eksum,temp,pres)
      call mdsave (istep,dt,epot,eksum)
      call mdrest (istep)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine oprep  --  frictional & random terms for BAOAB  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "oprep" sets up frictional and random terms needed to update
c     positions and velocities for the BAOAB and OBABO integrators
c
c
      subroutine oprep (dt,vfric,vrand)
      use atoms
      use atomid
      use bath
      use stodyn
      use units
      use usage
      implicit none
      integer i,j,k
      real*8 dt,ktm
      real*8 egdt,normal
      real*8 vsig,vnorm
      real*8 vfric(*)
      real*8 vrand(3,*)
      logical first
      external normal
      save first
      data first  / .true. /
c
c
c     set the atomic friction coefficients to the global value
c
      if (first) then
         first = .false.
         if (.not. allocated(fgamma))  allocate (fgamma(n))
         do i = 1, n
            fgamma(i) = friction
         end do
      end if
c
c     get the frictional and random terms for the next step
c
      egdt = exp(-friction*dt)
      do i = 1, nuse
         k = iuse(i)
         vfric(k) = egdt
         ktm = boltzmann * kelvin / mass(k)
         vsig = sqrt(ktm*(1.0d0-egdt*egdt))
         do j = 1, 3
            vnorm = normal ()
            vrand(j,k) = vsig * vnorm
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2013  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  program bar  --  thermodynamic values from simulation data  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "bar" computes the free energy, enthalpy and entropy difference
c     between two states via Zwanzig free energy perturbation (FEP)
c     and Bennett acceptance ratio (BAR) methods
c
c     note in mode 1 the code takes as input trajectory archives A
c     and B, originally generated for states 0 and 1, respectively;
c     it then finds the total potential energy for all frames of both
c     trajectories under control of key files for both states 0 and 1;
c     in mode 2, the FEP and BAR algorithms are used to compute the
c     free energy for state 0 --> state 1, and similar estimators
c     provide the enthalpy and entropy for state 0 --> state 1
c
c     modifications for NPT simulations by Chengwen Liu, University
c     of Texas at Austin, October 2015; enthalpy and entropy methods
c     by Aaron Gordon, Washington University, December 2016
c
c     literature references:
c
c     C. H. Bennett, "Efficient Estimation of Free Energy Differences
c     from Monte Carlo Data", Journal of Computational Physics, 22,
c     245-268 (1976)
c
c     K. B. Daly, J. B. Benziger, P. G. Debenedetti and
c     A. Z. Panagiotopoulos, "Massively Parallel Chemical Potential
c     Calculation on Graphics Processing Units", Computer Physics
c     Communications, 183, 2054-2062 (2012)  [modification for NPT]
c
c     M. A. Wyczalkowski, A. Vitalis and R. V. Pappu, "New Estimators
c     for Calculating Solvation Entropy and Enthalpy and Comparative
c     Assessments of Their Accuracy and Precision, Journal of Physical
c     Chemistry, 114, 8166-8180 (2010)  [entropy and enthalpy]
c
c
      program bar
      use iounit
      implicit none
      integer mode
      logical exist,query
      character*240 string
c
c
c     find thermodynamic perturbation procedure to perform
c
      call initial
      mode = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  mode
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' The Tinker Thermodynamic Perturbation Utility',
     &              ' Can :',
     &           //,4x,'(1) Create BAR File with Perturbed Potential',
     &              ' Energies',
     &           /,4x,'(2) Compute Thermodynamic Values from Tinker',
     &              ' BAR File')
         do while (mode.lt.1 .or. mode.gt.2)
            mode = 0
            write (iout,30)
   30       format (/,' Enter the Number of the Desired Choice :  ',$)
            read (input,40,err=50,end=50)  mode
   40       format (i10)
   50       continue
         end do
      end if
c
c     create Tinker BAR file or compute thermodynamic values
c
      if (mode .eq. 1)  call makebar
      if (mode .eq. 2)  call barcalc
      call final
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine makebar  --  store trajectory potential energy  ##
c     ##                                                             ##
c     #################################################################
c
c
      subroutine makebar
      use boxes
      use files
      use inform
      use iounit
      use keys
      use output
      use titles
      implicit none
      integer i,next
      integer ibar,iarc
      integer ilog,imod
      integer lenga,lengb
      integer ltitlea,ltitleb
      integer nkey0,nkey1
      integer nfrma,nfrmb
      integer maxframe
      integer freeunit
      integer trimtext
      real*8 energy
      real*8 tempa,tempb
      real*8, allocatable :: ua0(:)
      real*8, allocatable :: ua1(:)
      real*8, allocatable :: ub0(:)
      real*8, allocatable :: ub1(:)
      real*8, allocatable :: vola(:)
      real*8, allocatable :: volb(:)
      logical exist,first
      logical recompute
      logical use_log
      character*1 answer
      character*240 filea
      character*240 fileb
      character*240 titlea
      character*240 titleb
      character*240 barfile
      character*240 arcfile
      character*240 logfile
      character*240 record
      character*240 string
      character*240, allocatable :: keys0(:)
      character*240, allocatable :: keys1(:)
c
c
c     get trajectory A and setup mechanics calculation
c
      call initial
      call getarc (iarc)
      close (unit=iarc)
      call mechanic
c
c     store the filename for trajectory A
c
      filea = filename
      lenga = leng
      titlea = title
      ltitlea = ltitle
c
c     perform dynamic allocation of some local arrays
c
      allocate (keys0(nkey))
c
c     store the keyword values for state 0
c
      nkey0 = nkey
      do i = 1, nkey0
         keys0(i) = keyline(i)
      end do
c
c     find the original temperature value for trajectory A
c
      tempa = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  tempa
   10 continue
      do while (tempa .lt. 0.0d0)
         write (iout,20)
   20    format (/,' Enter Trajectory A Temperature in Degrees',
     &              ' K [298] :  ',$)
         read (input,30,err=40)  tempa
   30    format (f20.0)
         if (tempa .le. 0.0d0)  tempa = 298.0d0
   40    continue
      end do
c
c     get trajectory B and setup mechanics calculation
c
      call getarc (iarc)
      close (unit=iarc)
      call mechanic
      silent = .true.
c
c     store the filename for trajectory B
c
      fileb = filename
      lengb = leng
      titleb = title
      ltitleb = ltitle
c
c     perform dynamic allocation of some local arrays
c
      allocate (keys1(nkey))
c
c     store the keyword values for state 1
c
      nkey1 = nkey
      do i = 1, nkey1
         keys1(i) = keyline(i)
      end do
c
c     find the original temperature value for trajectory B
c
      tempb = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=50,end=50)  tempb
   50 continue
      do while (tempb .lt. 0.0d0)
         write (iout,60)
   60    format (/,' Enter Trajectory B Temperature in Degrees',
     &              ' K [298] :  ',$)
         read (input,70,err=80)  tempb
   70    format (f20.0)
         if (tempb .le. 0.0d0)  tempb = 298.0d0
   80    continue
      end do
c
c     decide whether to use energies from trajectory log files
c
      recompute = .true.
      answer = ' '
      call nextarg (string,exist)
      if (exist)  read (string,*,err=90,end=90)  answer
   90 continue
      if (answer .eq. ' ') then
         answer = 'N'
         write (iout,100)
  100    format (/,' Obtain Energies from Trajectory Logs if',
     &              ' Available [N] :  ',$)
         read (input,110)  record
  110    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'Y')  recompute = .false.
c
c     perform dynamic allocation of some local arrays
c
      maxframe = 1000000
      allocate (ua0(maxframe))
      allocate (ua1(maxframe))
      allocate (ub0(maxframe))
      allocate (ub1(maxframe))
      allocate (vola(maxframe))
      allocate (volb(maxframe))
c
c     reopen the file corresponding to trajectory A
c
      iarc = freeunit ()
      arcfile = filea
      call suffix (arcfile,'arc','old')
      if (archive) then
         open (unit=iarc,file=arcfile,status ='old')
      else if (binary) then
         open (unit=iarc,file=arcfile,form='unformatted',status ='old')
      end if
c
c     check for log with energies of trajectory A in state 0
c
      use_log = .false.
      if (.not. recompute) then
         logfile = filea(1:lenga)
         call suffix (logfile,'log','old')
         inquire (file=logfile,exist=exist)
         if  (exist) then
            use_log = .true.
            ilog = freeunit ()
            open (unit=ilog,file=logfile,status='old')
         end if
      end if
c
c     reset trajectory A using the parameters for state 0
c
      if (.not. use_log) then
         rewind (unit=iarc)
         first = .true.
         call readcart (iarc,first)
         nkey = nkey0
         do i = 1, nkey
            keyline(i) = keys0(i)
         end do
         call mechanic
      end if
c
c     find potential energies for trajectory A in state 0
c
      write (iout,120)
  120 format (/,' Initial Processing for Trajectory A :',/)
      i = 0
      do while (.not. abort)
         i = i + 1
         if (use_log) then
            abort = .true.
            do while (abort)
               read (ilog,130,err=150,end=150)  record
  130          format (a240)
               if (record(1:18) .eq. ' Current Potential') then
                  string = record(19:240)
                  read (string,*,err=140,end=140)  ua0(i)
                  abort = .false.
               end if
  140          continue
            end do
  150       continue
            if (abort)  i = i - 1
         else
            call cutoffs
            ua0(i) = energy ()
            call readcart (iarc,first)
         end if
         imod = mod(i,100)
         if ((.not.abort.and.imod.eq.0) .or. (abort.and.imod.ne.0)) then
            write (iout,160)  i
  160       format (7x,'Completed',i8,' Coordinate Frames')
            flush (iout)
         end if
         if (i .ge. maxframe)  abort = .true.
      end do
c
c     reset trajectory A using the parameters for state 1
c
      rewind (unit=iarc)
      first = .true.
      call readcart (iarc,first)
      nkey = nkey1
      do i = 1, nkey
         keyline(i) = keys1(i)
      end do
      call mechanic
c
c     find potential energies for trajectory A in state 1
c
      if (verbose) then
         write (iout,170)
  170    format (/,' Potential Energy Values for Trajectory A :',
     &           //,7x,'Frame',9x,'State 0',9x,'State 1',12x,'Delta',/)
      end if
      i = 0
      do while (.not. abort)
         i = i + 1
         call cutoffs
         ua1(i) = energy ()
         vola(i) = volbox
         if (verbose) then
            write (iout,180)  i,ua0(i),ua1(i),ua1(i)-ua0(i)
  180       format (i11,2x,3f16.4)
         end if
         call readcart (iarc,first)
         if (i .ge. maxframe)  abort = .true.
      end do
      nfrma = i
      close (unit=iarc)
c
c     save potential energies and volumes for trajectory A
c
      ibar = freeunit ()
      barfile = filea(1:lenga)//'.bar'
      call version (barfile,'new')
      open (unit=ibar,file=barfile,status ='new')
      if (ltitlea .eq. 0) then
         write (ibar,190)  nfrma,tempa
  190    format (i8,f10.2)
      else
         write (ibar,200)  nfrma,tempa,titlea(1:ltitlea)
  200    format (i8,f10.2,2x,a)
      end if
      do i = 1, nfrma
         if (vola(i) .eq. 0.0d0) then
            write (ibar,210)  i,ua0(i),ua1(i)
  210       format (i8,2x,2f18.4)
         else
            write (ibar,220)  i,ua0(i),ua1(i),vola(i)
  220       format (i8,2x,3f18.4)
         end if
      end do
      flush (ibar)
c
c     reopen the file corresponding to trajectory B
c
      iarc = freeunit ()
      arcfile = fileb
      call suffix (arcfile,'arc','old')
      if (archive) then
         open (unit=iarc,file=arcfile,status ='old')
      else if (binary) then
         open (unit=iarc,file=arcfile,form='unformatted',status ='old')
      end if
c
c     check for log with energies of trajectory B in state 1
c
      use_log = .false.
      if (.not. recompute) then
         logfile = fileb(1:lengb)
         call suffix (logfile,'log','old')
         inquire (file=logfile,exist=exist)
         if (exist) then
            use_log = .true.
            ilog = freeunit ()
            open (unit=ilog,file=logfile,status='old')
         end if
      end if
c
c     reset trajectory B using the parameters for state 1
c
      rewind (unit=iarc)
      first = .true.
      call readcart (iarc,first)
      nkey = nkey1
      do i = 1, nkey
         keyline(i) = keys1(i)
      end do
      call mechanic
c
c     find potential energies for trajectory B in state 1
c
      write (iout,230)
  230 format (/,' Initial Processing for Trajectory B :',/)
      i = 0
      do while (.not. abort)
         i = i + 1
         if (use_log) then
            abort = .true.
            do while (abort)
               read (ilog,240,err=260,end=260)  record
  240          format (a240)
               if (record(1:18) .eq. ' Current Potential') then
                  string = record(19:240)
                  read (string,*,err=250,end=250)  ub1(i)
                  abort = .false.
               end if
  250          continue
            end do
  260       continue
            if (abort)  i = i - 1
         else
            call cutoffs
            ub1(i) = energy ()
            call readcart (iarc,first)
         end if
         imod = mod(i,100)
         if ((.not.abort.and.imod.eq.0) .or. (abort.and.imod.ne.0)) then
            write (iout,270)  i
  270       format (7x,'Completed',i8,' Coordinate Frames')
            flush (iout)
         end if
         if (i .ge. maxframe)  abort = .true.
      end do
c
c     reset trajectory B using the parameters for state 0
c
      rewind (unit=iarc)
      first = .true.
      call readcart (iarc,first)
      nkey = nkey0
      do i = 1, nkey
         keyline(i) = keys0(i)
      end do
      call mechanic
c
c     find potential energies for trajectory B in state 0
c
      if (verbose) then
         write (iout,280)
  280    format (/,' Potential Energy Values for Trajectory B :',
     &           //,7x,'Frame',9x,'State 0',9x,'State 1',12x,'Delta',/)
      end if
      i = 0
      do while (.not. abort)
         i = i + 1
         call cutoffs
         ub0(i) = energy ()
         volb(i) = volbox
         if (verbose) then
            write (iout,290)  i,ub0(i),ub1(i),ub0(i)-ub1(i)
  290       format (i11,2x,3f16.4)
         end if
         call readcart (iarc,first)
         if (i .ge. maxframe)  abort = .true.
      end do
      nfrmb = i
      close (unit=iarc)
c
c     save potential energies and volumes for trajectory B
c
      if (ltitleb .eq. 0) then
         write (ibar,300)  nfrmb,tempb
  300    format (i8,f10.2)
      else
         write (ibar,310)  nfrmb,tempb,titleb(1:ltitleb)
  310    format (i8,f10.2,2x,a)
      end if
      do i = 1, nfrmb
         if (volb(i) .eq. 0.0d0) then
            write (ibar,320)  i,ub0(i),ub1(i)
  320       format (i8,2x,2f18.4)
         else
            write (ibar,330)  i,ub0(i),ub1(i),volb(i)
  330       format (i8,2x,3f18.4)
         end if
      end do
      close (unit=ibar)
      write (iout,340)  barfile(1:trimtext(barfile))
  340 format (/,' Potential Energy Values Written To :  ',a)
c
c     perform deallocation of some local arrays
c
      deallocate (keys0)
      deallocate (keys1)
c
c     perform deallocation of some local arrays
c
      deallocate (ua0)
      deallocate (ua1)
      deallocate (ub0)
      deallocate (ub1)
      deallocate (vola)
      deallocate (volb)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine barcalc  --  get thermodynamics via FEP & BAR  ##
c     ##                                                            ##
c     ################################################################
c
c
      subroutine barcalc
      use files
      use inform
      use iounit
      use titles
      use units
      implicit none
      integer i,j,k,ibar
      integer size,next
      integer iter,maxiter
      integer ltitlea,ltitleb
      integer nfrma,nfrmb
      integer nfrm,nbst
      integer starta,startb
      integer stopa,stopb
      integer stepa,stepb
      integer maxframe
      integer freeunit
      integer trimtext
      integer, allocatable :: bsta(:)
      integer, allocatable :: bstb(:)
      real*8 rt,term
      real*8 rta,rtb
      real*8 delta,eps
      real*8 frma,frmb
      real*8 tempa,tempb
      real*8 cold,cnew
      real*8 top,top2
      real*8 bot,bot2
      real*8 fterm,rfrm
      real*8 sum,sum2,bst
      real*8 vavea,vaveb
      real*8 vstda,vstdb
      real*8 vasum,vbsum
      real*8 vasum2,vbsum2
      real*8 stdev,patm
      real*8 random,ratio
      real*8 cfore,cback
      real*8 cfsum,cbsum
      real*8 cfsum2,cbsum2
      real*8 stdcf,stdcb
      real*8 uave0,uave1
      real*8 u0sum,u1sum
      real*8 u0sum2,u1sum2
      real*8 stdev0,stdev1
      real*8 hfore,hback
      real*8 sfore,sback
      real*8 hfsum,hbsum
      real*8 hfsum2,hbsum2
      real*8 stdhf,stdhb
      real*8 fore,back
      real*8 epv,stdpv
      real*8 hdir,hbar
      real*8 hsum,hsum2
      real*8 sbar,tsbar
      real*8 fsum,bsum
      real*8 fvsum,bvsum
      real*8 fbvsum,vsum
      real*8 fbsum0,fbsum1
      real*8 alpha0,alpha1
      real*8, allocatable :: ua0(:)
      real*8, allocatable :: ua1(:)
      real*8, allocatable :: ub0(:)
      real*8, allocatable :: ub1(:)
      real*8, allocatable :: vola(:)
      real*8, allocatable :: volb(:)
      real*8, allocatable :: vloga(:)
      real*8, allocatable :: vlogb(:)
      logical exist,query,done
      character*240 record
      character*240 string
      character*240 titlea
      character*240 titleb
      character*240 barfile
      external random
c
c
c     ask the user for file with potential energies and volumes
c
      call nextarg (barfile,exist)
      if (exist) then
         call basefile (barfile)
         call suffix (barfile,'bar','old')
         inquire (file=barfile,exist=exist)
      end if
      do while (.not. exist)
         write (iout,10)
   10    format (/,' Enter Potential Energy BAR File Name :  ',$)
         read (input,20)  barfile
   20    format (a240)
         call basefile (barfile)
         call suffix (barfile,'bar','old')
         inquire (file=barfile,exist=exist)
      end do
c
c     perform dynamic allocation of some local arrays
c
      maxframe = 1000000
      allocate (ua0(maxframe))
      allocate (ua1(maxframe))
      allocate (ub0(maxframe))
      allocate (ub1(maxframe))
      allocate (vola(maxframe))
      allocate (volb(maxframe))
      allocate (vloga(maxframe))
      allocate (vlogb(maxframe))
c
c     set beginning and ending frame for trajectory A
c
      starta = 0
      stopa = 0
      stepa = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=30,end=30)  starta
         query = .false.
      end if
      call nextarg (string,exist)
      if (exist)  read (string,*,err=30,end=30)  stopa
      call nextarg (string,exist)
      if (exist)  read (string,*,err=30,end=30)  stepa
   30 continue
      if (query) then
         write (iout,40)
   40    format (/,' First & Last Frame and Step Increment',
     &              ' for Trajectory A :  ',$)
         read (input,50)  record
   50    format (a120)
         read (record,*,err=60,end=60)  starta,stopa,stepa
   60    continue
      end if
      if (starta .eq. 0)  starta = 1
      if (stopa .eq. 0)  stopa = maxframe
      if (stepa .eq. 0)  stepa = 1
c
c     set beginning and ending frame for trajectory B
c
      startb = 0
      stopb = 0
      stepb = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=70,end=70)  startb
         query = .false.
      end if
      call nextarg (string,exist)
      if (exist)  read (string,*,err=70,end=70)  stopb
      call nextarg (string,exist)
      if (exist)  read (string,*,err=70,end=70)  stepb
   70 continue
      if (query) then
         write (iout,80)
   80    format (/,' First & Last Frame and Step Increment',
     &              ' for Trajectory B :  ',$)
         read (input,90)  record
   90    format (a120)
         read (record,*,err=100,end=100)  startb,stopb,stepb
  100    continue
      end if
      if (startb .eq. 0)  startb = 1
      if (stopb .eq. 0)  stopb = maxframe
      if (stepb .eq. 0)  stepb = 1
c
c     read potential energies and volumes for trajectory A
c
      ibar = freeunit ()
      open (unit=ibar,file=barfile,status='old')
      rewind (unit=ibar)
      nfrma = 0
      tempa = 0.0d0
      next = 1
      read (ibar,110,err=250,end=250)  record
  110 format (a240)
      size = trimtext (record)
      call gettext (record,string,next)
      read (string,*,err=250,end=250)  nfrma
      call gettext (record,string,next)
      read (string,*,err=250,end=250)  tempa
      titlea = record(next:trimtext(record))
      call trimhead (titlea)
      ltitlea = trimtext(titlea)
      do i = 1, starta-1
         read (ibar,120,err=160,end=160)
  120    format ()
      end do
      j = 0
      stopa = (min(stopa,nfrma)-starta+1)/stepa
      do i = 1, stopa
         read (ibar,130,err=160,end=160)  record
  130    format (a240)
         j = j + 1
         ua0(j) = 0.0d0
         ua1(j) = 0.0d0
         vola(j) = 0.0d0
         read (record,*,err=140,end=140)  k,ua0(j),ua1(j),vola(j)
  140    continue
         do k = 1, stepa-1
            read (ibar,150,err=160,end=160)
  150       format ()
         end do
      end do
  160 continue
      nfrma = j
c
c     reset the file position to the beginning of trajectory B
c
      rewind (unit=ibar)
      next = 1
      read (ibar,170,err=190,end=190)  record
  170 format (a240)
      size = trimtext (record)
      call gettext (record,string,next)
      read (string,*,err=190,end=190)  k
      do i = 1, k
         read (ibar,180,err=190,end=190)
  180    format ()
      end do
  190 continue
c
c     read potential energies and volumes for trajectory B
c
      nfrmb = 0
      tempb = 0.0d0
      next = 1
      read (ibar,200,err=250,end=250)  record
  200 format (a240)
      size = trimtext (record)
      call gettext (record,string,next)
      read (string,*,err=250,end=250)  nfrmb
      call gettext (record,string,next)
      read (string,*,err=250,end=250)  tempb
      titleb = record(next:trimtext(record))
      call trimhead (titleb)
      ltitleb = trimtext(titleb)
      do i = 1, startb-1
         read (ibar,210,err=250,end=250)
  210    format ()
      end do
      j = 0
      stopb = (min(stopb,nfrmb)-startb+1)/stepb
      do i = 1, stopb
         read (ibar,220,err=250,end=250)  record
  220    format (a240)
         j = j + 1
         ub0(j) = 0.0d0
         ub1(j) = 0.0d0
         volb(j) = 0.0d0
         read (record,*,err=230,end=230)  k,ub0(j),ub1(j),volb(j)
  230    continue
         do k = 1, stepb-1
            read (ibar,240,err=250,end=250)
  240       format ()
         end do
      end do
  250 continue
      nfrmb = j
      close (unit=ibar)
c
c     provide info about trajectories and number of frames
c
      write (iout,260)
  260 format (/,' Simulation Trajectory A and Thermodynamic',
     &           ' State 0 :  ',/)
      if (ltitlea .ne. 0) then
         write (iout,270)  titlea(1:ltitlea)
  270    format (' ',a)
      end if
      write (iout,280)  nfrma,tempa
  280 format (' Number of Frames :',4x,i8,/,' Temperature :',7x,f10.2)
      write (iout,290)
  290 format (/,' Simulation Trajectory B and Thermodynamic',
     &           ' State 1 :  ',/)
      if (ltitleb .ne. 0) then
         write (iout,300)  titleb(1:ltitleb)
  300    format (' ',a)
      end if
      write (iout,310)  nfrmb,tempb
  310 format (' Number of Frames :',4x,i8,/,' Temperature :',7x,f10.2)
c
c     set the frame ratio, temperature and Boltzmann factor
c
      frma = dble(nfrma)
      frmb = dble(nfrmb)
      rfrm = frma / frmb
      rta = gasconst * tempa
      rtb = gasconst * tempb
      rt = 0.5d0 * (rta+rtb)
c
c     set the number of bootstrap trials to be generated
c
      nfrm = max(nfrma,nfrmb)
      nbst = min(100000,nint(1.0d8/dble(nfrm)))
      bst = dble(nbst)
      ratio = bst / (bst-1.0d0)
c
c     find average volumes and corrections for both trajectories
c
      vasum = 0.0d0
      vasum2 = 0.0d0
      vbsum = 0.0d0
      vbsum2 = 0.0d0
      do k = 1, nbst
         sum = 0.0d0
         do i = 1, nfrma
            j = int(frma*random()) + 1
            sum = sum + vola(j)
         end do
         vavea = sum / frma
         vasum = vasum + vavea
         vasum2 = vasum2 + vavea*vavea
         sum = 0.0d0
         do i = 1, nfrmb
            j = int(frmb*random()) + 1
            sum = sum + volb(j)
         end do
         vaveb = sum / frmb
         vbsum = vbsum + vaveb
         vbsum2 = vbsum2 + vaveb*vaveb
      end do
      vavea = vasum / bst
      vstda = sqrt(ratio*(vasum2/bst-vavea*vavea))
      vaveb = vbsum / bst
      vstdb = sqrt(ratio*(vbsum2/bst-vaveb*vaveb))
      if (vavea .ne. 0.0d0) then
         do i = 1, nfrma
            if (vola(i) .ne. 0.0d0)
     &         vloga(i) = -rta * log(vola(i)/vavea)
         end do
      end if
      if (vaveb .ne. 0.0d0) then
         do i = 1, nfrmb
            if (volb(i) .ne. 0.0d0)
     &         vlogb(i) = -rtb * log(volb(i)/vaveb)
         end do
      end if
c
c     get the free energy change via thermodynamic perturbation
c
      write (iout,320)
  320 format (/,' Free Energy Difference via FEP Method :',/)
      cfsum = 0.0d0
      cfsum2 = 0.0d0
      cbsum = 0.0d0
      cbsum2 = 0.0d0
      do k = 1, nbst
         sum = 0.0d0
         do i = 1, nfrma
            j = int(frma*random()) + 1
            sum = sum + exp((ua0(j)-ua1(j)+vloga(j))/rta)
         end do
         cfore = -rta * log(sum/frma)
         cfsum = cfsum + cfore
         cfsum2 = cfsum2 + cfore*cfore
         sum = 0.0d0
         do i = 1, nfrmb
            j = int(frmb*random()) + 1
            sum = sum + exp((ub1(j)-ub0(j)+vlogb(j))/rtb)
         end do
         cback = rtb * log(sum/frmb)
         cbsum = cbsum + cback
         cbsum2 = cbsum2 + cback*cback
      end do
      cfore = cfsum / bst
      stdcf = sqrt(ratio*(cfsum2/bst-cfore*cfore))
      cback = cbsum / bst
      stdcb = sqrt(ratio*(cbsum2/bst-cback*cback))
      write (iout,330)  cfore,stdcf
  330 format (' Free Energy via Forward FEP',9x,f12.4,
     &           ' +/-',f9.4,' Kcal/mol')
      write (iout,340)  cback,stdcb
  340 format (' Free Energy via Backward FEP',8x,f12.4,
     &           ' +/-',f9.4,' Kcal/mol')
c
c     determine the initial free energy via the BAR method
c
      write (iout,350)
  350 format (/,' Free Energy Difference via BAR Method :',/)
      maxiter = 100
      eps = 0.0001d0
      done = .false.
      iter = 0
      cold = 0.0d0
      top = 0.0d0
      top2 = 0.0d0
      do i = 1, nfrmb
         fterm = 1.0d0 / (1.0d0+exp((ub0(i)-ub1(i)+vlogb(i)+cold)/rtb))
         top = top + fterm
         top2 = top2 + fterm*fterm
      end do
      bot = 0.0d0
      bot2 = 0.0d0
      do i = 1, nfrma
         fterm = 1.0d0 / (1.0d0+exp((ua1(i)-ua0(i)+vloga(i)-cold)/rta))
         bot = bot + fterm
         bot2 = bot2 + fterm*fterm
      end do
      cnew = rt*log(rfrm*top/bot) + cold
      stdev = sqrt((bot2-bot*bot/frma)/(bot*bot)
     &                + (top2-top*top/frmb)/(top*top))
      delta = abs(cnew-cold)
      write (iout,360)  iter,cnew
  360 format (' BAR Iteration',i4,19x,f12.4,' Kcal/mol')
      if (delta .lt. eps) then
         done = .true.
         write (iout,370)  cnew,stdev
  370    format (' BAR Free Energy Estimate',8x,f12.4,
     &              ' +/-',f9.4,' Kcal/mol')
      end if
c
c     iterate the BAR equation to converge the free energy
c
      do while (.not. done)
         iter = iter + 1
         cold = cnew
         top = 0.0d0
         top2 = 0.0d0
         do i = 1, nfrmb
            fterm = 1.0d0 / (1.0d0+exp((ub0(i)-ub1(i)+vlogb(i)
     &                                     +cold)/rtb))
            top = top + fterm
            top2 = top2 + fterm*fterm
         end do
         bot = 0.0d0
         bot2 = 0.0d0
         do i = 1, nfrma
            fterm = 1.0d0 / (1.0d0+exp((ua1(i)-ua0(i)+vloga(i)
     &                                     -cold)/rta))
            bot = bot + fterm
            bot2 = bot2 + fterm*fterm
         end do
         cnew = rt*log(rfrm*top/bot) + cold
         stdev = sqrt((bot2-bot*bot/frma)/(bot*bot)
     &                   + (top2-top*top/frmb)/(top*top))
         delta = abs(cnew-cold)
         write (iout,380)  iter,cnew
  380    format (' BAR Iteration',i4,19x,f12.4,' Kcal/mol')
         if (delta .lt. eps) then
            done = .true.
            write (iout,390)  cnew,stdev
  390       format (/,' Free Energy via BAR Estimate',8x,f12.4,
     &                 ' +/-',f9.4,' Kcal/mol')
         end if
         if (iter.ge.maxiter .and. .not.done) then
            done = .true.
            write (iout,400)  maxiter
  400       format (/,' BAR Free Energy Estimate not Converged',
     &                 ' after',i4,' Iterations')
            call fatal
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (bsta(nfrm))
      allocate (bstb(nfrm))
c
c     use bootstrap analysis to estimate statistical error
c
      sum = 0.0d0
      sum2 = 0.0d0
      do k = 1, nbst
         done = .false.
         iter = 0
         cold = 0.0d0
         top = 0.0d0
         do i = 1, nfrmb
            j = int(frmb*random()) + 1
            bstb(i) = j
            top = top + 1.0d0/(1.0d0+exp((ub0(j)-ub1(j)
     &                                   +vlogb(i)+cold)/rtb))
         end do
         bot = 0.0d0
         do i = 1, nfrma
            j = int(frma*random()) + 1
            bsta(i) = j
            bot = bot + 1.0d0/(1.0d0+exp((ua1(j)-ua0(j)
     &                                   +vloga(i)-cold)/rta))
         end do
         cnew = rt*log(rfrm*top/bot) + cold
         delta = abs(cnew-cold)
         do while (.not. done)
            iter = iter + 1
            cold = cnew
            top = 0.0d0
            do i = 1, nfrmb
               j = bstb(i)
               top = top + 1.0d0/(1.0d0+exp((ub0(j)-ub1(j)
     &                                      +vlogb(i)+cold)/rtb))
            end do
            bot = 0.0d0
            do i = 1, nfrma
               j = bsta(i)
               bot = bot + 1.0d0/(1.0d0+exp((ua1(j)-ua0(j)
     &                                      +vloga(i)-cold)/rta))
            end do
            cnew = rt*log(rfrm*top/bot) + cold
            delta = abs(cnew-cold)
            if (delta .lt. eps) then
               done = .true.
               sum = sum + cnew
               sum2 = sum2 + cnew*cnew
            end if
         end do
      end do
      cnew = sum / bst
      ratio = bst / (bst-1.0d0)
      stdev = sqrt(ratio*(sum2/bst-cnew*cnew))
      write (iout,410)  cnew,stdev
  410 format (' Free Energy via BAR Bootstrap',7x,f12.4,
     &           ' +/-',f9.4,' Kcal/mol')
c
c     perform deallocation of some local arrays
c
      deallocate (bsta)
      deallocate (bstb)
c
c     find the enthalpy directly via average potential energy
c
      write (iout,420)
  420 format (/,' Enthalpy from Potential Energy Averages :',/)
      patm = 1.0d0
      epv = (vaveb-vavea) * patm / prescon
      stdpv = (vstda+vstdb) * patm / prescon
      u0sum = 0.0d0
      u0sum2 = 0.0d0
      u1sum = 0.0d0
      u1sum2 = 0.0d0
      hsum = 0.0d0
      hsum2 = 0.0d0
      do k = 1, nbst
         uave0 = 0.0d0
         uave1 = 0.0d0
         do i = 1, nfrma
            j = int(frma*random()) + 1
            uave0 = uave0 + ua0(j)
         end do
         do i = 1, nfrmb
            j = int(frmb*random()) + 1
            uave1 = uave1 + ub1(j)
         end do
         uave0 = uave0 / frma
         uave1 = uave1 / frmb
         u0sum = u0sum + uave0
         u0sum2 = u0sum2 + uave0*uave0
         u1sum = u1sum + uave1
         u1sum2 = u1sum2 + uave1*uave1
         hdir = uave1 - uave0 + epv
         hsum = hsum + hdir
         hsum2 = hsum2 + hdir*hdir
      end do
      uave0 = u0sum / bst
      stdev0 = sqrt(ratio*(u0sum2/bst-uave0*uave0))
      uave1 = u1sum / bst
      stdev1 = sqrt(ratio*(u1sum2/bst-uave1*uave1))
      hdir = hsum / bst
      stdev = sqrt(ratio*(hsum2/bst-hdir*hdir))
      write (iout,430)  uave0,stdev0
  430 format (' Average Energy for State 0',10x,f12.4,
     &           ' +/-',f9.4,' Kcal/mol')
      write (iout,440)  uave1,stdev1
  440 format (' Average Energy for State 1',10x,f12.4,
     &           ' +/-',f9.4,' Kcal/mol')
      if (epv .ne. 0.0d0) then
         write (iout,450)  epv,stdpv
  450    format (' PdV Work Term for 1 Atm',13x,f12.4,
     &              ' +/-',f9.4,' Kcal/mol')
      end if
      write (iout,460)  hdir,stdev
  460 format (' Enthalpy via Direct Estimate',8x,f12.4,
     &           ' +/-',f9.4,' Kcal/mol')
c
c     calculate the enthalpy via thermodynamic perturbation
c
      write (iout,470)
  470 format (/,' Enthalpy and Entropy via FEP Method :',/)
      hfsum = 0.0d0
      hfsum2 = 0.0d0
      hbsum = 0.0d0
      hbsum2 = 0.0d0
      do k = 1, nbst
         top = 0.0d0
         bot = 0.0d0
         do i = 1, nfrma
            j = int(frma*random()) + 1
            term = exp((ua0(j)-ua1(j)+vloga(j))/rta)
            top = top + ua1(j)*term
            bot = bot + term
         end do
         hfore = (top/bot) - uave0
         hfsum = hfsum + hfore
         hfsum2 = hfsum2 + hfore*hfore
         top = 0.0d0
         bot = 0.0d0
         do i = 1, nfrmb
            j = int(frmb*random()) + 1
            term = exp((ub1(j)-ub0(j)+vlogb(j))/rtb)
            top = top + ub0(j)*term
            bot = bot + term
         end do
         hback = -(top/bot) + uave1
         hbsum = hbsum + hback
         hbsum2 = hbsum2 + hback*hback
      end do
      hfore = hfsum / bst
      stdhf = sqrt(ratio*(hfsum2/bst-hfore*hfore))
      stdhf = stdhf + stdev0
      sfore = (hfore-cfore) / tempa
      hback = hbsum / bst
      stdhb = sqrt(ratio*(hbsum2/bst-hback*hback))
      stdhb = stdhb + stdev1
      sback = (hback-cback) / tempb
      write (iout,480)  hfore,stdhf
  480 format (' Enthalpy via Forward FEP',12x,f12.4,
     &              ' +/-',f9.4,' Kcal/mol')
      write (iout,490)  sfore
  490 format (' Entropy via Forward FEP',13x,f12.6,' Kcal/mol/K')
      write (iout,500)  -tempa*sfore
  500 format (' Forward FEP -T*dS Value',13x,f12.4,' Kcal/mol')
      write (iout,510)  hback,stdhb
  510 format (/,' Enthalpy via Backward FEP',11x,f12.4,
     &              ' +/-',f9.4,' Kcal/mol')
      write (iout,520)  sback
  520 format (' Entropy via Backward FEP',12x,f12.6,' Kcal/mol/K')
      write (iout,530)  -tempb*sback
  530 format (' Backward FEP -T*dS Value',12x,f12.4,' Kcal/mol')
c
c     determine the enthalpy and entropy via the BAR method
c
      write (iout,540)
  540 format (/,' Enthalpy and Entropy via BAR Method :',/)
      hsum = 0.0d0
      hsum2 = 0.0d0
      do k = 1, nbst
         fsum = 0.0d0
         fvsum = 0.0d0
         fbvsum = 0.0d0
         vsum = 0.0d0
         fbsum0 = 0.0d0
         do i = 1, nfrma
            j = int(frma*random()) + 1
            fore = 1.0d0/(1.0d0+exp((ua1(j)-ua0(j)+vloga(j)-cnew)/rta))
            back = 1.0d0/(1.0d0+exp((ua0(j)-ua1(j)+vloga(j)+cnew)/rta))
            fsum = fsum + fore
            fvsum = fvsum + fore*ua0(j)
            fbvsum = fbvsum + fore*back*(ua1(j)-ua0(j)+vloga(j))
            vsum = vsum + ua0(j)
            fbsum0 = fbsum0 + fore*back
         end do
         alpha0 = fvsum - fsum*(vsum/frma) + fbvsum
         bsum = 0.0d0
         bvsum = 0.0d0
         fbvsum = 0.0d0
         vsum = 0.0d0
         fbsum1 = 0.0d0
         do i = 1, nfrmb
            j = int(frmb*random()) + 1
            fore = 1.0d0/(1.0d0+exp((ub1(j)-ub0(j)+vlogb(j)-cnew)/rtb))
            back = 1.0d0/(1.0d0+exp((ub0(j)-ub1(j)+vlogb(j)+cnew)/rtb))
            bsum = bsum + back
            bvsum = bvsum + back*ub1(j)
            fbvsum = fbvsum + fore*back*(ub1(j)-ub0(j)+vlogb(j))
            vsum = vsum + ub1(j)
            fbsum1 = fbsum1 + fore*back
         end do
         alpha1 = bvsum - bsum*(vsum/frmb) - fbvsum
         hbar = (alpha0-alpha1) / (fbsum0+fbsum1)
         hsum = hsum + hbar
         hsum2 = hsum2 + hbar*hbar
      end do
      hbar = hsum / bst
      stdev = sqrt(ratio*(hsum2/bst-hbar*hbar))
      tsbar = hbar - cnew
      sbar = tsbar / (0.5d0*(tempa+tempb))
      write (iout,550)  hbar,stdev
  550 format (' Enthalpy via BAR Estimate',11x,f12.4
     &           ' +/-',f9.4,' Kcal/mol')
      write (iout,560)  sbar
  560 format (' Entropy via BAR Estimate',12x,f12.6,' Kcal/mol/K')
      write (iout,570)  -tsbar
  570 format (' BAR Estimate -T*dS Value',12x,f12.4,' Kcal/mol')
c
c     perform deallocation of some local arrays
c
      deallocate (ua0)
      deallocate (ua1)
      deallocate (ub0)
      deallocate (ub1)
      deallocate (vola)
      deallocate (volb)
      deallocate (vloga)
      deallocate (vlogb)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine basefile  --  get base prefix from a filename  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "basefile" extracts from an input filename the portion
c     consisting of any directory name and the base filename;
c     also reads any keyfile and sets information level values
c
c
      subroutine basefile (string)
      use ascii
      use files
      implicit none
      integer i,k,trimtext
      character*1 letter
      character*240 prefix
      character*(*) string
c
c
c     account for home directory abbreviation in filename
c
      if (string(1:2) .eq. '~/') then
         call getenv ('HOME',prefix)
         string = prefix(1:trimtext(prefix))//
     &               string(2:trimtext(string))
      end if
c
c     store the input filename and find its full length
c
      filename = string
      leng = trimtext (string)
c
c     count the number of characters prior to any extension
c
      k = leng
      do i = 1, leng
         letter = string(i:i)
         if (letter .eq. '/')  k = leng
c        if (letter .eq. '\')  k = leng
         if (ichar(letter) .eq. backslash)  k = leng
         if (letter .eq. ']')  k = leng
         if (letter .eq. ':')  k = leng
         if (letter .eq. '~')  k = leng
         if (letter .eq. '.')  k = i - 1
      end do
c
c     set the length of the base file name without extension
c
      leng = min(leng,k)
c
c     find the length of any directory name prefix
c
      k = 0
      do i = leng, 1, -1
         letter = string(i:i)
         if (letter .eq. '/')  k = i
c        if (letter .eq. '\')  k = i
         if (ichar(letter) .eq. backslash)  k = i
         if (letter .eq. ']')  k = i
         if (letter .eq. ':')  k = i
         if (letter .eq. '~')  k = i
c        if (letter .eq. '.')  k = i
         if (k .ne. 0)  goto 10
      end do
   10 continue
      ldir = k
c
c     read and store the keywords from the keyfile
c
      call getkey
c
c     get the information level and output style
c
      call control
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module bath  --  thermostat and barostat control values  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     maxnose     maximum length of Nose-Hoover thermostat chain
c
c     voltrial    mean number of steps between Monte Carlo moves
c     kelvin      target value for the system temperature (K)
c     atmsph      target value for the system pressure (atm)
c     tautemp     time constant for Berendsen thermostat (psec)
c     taupres     time constant for Berendsen barostat (psec)
c     compress    isothermal compressibility of medium (atm-1)
c     collide     collision frequency for Andersen thermostat
c     volmove     maximum volume move for Monte Carlo barostat (Ang**3)
c     vbar        velocity of log volume for Nose-Hoover barostat
c     qbar        mass of the volume for Nose-Hoover barostat
c     gbar        force for the volume for Nose-Hoover barostat
c     vnh         velocity of each chained Nose-Hoover thermostat
c     qnh         mass for each chained Nose-Hoover thermostat
c     gnh         force for each chained Nose-Hoover thermostat
c     isothermal  logical flag governing use of temperature control
c     isobaric    logical flag governing use of pressure control
c     prestyp     pressure control type (ISOTROPIC, SEMIISO or ANISO)
c     volscale    choice of scaling method for Monte Carlo barostat
c     thermostat  choice of temperature control method to be used
c     barostat    choice of pressure control method to be used
c
c
      module bath
      implicit none
      integer maxnose
      parameter (maxnose=4)
      integer voltrial
      real*8 kelvin,atmsph
      real*8 tautemp,taupres
      real*8 compress,collide
      real*8 volmove
      real*8 vbar,qbar,gbar
      real*8 vnh(maxnose)
      real*8 qnh(maxnose)
      real*8 gnh(maxnose)
      logical isothermal
      logical isobaric
      character*9 prestyp
      character*9 volscale
      character*11 thermostat
      character*11 barostat
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine beeman  --  Beeman molecular dynamics step  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "beeman" performs a molecular dynamics time step via the
c     Beeman multistep recursion formula; uses either original
c     values or "Better Beeman" coefficients of Bernie Brooks
c
c     literature references:
c
c     D. Beeman, "Some Multistep Methods for Use in Molecular
c     Dynamics Calculations", Journal of Computational Physics,
c     20, 130-139 (1976)
c
c     B. R. Brooks, "Algorithms for Molecular Dynamics at Constant
c     Temperature and Pressure", DCRT Report, NIH, April 1988
c
c     A. A. Kuraev, A. O. Rak, S. V. Kolosov, A. A. Koronovskii
c     and A. E. Hramov, "Fast Algorithm for Numerically Integrating
c     Equations of Motion for Large Particles in Microwave Devices",
c     Technical Physics, 59, 318-324 (2014)
c
c
      subroutine beeman (istep,dt)
      use atomid
      use atoms
      use freeze
      use ielscf
      use mdstuf
      use moldyn
      use polar
      use units
      use usage
      implicit none
      integer i,j,k
      integer istep
      real*8 dt,dtx,dmix
      real*8 etot,eksum,epot
      real*8 temp,pres
      real*8 part1,part2
      real*8 dt_2,term
      real*8 ekin(3,3)
      real*8 stress(3,3)
      real*8, allocatable :: xold(:)
      real*8, allocatable :: yold(:)
      real*8, allocatable :: zold(:)
      real*8, allocatable :: derivs(:,:)
c
c
c     set time values and coefficients for Beeman integration
c
      dmix = dble(bmnmix)
      part1 = 0.5d0*dmix + 1.0d0
      part2 = part1 - 2.0d0
      dtx = dt / dmix
c
c     perform dynamic allocation of some local arrays
c
      allocate (xold(n))
      allocate (yold(n))
      allocate (zold(n))
      allocate (derivs(3,n))
c
c     store the current atom positions, then find half-step
c     velocities and full-step positions via Beeman recursion
c
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            v(j,k) = v(j,k) + (part1*a(j,k)-aalt(j,k))*dtx
         end do
         xold(k) = x(k)
         yold(k) = y(k)
         zold(k) = z(k)
         x(k) = x(k) + v(1,k)*dt
         y(k) = y(k) + v(2,k)*dt
         z(k) = z(k) + v(3,k)*dt
      end do
c
c     apply Verlet half-step updates for any auxiliary dipoles
c
      if (use_ielscf) then
         dt_2 = 0.5d0 * dt
         do i = 1, nuse
            k = iuse(i)
            do j = 1, 3
               vaux(j,k) = vaux(j,k) + aaux(j,k)*dt_2
               vpaux(j,k) = vpaux(j,k) + apaux(j,k)*dt_2
               uaux(j,k) = uaux(j,k) + vaux(j,k)*dt
               upaux(j,k) = upaux(j,k) + vpaux(j,k)*dt
            end do
         end do
      end if
c
c     get constraint-corrected positions and half-step velocities
c
      if (use_freeze)  call rattle (dt,xold,yold,zold)
c
c     get the potential energy and atomic forces
c
      call gradient (epot,derivs)
c
c     make half-step temperature and pressure corrections
c
      call temper2 (dt,temp)
      call pressure2 (epot,temp)
c
c     use Newton's second law to get the next accelerations;
c     find the full-step velocities using the Beeman recursion
c
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            aalt(j,k) = a(j,k)
            a(j,k) = -ekcal * derivs(j,k) / mass(k)
            v(j,k) = v(j,k) + (part2*a(j,k)+aalt(j,k))*dtx
         end do
      end do
c
c     apply Verlet full-step updates for any auxiliary dipoles
c
      if (use_ielscf) then
         term = 2.0d0 / (dt*dt)
         do i = 1, nuse
            k = iuse(i)
            do j = 1, 3
               aaux(j,k) = term * (uind(j,k)-uaux(j,k))
               apaux(j,k) = term * (uinp(j,k)-upaux(j,k))
               vaux(j,k) = vaux(j,k) + aaux(j,k)*dt_2
               vpaux(j,k) = vpaux(j,k) + apaux(j,k)*dt_2
            end do
         end do
      end if
c
c     find the constraint-corrected full-step velocities
c
      if (use_freeze) then
         call rattle2 (dt)
         do i = 1, nuse
            k = iuse(i)
            xold(k) = x(k)
            yold(k) = y(k)
            zold(k) = z(k)
         end do
      end if
c
c     make full-step temperature and pressure corrections
c
      call temper (dt,eksum,ekin,temp)
      call pressure (dt,ekin,pres,stress)
c
c     final constraint step to enforce position convergence
c
      if (use_freeze)  call shake (xold,yold,zold)
c
c     perform deallocation of some local arrays
c
      deallocate (xold)
      deallocate (yold)
      deallocate (zold)
      deallocate (derivs)
c
c     total energy is sum of kinetic and potential energies
c
      etot = eksum + epot
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,eksum,temp,pres)
      call mdsave (istep,dt,epot,eksum)
      call mdrest (istep)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine bcuint  --  bicubic interpolation of function  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "bcuint" performs a bicubic interpolation of the function
c     value on a 2D spline grid
c
c
      subroutine bcuint (y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy)
      implicit none
      integer i
      real*8 x1,x1l,x1u
      real*8 x2,x2l,x2u
      real*8 t,u,ansy
      real*8 y(4),y12(4)
      real*8 y1(4),y2(4)
      real*8 c(4,4)
c
c
c     get coefficients, then perform bicubic interpolation
c
      call bcucof (y,y1,y2,y12,x1u-x1l,x2u-x2l,c)
      t = (x1-x1l) / (x1u-x1l)
      u = (x2-x2l) / (x2u-x2l)
      ansy = 0.0d0
      do i = 4, 1, -1
         ansy = t*ansy + ((c(i,4)*u+c(i,3))*u+c(i,2))*u + c(i,1)
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine bcuint1  --  bicubic interpolation of gradient  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "bcuint1" performs a bicubic interpolation of the function
c     value and gradient along the directions of a 2D spline grid
c
c     literature reference:
c
c     W. H. Press, S. A. Teukolsky, W. T. Vetterling and B. P.
c     Flannery, Numerical Recipes (Fortran), 2nd Ed., Cambridge
c     University Press, 1992, Section 3.6
c
c
      subroutine bcuint1 (y,y1,y2,y12,x1l,x1u,x2l,x2u,
     &                       x1,x2,ansy,ansy1,ansy2)
      implicit none
      integer i
      real*8 x1,x1l,x1u
      real*8 x2,x2l,x2u
      real*8 t,u,ansy
      real*8 ansy1,ansy2
      real*8 y(4),y12(4)
      real*8 y1(4),y2(4)
      real*8 c(4,4)
c
c
c     get coefficients, then perform bicubic interpolation
c
      call bcucof (y,y1,y2,y12,x1u-x1l,x2u-x2l,c)
      t = (x1-x1l) / (x1u-x1l)
      u = (x2-x2l) / (x2u-x2l)
      ansy = 0.0d0
      ansy1 = 0.0d0
      ansy2 = 0.0d0
      do i = 4, 1, -1
         ansy = t*ansy + ((c(i,4)*u+c(i,3))*u+c(i,2))*u + c(i,1)
         ansy1 = u*ansy1 + (3.0d0*c(4,i)*t+2.0d0*c(3,i))*t + c(2,i)
         ansy2 = t*ansy2 + (3.0d0*c(i,4)*u+2.0d0*c(i,3))*u + c(i,2)
      end do
      ansy1 = ansy1 / (x1u-x1l)
      ansy2 = ansy2 / (x2u-x2l)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine bcuint2  --  bicubic interpolation of Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "bcuint2" performs a bicubic interpolation of the function value,
c     gradient and Hessian along the directions of a 2D spline grid
c
c
      subroutine bcuint2 (y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy,
     &                       ansy1,ansy2,ansy12,ansy11,ansy22)
      implicit none
      integer i
      real*8 x1,x1l,x1u,x2,x2l,x2u
      real*8 ansy,ansy1,ansy2
      real*8 ansy11,ansy22,ansy12
      real*8 y(4),y1(4),y2(4),y12(4)
      real*8 t,u,c(4,4)
c
c
c     get coefficients, then perform bicubic interpolation
c
      call bcucof (y,y1,y2,y12,x1u-x1l,x2u-x2l,c)
      t = (x1-x1l) / (x1u-x1l)
      u = (x2-x2l) / (x2u-x2l)
      ansy = 0.0d0
      ansy1 = 0.0d0
      ansy2 = 0.0d0
      ansy11 = 0.0d0
      ansy22 = 0.0d0
      do i = 4, 1, -1
         ansy = t*ansy + ((c(i,4)*u+c(i,3))*u+c(i,2))*u + c(i,1)
         ansy1 = u*ansy1 + (3.0d0*c(4,i)*t+2.0d0*c(3,i))*t + c(2,i)
         ansy2 = t*ansy2 + (3.0d0*c(i,4)*u+2.0d0*c(i,3))*u + c(i,2)
         ansy11 = u*ansy11 + 6.0d0*c(4,i)*t + 2.0d0*c(3,i)
         ansy22 = t*ansy22 + 6.0d0*c(i,4)*u + 2.0d0*c(i,3)
      end do
      ansy12 = 3.0d0*t*t*((3.0d0*c(4,4)*u+2.0d0*c(4,3))*u+c(4,2))
     &            + 2.0d0*t*((3.0d0*c(3,4)*u+2.0d0*c(3,3))*u+c(3,2))
     &            + (3.0d0*c(2,4)*u+2.0d0*c(2,3))*u + c(2,2)
      ansy1 = ansy1 / (x1u-x1l)
      ansy2 = ansy2 / (x2u-x2l)
      ansy11 = ansy11 / ((x1u-x1l)*(x1u-x1l))
      ansy22 = ansy22 / ((x2u-x2l)*(x2u-x2l))
      ansy12 = ansy12 / ((x1u-x1l)*(x2u-x2l))
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine bcucof  --  bicubic interpolation coefficients  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "bcucof" determines the coefficient matrix needed for bicubic
c     interpolation of a function, gradients and cross derivatives
c
c     literature reference:
c
c     W. H. Press, S. A. Teukolsky, W. T. Vetterling and B. P.
c     Flannery, Numerical Recipes (Fortran), 2nd Ed., Cambridge
c     University Press, 1992, Section 3.6
c
c
      subroutine bcucof (y,y1,y2,y12,d1,d2,c)
      implicit none
      integer i,j,k
      real*8 xx,d1,d2,d1d2
      real*8 y(4),y12(4)
      real*8 y1(4),y2(4)
      real*8 x(16),cl(16)
      real*8 c(4,4)
      real*8 wt(16,16)
      save wt
      data wt / 1.0d0, 0.0d0,-3.0d0, 2.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
     &         -3.0d0, 0.0d0, 9.0d0,-6.0d0, 2.0d0, 0.0d0,-6.0d0, 4.0d0,
     &          0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
     &          3.0d0, 0.0d0,-9.0d0, 6.0d0,-2.0d0, 0.0d0, 6.0d0,-4.0d0,
     &          0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
     &          0.0d0, 0.0d0, 9.0d0,-6.0d0, 0.0d0, 0.0d0,-6.0d0, 4.0d0,
     &          0.0d0, 0.0d0, 3.0d0,-2.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
     &          0.0d0, 0.0d0,-9.0d0, 6.0d0, 0.0d0, 0.0d0, 6.0d0,-4.0d0,
     &          0.0d0, 0.0d0, 0.0d0, 0.0d0, 1.0d0, 0.0d0,-3.0d0, 2.0d0,
     &         -2.0d0, 0.0d0, 6.0d0,-4.0d0, 1.0d0, 0.0d0,-3.0d0, 2.0d0,
     &          0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
     &         -1.0d0, 0.0d0, 3.0d0,-2.0d0, 1.0d0, 0.0d0,-3.0d0, 2.0d0,
     &          0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
     &          0.0d0, 0.0d0,-3.0d0, 2.0d0, 0.0d0, 0.0d0, 3.0d0,-2.0d0,
     &          0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 3.0d0,-2.0d0,
     &          0.0d0, 0.0d0,-6.0d0, 4.0d0, 0.0d0, 0.0d0, 3.0d0,-2.0d0,
     &          0.0d0, 1.0d0,-2.0d0, 1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
     &          0.0d0,-3.0d0, 6.0d0,-3.0d0, 0.0d0, 2.0d0,-4.0d0, 2.0d0,
     &          0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
     &          0.0d0, 3.0d0,-6.0d0, 3.0d0, 0.0d0,-2.0d0, 4.0d0,-2.0d0,
     &          0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
     &          0.0d0, 0.0d0,-3.0d0, 3.0d0, 0.0d0, 0.0d0, 2.0d0,-2.0d0,
     &          0.0d0, 0.0d0,-1.0d0, 1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
     &          0.0d0, 0.0d0, 3.0d0,-3.0d0, 0.0d0, 0.0d0,-2.0d0, 2.0d0,
     &          0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 1.0d0,-2.0d0, 1.0d0,
     &          0.0d0,-2.0d0, 4.0d0,-2.0d0, 0.0d0, 1.0d0,-2.0d0, 1.0d0,
     &          0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
     &          0.0d0,-1.0d0, 2.0d0,-1.0d0, 0.0d0, 1.0d0,-2.0d0, 1.0d0,
     &          0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
     &          0.0d0, 0.0d0, 1.0d0,-1.0d0, 0.0d0, 0.0d0,-1.0d0, 1.0d0,
     &          0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,-1.0d0, 1.0d0,
     &          0.0d0, 0.0d0, 2.0d0,-2.0d0, 0.0d0, 0.0d0,-1.0d0, 1.0d0 /
c
c
c     pack a temporary vector of corner values
c
      d1d2 = d1 * d2
      do i = 1, 4
         x(i) = y(i)
         x(i+4) = y1(i) * d1
         x(i+8) = y2(i) * d2
         x(i+12) = y12(i) * d1d2
      end do
c
c     matrix multiply by the stored weight table
c
      do i = 1, 16
         xx = 0.0d0
         do k = 1, 16
            xx = xx + wt(i,k)*x(k)
         end do
         cl(i) = xx
      end do
c
c     unpack the result into the coefficient table
c
      j = 0
      do i = 1, 4
         do k = 1, 4
            j = j + 1
            c(i,k) = cl(j)
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module bitor  --  bitorsions in the current structure  ##
c     ##                                                         ##
c     #############################################################
c
c
c     nbitor  total number of bitorsions in the system
c     ibitor  numbers of the atoms in each bitorsion
c
c
      module bitor
      implicit none
      integer nbitor
      integer, allocatable :: ibitor(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine bitors  --  locate and store bitorsions  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "bitors" finds the total number of bitorsions as pairs
c     of adjacent torsional angles, and the numbers of the five
c     atoms defining each bitorsion
c
c
      subroutine bitors
      use angbnd
      use atoms
      use bitor
      use couple
      implicit none
      integer i,j,k
      integer ia,ib,ic,id,ie
c
c
c     initial count of the total number of bitorsions
c
      nbitor = 0
      do i = 1, nangle
         ib = iang(1,i)
         ic = iang(2,i)
         id = iang(3,i)
         do j = 1, n12(ib)
            ia = i12(j,ib)
            if (ia.ne.ic .and. ia.ne.id) then
               do k = 1, n12(id)
                  ie = i12(k,id)
                  if (ie.ne.ic .and. ie.ne.ib .and. ie.ne.ia) then
                     nbitor = nbitor + 1
                  end if
               end do
            end if
         end do
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(ibitor))  deallocate (ibitor)
      allocate (ibitor(5,nbitor))
c
c     store the list of atoms involved in each bitorsion
c
      nbitor = 0
      do i = 1, nangle
         ib = iang(1,i)
         ic = iang(2,i)
         id = iang(3,i)
         do j = 1, n12(ib)
            ia = i12(j,ib)
            if (ia.ne.ic .and. ia.ne.id) then
               do k = 1, n12(id)
                  ie = i12(k,id)
                  if (ie.ne.ic .and. ie.ne.ib .and. ie.ne.ia) then
                     nbitor = nbitor + 1
                     ibitor(1,nbitor) = ia
                     ibitor(2,nbitor) = ib
                     ibitor(3,nbitor) = ic
                     ibitor(4,nbitor) = id
                     ibitor(5,nbitor) = ie
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module bndpot  --  bond stretch functional form details  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     cbnd      cubic coefficient in bond stretch potential
c     qbnd      quartic coefficient in bond stretch potential
c     bndunit   convert bond stretch energy to kcal/mole
c     bndtyp    type of bond stretch potential energy function
c
c
      module bndpot
      implicit none
      real*8 cbnd
      real*8 qbnd
      real*8 bndunit
      character*8 bndtyp
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module bndstr  --  bond stretches in the current structure  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     nbond   total number of bond stretches in the system
c     ibnd    numbers of the atoms in each bond stretch
c     bk      bond stretch force constants (kcal/mole/Ang**2)
c     bl      ideal bond length values in Angstroms
c
c
      module bndstr
      implicit none
      integer nbond
      integer, allocatable :: ibnd(:,:)
      real*8, allocatable :: bk(:)
      real*8, allocatable :: bl(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine bonds  --  locate and store covalent bonds  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "bonds" finds the total number of covalent bonds and
c     stores the atom numbers of the atoms defining each bond
c
c
      subroutine bonds
      use atmlst
      use atoms
      use bndstr
      use couple
      implicit none
      integer i,j,k,m
c
c
c     initial count of the total number of bonds
c
      nbond = 0
      do i = 1, n
         do j = 1, n12(i)
            k = i12(j,i)
            if (i .lt. k) then
               nbond = nbond + 1
            end if
         end do
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(ibnd))  deallocate (ibnd)
      if (allocated(bndlist))  deallocate (bndlist)
      allocate (ibnd(2,nbond))
      allocate (bndlist(maxval,n))
c
c     store the list of atoms involved in each bond
c
      nbond = 0
      do i = 1, n
         do j = 1, n12(i)
            k = i12(j,i)
            if (i .lt. k) then
               nbond = nbond + 1
               ibnd(1,nbond) = i
               ibnd(2,nbond) = k
c
c     store the numbers of the bonds involving each atom
c
               bndlist(j,i) = nbond
               do m = 1, n12(k)
                  if (i .eq. i12(m,k)) then
                     bndlist(m,k) = nbond
                     goto 10
                  end if
               end do
   10          continue
            end if
         end do
      end do
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2023 by Rae Corrigan & Jay W. Ponder  ##
c     ##                 All Rights Reserved                  ##
c     ##########################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine born  --  Born radii for implicit solvation  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "born" computes the Born radius of each atom for use with
c     the various implicit solvation models
c
c     literature references:
c
c     W. C. Still, A. Tempczyk, R. C. Hawley and T. Hendrickson,
c     "A Semianalytical Treatment of Solvation for Molecular
c     Mechanics and Dynamics", J. Amer. Chem. Soc., 112, 6127-6129
c     (1990)  ("Onion" Method; see supplimentary material)
c
c     D. Qiu, P. S. Shenkin, F. P. Hollinger and W. C. Still, "The
c     GB/SA Continuum Model for Solvation. A Fast Analytical Method
c     for the Calculation of Approximate Radii", J. Phys. Chem. A,
c     101, 3005-3014 (1997)  (Analytical Still Method)
c
c     G. D. Hawkins, C. J. Cramer and D. G. Truhlar, "Parametrized
c     Models of Aqueous Free Energies of Solvation Based on Pairwise
c     Descreening of Solute Atomic Charges from a Dielectric Medium",
c     J. Phys. Chem., 100, 19824-19839 (1996)  (HCT Method)
c
c     A. Onufriev, D. Bashford and D. A. Case, "Exploring Protein
c     Native States and Large-Scale Conformational Changes with a
c     Modified Generalized Born Model", PROTEINS, 55, 383-394 (2004)
c     (OBC Method)
c
c     T. Grycuk, "Deficiency of the Coulomb-field Approximation
c     in the Generalized Born Model: An Improved Formula for Born
c     Radii Evaluation", J. Chem. Phys., 119, 4817-4826 (2003)
c     (Grycuk Method)
c
c     M. Schaefer, C. Bartels and M. Karplus, "Solution Conformations
c     and Thermodynamics of Structured Peptides: Molecular Dynamics
c     Simulation with an Implicit Solvation Model", J. Mol. Biol.,
c     284, 835-848 (1998)  (ACE Method)
c
c
      subroutine born
      use atomid
      use atoms
      use bath
      use chgpot
      use couple
      use inform
      use iounit
      use math
      use mpole
      use mutant
      use pbstuf
      use solpot
      use solute
      implicit none
      integer i,j,k
      integer it,kt
      integer ii,kk
      integer, allocatable :: skip(:)
      real*8 area,rold,t
      real*8 shell,fraction
      real*8 inner,outer,tinit
      real*8 ratio,total
      real*8 xi,yi,zi,ri
      real*8 rk,sk,sk2
      real*8 lik,lik2
      real*8 uik,uik2
      real*8 tsum,tchain
      real*8 sum,sum2,sum3
      real*8 soluteint
      real*8 alpha,beta,gamma
      real*8 xr,yr,zr,rvdw
      real*8 r,r2,r3,r4
      real*8 gpi,pip5,p5inv
      real*8 theta,term,ccf
      real*8 l2,l4,lr,l4r
      real*8 u2,u4,ur,u4r
      real*8 expterm,rmu
      real*8 b0,gself,pi43
      real*8 bornmax
      real*8 pair,pbtotal
      real*8 probe,areatotal
      real*8 mixsn,neckval
      real*8, allocatable :: roff(:)
      real*8, allocatable :: weight(:)
      real*8, allocatable :: garea(:)
      real*8, allocatable :: pos(:,:)
      real*8, allocatable :: pbpole(:,:)
      real*8, allocatable :: pbself(:)
      real*8, allocatable :: pbpair(:)
      logical done
c
c
c     perform dynamic allocation of some local arrays
c
      if (borntyp .eq. 'STILL')  allocate (skip(n))
      allocate (roff(n))
      allocate (weight(n))
      allocate (garea(n))
      if (borntyp .eq. 'PERFECT') then
         allocate (pos(3,n))
         allocate (pbpole(13,n))
         allocate (pbself(n))
         allocate (pbpair(n))
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (borntyp .eq. 'PERFECT') then
         if (.not. allocated(apbe))  allocate (apbe(n))
         if (.not. allocated(pbep))  allocate (pbep(3,n))
         if (.not. allocated(pbfp))  allocate (pbfp(3,n))
         if (.not. allocated(pbtp))  allocate (pbtp(3,n))
      end if
c
c     set offset modified radii and OBC chain rule factor
c
      do i = 1, n
         roff(i) = rsolv(i) - doffset
         drobc(i) = 1.0d0
      end do
c
c     get the Born radii via the numerical "Onion" method
c
      if (borntyp .eq. 'ONION') then
         tinit = 0.1d0
         ratio = 1.5d0
         do i = 1, n
            t = tinit
            rold = roff(i)
            total = 0.0d0
            done = .false.
            do while (.not. done)
               roff(i) = roff(i) + 0.5d0*t
               call surfatom (i,area,roff)
               fraction = area / (4.0d0*pi*roff(i)**2)
               if (fraction .lt. 0.99d0) then
                  inner = roff(i) - 0.5d0*t
                  outer = inner + t
                  shell = 1.0d0/inner - 1.0d0/outer
                  total = total + fraction*shell
                  roff(i) = roff(i) + 0.5d0*t
                  t = ratio * t
               else
                  inner = roff(i) - 0.5d0*t
                  total = total + 1.0d0/inner
                  done = .true.
               end if
            end do
            rborn(i) = 1.0d0 / total
            roff(i) = rold
         end do
c
c     get the Born radii via "Onion" method and Grycuk integral
c
      else if (borntyp .eq. 'GONION') then
         tinit = 0.1d0
         ratio = 1.5d0
         probe = onipr
         do i = 1, n
            weight(i) = 1.0d0
         end do
         do i = 1, n
            t = tinit
            rold = roff(i)
            total = 0.0d0
            done = .false.
            do while (.not. done)
               roff(i) = roff(i) + 0.5d0*t
               call surface (roff,weight,probe,areatotal,garea)
               fraction = garea(i) / (4.0d0*pi*(roff(i)+probe)**2)
               if (fraction .lt. 0.99d0) then
                  inner = roff(i) - 0.5d0*t
                  outer = inner + t
                  shell = 1.0d0/(inner**3) - 1.0d0/(outer**3)
                  shell = shell/3.0d0
                  total = total + fraction*shell
                  roff(i) = roff(i) + 0.5d0*t
                  t = ratio * t
               else
                  inner = roff(i) - 0.5d0*t
                  total = total + 1.0d0/(3.0d0*(inner**3))
                  done = .true.
               end if
            end do
            rborn(i) = 1.0d0/((3.0d0*total)**third)
            roff(i) = rold
         end do
c
c     get the Born radii via the analytical Still method;
c     note this code only loops over the variable parts
c
      else if (borntyp .eq. 'STILL') then
         do i = 1, n
            skip(i) = 0
         end do
         p5inv = 1.0d0 / p5
         pip5 = pi * p5
         do i = 1, n
            xi = x(i)
            yi = y(i)
            zi = z(i)
            gpi = gpol(i)
            skip(i) = i
            do j = 1, n12(i)
               skip(i12(j,i)) = i
            end do
            do j = 1, n13(i)
               skip(i13(j,i)) = i
            end do
            do k = 1, n
               if (skip(k) .ne. i) then
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  r2 = xr**2 + yr**2 + zr**2
                  r4 = r2 * r2
                  rvdw = rsolv(i) + rsolv(k)
                  ratio = r2 / (rvdw*rvdw)
                  if (ratio .gt. p5inv) then
                     ccf = 1.0d0
                  else
                     theta = ratio * pip5
                     term = 0.5d0 * (1.0d0-cos(theta))
                     ccf = term * term
                  end if
                  gpi = gpi + p4*ccf*vsolv(k)/r4
               end if
            end do
            rborn(i) = -0.5d0 * electric / gpi
         end do
c
c     get the Born radii via the Hawkins-Cramer-Truhlar method
c
      else if (borntyp .eq. 'HCT') then
         do i = 1, n
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ri = roff(i)
            sum = 1.0d0 / ri
            do k = 1, n
               if (i .ne. k) then
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  r2 = xr**2 + yr**2 + zr**2
                  r = sqrt(r2)
                  rk = roff(k)
                  sk = rk * shct(k)
                  if (ri .lt. r+sk) then
                     sk2 = sk * sk
                     lik = 1.0d0 / max(ri,abs(r-sk))
                     uik = 1.0d0 / (r+sk)
                     lik2 = lik * lik
                     uik2 = uik * uik
                     term = lik - uik + 0.25d0*r*(uik2-lik2)
     &                         + (0.5d0/r)*log(uik/lik)
     &                         + (0.25d0*sk2/r)*(lik2-uik2)
                     if (ri .lt. sk-r) then
                        term = term + 2.0d0*(1.0d0/ri-lik)
                     end if
                     sum = sum - 0.5d0*term
                  end if
               end if
            end do
            rborn(i) = 1.0d0 / sum
         end do
c
c     get the Born radii via the Onufriev-Bashford-Case method
c
      else if (borntyp .eq. 'OBC') then
         do i = 1, n
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ri = roff(i)
            sum = 0.0d0
            do k = 1, n
               if (i .ne. k) then
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  r2 = xr**2 + yr**2 + zr**2
                  r = sqrt(r2)
                  rk = roff(k)
                  sk = rk * shct(k)
                  if (ri .lt. r+sk) then
                     sk2 = sk * sk
                     lik = 1.0d0 / max(ri,abs(r-sk))
                     uik = 1.0d0 / (r+sk)
                     lik2 = lik * lik
                     uik2 = uik * uik
                     term = lik - uik + 0.25d0*r*(uik2-lik2)
     &                         + (0.5d0/r)*log(uik/lik)
     &                         + (0.25d0*sk2/r)*(lik2-uik2)
                     if (ri .lt. sk-r) then
                        term = term + 2.0d0*(1.0d0/ri-lik)
                     end if
                     sum = sum + 0.5d0*term
                  end if
               end if
            end do
            alpha = aobc(i)
            beta = bobc(i)
            gamma = gobc(i)
            sum = ri * sum
            sum2 = sum * sum
            sum3 = sum * sum2
            tsum = tanh(alpha*sum - beta*sum2 + gamma*sum3)
            rborn(i) = 1.0d0/ri - tsum/rsolv(i)
            rborn(i) = 1.0d0 / rborn(i)
            tchain = ri * (alpha-2.0d0*beta*sum+3.0d0*gamma*sum2)
            drobc(i) = (1.0d0-tsum*tsum) * tchain / rsolv(i)
         end do
c
c     get the Born radii via Grycuk modified HCT method
c
      else if (borntyp .eq. 'GRYCUK') then
         pi43 = 4.0d0 * third * pi
         do i = 1, n
            rborn(i) = 0.0d0
            ri = rsolv(i)
            if (ri .gt. 0.0d0) then
               xi = x(i)
               yi = y(i)
               zi = z(i)
               sum = pi43 / ri**3
               soluteint = 0.0d0
               ri = max(rsolv(i),rdescr(i)) + descoff
               do k = 1, n
                  rk = rdescr(k)
                  mixsn = 0.5d0 * (sneck(i)+sneck(k))
                  if (mut(k))  mixsn = mixsn * elambda
                  if (i.ne.k .and. rk.gt.0.0d0) then
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     r2 = xr**2 + yr**2 + zr**2
                     r = sqrt(r2)
                     sk = rk * shct(k)
                     if (sk .gt. 0.0d0) then
                        if (ri .lt. r+sk) then
                           sk2 = sk * sk
                           if (ri+r .lt. sk) then
                              lik = ri
                              uik = sk - r
                              soluteint = soluteint + pi43*(1.0d0/uik**3
     &                                                   -1.0d0/lik**3)
                           end if
                           uik = r + sk
                           if (ri+r .lt. sk) then
                              lik = sk - r
                           else if (r .lt. ri+sk) then
                              lik = ri
                           else
                              lik = r - sk
                           end if
                           l2 = lik * lik
                           l4 = l2 * l2
                           lr = lik * r
                           l4r = l4 * r
                           u2 = uik * uik
                           u4 = u2 * u2
                           ur = uik * r
                           u4r = u4 * r
                           term = (3.0d0*(r2-sk2)+6.0d0*u2-8.0d0*ur)/u4r
     &                               - (3.0d0*(r2-sk2)+6.0d0*l2
     &                                    -8.0d0*lr)/l4r
                           soluteint = soluteint - pi*term/12.0d0
                        end if
                        if (useneck) then
                           call neck (r,ri,rk,mixsn,neckval)
                           soluteint = soluteint - neckval
                        end if
                     end if
                  end if
               end do
               if (usetanh) then
                  bornint(i) = soluteint
                  call tanhrsc (soluteint,rsolv(i))
               end if
               sum = sum + soluteint
               rborn(i) = (sum/pi43)**third
               if (rborn(i) .le. 0.0d0)  rborn(i) = 0.0001d0
               rborn(i) = 1.0d0 / rborn(i)
            end if
         end do
c
c     get the Born radii via analytical continuum electrostatics
c
      else if (borntyp .eq. 'ACE') then
         b0 = 0.0d0
         do i = 1, n
            b0 = b0 + vsolv(i)
         end do
         b0 = (0.75d0*b0/pi)**third
         do i = 1, n
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ri = rsolv(i)
            it = class(i)
            gself = 1.0d0/ri + 2.0d0*wace(it,it)
            do k = 1, n
               if (k .ne. i) then
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  kt = class(k)
                  r2 = xr**2 + yr**2 + zr**2
                  r3 = r2 * sqrt(r2)
                  r4 = r2 * r2
                  expterm = wace(it,kt) * exp(-r2/s2ace(it,kt))
                  rmu = r4 + uace(it,kt)**4
                  term = (vsolv(k)/(8.0d0*pi)) * (r3/rmu)**4
                  gself = gself - 2.0d0*(expterm+term)
               end if
            end do
            if (gself .ge. 0.5d0/b0) then
               rborn(i) = 1.0d0 / gself
            else
               rborn(i) = 2.0d0 * b0 * (1.0d0+b0*gself)
            end if
         end do
c
c     get the "perfect" Born radii via Poisson-Boltzmann
c
      else if (borntyp .eq. 'PERFECT') then
         do i = 1, n
            pos(1,i) = x(i)
            pos(2,i) = y(i)
            pos(3,i) = z(i)
            do j = 1, 13
               pbpole(j,i) = 0.0d0
            end do
         end do
         term = -0.5d0 * electric * (1.0d0-1.0d0/sdie)
c
c     find the perfect radii and optional self-energies
c
         if (debug) then
            call chkpole
            call rotpole ('MPOLE')
            write (iout,10)
   10       format (/,' Perfect Self Energy Values :',/)
         end if
         do ii = 1, npole
            i = ipole(ii)
            pbpole(1,i) = 1.0d0
            call apbsempole (n,pos,rsolv,pbpole,pbe,
     &                       apbe,pbep,pbfp,pbtp)
            pbpole(1,i) = 0.0d0
            rborn(i) = term / pbe
            if (debug) then
               pbpole(1,i) = rpole(1,i)
               do j = 2, 4
                  pbpole(j,i) = rpole(j,i)
               end do
               do j = 5, 13
                  pbpole(j,i) = 3.0d0 * rpole(j,i)
               end do
               call apbsempole (n,pos,rsolv,pbpole,pbe,
     &                          apbe,pbep,pbfp,pbtp)
               do j = 1, 13
                  pbpole(j,i) = 0.0d0
               end do
               pbself(i) = pbe
               pbtotal = pbtotal + pbe
               write (iout,20)  i,pbe
   20          format (i8,5x,f12.4)
            end if
         end do
c
c     find the perfect permanent pair energy values
c
         if (debug) then
            write (iout,30)
   30       format (/,' Perfect Pair Energy Values :',/)
            do ii = 1, npole
               i = ipole(ii)
               pbpole(1,i) = rpole(1,i)
               do j = 2, 4
                  pbpole(j,i) = rpole(j,i)
               end do
               do j = 5, 13
                  pbpole(j,i) = 3.0d0 * rpole(j,i)
               end do
               do kk = ii+1, npole
                  k = ipole(kk)
                  pbpole(1,k) = rpole(1,k)
                  do j = 2, 4
                     pbpole(j,k) = rpole(j,k)
                  end do
                  do j = 5, 13
                     pbpole(j,k) = 3.0d0 * rpole(j,k)
                  end do
                  call apbsempole (n,pos,rsolv,pbpole,pbe,
     &                             apbe,pbep,pbfp,pbtp)
                  pair = pbe - pbself(i) - pbself(k)
                  write (iout,40)  i,k,pair
   40             format (5x,2i8,f12.4)
                  pbtotal = pbtotal + pair
                  pbpair(i) = pbpair(i) + 0.5d0 * pair
                  pbpair(k) = pbpair(k) + 0.5d0 * pair
                  do j = 1, 13
                     pbpole(j,k) = 0.0d0
                  end do
               end do 
               do j = 1, 13
                  pbpole(j,i) = 0.0d0
               end do
            end do
            do ii = 1, npole
               i = ipole(ii)
               pbpole(1,i) = rpole(1,i)
               do j = 2, 4
                  pbpole(j,i) = rpole(j,i)
               end do
               do j = 5, 13
                  pbpole(j,i) = 3.0d0 * rpole(j,i)
               end do
            end do
            call apbsempole (n,pos,rsolv,pbpole,pbe,
     &                       apbe,pbep,pbfp,pbtp)
            write(iout,50)  pbe
   50       format (/,' Single PB Calculation :  ',f12.4) 
            write(iout,60)  pbtotal
   60       format (' Sum of Self and Pairs :  ',f12.4)
         end if
c
c     print the perfect self-energies and cross-energies
c
         write (iout,70)
   70    format (/,' Perfect Self-Energies and Cross-Energies :',
     &           //,' Type',12x,'Atom Name',24x,'Self',7x,'Cross',/)
         do ii = 1, npole
            i = ipole(ii)
            write (iout,80)  i,name(i),pbself(i),pbpair(i)
   80       format (' PB-Perfect',2x,i8,'-',a3,17x,2f12.4)
         end do
      end if
c
c     perform deallocation of some local arrays
c
      if (borntyp .eq. 'STILL')  deallocate (skip)
      deallocate (roff)
      deallocate (weight)
      deallocate (garea)
      if (borntyp .eq. 'PERFECT') then
         deallocate (pos)
         deallocate (pbpole)
         deallocate (pbself)
         deallocate (pbpair)
      end if
c
c     make sure the final values are in a reasonable range
c
      bornmax = 500.0d0
      do i = 1, n
         if (rborn(i).lt.0.0d0 .or. rborn(i).gt.bornmax)
     &      rborn(i) = bornmax
      end do
c
c     write out the final Born radius value for each atom
c
      if (debug) then
         write (iout,90)
   90    format (/,' Born Radii for Individual Atoms :',/)
         k = 1
         do while (k .le. n)
            write (iout,100)  (i,rborn(i),i=k,min(k+4,n))
  100       format (1x,5(i7,f8.3))
            k = k + 5
         end do
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine born1  --  Born radii chain rule derivatives  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "born1" computes derivatives of the Born radii with respect
c     to atomic coordinates and increments total energy derivatives
c     and virial components for potentials involving Born radii
c
c
      subroutine born1
      use atomid
      use atoms
      use chgpot
      use couple
      use deriv
      use math
      use mutant
      use solpot
      use solute
      use virial
      implicit none
      integer i,j,k
      integer it,kt
      integer, allocatable :: skip(:)
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 de,de1,de2
      real*8 r,r2,r3,r4,r6
      real*8 p5inv,pip5
      real*8 gpi,vk,ratio
      real*8 ccf,cosq,dccf
      real*8 sinq,theta
      real*8 factor,term
      real*8 rb2,ri,rk
      real*8 sk,sk2
      real*8 lik,lik2,lik3
      real*8 uik,uik2,uik3
      real*8 dlik,duik
      real*8 t1,t2,t3
      real*8 rbi,rbi2,vi
      real*8 ws2,s2ik,uik4
      real*8 mixsn,neckderi,tcr
      real*8 dbr,dborn,pi43
      real*8 expterm,rusum
      real*8 dedx,dedy,dedz
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: roff(:)
      logical use_gk
c
c
c     perform dynamic allocation of some local arrays
c
      if (borntyp .eq. 'STILL')  allocate (skip(n))
      allocate (roff(n))
c
c     compute atomic radii modified by the dielectric offset
c
      do i = 1, n
         roff(i) = rsolv(i) - doffset
      end do
c
c     set flag for use of generalized Kirkwood solvation model
c
      use_gk = .false.
      if (solvtyp(1:2) .eq. 'GK')  use_gk = .true.
c
c     get Born radius chain rule components for the Still method
c
      if (borntyp .eq. 'STILL') then
         p5inv = 1.0d0 / p5
         pip5 = pi * p5
         do i = 1, n
            skip(i) = 0
         end do
         do i = 1, n
            xi = x(i)
            yi = y(i)
            zi = z(i)
            skip(i) = i
            do j = 1, n12(i)
               skip(i12(j,i)) = i
            end do
            do j = 1, n13(i)
               skip(i13(j,i)) = i
            end do
            gpi = 2.0d0 * rborn(i)**2 / electric
            do k = 1, n
               if (skip(k) .ne. i) then
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  vk = vsolv(k)
                  r2 = xr**2 + yr**2 + zr**2
                  r = sqrt(r2)
                  r6 = r2 * r2 * r2
                  ratio = r2 / (rsolv(i)+rsolv(k))**2
                  if (ratio .gt. p5inv) then
                     ccf = 1.0d0
                     dccf = 0.0d0
                  else
                     theta = ratio * pip5
                     cosq = cos(theta)
                     term = 0.5d0 * (1.0d0-cosq)
                     ccf = term * term
                     sinq = sin(theta)
                     dccf = 2.0d0 * term * sinq * pip5 * ratio
                  end if
                  dborn = drb(i)
                  if (use_gk)  dborn = dborn + drbp(i)
                  de = dborn * p4 * gpi * vk * (4.0d0*ccf-dccf)/r6
c
c     increment the overall implicit solvation derivatives
c
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
                  des(1,i) = des(1,i) + dedx
                  des(2,i) = des(2,i) + dedy
                  des(3,i) = des(3,i) + dedz
                  des(1,k) = des(1,k) - dedx
                  des(2,k) = des(2,k) - dedy
                  des(3,k) = des(3,k) - dedz
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end do
         end do
c
c     get Born radius chain rule components for the HCT method
c
      else if (borntyp .eq. 'HCT') then
         do i = 1, n
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ri = roff(i)
            rb2 = rborn(i) * rborn(i)
            do k = 1, n
               if (k .ne. i) then
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  r2 = xr**2 + yr**2 + zr**2
                  r = sqrt(r2)
                  rk = roff(k)
                  sk = rk * shct(k)
                  if (ri .lt. r+sk) then
                     sk2 = sk * sk
                     lik = 1.0d0 / max(ri,abs(r-sk))
                     uik = 1.0d0 / (r+sk)
                     lik2 = lik * lik
                     uik2 = uik * uik
                     lik3 = lik * lik2
                     uik3 = uik * uik2
                     dlik = 1.0d0
                     if (ri .ge. r-sk)  dlik = 0.0d0
                     duik = 1.0d0
                     t1 = 0.5d0*lik2 + 0.25d0*sk2*lik3/r
     &                       - 0.25d0*(lik/r+lik3*r)
                     t2 = -0.5d0*uik2 - 0.25d0*sk2*uik3/r
     &                       + 0.25d0*(uik/r+uik3*r)
                     t3 = 0.125d0*(1.0d0+sk2/r2)*(lik2-uik2)
     &                       + 0.25d0*log(uik/lik)/r2
                     dborn = drb(i)
                     if (use_gk)  dborn = dborn + drbp(i)
                     de = dborn * rb2 * (dlik*t1+duik*t2+t3) / r
c
c     increment the overall implicit solvation derivatives
c
                     dedx = de * xr
                     dedy = de * yr
                     dedz = de * zr
                     des(1,i) = des(1,i) + dedx
                     des(2,i) = des(2,i) + dedy
                     des(3,i) = des(3,i) + dedz
                     des(1,k) = des(1,k) - dedx
                     des(2,k) = des(2,k) - dedy
                     des(3,k) = des(3,k) - dedz
c
c     increment the internal virial tensor components
c
                     vxx = xr * dedx
                     vyx = yr * dedx
                     vzx = zr * dedx
                     vyy = yr * dedy
                     vzy = zr * dedy
                     vzz = zr * dedz
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end if
            end do
         end do
c
c     get Born radius chain rule components for the OBC method
c
      else if (borntyp .eq. 'OBC') then
         do i = 1, n
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ri = roff(i)
            rb2 = rborn(i) * rborn(i) * drobc(i)
            do k = 1, n
               if (k .ne. i) then
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  r2 = xr**2 + yr**2 + zr**2
                  r = sqrt(r2)
                  rk = roff(k)
                  sk = rk * shct(k)
                  if (ri .lt. r+sk) then
                     sk2 = sk * sk
                     lik = 1.0d0 / max(ri,abs(r-sk))
                     uik = 1.0d0 / (r+sk)
                     lik2 = lik * lik
                     uik2 = uik * uik
                     lik3 = lik * lik2
                     uik3 = uik * uik2
                     dlik = 1.0d0
                     if (ri .ge. r-sk)  dlik = 0.0d0
                     duik = 1.0d0
                     t1 = 0.5d0*lik2 + 0.25d0*sk2*lik3/r
     &                       - 0.25d0*(lik/r+lik3*r)
                     t2 = -0.5d0*uik2 - 0.25d0*sk2*uik3/r
     &                       + 0.25d0*(uik/r+uik3*r)
                     t3 = 0.125d0*(1.0d0+sk2/r2)*(lik2-uik2)
     &                       + 0.25d0*log(uik/lik)/r2
                     dborn = drb(i)
                     if (use_gk)  dborn = dborn + drbp(i)
                     de = dborn * rb2 * (dlik*t1+duik*t2+t3) / r
c
c     increment the overall permanent solvation derivatives
c
                     dedx = de * xr
                     dedy = de * yr
                     dedz = de * zr
                     des(1,i) = des(1,i) + dedx
                     des(2,i) = des(2,i) + dedy
                     des(3,i) = des(3,i) + dedz
                     des(1,k) = des(1,k) - dedx
                     des(2,k) = des(2,k) - dedy
                     des(3,k) = des(3,k) - dedz
c
c     increment the internal virial tensor components
c
                     vxx = xr * dedx
                     vyx = yr * dedx
                     vzx = zr * dedx
                     vyy = yr * dedy
                     vzy = zr * dedy
                     vzz = zr * dedz
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end if
            end do
         end do
c
c     get Born radius chain rule components for Grycuk HCT method
c
      else if (borntyp .eq. 'GRYCUK') then
         pi43 = 4.0d0 * third * pi
         factor = -(pi**third) * 6.0d0**(2.0d0*third) / 9.0d0
         do i = 1, n
            ri = rsolv(i)
            if (ri .gt. 0.0d0) then
               xi = x(i)
               yi = y(i)
               zi = z(i)
               term = pi43 / rborn(i)**3.0d0
               term = factor / term**(4.0d0*third)
               ri = max(rsolv(i),rdescr(i)) + descoff
               if (usetanh) then
                  call tanhrscchr (bornint(i),rsolv(i),tcr)
                  term = term * tcr
               end if
               do k = 1, n
                  rk = rdescr(k)
                  mixsn = 0.5d0 * (sneck(i)+sneck(k))
                  if (mut(k))  mixsn = mixsn * elambda
                  if (k.ne.i .and. rk.gt.0.0d0) then
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     r2 = xr**2 + yr**2 + zr**2
                     r = sqrt(r2)
                     sk = rk * shct(k)
                     if (sk .gt. 0.0d0) then
                        if (ri .lt. r+sk) then
                           sk2 = sk * sk
                           de = 0.0d0
                           if (ri+r .lt. sk) then
                              uik = sk - r
                              de = -4.0d0 * pi / uik**4
                           end if
                           if (ri+r .lt. sk) then
                              lik = sk - r
                              de = de + 0.25d0*pi*(sk2-4.0d0*sk*r
     &                                     +17.0d0*r2) / (r2*lik**4)
                           else if (r .lt. ri+sk) then
                              lik = ri
                              de = de + 0.25d0*pi*(2.0d0*ri*ri-sk2-r2)
     &                                     / (r2*lik**4)
                           else
                              lik = r - sk
                              de = de + 0.25d0*pi*(sk2-4.0d0*sk*r+r2)
     &                                     / (r2*lik**4)
                           end if
                           uik = r + sk
                           de = de - 0.25d0*pi*(sk2+4.0d0*sk*r+r2)
     &                                  / (r2*uik**4)
                           if (useneck) then
                              call neckder (r,ri,rk,mixsn,neckderi)
                              de = de + neckderi
                           end if
                           dbr = term * de/r
                           dborn = drb(i)
                           if (use_gk)  dborn = dborn + drbp(i)
                           de = dbr * dborn
                           dedx = de * xr
                           dedy = de * yr
                           dedz = de * zr
                           des(1,i) = des(1,i) + dedx
                           des(2,i) = des(2,i) + dedy
                           des(3,i) = des(3,i) + dedz
                           des(1,k) = des(1,k) - dedx
                           des(2,k) = des(2,k) - dedy
                           des(3,k) = des(3,k) - dedz
c
c     increment the internal virial tensor components
c
                           vxx = xr * dedx
                           vyx = yr * dedx
                           vzx = zr * dedx
                           vyy = yr * dedy
                           vzy = zr * dedy
                           vzz = zr * dedz
                           vir(1,1) = vir(1,1) + vxx
                           vir(2,1) = vir(2,1) + vyx
                           vir(3,1) = vir(3,1) + vzx
                           vir(1,2) = vir(1,2) + vyx
                           vir(2,2) = vir(2,2) + vyy
                           vir(3,2) = vir(3,2) + vzy
                           vir(1,3) = vir(1,3) + vzx
                           vir(2,3) = vir(2,3) + vzy
                           vir(3,3) = vir(3,3) + vzz
                        end if
                     end if
                  end if
               end do
            end if
         end do
c
c     get Born radius chain rule components for the ACE method
c
      else if (borntyp .eq. 'ACE') then
         do i = 1, n
            xi = x(i)
            yi = y(i)
            zi = z(i)
            it = class(i)
            vi = vsolv(i)
            rbi = rborn(i)
            rbi2 = rbi * rbi
            do k = 1, n
               if (k .ne. i) then
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  kt = class(k)
                  vk = vsolv(k)
                  s2ik = 1.0d0 / s2ace(it,kt)
                  ws2 = wace(it,kt) * s2ik
                  uik4 = uace(it,kt)**4
                  r2 = xr**2 + yr**2 + zr**2
                  r = sqrt(r2)
                  r3 = r2 * r
                  r4 = r2 * r2
                  r6 = r2 * r4
                  rusum = r4 + uik4
                  ratio = r3 / rusum
                  expterm = exp(-r2*s2ik)
                  de1 = -4.0d0 * r * ws2 * expterm
                  de2 = 3.0d0*r2/rusum - 4.0d0*r6/rusum**2
                  dborn = drb(i)
                  if (use_gk)  dborn = dborn + drbp(i)
                  de = dborn * rbi2 * (de1+vk*ratio**3*de2/pi) / r
c
c     increment the overall implicit solvation derivatives
c
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
                  des(1,i) = des(1,i) + dedx
                  des(2,i) = des(2,i) + dedy
                  des(3,i) = des(3,i) + dedz
                  des(1,k) = des(1,k) - dedx
                  des(2,k) = des(2,k) - dedy
                  des(3,k) = des(3,k) - dedz
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      if (borntyp .eq. 'STILL')  deallocate (skip)
      deallocate (roff)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine tanhrsc  --  tanh rescaling of effective radii  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "tanhrsc" calculates the rescaled descreening correction for 
c     effective Born radius calculations
c
c     literature references:
c
c     A. Onufriev, D. Bashford, and D. Case, "Exploring Protein Native
c     States and Large-Scale Conformational Changes with a Modified 
c     Generalized Born Model", Proteins 55, 383-394 (2004)
c
c     B. Aguilar, R. Shadrach, and A. V. Onufriev, "Reducing the 
c     Secondary Structure Bias in the Generalized Born Model via 
c     R6 Effective Radii", Journal of Chemical Theory and Computation,
c     6, 3613-3630, (2010)
c
c     variables and parameters:
c
c     ii    total integral of 1/r^6 over atoms and pairwise necks
c     rhoi  base radius for the atom being descreened
c
c
      subroutine tanhrsc (ii,rhoi)
      use math
      use solute
      implicit none
      real*8 ii,rhoi
      real*8 maxborn
      real*8 recipmaxborn3
      real*8 b0,b1,b2,pi43
      real*8 rho3,rho3psi,rho6psi2
      real*8 rho9psi3,tanhconst
c
c
c     assign constants
c
      pi43 = 4.0d0 * third * pi 
      maxborn = 30.0d0
      recipmaxborn3 = maxborn**(-3.0d0)
      b0 = 0.9563d0
      b1 = 0.2578d0
      b2 = 0.0810d0
c
c     calculate tanh components
c
      rho3 = rhoi * rhoi * rhoi
      rho3psi = rho3 * (-1.0d0*ii)
      rho6psi2 = rho3psi * rho3psi
      rho9psi3 = rho6psi2 * rho3psi
c
c     if tanh function is 1, then effective radius is max radius
c
      tanhconst = pi43 * ((1.0d0/rho3)-recipmaxborn3)
      ii = -tanhconst * tanh(b0*rho3psi-b1*rho6psi2+b2*rho9psi3)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine tanhrscchr  --  get tanh rescaling derivatives  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "tanhrscchr" returns the derivative of the tanh rescaling
c     for the Born radius chain rule term  
c
c     variables and parameters:
c
c     ii       total integral of 1/r^6 over atoms and pairwise necks
c     rhoi     base radius for the atom being descreened
c     derival  tanh chain rule derivative term
c
c
      subroutine tanhrscchr (ii,rhoi,derival)
      use math
      use solute
      implicit none
      real*8 ii,rhoi
      real*8 maxborn
      real*8 recipmaxborn3
      real*8 b0,b1,b2,pi43
      real*8 rho3,rho3psi,rho6psi2
      real*8 rho9psi3,rho6psi,rho9psi2
      real*8 tanhconst,tanhterm,tanh2
      real*8 chainrule,derival
c
c
c     assign the constant values
c
      pi43 = 4.0d0 * third * pi 
      maxborn = 30.0d0
      recipmaxborn3 = maxborn**(-3.0d0)
      b0 = 0.9563d0
      b1 = 0.2578d0
      b2 = 0.0810d0
c
c     calculate tanh chain rule components
c
      rho3 = rhoi * rhoi * rhoi
      rho3psi = rho3 * (-1.0d0*ii)
      rho6psi2 = rho3psi * rho3psi
      rho9psi3 = rho6psi2 * rho3psi
      rho6psi = rho3 * rho3 * (-1.0d0*ii)
      rho9psi2 = rho6psi2 * rho3
      tanhterm = tanh(b0*rho3psi-b1*rho6psi2+b2*rho9psi3)
      tanh2 = tanhterm * tanhterm
      chainrule = b0*rho3 - 2.0d0*b1*rho6psi + 3.0d0*b2*rho9psi2 
      tanhconst = pi43 * ((1.0d0/rho3)-recipmaxborn3)
      derival = tanhconst * chainrule * (1.0d0-tanh2)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module bound  --  periodic boundary condition controls  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     polycut       cutoff distance for infinite polymer nonbonds
c     polycut2      square of infinite polymer nonbond cutoff
c     use_bounds    flag to use periodic boundary conditions
c     use_replica   flag to use replicates for periodic system
c     use_polymer   flag to mark presence of infinite polymer
c     use_wrap      flag to wrap coordinates in output files
c
c
      module bound
      implicit none
      real*8 polycut
      real*8 polycut2
      logical use_bounds
      logical use_replica
      logical use_polymer
      logical use_wrap
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine bounds  --  check periodic boundary conditions  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "bounds" finds the center of mass of each molecule and
c     translates any stray molecules back into the periodic box
c
c
      subroutine bounds
      use atomid
      use atoms
      use boxes
      use math
      use molcul
      implicit none
      integer i,j,k
      integer init,stop
      real*8 weigh,corr
      real*8 xmid,ymid,zmid
      real*8 xfrac,yfrac,zfrac
      real*8 xcom,ycom,zcom
c
c
c     locate the center of mass of each molecule
c
      do i = 1, nmol
         init = imol(1,i)
         stop = imol(2,i)
         xmid = 0.0d0
         ymid = 0.0d0
         zmid = 0.0d0
         do j = init, stop
            k = kmol(j)
            weigh = mass(k)
            xmid = xmid + x(k)*weigh
            ymid = ymid + y(k)*weigh
            zmid = zmid + z(k)*weigh
         end do
         weigh = molmass(i)
         xmid = xmid / weigh
         ymid = ymid / weigh
         zmid = zmid / weigh
c
c     get fractional coordinates of center of mass
c
         if (triclinic) then
            zfrac = zmid / gamma_term
            yfrac = (ymid - zfrac*beta_term) / gamma_sin
            xfrac = xmid - yfrac*gamma_cos - zfrac*beta_cos
         else if (monoclinic) then
            zfrac = zmid / beta_sin
            yfrac = ymid
            xfrac = xmid - zfrac*beta_cos
         else
            zfrac = zmid
            yfrac = ymid
            xfrac = xmid
         end if
c
c     translate center of mass into the periodic box
c
         if (dodecadron) then
            xfrac = xfrac - xbox*nint(xfrac/xbox)
            yfrac = yfrac - ybox*nint(yfrac/ybox)
            zfrac = zfrac - root2*zbox*nint(zfrac/(zbox*root2))
            corr = xbox2 * int(abs(xfrac/xbox)+abs(yfrac/ybox)
     &                               +abs(root2*zfrac/zbox))
            xfrac = xfrac - sign(corr,xfrac)
            yfrac = yfrac - sign(corr,yfrac)
            zfrac = zfrac - sign(corr,zfrac)*root2
         else if (octahedron) then
            xfrac = xfrac - xbox*nint(xfrac/xbox)
            yfrac = yfrac - ybox*nint(yfrac/ybox)
            zfrac = zfrac - zbox*nint(zfrac/zbox)
            if (abs(xfrac)+abs(yfrac)+abs(zfrac) .gt. box34) then
               xfrac = xfrac - sign(xbox2,xfrac)
               yfrac = yfrac - sign(ybox2,yfrac)
               zfrac = zfrac - sign(zbox2,zfrac)
            end if
         else 
            xfrac = xfrac - xbox*nint(xfrac/xbox)
            yfrac = yfrac - ybox*nint(yfrac/ybox)
            zfrac = zfrac - zbox*nint(zfrac/zbox)
         end if
c
c     convert translated fractional center of mass to Cartesian
c
         if (triclinic) then
            xcom = xfrac + yfrac*gamma_cos + zfrac*beta_cos
            ycom = yfrac*gamma_sin + zfrac*beta_term
            zcom = zfrac * gamma_term
         else if (monoclinic) then
            xcom = xfrac + zfrac*beta_cos
            ycom = yfrac
            zcom = zfrac * beta_sin
         else
            xcom = xfrac
            ycom = yfrac
            zcom = zfrac
         end if
c
c     translate coordinates via offset from center of mass
c
         do j = init, stop
            k = kmol(j)
            x(k) = x(k) - xmid + xcom
            y(k) = y(k) - ymid + ycom
            z(k) = z(k) - zmid + zcom
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module boxes  --  periodic boundary condition parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     xbox        length of a-axis of periodic box in Angstroms
c     ybox        length of b-axis of periodic box in Angstroms
c     zbox        length of c-axis of periodic box in Angstroms
c     alpha       angle between b- and c-axes of box in degrees
c     beta        angle between a- and c-axes of box in degrees
c     gamma       angle between a- and b-axes of box in degrees
c     xbox2       half of the a-axis length of periodic box
c     ybox2       half of the b-axis length of periodic box
c     zbox2       half of the c-axis length of periodic box
c     box34       three-fourths axis length of truncated octahedron
c     volbox      volume in Ang**3 of the periodic box
c     alpha_sin   sine of the alpha periodic box angle
c     alpha_cos   cosine of the alpha periodic box angle
c     beta_sin    sine of the beta periodic box angle
c     beta_cos    cosine of the beta periodic box angle
c     gamma_sin   sine of the gamma periodic box angle
c     gamma_cos   cosine of the gamma periodic box angle
c     beta_term   term used in generating triclinic box
c     gamma_term  term used in generating triclinic box
c     lvec        real space lattice vectors as matrix rows
c     recip       reciprocal lattice vectors as matrix columns
c     orthogonal  flag to mark periodic box as orthogonal
c     monoclinic  flag to mark periodic box as monoclinic
c     triclinic   flag to mark periodic box as triclinic
c     octahedron  flag to mark box as truncated octahedron
c     dodecadron  flag to mark box as rhombic dodecahedron
c     nonprism    flag to mark octahedron or dodecahedron
c     nosymm      flag to mark use or lack of lattice symmetry
c     spacegrp    space group symbol for the unit cell type
c
c
      module boxes
      implicit none
      real*8 xbox,ybox,zbox
      real*8 alpha,beta,gamma
      real*8 xbox2,ybox2,zbox2
      real*8 box34,volbox
      real*8 alpha_sin
      real*8 alpha_cos
      real*8 beta_sin
      real*8 beta_cos
      real*8 gamma_sin
      real*8 gamma_cos
      real*8 beta_term
      real*8 gamma_term
      real*8 lvec(3,3)
      real*8 recip(3,3)
      logical orthogonal
      logical monoclinic
      logical triclinic
      logical octahedron
      logical dodecadron
      logical nonprism
      logical nosymm
      character*10 spacegrp
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine calendar  --  find the current date and time  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "calendar" returns the current time as a set of integer values
c     representing the year, month, day, hour, minute and second
c
c     note only one of the various implementations below should
c     be activated by removing comment characters
c
c
      subroutine calendar (year,month,day,hour,minute,second)
      implicit none
      integer year,month
      integer day,hour
      integer minute,second
c
c
c     use the standard "date_and_time" intrinsic function
c
      integer values(8)
      character*5 zone
      character*8 date
      character*10 time
      call date_and_time (date,time,zone,values)
      year = values(1)
      month = values(2)
      day = values(3)
      hour = values(5)
      minute = values(6)
      second = values(7)
c
c     use the obsolete "itime" and "idate" intrinsic functions
c
c     integer hms(3)
c     call itime (hms)
c     hour = hms(1)
c     minute = hms(2)
c     second = hms(3)
c     call idate (month,day,year)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module cell  --  replicated cell periodic boundaries  ##
c     ##                                                        ##
c     ############################################################
c
c
c     ncell    total number of cell replicates for periodic boundaries
c     icell    offset along axes for each replicate periodic cell
c     xcell    length of the a-axis of the complete replicated cell
c     ycell    length of the b-axis of the complete replicated cell
c     zcell    length of the c-axis of the complete replicated cell
c     xcell2   half the length of the a-axis of the replicated cell
c     ycell2   half the length of the b-axis of the replicated cell
c     zcell2   half the length of the c-axis of the replicated cell
c
c
      module cell
      implicit none
      integer ncell
      integer, allocatable :: icell(:,:)
      real*8 xcell
      real*8 ycell
      real*8 zcell
      real*8 xcell2
      real*8 ycell2
      real*8 zcell2
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine center  --  superimpose structure centroids  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "center" moves the weighted centroid of each coordinate
c     set to the origin during least squares superposition
c
c
      subroutine center (n1,x1,y1,z1,n2,x2,y2,z2,xmid,ymid,zmid)
      use align
      implicit none
      integer i,k,n1,n2
      real*8 weigh,norm
      real*8 xmid,ymid,zmid
      real*8 x1(*),x2(*)
      real*8 y1(*),y2(*)
      real*8 z1(*),z2(*)
c
c
c     find the weighted centroid of the second
c     structure and translate it to the origin
c
      xmid = 0.0d0
      ymid = 0.0d0
      zmid = 0.0d0
      norm = 0.0d0
      do i = 1, nfit
         k = ifit(2,i)
         weigh = wfit(i)
         xmid = xmid + x2(k)*weigh
         ymid = ymid + y2(k)*weigh
         zmid = zmid + z2(k)*weigh
         norm = norm + weigh
      end do
      xmid = xmid / norm
      ymid = ymid / norm
      zmid = zmid / norm
      do i = 1, n2
         x2(i) = x2(i) - xmid
         y2(i) = y2(i) - ymid
         z2(i) = z2(i) - zmid
      end do
c
c     now repeat for the first structure, note
c     that this centroid position gets returned
c
      xmid = 0.0d0
      ymid = 0.0d0
      zmid = 0.0d0
      norm = 0.0d0
      do i = 1, nfit
         k = ifit(1,i)
         weigh = wfit(i)
         xmid = xmid + x1(k)*weigh
         ymid = ymid + y1(k)*weigh
         zmid = zmid + z1(k)*weigh
         norm = norm + weigh
      end do
      xmid = xmid / norm
      ymid = ymid / norm
      zmid = zmid / norm
      do i = 1, n1
         x1(i) = x1(i) - xmid
         y1(i) = y1(i) - ymid
         z1(i) = z1(i) - zmid
      end do
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2020 by Chengwen Liu & Jay W. Ponder  ##
c     ##                 All Rights Reserved                  ##
c     ##########################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module cflux  --  charge flux terms in current structure  ##
c     ##                                                            ##
c     ################################################################
c
c
c     nbflx   total number of bond charge flux interactions
c     naflx   total number of angle charge flux interactions
c     bflx    bond stretching charge flux constant (electrons/Ang)
c     aflx    angle bending charge flux constant (electrons/radian)
c     abflx   asymmetric stretch charge flux constant (electrons/Ang)
c
c
      module cflux
      implicit none
      integer nbflx
      integer naflx
      real*8, allocatable :: bflx(:)
      real*8, allocatable :: aflx(:,:)
      real*8, allocatable :: abflx(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module charge  --  partial charges in current structure  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     nion      total number of partial charge sites in the system
c     iion      number of the atom for each partial charge site
c     jion      neighbor generation site to use for each atom
c     kion      cutoff switching site to use for each atom
c     pchg      current partial charge value for each atom (e-)
c     pchg0     original partial charge values for charge flux
c
c
      module charge
      implicit none
      integer nion
      integer, allocatable :: iion(:)
      integer, allocatable :: jion(:)
      integer, allocatable :: kion(:)
      real*8, allocatable :: pchg(:)
      real*8, allocatable :: pchg0(:)
      save
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module chgpen  --  charge penetration in current structure  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     ncp       total number of charge penetration sites in system
c     pcore     number of core electrons assigned to each atom
c     pval      number of valence electrons assigned to each atom
c     pval0     original number of valence electrons for charge flux
c     palpha    charge penetration damping value at each atom
c
c
      module chgpen
      implicit none
      integer ncp
      real*8, allocatable :: pcore(:)
      real*8, allocatable :: pval(:)
      real*8, allocatable :: pval0(:)
      real*8, allocatable :: palpha(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module chgpot  --  charge-charge functional form details  ##
c     ##                                                            ##
c     ################################################################
c
c
c     electric   energy factor in kcal/mole for current force field
c     dielec     dielectric constant for electrostatic interactions
c     ebuffer    electrostatic buffering constant added to distance
c     c1scale    factor by which 1-1 charge interactions are scaled
c     c2scale    factor by which 1-2 charge interactions are scaled
c     c3scale    factor by which 1-3 charge interactions are scaled
c     c4scale    factor by which 1-4 charge interactions are scaled
c     c5scale    factor by which 1-5 charge interactions are scaled
c     neutnbr    logical flag governing use of neutral group neighbors
c     neutcut    logical flag governing use of neutral group cutoffs
c
c
      module chgpot
      implicit none
      real*8 electric
      real*8 dielec,ebuffer
      real*8 c1scale,c2scale
      real*8 c3scale,c4scale
      real*8 c5scale
      logical neutnbr,neutcut
      save
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module chgtrn  --  charge transfer in current structure  ##        
c     ##                                                           ##
c     ###############################################################
c
c
c     nct       total number of dispersion sites in the system
c     chgct     charge for charge transfer at each multipole site
c     dmpct     charge transfer damping factor at each multipole site
c
c
      module chgtrn
      implicit none
      integer nct
      real*8, allocatable :: chgct(:)
      real*8, allocatable :: dmpct(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine chkpole  --  check multipoles at chiral sites  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "chkpole" inverts multipole moments as necessary at atoms
c     with chiral local reference frame definitions
c
c
      subroutine chkpole
      use atoms
      use mpole
      use repel
      implicit none
      integer i,k
      integer ia,ib,ic,id
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 c1,c2,c3,vol
      logical dopol,dorep
      logical check
c
c
c     loop over multipoles and test for chirality inversion
c
      do i = 1, n
         dopol = .false.
         dorep = .false.
         if (allocated(pollist)) then
            if (pollist(i) .ne. 0)  dopol = .true.
         end if
         if (allocated(replist)) then
            if (replist(i) .ne. 0)  dorep = .true.
         end if
         if (dopol .or. dorep) then
            check = .true.
            if (polaxe(i) .ne. 'Z-then-X')  check = .false.
            if (yaxis(i) .eq. 0)  check = .false.
            if (check) then
               k = yaxis(i)
               ia = i
               ib = zaxis(i)
               ic = xaxis(i)
               id = abs(k)
c
c     compute the signed parallelpiped volume at chiral site
c
               xad = x(ia) - x(id)
               yad = y(ia) - y(id)
               zad = z(ia) - z(id)
               xbd = x(ib) - x(id)
               ybd = y(ib) - y(id)
               zbd = z(ib) - z(id)
               xcd = x(ic) - x(id)
               ycd = y(ic) - y(id)
               zcd = z(ic) - z(id)
               c1 = ybd*zcd - zbd*ycd
               c2 = ycd*zad - zcd*yad
               c3 = yad*zbd - zad*ybd
               vol = xad*c1 + xbd*c2 + xcd*c3
c
c     invert the multipole components involving the y-axis
c
               if ((k.lt.0.and.vol.gt.0.0d0) .or.
     &             (k.gt.0.and.vol.lt.0.0d0)) then
                  yaxis(i) = -k
                  if (dopol) then
                     pole(3,i) = -pole(3,i)
                     pole(6,i) = -pole(6,i)
                     pole(8,i) = -pole(8,i)
                     pole(10,i) = -pole(10,i)
                     pole(12,i) = -pole(12,i)
                  end if
                  if (dorep) then
                     repole(3,i) = -repole(3,i)
                     repole(6,i) = -repole(6,i)
                     repole(8,i) = -repole(8,i)
                     repole(10,i) = -repole(10,i)
                     repole(12,i) = -repole(12,i)
                  end if
               end if
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2004  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine chkring  --  check atom set for small rings  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "chkring" tests an atom or a set of connected atoms for
c     their presence within a single 3- to 6-membered ring
c
c
      subroutine chkring (iring,ia,ib,ic,id)
      use couple
      implicit none
      integer i,j,k,m,p,q,r
      integer ia,ib,ic,id
      integer iring,nset
c
c
c     initialize the ring size and number of atoms to test
c
      iring = 0
      nset = 0
      if (ia .gt. 0)  nset = 1
      if (ib .gt. 0)  nset = 2
      if (ic .gt. 0)  nset = 3
      if (id .gt. 0)  nset = 4
c
c     cannot be in a ring if the terminal atoms are univalent
c
      if (nset .eq. 1) then
         if (n12(ia) .le. 1)  nset = 0
      else if (nset .eq. 2) then
         if (min(n12(ia),n12(ib)) .le. 1)  nset = 0
      else if (nset .eq. 3) then
         if (min(n12(ia),n12(ic)) .le. 1)  nset = 0
      else if (nset .eq. 4) then
         if (min(n12(ia),n12(id)) .le. 1)  nset = 0
      end if
c
c     check the input atoms for sequential connectivity
c
      if (nset .gt. 1) then
         do j = 1, n12(ia)
            i = i12(j,ia)
            if (ib .eq. i) then
               if (nset .eq. 2)  goto 10
               do k = 1, n12(ib)
                  m = i12(k,ib)
                  if (ic .eq. m) then
                     if (nset .eq. 3)  goto 10
                     do p = 1, n12(ic)
                        q = i12(p,ic)
                        if (id .eq. q)  goto 10
                     end do
                  end if
               end do
            end if
         end do
         nset = 0
   10    continue
      end if
c
c     check for an atom contained inside a small ring
c
      if (nset .eq. 1) then
         do j = 1, n12(ia)-1
            i = i12(j,ia)
            do k = j+1, n12(ia)
               m = i12(k,ia)
               do p = 1, n12(i)
                  if (m .eq. i12(p,i)) then
                     iring = 3
                     goto 20
                  end if
               end do
            end do
         end do
         do j = 1, n12(ia)-1
            i = i12(j,ia)
            do k = j+1, n12(ia)
               m = i12(k,ia)
               do p = 1, n12(i)
                  r = i12(p,i)
                  if (r .ne. ia) then
                     do q = 1, n12(m)
                        if (r .eq. i12(q,m)) then
                           iring = 4
                           goto 20
                        end if
                     end do
                  end if
               end do
            end do
         end do
         do j = 1, n13(ia)-1
            i = i13(j,ia)
            do k = j+1, n13(ia)
               m = i13(k,ia)
               do p = 1, n12(i)
                  if (m .eq. i12(p,i)) then
                     iring = 5
                     goto 20
                  end if
               end do
               do p = 1, n13(i)
                  if (m .eq. i13(p,i)) then
                     iring = 6
                     goto 20
                  end if
               end do
            end do
         end do
   20    continue
c
c     check for a bond contained inside a small ring
c
      else if (nset .eq. 2) then
         do j = 1, n12(ia)
            i = i12(j,ia)
            do k = 1, n12(ib)
               if (i .eq. i12(k,ib)) then
                  iring = 3
                  goto 30
               end if
            end do
         end do
         do j = 1, n12(ia)
            i = i12(j,ia)
            if (ib .ne. i) then
               do k = 1, n12(ib)
                  m = i12(k,ib)
                  if (ia .ne. m) then
                     do p = 1, n12(i)
                        if (m .eq. i12(p,i)) then
                           iring = 4
                           goto 30
                        end if
                     end do
                  end if
               end do
            end if
         end do
         do j = 1, n13(ia)
            i = i13(j,ia)
            do k = 1, n13(ib)
               if (i .eq. i13(k,ib)) then
                  iring = 5
                  goto 30
               end if
            end do
         end do
         do j = 1, n12(ia)
            i = i12(j,ia)
            if (ib .ne. i) then
               do k = 1, n13(ib)
                  m = i13(k,ib)
                  do p = 1, n13(i)
                     if (m .eq. i13(p,i)) then
                        iring = 6
                        do q = 1, n12(ia)
                           if (m .eq. i12(q,ia))  iring = 0
                        end do
                        if (iring .eq. 6)  goto 30
                     end if
                  end do
               end do
            end if
         end do
   30    continue
c
c     check for an angle contained inside a small ring
c
      else if (nset .eq. 3) then
         do j = 1, n12(ia)
            if (ic .eq. i12(j,ia)) then
               iring = 3
               goto 40
            end if
         end do
         do j = 1, n12(ia)
            i = i12(j,ia)
            if (ib .ne. i) then
               do k = 1, n12(ic)
                  if (i .eq. i12(k,ic)) then
                     iring = 4
                     goto 40
                  end if
               end do
            end if
         end do
         do j = 1, n12(ia)
            i = i12(j,ia)
            if (ib .ne. i) then
               do k = 1, n13(ic)
                  if (i .eq. i13(k,ic)) then
                     iring = 5
                     goto 40
                  end if
               end do
            end if
         end do
         do j = 1, n13(ia)
            i = i13(j,ia)
            if (ic .ne. i) then
               do k = 1, n13(ic)
                  if (i .eq. i13(k,ic)) then
                     iring = 6
                     goto 40
                  end if
               end do
            end if
         end do
   40    continue
c
c     check for a torsion contained inside a small ring
c
      else if (nset .eq. 4) then
         do j = 1, n12(ia)
            if (id .eq. i12(j,ia)) then
               iring = 4
               goto 50
            end if
         end do
         do j = 1, n12(ia)
            i = i12(j,ia)
            if (ib .ne. i) then
               do k = 1, n12(id)
                  if (i .eq. i12(k,id)) then
                     iring = 5
                     goto 50
                  end if
               end do
            end if
         end do
         do j = 1, n12(ia)
            i = i12(j,ia)
            if (ib .ne. i) then
               do k = 1, n13(id)
                  if (i .eq. i13(k,id)) then
                     iring = 6
                     goto 50
                  end if
               end do
            end if
         end do
   50    continue
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2024  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine chksymm  --  test for 1D, 2D & other symmetry  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "chksymm" examines the current coordinates for linearity,
c     planarity, internal mirror planes or a center of inversion
c
c
      subroutine chksymm (symmtyp)
      use atoms
      implicit none
      integer i,nave
      real*8 eps
      real*8 xave,yave,zave
      logical xnul,ynul,znul
      character*6 symmtyp
c
c
c     copy current coordinates into a reference storage area
c
      call makeref (1)
c
c     move the atomic coordinates into the inertial frame
c
      call inertia (2)
c
c     test maximal coordinates for linearity and planarity
c
      eps = 0.001d0
      symmtyp = 'NONE'
      xnul = .true.
      ynul = .true.
      znul = .true.
      do i = 1, n
         if (abs(x(i)) .gt. eps)  xnul = .false.
         if (abs(y(i)) .gt. eps)  ynul = .false.
         if (abs(z(i)) .gt. eps)  znul = .false.
      end do
      if (n .eq. 3)  symmtyp = 'PLANAR'
      if (xnul)  symmtyp = 'PLANAR'
      if (ynul)  symmtyp = 'PLANAR'
      if (znul)  symmtyp = 'PLANAR'
      if (n .eq. 2)  symmtyp = 'LINEAR'
      if (xnul .and. ynul)  symmtyp = 'LINEAR'
      if (xnul .and. znul)  symmtyp = 'LINEAR'
      if (ynul .and. znul)  symmtyp = 'LINEAR'
      if (n .eq. 1)  symmtyp = 'SINGLE'
c
c     test mean coords for mirror plane and inversion center
c
      if (symmtyp .eq. 'NONE') then
         xave = 0.0d0
         yave = 0.0d0
         zave = 0.0d0
         do i = 1, n
            xave = xave + x(i)
            yave = yave + y(i)
            zave = zave + z(i)
         end do
         xave = abs(xave) / dble(n)
         yave = abs(yave) / dble(n)
         zave = abs(zave) / dble(n)
         nave = 0
         if (xave .lt. eps)  nave = nave + 1
         if (yave .lt. eps)  nave = nave + 1
         if (zave .lt. eps)  nave = nave + 1
         if (nave .ne. 0)  symmtyp = 'MIRROR'
         if (nave .eq. 3)  symmtyp = 'CENTER'
      end if
c
c     move original coordinates back into current structure
c
      call getref (1)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2000  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine chkxyz  --  check for coincident coordinates  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "chkxyz" finds any pairs of atoms with identical Cartesian
c     coordinates, and prints a warning message
c
c
      subroutine chkxyz (clash)
      use atoms
      use iounit
      implicit none
      integer i,j
      real*8 xi,yi,zi
      real*8 eps,r2
      logical clash
      logical header
c
c
c     initialize distance tolerance and atom collision flag
c
      eps = 0.000001d0
      clash = .false.
      header = .true.
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(n,x,y,z,eps,clash,header)
!$OMP DO
c
c     loop over atom pairs testing for identical coordinates
c
      do i = 1, n-1
         xi = x(i)
         yi = y(i)
         zi = z(i)
         do j = i+1, n
            r2 = (x(j)-xi)**2 + (y(j)-yi)**2 + (z(j)-zi)**2
            if (r2 .lt. eps) then
               clash = .true.
               if (header) then
                  header = .false.
                  write (iout,10)
   10             format ()
               end if
               write (iout,20)  i,j
   20          format (' CHKXYZ  --  Warning, Atoms',i6,' and',i6,
     &                    ' have Identical Coordinates')
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine cholesky  --  modified Cholesky linear solver  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "cholesky" uses a modified Cholesky method to solve the linear
c     system Ax = b, returning "x" in "b"; "A" must be a real symmetric
c     positive definite matrix with its upper triangle including the
c     diagonal stored by rows
c
c     literature reference:
c
c     R. S. Martin, G. Peters and J. H. Wilkinson, "Symmetric
c     Decomposition of a Positive Definite Matrix", Numerische
c     Mathematik, 7, 362-383 (1965)
c
c
      subroutine cholesky (nvar,a,b)
      implicit none
      integer i,j,k,nvar
      integer ii,ij,ik,ki,kk
      integer im,jk,jm
      real*8 r,s,t
      real*8 a(*)
      real*8 b(*)
c
c
c     Cholesky factorization to reduce "A" to (L)(D)(L transpose)
c     "L" has a unit diagonal; store 1.0/D on the diagonal of "A"
c
      ii = 1
      do i = 1, nvar
         im = i - 1
         if (i .ne. 1) then
            ij = i
            do j = 1, im
               r = a(ij)
               if (j .ne. 1) then
                  ik = i
                  jk = j
                  jm = j - 1
                  do k = 1, jm
                     r = r - a(ik)*a(jk)
                     ik = nvar - k + ik
                     jk = nvar - k + jk
                  end do
               end if
               a(ij) = r
               ij = nvar - j + ij
            end do
         end if
         r = a(ii)
         if (i .ne. 1) then
            kk = 1
            ik = i
            do k = 1, im
               s = a(ik)
               t = s * a(kk)
               a(ik) = t
               r = r - s*t
               ik = nvar - k + ik
               kk = nvar - k + 1 + kk
            end do
         end if
         a(ii) = 1.0d0 / r
         ii = nvar - i + 1 + ii
      end do
c
c     solve linear equations; first solve Ly = b for y
c
      do i = 1, nvar
         if (i .ne. 1) then
            ik = i
            im = i - 1
            r = b(i)
            do k = 1, im
               r = r - b(k)*a(ik)
               ik = nvar - k + ik
            end do
            b(i) = r
         end if
      end do
c
c     finally, solve (D)(L transpose)(x) = y for x
c
      ii = nvar * (nvar+1) / 2
      do j = 1, nvar
         i = nvar + 1 - j
         r = b(i) * a(ii)
         if (j .ne. 1) then
            im = i + 1
            ki = ii + 1
            do k = im, nvar
               r = r - a(ki)*b(k)
               ki = ki + 1
            end do
         end if
         b(i) = r
         ii = ii - j - 1
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module chrono  --  clock time values for current program  ##
c     ##                                                            ##
c     ################################################################
c
c
c     twall   current processor wall clock time in seconds
c     tcpu    elapsed cpu time from start of program in seconds
c
c
      module chrono
      implicit none
      real*8 twall
      real*8 tcpu
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2010  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module chunks  --  PME grid spatial decomposition values  ##
c     ##                                                            ##
c     ################################################################
c
c
c     nchunk     total number of spatial regions for PME grid
c     nchk1      number of spatial regions along the a-axis
c     nchk2      number of spatial regions along the b-axis
c     nchk3      number of spatial regions along the c-axis
c     ngrd1      number of grid points per region along a-axis
c     ngrd2      number of grid points per region along b-axis
c     ngrd3      number of grid points per region along c-axis
c     nlpts      PME grid points to the left of center point
c     nrpts      PME grid points to the right of center point
c     grdoff     offset for index into B-spline coefficients
c     pmetable   PME grid spatial regions involved for each site
c
c
      module chunks
      implicit none
      integer nchunk
      integer nchk1,nchk2,nchk3
      integer ngrd1,ngrd2,ngrd3
      integer nlpts,nrpts,grdoff
      integer, allocatable :: pmetable(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2010  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine settime  --  initialize wall clock and CPU time  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "settime" initializes the wall clock and elapsed CPU times
c
c
      subroutine settime
      use chrono
      implicit none
      integer count,crate,cmax
      real time
c
c
c     set wall clock and cpu time via Fortran intrinsic functions
c
      call system_clock (count,crate,cmax)
      twall = dble(count) / dble(crate)
      call cpu_time (time)
      tcpu = dble(time)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine gettime  --  elapsed wall clock and CPU times  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "gettime" finds the elapsed wall clock and CPU times in seconds
c     since the last call to "settime"
c
c
      subroutine gettime (wall,cpu)
      use chrono
      implicit none
      integer count,crate,cmax
      real time
      real*8 wall,cpu
      real*8 twall0,tcpu0
c
c
c     get total wall clock time via Fortran intrinsic functions
c
      twall0 = twall
      call system_clock (count,crate,cmax)
      twall = dble(count) / dble(crate)
      wall = twall - twall0
      if (wall .lt. 0.0d0)  wall = wall + dble(cmax)/dble(crate)
c
c     get elapsed CPU time via Fortran intrinsic functions
c
      tcpu0 = tcpu
      call cpu_time (time)
      tcpu = dble(time)
      cpu = tcpu - tcpu0
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine cluster  --  set user-defined groups of atoms  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "cluster" gets the partitioning of the system into groups
c     and stores a list of the group to which each atom belongs
c
c
      subroutine cluster
      use atomid
      use atoms
      use bound
      use group
      use inform
      use iounit
      use keys
      use molcul
      implicit none
      integer i,j,k
      integer next,size
      integer gnum,ga,gb
      integer, allocatable :: list(:)
      real*8 wg
      logical header
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(igrp))  allocate (igrp(2,0:maxgrp))
      if (.not. allocated(grpmass))  allocate (grpmass(0:maxgrp))
      if (.not. allocated(wgrp))  allocate (wgrp(0:maxgrp,0:maxgrp))
      if (allocated(kgrp))  deallocate (kgrp)
      if (allocated(grplist))  deallocate (grplist)
      allocate (kgrp(n))
      allocate (grplist(n))
c
c     set defaults for the group atom list and weight options
c
      use_group = .false.
      use_intra = .false.
      use_inter = .false.
      ngrp = 0
      do i = 1, n
         kgrp(i) = 0
         grplist(i) = 0
      end do
      do i = 0, maxgrp
         igrp(1,i) = 1
         igrp(2,i) = 0
      end do
      do i = 0, maxgrp
         do j = 0, maxgrp
            wgrp(j,i) = 1.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      size = max(100,n)
      allocate (list(size))
c
c     get any keywords containing atom group definitions
c
      do j = 1, nkey
         next = 1
         record = keyline(j)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:6) .eq. 'GROUP ') then
            use_group = .true.
            gnum = 0
            do i = 1, size
               list(i) = 0
            end do
            call getnumb (record,gnum,next)
            if (gnum .gt. maxgrp) then
               write (iout,10)
   10          format (/,' CLUSTER  --  Too many Atom Groups;',
     &                    ' Increase MAXGRP')
               call fatal
            end if
            string = record(next:240)
            read (string,*,err=20,end=20)  (list(i),i=1,size)
   20       continue
            i = 1
            do while (list(i) .ne. 0)
               if (list(i) .gt. 0) then
                  grplist(list(i)) = gnum
                  i = i + 1
               else
                  do k = abs(list(i)), abs(list(i+1))
                     grplist(k) = gnum
                  end do
                  i = i + 2
               end if
            end do
c
c     get any keywords with weights for group interactions
c
         else if (keyword(1:15) .eq. 'GROUP-MOLECULE ') then
            use_group = .true.
            use_inter = .true.
            use_intra = .false.
            if (nmol .gt. maxgrp) then
               write (iout,30)
   30          format (/,' CLUSTER  --  Too many Atom Groups;',
     &                    ' Increase MAXGRP')
               call fatal
            end if
            do i = 1, nmol
               do k = imol(1,i), imol(2,i)
                  grplist(kmol(k)) = i
               end do
            end do
c
c     get any keywords with weights for group interactions
c
         else if (keyword(1:13) .eq. 'GROUP-SELECT ') then
            ga = 0
            gb = 0
            wg = -1.0d0
            string = record(next:240)
            read (string,*,err=40,end=40)  ga,gb,wg
   40       continue
            if (wg .lt. 0.0d0)  wg = 1.0d0
            wgrp(ga,gb) = wg
            wgrp(gb,ga) = wg
            use_inter = .false.
c
c     get keywords to select common sets of group interactions
c
         else if (keyword(1:12) .eq. 'GROUP-INTRA ') then
            use_intra = .true.
            use_inter = .false.
         else if (keyword(1:12) .eq. 'GROUP-INTER ') then
            use_inter = .true.
            use_intra = .false.
         end if
      end do
c
c     pack atoms of each group into a contiguous indexed list
c
      if (use_group) then
         do i = 1, n
            list(i) = grplist(i)
         end do
         call sort3 (n,list,kgrp)
c
c     find the first and last atom in each of the groups
c
         k = list(1)
         igrp(1,k) = 1
         do i = 1, n
            j = list(i)
            if (j .ne. k) then
               igrp(2,k) = i - 1
               igrp(1,j) = i
               k = j
            end if
            ngrp = max(j,ngrp)
         end do
         igrp(2,j) = n
c
c     sort the list of atoms in each group by atom number
c
         do i = 0, ngrp
            size = igrp(2,i) - igrp(1,i) + 1
            if (igrp(1,i) .ne. 0)  call sort (size,kgrp(igrp(1,i)))
         end do
c
c     if groups are not used, put full system in default group
c
      else
         ngrp = 0
         igrp(1,0) = 1
         igrp(2,0) = n
         do i = 1, n
            kgrp(i) = i
            grplist(i) = 0
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (list)
c
c     compute the total mass of all atoms in each group
c
      do i = 0, ngrp
         grpmass(i) = 0.0d0
         do j = igrp(1,i), igrp(2,i)
            grpmass(i) = grpmass(i) + mass(kgrp(j))
         end do
      end do
c
c     turn off bounds and replicas for intragroup calculations
c
      if (use_intra) then
         use_bounds = .false.
         use_replica = .false.
         call cutoffs
      end if
c
c     use only intragroup or intergroup interactions if selected
c
      if (use_intra) then
         do i = 0, ngrp
            do j = 0, ngrp
               wgrp(j,i) = 0.0d0
            end do
            wgrp(i,i) = 1.0d0
         end do
      end if
      if (use_inter) then
         do i = 0, ngrp
            do j = 0, ngrp
               wgrp(j,i) = 1.0d0
            end do
            wgrp(i,i) = 0.0d0
         end do
      end if
c
c     disable consideration of interactions with empty groups
c
      do i = 0, ngrp
         size = igrp(2,i) - igrp(1,i) + 1
         if (size .eq. 0) then
            do j = 0, ngrp
               wgrp(j,i) = 0.0d0
               wgrp(i,j) = 0.0d0
            end do
         end if
      end do
c
c     output the final list of atoms in each group
c
      if (use_group .and. debug) then
         do i = 1, ngrp
            size = igrp(2,i) - igrp(1,i) + 1
            if (size .ne. 0) then
               write (iout,50)  i
   50          format (/,' List of Atoms in Group',i3,' :',/)
               write (iout,60)  (kgrp(j),j=igrp(1,i),igrp(2,i))
   60          format (3x,10i7)
            end if
         end do
      end if
c
c     output the weights for intragroup and intergroup interactions
c
      if (use_group .and. debug) then
         header = .true.
         do i = 0, ngrp
            do j = i, ngrp
               if (wgrp(j,i) .ne. 0.0d0) then
                  if (header) then
                     header = .false.
                     write (iout,70)
   70                format (/,' Active Sets of Intra- and InterGroup',
     &                          ' Interactions :',
     &                       //,11x,'Groups',15x,'Type',14x,'Weight',/)
                  end if
                  if (i .eq. j) then
                     write (iout,80)  i,j,wgrp(j,i)
   80                format (5x,2i6,12x,'IntraGroup',5x,f12.4)
                  else
                     write (iout,90)  i,j,wgrp(j,i)
   90                format (5x,2i6,12x,'InterGroup',5x,f12.4)
                  end if
               end if
            end do
         end do
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine column  --  access Hessian elements by column  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "column" takes the off-diagonal Hessian elements stored
c     as sparse rows and sets up indices to allow column access
c
c
      subroutine column (nvar,hinit,hstop,hindex,
     &                   cinit,cstop,cindex,cvalue)
      implicit none
      integer i,j,k
      integer m,nvar
      integer hinit(*)
      integer hstop(*)
      integer cinit(*)
      integer cstop(*)
      integer hindex(*)
      integer cindex(*)
      integer cvalue(*)
c
c
c     zero out the start and end marker for each column
c
      do i = 1, nvar
         cinit(i) = 0
         cstop(i) = 0
      end do
c
c     count the number of elements in each column
c
      do i = 1, nvar
         do j = hinit(i), hstop(i)
            k = hindex(j)
            cstop(k) = cstop(k) + 1
         end do
      end do
c
c     set each start marker just past last element for its column
c
      cinit(1) = cstop(1) + 1
      do i = 2, nvar
         cinit(i) = cinit(i-1) + cstop(i)
      end do
c
c     set column index by scanning rows in reverse order
c
      do i = nvar, 1, -1
         do j = hinit(i), hstop(i)
            k = hindex(j)
            m = cinit(k) - 1
            cinit(k) = m
            cindex(m) = i
            cvalue(m) = j
         end do
      end do
c
c     convert from number of elements to end marker for column
c
      do i = 1, nvar
         cstop(i) = cinit(i) + cstop(i) - 1
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine command  --  get any command line arguments  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "command" uses the standard Unix-like iargc/getarg routines
c     to get the number and values of arguments specified on the
c     command line at program runtime
c
c
      subroutine command
      use argue
      implicit none
      integer i,iargc
      character*1 letter
      character*20 blank
c
c
c     initialize command line arguments as blank strings
c
      narg = 0
      blank = '                    '
      do i = 0, maxarg
         arg(i) = blank//blank//blank
      end do
c
c     get the number of arguments and store each in a string
c
      narg = iargc ()
      if (narg .gt. maxarg)  narg = maxarg
      do i = 0, narg
         call getarg (i,arg(i))
      end do
c
c     mark the command line options as unuseable for input
c
      listarg(0) = .false.
      do i = 1, narg
         listarg(i) = .true.
      end do
      do i = 1, narg
         letter = arg(i)(1:1)
         if (letter .eq. '-') then
            letter = arg(i)(2:2)
            call upcase (letter)
            if (letter.ge.'A' .and. letter.le.'Z') then
               listarg(i) = .false.
               listarg(i+1) = .false.
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine connect  --  attached atom list from Z-matrix  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "connect" sets up the attached atom arrays
c     starting from a set of internal coordinates
c
c
      subroutine connect
      use atoms
      use couple
      use zcoord
      use zclose
      implicit none
      integer i,j,k
      integer id1,id2
c
c
c     zero out the number of atoms attached to each atom
c
      do i = 1, n
         n12(i) = 0
         do j = 1, maxval
            i12(j,i) = 0
         end do
      end do
c
c     loop over the bonds in the Z-matrix, adding each bond
c     to the attach atom lists unless it is to be removed
c
      do i = 2, n
         k = iz(1,i)
         do j = 1, ndel
            id1 = idel(1,j)
            id2 = idel(2,j)
            if ((i.eq.id1 .and. k.eq.id2) .or.
     &          (i.eq.id2 .and. k.eq.id1))  goto 10
         end do
         n12(i) = n12(i) + 1
         n12(k) = n12(k) + 1
         i12(n12(i),i) = k
         i12(n12(k),k) = i
   10    continue
      end do
c
c     add any extra bonds used to make ring closures
c
      do i = 1, nadd
         do j = 1, 2
            k = iadd(j,i)
            n12(k) = n12(k) + 1
            i12(n12(k),k) = iadd(3-j,i)
         end do
      end do
c
c     sort the attached atom lists into ascending order
c
      do i = 1, n
         call sort (n12(i),i12(1,i))
      end do
      return
      end
c
c
c     ##################################################################
c     ##  COPYRIGHT (C) 1990 by Jay William Ponder                    ##
c     ##  COPYRIGHT (C) 1985 by Scripps Clinic & Research Foundation  ##
c     ##                     All Rights Reserved                      ##
c     ##################################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine connolly  --  analytical surface area & volume  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "connolly" uses the algorithms from the AMS/VAM programs of
c     Michael Connolly to compute the analytical molecular surface
c     area and volume of a collection of spherical atoms; thus
c     it implements Fred Richards' molecular surface definition as
c     a set of analytically defined spherical and toroidal polygons
c
c     literature references:
c
c     M. L. Connolly, "Analytical Molecular Surface Calculation",
c     Journal of Applied Crystallography, 16, 548-558 (1983)
c
c     M. L. Connolly, "Computation of Molecular Volume", Journal
c     of the American Chemical Society, 107, 1118-1124 (1985)
c
c     variables only in the Connolly routines:
c
c     na      number of atoms
c     ntt     number of temporary tori
c     nt      number of tori
c     np      number of probe positions
c     nv      number of vertices
c     nen     number of concave edges
c     nfn     number of concave faces
c     nc      number of circles
c     neq     number of convex edges
c     nfs     number of saddle faces
c     ncy     number of cycles
c     fqncy   number of cycles bounding convex face
c     nfq     number of convex faces
c     cyneq   number of convex edges in cycle
c
c     axyz    atomic coordinates
c     ar      atomic radii
c     pr      probe radius
c     skip    if true, atom is not used
c     nosurf  if true, atom has no free surface
c     afree   atom free of neighbors
c     abur    atom buried
c
c     acls    begin and end pointers for atoms neighbors
c     cls     atom numbers of neighbors
c     clst    pointer from neighbor to torus
c
c     tta     torus atom numbers
c     ttfe    first edge of each temporary torus
c     ttle    last edge of each temporary torus
c     enext   pointer to next edge of torus
c     ttbur   torus buried
c     ttfree  torus free
c
c     t       torus center
c     tr      torus radius
c     tax     torus axis
c     ta      torus atom numbers
c     tfe     torus first edge
c     tfree   torus free of neighbors
c
c     p       probe coordinates
c     pa      probe atom numbers
c     vxyz    vertex coordinates
c     va      vertex atom number
c     vp      vertex probe number
c     c       circle center
c     cr      circle radius
c     ca      circle atom number
c     ct      circle torus number
c
c     env     concave edge vertex numbers
c     fnen    concave face concave edge numbers
c     eqc     convex edge circle number
c     eqv     convex edge vertex numbers
c     afe     first convex edge of each atom
c     ale     last convex edge of each atom
c     eqnext  pointer to next convex edge of atom
c     fsen    saddle face concave edge numbers
c     fseq    saddle face convex edge numbers
c     cyeq    cycle convex edge numbers
c     fqa     atom number of convex face
c     fqcy    convex face cycle numbers
c
c
      subroutine connolly (n,x,y,z,rad,exclude,reentrant,area,volume)
      use faces
      implicit none
      integer i,n
      real*8 area,volume
      real*8 exclude
      real*8 reentrant
      real*8 eps
      real*8 x(*)
      real*8 y(*)
      real*8 z(*)
      real*8 rad(*)
      logical dowiggle
c
c
c     dimensions for arrays used by Connolly routines
c
      maxcls = 320 * n
      maxtt = 160 * n
      maxt = 8 * n
      maxp = 8 * n
      maxv = 24 * n
      maxen = 24 * n
      maxfn = 8 * n
      maxc = 16 * n
      maxeq = 24 * n
      maxfs = 12 * n
      maxcy = 6 * n
      mxcyeq = 32
      maxfq = 4 * n
      mxfqcy = 10
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(ar))  allocate (ar(n))
      if (.not. allocated(axyz))  allocate (axyz(3,n))
      if (.not. allocated(skip))  allocate (skip(n))
      if (.not. allocated(nosurf))  allocate (nosurf(n))
      if (.not. allocated(afree))  allocate (afree(n))
      if (.not. allocated(abur))  allocate (abur(n))
      if (.not. allocated(cls))  allocate (cls(maxcls))
      if (.not. allocated(clst))  allocate (clst(maxcls))
      if (.not. allocated(acls))  allocate (acls(2,n))
      if (.not. allocated(ttfe))  allocate (ttfe(maxtt))
      if (.not. allocated(ttle))  allocate (ttle(maxtt))
      if (.not. allocated(enext))  allocate (enext(maxen))
      if (.not. allocated(tta))  allocate (tta(2,maxtt))
      if (.not. allocated(ttbur))  allocate (ttbur(maxtt))
      if (.not. allocated(ttfree))  allocate (ttfree(maxtt))
      if (.not. allocated(tfe))  allocate (tfe(maxt))
      if (.not. allocated(ta))  allocate (ta(2,maxt))
      if (.not. allocated(tr))  allocate (tr(maxt))
      if (.not. allocated(t))  allocate (t(3,maxt))
      if (.not. allocated(tax))  allocate (tax(3,maxt))
      if (.not. allocated(tfree))  allocate (tfree(maxt))
      if (.not. allocated(pa))  allocate (pa(3,maxp))
      if (.not. allocated(p))  allocate (p(3,maxp))
      if (.not. allocated(va))  allocate (va(maxv))
      if (.not. allocated(vp))  allocate (vp(maxv))
      if (.not. allocated(vxyz))  allocate (vxyz(3,maxv))
      if (.not. allocated(env))  allocate (env(2,maxen))
      if (.not. allocated(fnen))  allocate (fnen(3,maxfn))
      if (.not. allocated(ca))  allocate (ca(maxc))
      if (.not. allocated(ct))  allocate (ct(maxc))
      if (.not. allocated(cr))  allocate (cr(maxc))
      if (.not. allocated(c))  allocate (c(3,maxc))
      if (.not. allocated(eqc))  allocate (eqc(maxeq))
      if (.not. allocated(eqv))  allocate (eqv(2,maxeq))
      if (.not. allocated(afe))  allocate (afe(n))
      if (.not. allocated(ale))  allocate (ale(n))
      if (.not. allocated(eqnext))  allocate (eqnext(maxeq))
      if (.not. allocated(fsen))  allocate (fsen(2,maxfs))
      if (.not. allocated(fseq))  allocate (fseq(2,maxfs))
      if (.not. allocated(cyneq))  allocate (cyneq(maxcy))
      if (.not. allocated(cyeq))  allocate (cyeq(mxcyeq,maxcy))
      if (.not. allocated(fqa))  allocate (fqa(maxfq))
      if (.not. allocated(fqncy))  allocate (fqncy(maxfq))
      if (.not. allocated(fqcy))  allocate (fqcy(mxfqcy,maxfq))
c
c     set the number of atoms and reentrant probe radius 
c
      na = n
      pr = reentrant
c
c     set atom coordinates and radii, the excluded buffer
c     probe radius ("exclude") is added to atomic radii
c
      do i = 1, na
         axyz(1,i) = x(i)
         axyz(2,i) = y(i)
         axyz(3,i) = z(i)
         ar(i) = rad(i)
         if (ar(i) .eq. 0.0d0) then
            skip(i) = .true.
         else
            ar(i) = ar(i) + exclude
            skip(i) = .false.
         end if
      end do
c
c     random coordinate perturbation to avoid numerical issues
c
      dowiggle = .true.
      if (dowiggle) then
         eps = 0.000001d0
         call wiggle (na,axyz,eps)
      end if
c
c     find the analytical surface area and volume
c
      call nearby
      call torus
      call place
      call compress
      call saddles
      call contact
      call vam (area,volume)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine nearby  --  list of neighboring atom pairs  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "nearby" finds all of the through-space neighbors of each
c     atom for use in surface area and volume calculations
c
c     local variables :
c
c     ico      integer cube coordinates
c     icuptr   pointer to next atom in cube
c     comin    minimum atomic coordinates (cube corner)
c     icube    pointer to first atom in list for cube
c     scube    true if cube contains active atoms
c     sscube   true if cube or adjacent cubes have active atoms
c     itnl     temporary neighbor list, before sorting
c
c
      subroutine nearby
      use faces
      implicit none
      integer maxclsa
      parameter (maxclsa=1000)
      integer i,j,k,m
      integer iptr,juse
      integer i1,j1,k1
      integer iatom,jatom
      integer ici,icj,ick
      integer jci,jcj,jck
      integer jcls,jmin
      integer jmincls,jmold
      integer ncls,nclsa
      integer maxcube
      integer clsa(maxclsa)
      integer itnl(maxclsa)
      integer, allocatable :: icuptr(:)
      integer, allocatable :: ico(:,:)
      integer, allocatable :: icube(:,:,:)
      real*8 radmax,width
      real*8 sum,sumi
      real*8 dist2,d2,r2
      real*8 vect1,vect2,vect3
      real*8 comin(3)
      logical, allocatable :: scube(:,:,:)
      logical, allocatable :: sscube(:,:,:)
c
c
c     ignore all atoms that are completely inside another atom;
c     may give nonsense results if this step is not taken
c
      do i = 1, na-1
         if (.not. skip(i)) then
            do j = i+1, na
               d2 = dist2(axyz(1,i),axyz(1,j))
               r2 = (ar(i) - ar(j))**2
               if (.not.skip(j) .and. d2.lt.r2) then
                  if (ar(i) .lt. ar(j)) then
                     skip(i) = .true.
                  else
                     skip(j) = .true.
                  end if
               end if
            end do
         end if
      end do
c
c     check for new coordinate minima and radii maxima
c
      radmax = 0.0d0
      do k = 1, 3
         comin(k) = axyz(k,1)
      end do
      do i = 1, na
         do k = 1, 3
            if (axyz(k,i) .lt. comin(k))  comin(k) = axyz(k,i)
         end do
         if (ar(i) .gt. radmax)  radmax = ar(i)
      end do
c
c     calculate width of cube from maximum
c     atom radius and probe radius
c
      width = 2.0d0 * (radmax+pr)
c
c     perform dynamic allocation of some local arrays
c
      maxcube = 40
      allocate (icuptr(na))
      allocate (ico(3,na))
      allocate (icube(maxcube,maxcube,maxcube))
      allocate (scube(maxcube,maxcube,maxcube))
      allocate (sscube(maxcube,maxcube,maxcube))
c
c     set up cube arrays; first the integer coordinate arrays
c
      do i = 1, na
         do k = 1, 3
            ico(k,i) = int((axyz(k,i)-comin(k))/width) + 1
            if (ico(k,i) .lt. 1) then
               call cerror ('Cube Coordinate Too Small')
            else if (ico(k,i) .gt. maxcube) then
               call cerror ('Cube Coordinate Too Large')
            end if
         end do
      end do
c
c     initialize head pointer and srn=2 arrays
c
      do i = 1, maxcube
         do j = 1, maxcube
            do k = 1, maxcube
               icube(i,j,k) = 0
               scube(i,j,k) = .false.
               sscube(i,j,k) = .false.
            end do
         end do
      end do
c
c     initialize linked list pointers
c
      do i = 1, na
         icuptr(i) = 0
      end do
c
c     set up head and later pointers for each atom
c
      do iatom = 1, na
c
c     skip atoms with surface request numbers of zero
c
         if (skip(iatom))  goto 30
         i = ico(1,iatom)
         j = ico(2,iatom)
         k = ico(3,iatom)
         if (icube(i,j,k) .le. 0) then
c
c     first atom in this cube
c
            icube(i,j,k) = iatom
         else
c
c     add to end of linked list
c
            iptr = icube(i,j,k)
   10       continue
c
c     check for duplicate atoms, turn off one of them
c
            if (dist2(axyz(1,iatom),axyz(1,iptr)) .le. 0.0d0) then
               skip(iatom) = .true.
               goto 30
            end if
c
c     move on down the list
c
            if (icuptr(iptr) .le. 0)  goto 20
            iptr = icuptr(iptr)
            goto 10
   20       continue
c
c     store atom number
c
            icuptr(iptr) = iatom
         end if
c
c     check for surfaced atom
c
         if (.not. skip(iatom))  scube(i,j,k) = .true.
   30    continue
      end do
c
c     check if this cube or any adjacent cube has active atoms
c
      do k = 1, maxcube
         do j = 1, maxcube
            do i = 1, maxcube
               if (icube(i,j,k) .ne. 0) then
                  do k1 = max(k-1,1), min(k+1,maxcube)
                     do j1 = max(j-1,1), min(j+1,maxcube)
                        do i1 = max(i-1,1), min(i+1,maxcube)
                           if (scube(i1,j1,k1)) then
                              sscube(i,j,k) = .true.
                           end if
                        end do
                     end do
                  end do
               end if
            end do
         end do
      end do
      ncls = 0
c
c     zero pointers for atom and find its cube
c
      do i = 1, na
         nclsa = 0
         nosurf(i) = skip(i)
         acls(1,i) = 0
         acls(2,i) = 0
         if (skip(i))  goto 70
         ici = ico(1,i)
         icj = ico(2,i)
         ick = ico(3,i)
c
c     skip iatom if its cube and adjoining
c     cubes contain only blockers
c
         if (.not. sscube(ici,icj,ick))  goto 70
         sumi = 2.0d0*pr + ar(i)
c
c     check iatom cube and adjacent cubes for neighboring atoms
c
         do jck = max(ick-1,1), min(ick+1,maxcube)
            do jcj = max(icj-1,1), min(icj+1,maxcube)
               do jci = max(ici-1,1), min(ici+1,maxcube)
                  j = icube(jci,jcj,jck)
   40             continue
c
c     check for end of linked list for this cube
c
                  if (j .le. 0)  goto 60
                  if (i .eq. j)  goto 50
                  if (skip(j))  goto 50
c
c     distance check
c
                  sum = sumi + ar(j)
                  vect1 = abs(axyz(1,j) - axyz(1,i))
                  if (vect1 .ge. sum)  goto 50
                  vect2 = abs(axyz(2,j) - axyz(2,i))
                  if (vect2 .ge. sum)  goto 50
                  vect3 = abs(axyz(3,j) - axyz(3,i))
                  if (vect3 .ge. sum)  goto 50
                  d2 = vect1**2 + vect2**2 + vect3**2
                  if (d2 .ge. sum**2)  goto 50
c
c     atoms are neighbors, save atom number in temporary array
c
                  if (.not. skip(j))  nosurf(i) = .false.
                  nclsa = nclsa + 1
                  if (nclsa .gt. maxclsa) then
                     call cerror ('Too many Neighbors for Atom')
                  end if
                  itnl(nclsa) = j
   50             continue
c
c     get number of next atom in cube
c
                  j = icuptr(j)
                  goto 40
   60             continue
               end do
            end do
         end do
         if (nosurf(i))  goto 70
c
c     set up neighbors arrays with jatom in increasing order
c
         jmold = 0
         do juse = 1, nclsa
            jmin = na + 1
            do jcls = 1, nclsa
c
c     don't use ones already sorted
c
               if (itnl(jcls) .gt. jmold) then
                  if (itnl(jcls) .lt. jmin) then
                     jmin = itnl(jcls)
                     jmincls = jcls
                  end if
               end if
            end do
            jmold = jmin
            jcls = jmincls
            jatom = itnl(jcls)
            clsa(juse) = jatom
         end do
c
c     set up pointers to first and last neighbors of atom
c
         if (nclsa .gt. 0) then
            acls(1,i) = ncls + 1
            do m = 1, nclsa
               ncls = ncls + 1
               if (ncls .gt. maxcls) then
                  call cerror ('Too many Neighboring Atom Pairs')
               end if
               cls(ncls) = clsa(m)
            end do
            acls(2,i) = ncls
         end if
   70    continue
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (icuptr)
      deallocate (ico)
      deallocate (icube)
      deallocate (scube)
      deallocate (sscube)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine torus  --  position of each temporary torus  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "torus" sets a list of all of the temporary torus positions
c     by testing for a torus between each atom and its neighbors
c
c
      subroutine torus
      use faces
      implicit none
      integer ia,ja,jn
      integer ibeg,iend
      real*8 ttr
      real*8 tt(3)
      real*8 ttax(3)
      logical ttok
c
c
c     no torus is possible if there is only one atom
c
      ntt = 0
      do ia = 1, na
         afree(ia) = .true.
      end do
      if (na .le. 1)  return
c
c     get begin and end pointers to neighbors of this atom
c
      do ia = 1, na
         if (.not. nosurf(ia)) then
            ibeg = acls(1,ia)
            iend = acls(2,ia)
c
c     check for no neighbors
c
            if (ibeg .gt. 0) then
               do jn = ibeg, iend
c
c     clear pointer from neighbor to torus
c
                  clst(jn) = 0
c
c     get atom number of neighbor
c
                  ja = cls(jn)
c
c     don't create torus twice
c
                  if (ja .ge. ia) then
c
c     do some solid geometry
c
                     call gettor (ia,ja,ttok,tt,ttr,ttax)
                     if (ttok) then
c
c     we have a temporary torus, set up variables
c
                        ntt = ntt + 1
                        if (ntt .gt. maxtt) then
                           call cerror ('Too many Temporary Tori')
                        end if
c
c     mark both atoms not free
c
                        afree(ia) = .false.
                        afree(ja) = .false.
                        tta(1,ntt) = ia
                        tta(2,ntt) = ja
c
c     pointer from neighbor to torus
c
                        clst(jn) = ntt
c
c     initialize torus as both free and buried
c
                        ttfree(ntt) = .true.
                        ttbur(ntt) = .true.
c
c     clear pointers from torus to first and last concave edges
c
                        ttfe(ntt) = 0
                        ttle(ntt) = 0
                     end if
                  end if
               end do
            end if
         end if
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine place  --  locate positions of the probe sites  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "place" finds the probe sites by putting the probe sphere
c     tangent to each triple of neighboring atoms
c
c
      subroutine place
      use faces
      implicit none
      integer maxmnb
      parameter (maxmnb=500)
      integer k,ke,kv
      integer l,l1,l2
      integer ia,ja,ka
      integer ik,ip,jk
      integer km,la,lm
      integer lkf,itt,nmnb
      integer iend,jend
      integer iptr,jptr
      integer mnb(maxmnb)
      integer ikt(maxmnb)
      integer jkt(maxmnb)
      integer lkcls(maxmnb)
      real*8 dist2,d2,det
      real*8 hij,hijk
      real*8 uij(3),uijk(3)
      real*8 bij(3),bijk(3)
      real*8 aijk(3),pijk(3)
      real*8 tempv(3)
      real*8 discls(maxmnb)
      real*8 sumcls(maxmnb)
      logical tb,ttok,prbok
c
c
c     no possible placement if there are no temporary tori
c
      np = 0
      nfn = 0
      nen = 0
      nv = 0
      if (ntt .le. 0)  return
c
c     consider each torus in turn
c
      do itt = 1, ntt
c
c     get atom numbers
c
         ia = tta(1,itt)
         ja = tta(2,itt)
c
c     form mutual neighbor list; clear number
c     of mutual neighbors of atoms ia and ja
c
         nmnb = 0
c
c     get begin and end pointers for each atom's neighbor list
c
         iptr = acls(1,ia)
         jptr = acls(1,ja)
         if (iptr.le.0 .or. jptr.le.0)  goto 130
         iend = acls(2,ia)
         jend = acls(2,ja)
c
c     collect mutual neighbors
c
   10    continue
c
c     check for end of loop
c
         if (iptr .gt. iend)  goto 40
         if (jptr .gt. jend)  goto 40
c
c     go move the lagging pointer
c
         if (cls(iptr) .lt. cls(jptr))  goto 20
         if (cls(jptr) .lt. cls(iptr))  goto 30
c
c     both point at same neighbor; one more mutual neighbor
c     save atom number of mutual neighbor
c
         nmnb = nmnb + 1
         if (nmnb .gt. maxmnb) then
            call cerror ('Too many Mutual Neighbors')
         end if
         mnb(nmnb) = cls(iptr)
c
c     save pointers to second and third tori
c
         ikt(nmnb) = clst(iptr)
         jkt(nmnb) = clst(jptr)
   20    continue
c
c     increment pointer to ia atom neighbors
c
         iptr = iptr + 1
         goto 10
   30    continue
c
c     increment pointer to ja atom neighbors
c
         jptr = jptr + 1
         goto 10
   40    continue
c
c     we have all the mutual neighbors of ia and ja
c     if no mutual neighbors, skip to end of loop
c
         if (nmnb .le. 0) then
            ttbur(itt) = .false.
            goto 130
         end if
         call gettor (ia,ja,ttok,bij,hij,uij)
         do km = 1, nmnb
            ka = mnb(km)
            discls(km) = dist2(bij,axyz(1,ka))
            sumcls(km) = (pr+ar(ka))**2
c
c     initialize link to next farthest out neighbor
c
            lkcls(km) = 0
         end do
c
c     set up a linked list of neighbors in order of
c     increasing distance from ia-ja torus center
c
         lkf = 1
         if (nmnb .le. 1)  goto 70
c
c     put remaining neighbors in linked list at proper position
c
         do l = 2, nmnb
            l1 = 0
            l2 = lkf
   50       continue
            if (discls(l) .lt. discls(l2))  goto 60
            l1 = l2
            l2 = lkcls(l2)
            if (l2 .ne. 0)  goto 50
   60       continue
c
c     add to list
c
            if (l1 .eq. 0) then
               lkf = l
               lkcls(l) = l2
            else
               lkcls(l1) = l
               lkcls(l) = l2
            end if
         end do
   70    continue
c
c     loop thru mutual neighbors
c
         do km = 1, nmnb
c
c     get atom number of neighbors
c
            ka = mnb(km)
            if (skip(ia) .and. skip(ja) .and. skip(ka))  goto 120
c
c     get tori numbers for neighbor
c
            ik = ikt(km)
            jk = jkt(km)
c
c     possible new triple, do some geometry to
c     retrieve saddle center, axis and radius
c
            call getprb (ia,ja,ka,prbok,tb,bijk,hijk,uijk)
            if (tb) then
               ttbur(itt) = .true.
               ttfree(itt) = .false.
               goto 120
            end if
c
c     no duplicate triples
c
            if (ka .lt. ja)  goto 120
c
c     check whether any possible probe positions
c
            if (.not. prbok)  goto 120
c
c     altitude vector
c
            do k = 1, 3
               aijk(k) = hijk * uijk(k)
            end do
c
c     we try two probe placements
c
            do ip = 1, 2
               do k = 1, 3
                  if (ip .eq. 1) then
                     pijk(k) = bijk(k) + aijk(k)
                  else
                     pijk(k) = bijk(k) - aijk(k)
                  end if
               end do
c
c     mark three tori not free
c
               ttfree(itt) = .false.
               ttfree(ik) = .false.
               ttfree(jk) = .false.
c
c     check for collisions
c
               lm = lkf
   80          continue
               if (lm .le. 0)  goto 100
c
c     get atom number of mutual neighbor
c
               la = mnb(lm)
c
c     must not equal third atom
c
               if (la .eq. ka)  goto 90
c
c     compare distance to sum of radii
c
               d2 = dist2(pijk,axyz(1,la))
               if (d2 .le. sumcls(lm))  goto 110
   90          continue
               lm = lkcls(lm)
               goto 80
  100          continue
c
c     we have a new probe position
c
               np = np + 1
               if (np .gt. maxp) then
                  call cerror ('Too many Probe Positions')
               end if
c
c     mark three tori not buried
c
               ttbur(itt) = .false.
               ttbur(ik) = .false.
               ttbur(jk) = .false.
c
c     store probe center
c
               do k = 1, 3
                  p(k,np) = pijk(k)
               end do
c
c     calculate vectors from probe to atom centers
c
               if (nv+3 .gt. maxv)  call cerror ('Too many Vertices')
               do k = 1, 3
                  vxyz(k,nv+1) = axyz(k,ia) - p(k,np)
                  vxyz(k,nv+2) = axyz(k,ja) - p(k,np)
                  vxyz(k,nv+3) = axyz(k,ka) - p(k,np)
               end do
c
c     calculate determinant of vectors defining triangle
c
               det = vxyz(1,nv+1)*vxyz(2,nv+2)*vxyz(3,nv+3)
     &                  + vxyz(1,nv+2)*vxyz(2,nv+3)*vxyz(3,nv+1)
     &                  + vxyz(1,nv+3)*vxyz(2,nv+1)*vxyz(3,nv+2)
     &                  - vxyz(1,nv+3)*vxyz(2,nv+2)*vxyz(3,nv+1)
     &                  - vxyz(1,nv+2)*vxyz(2,nv+1)*vxyz(3,nv+3)
     &                  - vxyz(1,nv+1)*vxyz(2,nv+3)*vxyz(3,nv+2)
c
c     now add probe coordinates to vertices
c
               do k = 1, 3
                  vxyz(k,nv+1) = p(k,np) + vxyz(k,nv+1)*pr/(ar(ia)+pr)
                  vxyz(k,nv+2) = p(k,np) + vxyz(k,nv+2)*pr/(ar(ja)+pr)
                  vxyz(k,nv+3) = p(k,np) + vxyz(k,nv+3)*pr/(ar(ka)+pr)
               end do
c
c     want the concave face to have counter-clockwise orientation
c
               if (det .gt. 0.0d0) then
c
c     swap second and third vertices
c
                  do k = 1, 3
                     tempv(k) = vxyz(k,nv+2)
                     vxyz(k,nv+2) = vxyz(k,nv+3)
                     vxyz(k,nv+3) = tempv(k)
                  end do
c
c     set up pointers from probe to atoms
c
                  pa(1,np) = ia
                  pa(2,np) = ka
                  pa(3,np) = ja
c
c     set up pointers from vertices to atoms
c
                  va(nv+1) = ia
                  va(nv+2) = ka
                  va(nv+3) = ja
c
c     insert concave edges into linked lists for appropriate tori
c
                  call inedge (nen+1,ik)
                  call inedge (nen+2,jk)
                  call inedge (nen+3,itt)
               else
c
c     similarly, if face already counter clockwise
c
                  pa(1,np) = ia
                  pa(2,np) = ja
                  pa(3,np) = ka
                  va(nv+1) = ia
                  va(nv+2) = ja
                  va(nv+3) = ka
                  call inedge (nen+1,itt)
                  call inedge (nen+2,jk)
                  call inedge (nen+3,ik)
               end if
c
c     set up pointers from vertices to probe
c
               do kv = 1, 3
                  vp(nv+kv) = np
               end do
c
c     set up concave edges and concave face
c
               if (nen+3 .gt. maxen) then
                  call cerror ('Too many Concave Edges')
               end if
c
c     edges point to vertices
c
               env(1,nen+1) = nv+1
               env(2,nen+1) = nv+2
               env(1,nen+2) = nv+2
               env(2,nen+2) = nv+3
               env(1,nen+3) = nv+3
               env(2,nen+3) = nv+1
               if (nfn+1 .gt. maxfn) then
                  call cerror ('Too many Concave Faces')
               end if
c
c     face points to edges
c
               do ke = 1, 3
                  fnen(ke,nfn+1) = nen + ke
               end do
c
c     increment counters for number of faces, edges and vertices
c
               nfn = nfn + 1
               nen = nen + 3
               nv = nv + 3
  110          continue
            end do
  120       continue
         end do
  130    continue
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine inedge  --  manage linked list of torus edges  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "inedge" inserts a concave edge into the
c     linked list for its temporary torus
c
c
      subroutine inedge (ien,itt)
      use faces
      implicit none
      integer ien,itt,ieqen
c
c
c     check for a serious error in the calling arguments
c
      if (ien .le. 0)  call cerror ('Bad Edge Number in INEDGE')
      if (itt .le. 0)  call cerror ('Bad Torus Number in INEDGE')
c
c     set beginning of list or add to end
c
      if (ttfe(itt) .eq. 0) then
         ttfe(itt) = ien
         enext(ien) = 0
         ttle(itt) = ien
      else
         ieqen = ttle(itt)
         enext(ieqen) = ien
         enext(ien) = 0
         ttle(itt) = ien
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine compress  --  condense temporary to final tori  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "compress" transfers only the non-buried tori from
c     the temporary tori arrays to the final tori arrays
c
c
      subroutine compress
      use faces
      implicit none
      integer itt,ia,ja
      integer iptr,ned
      integer ip1,ip2
      integer iv1,iv2
      logical ttok
c
c
c     initialize the number of nonburied tori
c
      nt = 0
      if (ntt .le. 0)  return
c
c     if torus is free, then it is not buried;
c     skip to end of loop if buried torus
c
      do itt = 1, ntt
         if (ttfree(itt))  ttbur(itt) = .false.
         if (.not. ttbur(itt)) then
c
c     first, transfer information
c
            nt = nt + 1
            if (nt .gt. maxt)  call cerror ('Too many NonBuried Tori')
            ia = tta(1,itt)
            ja = tta(2,itt)
            call gettor (ia,ja,ttok,t(1,nt),tr(nt),tax(1,nt))
            ta(1,nt) = ia
            ta(2,nt) = ja
            tfree(nt) = ttfree(itt)
            tfe(nt) = ttfe(itt)
c
c     special check for inconsistent probes
c
            iptr = tfe(nt)
            ned = 0
            do while (iptr .ne. 0)
               ned = ned + 1
               iptr = enext(iptr)
            end do
            if (mod(ned,2) .ne. 0) then
               iptr = tfe(nt)
               do while (iptr .ne. 0)
                  iv1 = env(1,iptr)
                  iv2 = env(2,iptr)
                  ip1 = vp(iv1)
                  ip2 = vp(iv2)
                  call cerror ('Odd Torus for Probes IP1 and IP2')
                  iptr = enext(iptr)
               end do
            end if
         end if
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine saddles  --  builds saddle pieces from tori  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "saddles" constructs circles, convex edges and saddle faces
c
c
      subroutine saddles
      use faces
      use math
      implicit none
      integer maxent
      parameter (maxent=500)
      integer k,ia,in,ip
      integer it,iv,itwo
      integer ien,ient,nent
      integer l1,l2,m1,n1
      integer ten(maxent)
      integer nxtang(maxent)
      real*8 triple,factor
      real*8 dtev,dt
      real*8 atvect(3)
      real*8 teang(maxent)
      real*8 tev(3,maxent)
      logical sdstrt(maxent)
c
c
c     zero the number of circles, convex edges and saddle faces
c
      nc = 0
      neq = 0
      nfs = 0
      do ia = 1, na
         afe(ia) = 0
         ale(ia) = 0
         abur(ia) = .true.
      end do
c
c     no saddle faces if no tori
c
      if (nt .lt. 1)  return
c
c     cycle through tori
c
      do it = 1, nt
         if (skip(ta(1,it)) .and. skip(ta(2,it)))  goto 80
c
c     set up two circles
c
         do in = 1, 2
            ia = ta(in,it)
c
c     mark atom not buried
c
            abur(ia) = .false.
c
c     vector from atom to torus center
c
            do k = 1, 3
               atvect(k) = t(k,it) - axyz(k,ia)
            end do
            factor = ar(ia) / (ar(ia)+pr)
c
c     one more circle
c
            nc = nc + 1
            if (nc .gt. maxc)  call cerror ('Too many Circles')
c
c     circle center
c
            do k = 1, 3
               c(k,nc) = axyz(k,ia) + factor*atvect(k)
            end do
c
c     pointer from circle to atom and to torus
c
            ca(nc) = ia
            ct(nc) = it
c
c     circle radius
c
            cr(nc) = factor * tr(it)
         end do
c
c     skip to special code if free torus
c
         if (tfree(it))  goto 70
c
c     now we collect all the concave edges for this torus;
c     for each concave edge, calculate vector from torus center
c     thru probe center and the angle relative to first such vector
c
c     clear the number of concave edges for torus
c
         nent = 0
c
c     pointer to start of linked list
c
         ien = tfe(it)
   10    continue
c
c     finished if concave edge pointer is zero
c
         if (ien .le. 0)  goto 20
c
c     one more concave edge
c
         nent = nent + 1
         if (nent .gt. maxent) then
            call cerror ('Too many Edges for Torus')
         end if
c
c     first vertex of edge
c
         iv = env(1,ien)
c
c     probe number of vertex
c
         ip = vp(iv)
         do k = 1, 3
            tev(k,nent) = p(k,ip) - t(k,it)
         end do
         dtev = 0.0d0
         do k = 1, 3
            dtev = dtev + tev(k,nent)**2
         end do
         if (dtev .le. 0.0d0)  call cerror ('Probe on Torus Axis')
         dtev = sqrt(dtev)
         do k = 1, 3
            tev(k,nent) = tev(k,nent) / dtev
         end do
c
c     store concave edge number
c
         ten(nent) = ien
         if (nent .gt. 1) then
c
c     calculate angle between this vector and first vector
c
            dt = 0.0d0
            do k = 1, 3
               dt = dt + tev(k,1)*tev(k,nent)
            end do
c
c     be careful
c
            if (dt .gt. 1.0d0)  dt = 1.0d0
            if (dt .lt. -1.0d0)  dt = -1.0d0
c
c     store angle
c
            teang(nent) = acos(dt)
c
c     get the sign right
c
            if (triple(tev(1,1),tev(1,nent),tax(1,it)) .lt. 0.0d0) then
               teang(nent) = 2.0d0*pi - teang(nent)
            end if
         else
            teang(1) = 0.0d0
         end if
c
c     saddle face starts with this edge if it points parallel
c     to torus axis vector (which goes from first to second atom)
c
         sdstrt(nent) = (va(iv) .eq. ta(1,it))
c
c     next edge in list
c
         ien = enext(ien)
         goto 10
   20    continue
         if (nent .le. 0) then
            call cerror ('No Edges for Non-free Torus')
         end if
         itwo = 2
         if (mod(nent,itwo) .ne. 0) then
            call cerror ('Odd Number of Edges for Torus')
         end if
c
c     set up linked list of concave edges in order
c     of increasing angle around the torus axis;
c     clear second linked (angle-ordered) list pointers
c
         do ient = 1, nent
            nxtang(ient) = 0
         end do
         do ient = 2, nent
c
c     we have an entry to put into linked list
c     search for place to put it
c
            l1 = 0
            l2 = 1
   30       continue
            if (teang(ient) .lt. teang(l2))  goto 40
c
c     not yet, move along
c
            l1 = l2
            l2 = nxtang(l2)
            if (l2 .ne. 0)  goto 30
   40       continue
c
c     we are at end of linked list or between l1 and l2;
c     insert edge
c
            if (l1 .le. 0)  call cerror ('Logic Error in SADDLES')
            nxtang(l1) = ient
            nxtang(ient) = l2
         end do
c
c     collect pairs of concave edges into saddles
c     create convex edges while you're at it
c
         l1 = 1
   50    continue
         if (l1 .le. 0)  goto 60
c
c     check for start of saddle
c
         if (sdstrt(l1)) then
c
c     one more saddle face
c
            nfs = nfs + 1
            if (nfs .gt. maxfs)  call cerror ('Too many Saddle Faces')
c
c     get edge number
c
            ien = ten(l1)
c
c     first concave edge of saddle
c
            fsen(1,nfs) = ien
c
c     one more convex edge
c
            neq = neq + 1
            if (neq .gt. maxeq)  call cerror ('Too many Convex Edges')
c
c     first convex edge points to second circle
c
            eqc(neq) = nc
c
c     atom circle lies on
c
            ia = ca(nc)
c
c     insert convex edge into linked list for atom
c
            call ipedge (neq,ia)
c
c     first vertex of convex edge is second vertex of concave edge
c
            eqv(1,neq) = env(2,ien)
c
c     first convex edge of saddle
c
            fseq(1,nfs) = neq
c
c     one more convex edge
c
            neq = neq + 1
            if (neq .gt. maxeq)  call cerror ('Too many Convex Edges')
c
c     second convex edge points to first circle
c
            eqc(neq) = nc - 1
            ia = ca(nc-1)
c
c     insert convex edge into linked list for atom
c
            call ipedge (neq,ia)
c
c     second vertex of second convex edge
c     is first vertex of first concave edge
c
            eqv(2,neq) = env(1,ien)
            l1 = nxtang(l1)
c
c     wrap around
c
            if (l1 .le. 0)  l1 = 1
            if (sdstrt(l1)) then
               m1 = nxtang(l1)
               if (m1 .le. 0)  m1 = 1
               if (sdstrt(m1))  call cerror ('Three Starts in a Row')
               n1 = nxtang(m1)
c
c     the old switcheroo
c
               nxtang(l1) = n1
               nxtang(m1) = l1
               l1 = m1
            end if
            ien = ten(l1)
c
c     second concave edge for saddle face
c
            fsen(2,nfs) = ien
c
c     second vertex of first convex edge is
c     first vertex of second concave edge
c
            eqv(2,neq-1) = env(1,ien)
c
c     first vertex of second convex edge is
c     second vertex of second concave edge
c
            eqv(1,neq) = env(2,ien)
            fseq(2,nfs) = neq
c
c     quit if we have wrapped around to first edge
c
            if (l1 .eq. 1)  goto 60
         end if
c
c     next concave edge
c
         l1 = nxtang(l1)
         goto 50
   60    continue
         goto 80
c
c     free torus
c
   70    continue
c
c     set up entire circles as convex edges for new saddle surface;
c     one more saddle face
c
         nfs = nfs + 1
         if (nfs .gt. maxfs)  call cerror ('Too many Saddle Faces')
c
c     no concave edges for saddle
c
         fsen(1,nfs) = 0
         fsen(2,nfs) = 0
c
c     one more convex edge
c
         neq = neq + 1
         ia = ca(nc)
c
c     insert convex edge into linked list for atom
c
         call ipedge (neq,ia)
c
c     no vertices for convex edge
c
         eqv(1,neq) = 0
         eqv(2,neq) = 0
c
c     pointer from convex edge to second circle
c
         eqc(neq) = nc
c
c     first convex edge for saddle face
c
         fseq(1,nfs) = neq
c
c     one more convex edge
c
         neq = neq + 1
         ia = ca(nc-1)
c
c     insert second convex edge into linked list
c
         call ipedge (neq,ia)
c
c     no vertices for convex edge
c
         eqv(1,neq) = 0
         eqv(2,neq) = 0
c
c     convex edge points to first circle
c
         eqc(neq) = nc - 1
c
c     second convex edge for saddle face
c
         fseq(2,nfs) = neq
c
c     nothing to do for buried torus
c
   80    continue
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine gettor  --  test torus site between two atoms  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "gettor" tests for a possible torus position at the interface
c     between two atoms, and finds the torus radius, center and axis
c
c
      subroutine gettor (ia,ja,ttok,torcen,torad,torax)
      use faces
      implicit none
      integer k,ia,ja
      real*8 dist2,dij
      real*8 temp,temp1
      real*8 temp2
      real*8 torad
      real*8 torcen(3)
      real*8 torax(3)
      real*8 vij(3)
      real*8 uij(3)
      real*8 bij(3)
      logical ttok
c
c
c     get the distance between the two atoms
c
      ttok = .false.
      dij = sqrt(dist2(axyz(1,ia),axyz(1,ja)))
c
c     find a unit vector along interatomic (torus) axis
c
      do k = 1, 3
         vij(k) = axyz(k,ja) - axyz(k,ia)
         uij(k) = vij(k) / dij
      end do
c
c     find coordinates of the center of the torus
c
      temp = 1.0d0 + ((ar(ia)+pr)**2-(ar(ja)+pr)**2)/dij**2
      do k = 1, 3
         bij(k) = axyz(k,ia) + 0.5d0*vij(k)*temp
      end do
c
c     skip if atoms too far apart (should not happen)
c
      temp1 = (ar(ia)+ar(ja)+2.0d0*pr)**2 - dij**2
      if (temp1 .ge. 0.0d0) then
c
c     skip if one atom is inside the other
c
         temp2 = dij**2 - (ar(ia)-ar(ja))**2
         if (temp2 .ge. 0.0d0) then
c
c     store the torus radius, center and axis
c
            ttok = .true.
            torad = sqrt(temp1*temp2) / (2.0d0*dij)
            do k = 1, 3
               torcen(k) = bij(k)
               torax(k) = uij(k)
            end do
         end if
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine getprb  --  test probe site between three atoms  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "getprb" tests for a possible probe position at the interface
c     between three neighboring atoms
c
c
      subroutine getprb (ia,ja,ka,prbok,tb,bijk,hijk,uijk)
      use faces
      implicit none
      integer k,ia,ja,ka
      real*8 dot,dotijk,dotut
      real*8 wijk,swijk,fact
      real*8 dist2,dat2
      real*8 rad,rad2
      real*8 dba,rip2,hijk
      real*8 rij,rik
      real*8 uij(3),uik(3)
      real*8 uijk(3),utb(3)
      real*8 tij(3),tik(3)
      real*8 bijk(3),tijik(3)
      logical prbok,tb,tok
c
c
c     initialize, then check torus over atoms "ia" and "ja"
c
      prbok = .false.
      tb = .false.
      call gettor (ia,ja,tok,tij,rij,uij)
      if (.not. tok)  return
      dat2 = dist2(axyz(1,ka),tij)
      rad2 = (ar(ka)+pr)**2 - rij**2
c
c     if "ka" less than "ja", then all we care about
c     is whether the torus is buried
c
      if (ka .lt. ja) then
         if (rad2 .le. 0.0d0)  return
         if (dat2 .gt. rad2)  return
      end if
      call gettor (ia,ka,tok,tik,rik,uik)
      if (.not. tok)  return
      dotijk = dot(uij,uik)
      if (dotijk .gt. 1.0d0)  dotijk = 1.0d0
      if (dotijk .lt. -1.0d0)  dotijk = -1.0d0
      wijk = acos(dotijk)
      swijk = sin(wijk)
c
c     if the three atoms are colinear, then there is no
c     probe placement; but we still care whether the torus
c     is buried by atom "k"
c
      if (swijk .eq. 0.0d0) then
         tb = (rad2.gt.0.0d0 .and. dat2.le.rad2)
         return
      end if
      call vcross (uij,uik,uijk)
      do k = 1, 3
         uijk(k) = uijk(k) / swijk
      end do
      call vcross (uijk,uij,utb)
      do k = 1, 3
         tijik(k) = tik(k) - tij(k)
      end do
      dotut = dot(uik,tijik)
      fact = dotut / swijk
      do k = 1, 3
         bijk(k) = tij(k) + utb(k)*fact
      end do
      dba = dist2(axyz(1,ia),bijk)
      rip2 = (ar(ia) + pr)**2
      rad = rip2 - dba
      if (rad .lt. 0.0d0) then
         tb = (rad2.gt.0.0d0 .and. dat2.le.rad2)
      else
         prbok = .true.
         hijk = sqrt(rad)
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ipedge  --  manage linked list of convex edges  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ipedge" inserts convex edge into linked list for atom
c
c
      subroutine ipedge (ieq,ia)
      use faces
      implicit none
      integer ieq,ia,ieqen
c
c
c     first, check for an error condition
c
      if (ieq .le. 0)  call cerror ('Bad Edge Number in IPEDGE')
      if (ia .le. 0)  call cerror ('Bad Atom Number in IPEDGE')
c
c     set beginning of list or add to end
c
      if (afe(ia) .eq. 0) then
         afe(ia) = ieq
         eqnext(ieq) = 0
         ale(ia) = ieq
      else
         ieqen = ale(ia)
         eqnext(ieqen) = ieq
         eqnext(ieq) = 0
         ale(ia) = ieq
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine contact  --  builds exposed contact surfaces  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "contact" constructs the contact surface, cycles and convex faces
c
c
      subroutine contact
      use faces
      implicit none
      integer maxeqa,maxcypa
      parameter (maxeqa=300)
      parameter (maxcypa=100)
      integer i,k,ia,ia2,it
      integer ieq,ic,jc,jcy
      integer neqa,ieqa,jeqa
      integer ncypa,icya,jcya,kcya
      integer ncyeq,icyeq,jcyeq
      integer ncyold,nused,lookv
      integer aic(maxeqa)
      integer aia(maxeqa)
      integer aeq(maxeqa)
      integer av(2,maxeqa)
      integer ncyeqa(maxcypa)
      integer cyeqa(mxcyeq,maxcypa)
      real*8 anorm,anaa,factor
      real*8 acvect(3,maxeqa)
      real*8 aavect(3,maxeqa)
      real*8 pole(3),unvect(3)
      real*8 acr(maxeqa)
      logical ptincy,eqused(maxeqa)
      logical cycy(maxcypa,maxcypa)
      logical cyused(maxcypa)
      logical samef(maxcypa,maxcypa)
c
c
c     zero out the number of cycles and convex faces
c
      ncy = 0
      nfq = 0
c
c     mark all free atoms not buried
c
      do ia = 1, na
         if (afree(ia))  abur(ia) = .false.
      end do
c
c     go through all atoms
c
      do ia = 1, na
         if (skip(ia))  goto 130
c
c     skip to end of loop if buried atom
c
         if (abur(ia))  goto 130
c
c     special code for completely solvent-accessible atom
c
         if (afree(ia))  goto 120
c
c     gather convex edges for atom
c     clear number of convex edges for atom
c
         neqa = 0
c
c     pointer to first edge
c
         ieq = afe(ia)
   10    continue
c
c     check whether finished gathering
c
         if (ieq .le. 0)  goto 20
c
c     one more edge
c
         neqa = neqa + 1
         if (neqa .gt. maxeqa) then
            call cerror ('Too many Convex Edges for Atom')
         end if
c
c      store vertices of edge
c
         av(1,neqa) = eqv(1,ieq)
         av(2,neqa) = eqv(2,ieq)
c
c     store convex edge number
c
         aeq(neqa) = ieq
         ic = eqc(ieq)
c
c     store circle number
c
         aic(neqa) = ic
c
c     get neighboring atom
c
         it = ct(ic)
         if (ta(1,it) .eq. ia) then
            ia2 = ta(2,it)
         else
            ia2 = ta(1,it)
         end if
c
c     store other atom number, we might need it sometime
c
         aia(neqa) = ia2
c
c     vector from atom to circle center; also
c     vector from atom to center of neighboring atom
c     sometimes we use one vector, sometimes the other
c
         do k = 1, 3
            acvect(k,neqa) = c(k,ic) - axyz(k,ia)
            aavect(k,neqa) = axyz(k,ia2) - axyz(k,ia)
         end do
c
c     circle radius
c
         acr(neqa) = cr(ic)
c
c     pointer to next edge
c
         ieq = eqnext(ieq)
         goto 10
   20    continue
         if (neqa .le. 0) then
            call cerror ('No Edges for Non-buried, Non-free Atom')
         end if
c
c     form cycles; initialize all the
c     convex edges as not used in cycle
c
         do ieqa = 1, neqa
            eqused(ieqa) = .false.
         end do
c
c     save old number of cycles
c
         ncyold = ncy
         nused = 0
         ncypa = 0
   30    continue
c
c     look for starting edge
c
         do ieqa = 1, neqa
            if (.not. eqused(ieqa))  goto 40
         end do
c
c     cannot find starting edge, finished
c
         goto 80
   40    continue
c
c     pointer to edge
c
         ieq = aeq(ieqa)
c
c     one edge so far for this cycle
c
         ncyeq = 1
c
c     one more cycle for atom
c
         ncypa = ncypa + 1
         if (ncypa .gt. maxcypa) then
            call cerror ('Too many Cycles per Atom')
         end if
c
c     mark edge used in cycle
c
         eqused(ieqa) = .true.
         nused = nused + 1
c
c     one more cycle for molecule
c
         ncy = ncy + 1
         if (ncy .gt. maxcy)  call cerror ('Too many Cycles')
c
c     index of edge in atom cycle array
c
         cyeqa(ncyeq,ncypa) = ieqa
c
c     store in molecule cycle array a pointer to edge
c
         cyeq(ncyeq,ncy) = ieq
c
c     second vertex of this edge is the vertex to look
c     for next as the first vertex of another edge
c
         lookv = av(2,ieqa)
c
c     if no vertex, this cycle is finished
c
         if (lookv .le. 0)  goto 70
   50    continue
c
c     look for next connected edge
c
         do jeqa = 1, neqa
            if (eqused(jeqa))  goto 60
c
c     check second vertex of ieqa versus first vertex of jeqa
c
            if (av(1,jeqa) .ne. lookv)  goto 60
c
c     edges are connected
c     pointer to edge
c
            ieq = aeq(jeqa)
c
c     one more edge for this cycle
c
            ncyeq = ncyeq + 1
            if (ncyeq .gt. mxcyeq) then
               call cerror ('Too many Edges per Cycle')
            end if
            eqused(jeqa) = .true.
            nused = nused + 1
c
c     store index in local edge array
c
            cyeqa(ncyeq,ncypa) = jeqa
c
c     store pointer to edge
c
            cyeq(ncyeq,ncy) = ieq
c
c     new vertex to look for
c
            lookv = av(2,jeqa)
c
c     if no vertex, this cycle is in trouble
c
            if (lookv .le. 0) then
               call cerror ('Pointer Error in Cycle')
            end if
            goto 50
   60       continue
         end do
c
c     it better connect to first edge of cycle
c
         if (lookv .ne. av(1,ieqa)) then
            call cerror ('Cycle does not Close')
         end if
   70    continue
c
c     this cycle is finished, store number of edges in cycle
c
         ncyeqa(ncypa) = ncyeq
         cyneq(ncy) = ncyeq
         if (nused .ge. neqa)  goto 80
c
c     look for more cycles
c
         goto 30
   80    continue
c
c     compare cycles for inside/outside relation;
c     check to see if cycle i is inside cycle j
c
         do icya = 1, ncypa
            do jcya = 1, ncypa
               jcy = ncyold + jcya
               cycy(icya,jcya) = .true.
               if (icya .eq. jcya)  goto 90
c
c     if cycle j has two or fewer edges, nothing can
c     lie in its exterior; i is therefore inside j
c
               if (ncyeqa(jcya) .le. 2)  goto 90
c
c     if cycles i and j have a pair of edges belonging
c     to the same circle, then they are outside each other
c
               do icyeq = 1, ncyeqa(icya)
                  ieqa = cyeqa(icyeq,icya)
                  ic = aic(ieqa)
                  do jcyeq = 1, ncyeqa(jcya)
                     jeqa = cyeqa(jcyeq,jcya)
                     jc = aic(jeqa)
                     if (ic .eq. jc) then
                        cycy(icya,jcya) = .false.
                        goto 90
                     end if
                  end do
               end do
               ieqa = cyeqa(1,icya)
               anaa = anorm(aavect(1,ieqa))
               factor = ar(ia) / anaa
c
c     north pole and unit vector pointing south
c
               do k = 1, 3
                  pole(k) = factor*aavect(k,ieqa) + axyz(k,ia)
                  unvect(k) = -aavect(k,ieqa) / anaa
               end do
               cycy(icya,jcya) = ptincy(pole,unvect,jcy)
   90          continue
            end do
         end do
c
c     group cycles into faces; direct comparison for i and j
c
         do icya = 1, ncypa
            do jcya = 1, ncypa
c
c     tentatively say that cycles i and j bound
c     the same face if they are inside each other
c
               samef(icya,jcya) = (cycy(icya,jcya) .and.
     &                               cycy(jcya,icya))
            end do
         end do
c
c     if i is in exterior of k, and k is in interior of
c     i and j, then i and j do not bound the same face
c
         do icya = 1, ncypa
            do jcya = 1, ncypa
               if (icya .ne. jcya) then
                  do kcya = 1, ncypa
                     if (kcya.ne.icya .and. kcya.ne.jcya) then
                        if (cycy(kcya,icya) .and. cycy(kcya,jcya)
     &                        .and. .not.cycy(icya,kcya)) then
                           samef(icya,jcya) = .false.
                           samef(jcya,icya) = .false.
                        end if
                     end if
                  end do
               end if
            end do
         end do
c
c     fill gaps so that "samef" falls into complete blocks
c
         do icya = 1, ncypa-2
            do jcya = icya+1, ncypa-1
               if (samef(icya,jcya)) then
                  do kcya = jcya+1, ncypa
                     if (samef(jcya,kcya)) then
                        samef(icya,kcya) = .true.
                        samef(kcya,icya) = .true.
                     end if
                  end do
               end if
            end do
         end do
c
c     group cycles belonging to the same face
c
         do icya = 1, ncypa
            cyused(icya) = .false.
         end do
c
c     clear number of cycles used in bounding faces
c
         nused = 0
         do icya = 1, ncypa
c
c     check for already used
c
            if (cyused(icya))  goto 110
c
c     one more convex face
c
            nfq = nfq + 1
            if (nfq .gt. maxfq) then
               call cerror ('Too many Convex Faces')
            end if
c
c     clear number of cycles for face
c
            fqncy(nfq) = 0
c
c     pointer from face to atom
c
            fqa(nfq) = ia
c
c     look for all other cycles belonging to same face
c
            do jcya = 1, ncypa
c
c     check for cycle already used in another face
c
               if (cyused(jcya))  goto 100
c
c     cycles i and j belonging to same face
c
               if (.not. samef(icya,jcya))  goto 100
c
c     mark cycle used
c
               cyused(jcya) = .true.
               nused = nused + 1
c
c     one more cycle for face
c
               fqncy(nfq) = fqncy(nfq) + 1
               if (fqncy(nfq) .gt. mxfqcy) then
                  call cerror ('Too many Cycles bounding Convex Face')
               end if
               i = fqncy(nfq)
c
c     store cycle number
c
               fqcy(i,nfq) = ncyold + jcya
c
c     check for finished
c
               if (nused .ge. ncypa)  goto 130
  100          continue
            end do
  110       continue
         end do
c
c     should not fall through end of do loops
c
         call cerror ('Not all Cycles grouped into Convex Faces')
  120    continue
c
c     one face for free atom; no cycles
c
         nfq = nfq + 1
         if (nfq .gt. maxfq) then
            call cerror ('Too many Convex Faces')
         end if
         fqa(nfq) = ia
         fqncy(nfq) = 0
  130    continue
      end do
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine vam  --  find area and volume of molecule  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "vam" takes the analytical molecular surface defined
c     as a collection of spherical and toroidal polygons
c     and uses it to compute the surface area and volume
c
c
      subroutine vam (area,volume)
      use faces
      use inform
      use iounit
      use math
      implicit none
      integer maxdot,maxop,nscale
      parameter (maxdot=1000)
      parameter (maxop=100)
      parameter (nscale=20)
      integer k,ke,ke2,kv
      integer ia,ic,ip,it
      integer ien,ieq
      integer ifn,ifq,ifs
      integer iv,iv1,iv2
      integer isc,jfn
      integer ndots,idot
      integer nop,iop,nate
      integer neat,neatmx
      integer ivs(3)
      integer ispind(3)
      integer ispnd2(3)
      integer ifnop(maxop)
      integer, allocatable :: nlap(:)
      integer, allocatable :: enfs(:)
      integer, allocatable :: fnt(:,:)
      integer, allocatable :: nspt(:,:)
      real*8 area,volume
      real*8 alens,vint,vcone
      real*8 vpyr,vlens,hedron
      real*8 totaq,totvq,totas
      real*8 totvs,totasp,totvsp
      real*8 totan,totvn
      real*8 alenst,alensn
      real*8 vlenst,vlensn,prism
      real*8 areaq,volq,areas,vols
      real*8 areasp,volsp,arean,voln
      real*8 depth,triple,dist2
      real*8 areado,voldo,dot,dota
      real*8 ds2,dij2,dt,dpp
      real*8 rm,rat,rsc,rho
      real*8 sumsc,sumsig,sumlam
      real*8 stq,scinc,coran,corvn
      real*8 cenop(3,maxop)
      real*8 sdot(3),dotv(nscale)
      real*8 tau(3),ppm(3)
      real*8 xpnt1(3),xpnt2(3)
      real*8 qij(3),qji(3)
      real*8 vects(3,3)
      real*8 vect1(3),vect2(3)
      real*8 vect3(3),vect4(3)
      real*8 vect5(3),vect6(3)
      real*8 vect7(3),vect8(3)
      real*8 upp(3),thetaq(3)
      real*8 sigmaq(3)
      real*8 umq(3),upq(3)
      real*8 uc(3),uq(3),uij(3)
      real*8 dots(3,maxdot)
      real*8 tdots(3,maxdot)
      real*8, allocatable :: atmarea(:)
      real*8, allocatable :: depths(:)
      real*8, allocatable :: cora(:)
      real*8, allocatable :: corv(:)
      real*8, allocatable :: alts(:,:)
      real*8, allocatable :: fncen(:,:)
      real*8, allocatable :: fnvect(:,:,:)
      logical spindl
      logical alli,allj
      logical anyi,anyj
      logical case1,case2
      logical cinsp,cintp
      logical usenum
      logical vip(3)
      logical ate(maxop)
      logical, allocatable :: badav(:)
      logical, allocatable :: badt(:)
      logical, allocatable :: fcins(:,:)
      logical, allocatable :: fcint(:,:)
      logical, allocatable :: fntrev(:,:)
c
c
c     compute the volume of the interior polyhedron
c
      hedron = 0.0d0
      do ifn = 1, nfn
         call measpm (ifn,prism)
         hedron = hedron + prism
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (nlap(nfn))
      allocate (enfs(20*na))
      allocate (fnt(3,nfn))
      allocate (nspt(3,nfn))
      allocate (atmarea(na))
      allocate (depths(nfn))
      allocate (cora(nfn))
      allocate (corv(nfn))
      allocate (alts(3,nfn))
      allocate (fncen(3,nfn))
      allocate (fnvect(3,3,nfn))
      allocate (badav(nfn))
      allocate (badt(nfn))
      allocate (fcins(3,nfn))
      allocate (fcint(3,nfn))
      allocate (fntrev(3,nfn))
c
c     compute the area and volume due to convex faces
c     as well as the area partitioned among the atoms
c
      totaq = 0.0d0
      totvq = 0.0d0
      do ia = 1, na
         atmarea(ia) = 0.0d0
      end do
      do ifq = 1, nfq
         call measfq (ifq,areaq,volq)
         ia = fqa(ifq)
         atmarea(ia) = atmarea(ia) + areaq
         totaq = totaq + areaq
         totvq = totvq + volq
      end do
c
c     compute the area and volume due to saddle faces
c     as well as the spindle correction value
c
      totas = 0.0d0
      totvs = 0.0d0
      totasp = 0.0d0
      totvsp = 0.0d0
      do ifs = 1, nfs
         do k = 1, 2
            ien = fsen(k,ifs)
            if (ien .gt. 0)  enfs(ien) = ifs
         end do
         call measfs (ifs,areas,vols,areasp,volsp)
         totas = totas + areas
         totvs = totvs + vols
         totasp = totasp + areasp
         totvsp = totvsp + volsp
         if (areas-areasp .lt. 0.0d0) then
            call cerror ('Negative Area for Saddle Face')
         end if
      end do
c
c     compute the area and volume due to concave faces
c
      totan = 0.0d0
      totvn = 0.0d0
      do ifn = 1, nfn
         call measfn (ifn,arean,voln)
         totan = totan + arean
         totvn = totvn + voln
      end do
c
c     compute the area and volume lens correction values
c
      alenst = 0.0d0
      alensn = 0.0d0
      vlenst = 0.0d0
      vlensn = 0.0d0
      if (pr .le. 0.0d0)  goto 140
      ndots = maxdot
      call gendot (ndots,dots,pr,0.0d0,0.0d0,0.0d0)
      dota = (4.0d0 * pi * pr**2) / ndots
      do ifn = 1, nfn
         nlap(ifn) = 0
         cora(ifn) = 0.0d0
         corv(ifn) = 0.0d0
         badav(ifn) = .false.
         badt(ifn) = .false.
         do k = 1, 3
            nspt(k,ifn) = 0
         end do
         ien = fnen(1,ifn)
         iv = env(1,ien)
         ip = vp(iv)
         depths(ifn) = depth(ip,alts(1,ifn))
         do k = 1, 3
            fncen(k,ifn) = p(k,ip)
         end do
         ia = va(iv)
c
c     get vertices and vectors
c
         do ke = 1, 3
            ien = fnen(ke,ifn)
            ivs(ke) = env(1,ien)
            ia = va(ivs(ke))
            ifs = enfs(ien)
            ieq = fseq(1,ifs)
            ic = eqc(ieq)
            it = ct(ic)
            fnt(ke,ifn) = it
            fntrev(ke,ifn) = (ta(1,it) .ne. ia)
         end do
         do ke = 1, 3
            do k = 1, 3
               vects(k,ke) = vxyz(k,ivs(ke)) - p(k,ip)
            end do
         end do
c
c     calculate normal vectors for the three planes
c     that cut out the geodesic triangle
c
         call vcross (vects(1,1),vects(1,2),fnvect(1,1,ifn))
         call vnorm (fnvect(1,1,ifn),fnvect(1,1,ifn))
         call vcross (vects(1,2),vects(1,3),fnvect(1,2,ifn))
         call vnorm (fnvect(1,2,ifn),fnvect(1,2,ifn))
         call vcross (vects(1,3),vects(1,1),fnvect(1,3,ifn))
         call vnorm (fnvect(1,3,ifn),fnvect(1,3,ifn))
      end do
      do ifn = 1, nfn-1
         do jfn = ifn+1, nfn
            dij2 = dist2(fncen(1,ifn),fncen(1,jfn))
            if (dij2 .gt. 4.0d0*pr**2)  goto 90
            if (depths(ifn).gt.pr .and. depths(jfn).gt.pr)  goto 90
c
c     these two probes may have intersecting surfaces
c
            dpp = sqrt(dist2(fncen(1,ifn),fncen(1,jfn)))
c
c     compute the midpoint
c
            do k = 1, 3
               ppm(k) = (fncen(k,ifn) + fncen(k,jfn)) / 2.0d0
               upp(k) = (fncen(k,jfn) - fncen(k,ifn)) / dpp
            end do
            rm = pr**2 - (dpp/2.0d0)**2
            if (rm .lt. 0.0d0)  rm = 0.0d0
            rm = sqrt(rm)
            rat = dpp / (2.0d0*pr)
            if (rat .gt. 1.0d0)  rat = 1.0d0
            if (rat .lt. -1.0d0)  rat = -1.0d0
            rho = asin(rat)
c
c     use circle-plane intersection routine
c
            alli = .true.
            anyi = .false.
            spindl = .false.
            do k = 1, 3
               ispind(k) = 0
               ispnd2(k) = 0
            end do
            do ke = 1, 3
               thetaq(ke) = 0.0d0
               sigmaq(ke) = 0.0d0
               tau(ke) = 0.0d0
               call cirpln (ppm,rm,upp,fncen(1,ifn),fnvect(1,ke,ifn),
     &                              cinsp,cintp,xpnt1,xpnt2)
               fcins(ke,ifn) = cinsp
               fcint(ke,ifn) = cintp
               if (.not. cinsp)  alli = .false.
               if (cintp)  anyi = .true.
               if (.not. cintp)  goto 10
               it = fnt(ke,ifn)
               if (tr(it) .gt. pr)  goto 10
               do ke2 = 1, 3
                  if (it .eq. fnt(ke2,jfn)) then
                     ispind(ke) = it
                     nspt(ke,ifn) = nspt(ke,ifn) + 1
                     ispnd2(ke2) = it
                     nspt(ke2,jfn) = nspt(ke2,jfn) + 1
                     spindl = .true.
                  end if
               end do
               if (ispind(ke) .eq. 0)  goto 10
c
c     check that the two ways of calculating
c     intersection points match
c
               rat = tr(it) / pr
               if (rat .gt. 1.0d0)  rat = 1.0d0
               if (rat .lt. -1.0d0)  rat = -1.0d0
               thetaq(ke) = acos(rat)
               stq = sin(thetaq(ke))
               if (fntrev(ke,ifn)) then
                  do k = 1, 3
                     uij(k) = -tax(k,it)
                  end do
               else
                  do k = 1, 3
                     uij(k) = tax(k,it)
                  end do
               end if
               do k = 1, 3
                  qij(k) = t(k,it) - stq * pr * uij(k)
                  qji(k) = t(k,it) + stq * pr * uij(k)
               end do
               do k = 1, 3
                  umq(k) = (qij(k) - ppm(k)) / rm
                  upq(k) = (qij(k) - fncen(k,ifn)) / pr
               end do
               call vcross (uij,upp,vect1)
               dt = dot(umq,vect1)
               if (dt .gt. 1.0d0)  dt = 1.0d0
               if (dt .lt. -1.0d0)  dt = -1.0d0
               sigmaq(ke) = acos(dt)
               call vcross (upq,fnvect(1,ke,ifn),vect1)
               call vnorm (vect1,uc)
               call vcross (upp,upq,vect1)
               call vnorm (vect1,uq)
               dt = dot(uc,uq)
               if (dt .gt. 1.0d0)  dt = 1.0d0
               if (dt .lt. -1.0d0)  dt = -1.0d0
               tau(ke) = pi - acos(dt)
   10          continue
            end do
            allj = .true.
            anyj = .false.
            do ke = 1, 3
               call cirpln (ppm,rm,upp,fncen(1,jfn),fnvect(1,ke,jfn),
     &                              cinsp,cintp,xpnt1,xpnt2)
               fcins(ke,jfn) = cinsp
               fcint(ke,jfn) = cintp
               if (.not. cinsp)  allj = .false.
               if (cintp)  anyj = .true.
            end do
            case1 = (alli .and. allj .and. .not.anyi .and. .not.anyj)
            case2 = (anyi .and. anyj .and. spindl)
            if (.not.case1 .and. .not.case2)  goto 90
c
c     this kind of overlap can be handled
c
            nlap(ifn) = nlap(ifn) + 1
            nlap(jfn) = nlap(jfn) + 1
            do ke = 1, 3
               ien = fnen(ke,ifn)
               iv1 = env(1,ien)
               iv2 = env(2,ien)
               do k = 1, 3
                  vect3(k) = vxyz(k,iv1) - fncen(k,ifn)
                  vect4(k) = vxyz(k,iv2) - fncen(k,ifn)
               end do
               do ke2 = 1, 3
                  if (ispind(ke) .eq. ispnd2(ke2))  goto 40
                  if (ispind(ke) .eq. 0)  goto 40
                  call cirpln (fncen(1,ifn),pr,fnvect(1,ke,ifn),
     &                           fncen(1,jfn),fnvect(1,ke2,jfn),
     &                           cinsp,cintp,xpnt1,xpnt2)
                  if (.not. cintp)  goto 40
                  ien = fnen(ke2,jfn)
                  iv1 = env(1,ien)
                  iv2 = env(2,ien)
                  do k = 1, 3
                     vect7(k) = vxyz(k,iv1) - fncen(k,jfn)
                     vect8(k) = vxyz(k,iv2) - fncen(k,jfn)
                  end do
c
c     check whether point lies on spindle arc
c
                  do k = 1, 3
                     vect1(k) = xpnt1(k) - fncen(k,ifn)
                     vect2(k) = xpnt2(k) - fncen(k,ifn)
                     vect5(k) = xpnt1(k) - fncen(k,jfn)
                     vect6(k) = xpnt2(k) - fncen(k,jfn)
                  end do
                  if (triple(vect3,vect1,fnvect(1,ke,ifn)) .lt. 0.0d0)
     &               goto 20
                  if (triple(vect1,vect4,fnvect(1,ke,ifn)) .lt. 0.0d0)
     &               goto 20
                  if (triple(vect7,vect5,fnvect(1,ke2,jfn)) .lt. 0.0d0)
     &               goto 20
                  if (triple(vect5,vect8,fnvect(1,ke2,jfn)) .lt. 0.0d0)
     &               goto 20
                  goto 30
   20             continue
                  if (triple(vect3,vect2,fnvect(1,ke,ifn)) .lt. 0.0d0)
     &               goto 40
                  if (triple(vect2,vect4,fnvect(1,ke,ifn)) .lt. 0.0d0)
     &               goto 40
                  if (triple(vect7,vect6,fnvect(1,ke2,jfn)) .lt. 0.0d0)
     &               goto 40
                  if (triple(vect6,vect8,fnvect(1,ke2,jfn)) .lt. 0.0d0)
     &               goto 40
   30             continue
                  badav(ifn) = .true.
   40             continue
               end do
            end do
            do ke = 1, 3
               ien = fnen(ke,ifn)
               iv1 = env(1,ien)
               iv2 = env(2,ien)
               do k = 1, 3
                  vect3(k) = vxyz(k,iv1) - fncen(k,ifn)
                  vect4(k) = vxyz(k,iv2) - fncen(k,ifn)
               end do
               do ke2 = 1, 3
                  if (ispind(ke) .eq. ispnd2(ke2))  goto 70
                  if (ispnd2(ke2) .eq. 0)  goto 70
                  call cirpln (fncen(1,jfn),pr,fnvect(1,ke2,jfn),
     &                           fncen(1,ifn),fnvect(1,ke,ifn),
     &                           cinsp,cintp,xpnt1,xpnt2)
                  if (.not. cintp)  goto 70
                  ien = fnen(ke2,jfn)
                  iv1 = env(1,ien)
                  iv2 = env(2,ien)
                  do k = 1, 3
                     vect7(k) = vxyz(k,iv1) - fncen(k,jfn)
                     vect8(k) = vxyz(k,iv2) - fncen(k,jfn)
                  end do
c
c     check whether point lies on spindle arc
c
                  do k = 1, 3
                     vect1(k) = xpnt1(k) - fncen(k,ifn)
                     vect2(k) = xpnt2(k) - fncen(k,ifn)
                     vect5(k) = xpnt1(k) - fncen(k,jfn)
                     vect6(k) = xpnt2(k) - fncen(k,jfn)
                  end do
                  if (triple(vect3,vect1,fnvect(1,ke,ifn)) .lt. 0.0d0)
     &               goto 50
                  if (triple(vect1,vect4,fnvect(1,ke,ifn)) .lt. 0.0d0)
     &               goto 50
                  if (triple(vect7,vect5,fnvect(1,ke2,jfn)) .lt. 0.0d0)
     &               goto 50
                  if (triple(vect5,vect8,fnvect(1,ke2,jfn)) .lt. 0.0d0)
     &               goto 50
                  goto 60
   50             continue
                  if (triple(vect3,vect2,fnvect(1,ke,ifn)) .lt. 0.0d0)
     &               goto 70
                  if (triple(vect2,vect4,fnvect(1,ke,ifn)) .lt. 0.0d0)
     &               goto 70
                  if (triple(vect7,vect6,fnvect(1,ke2,jfn)) .lt. 0.0d0)
     &               goto 70
                  if (triple(vect6,vect8,fnvect(1,ke2,jfn)) .lt. 0.0d0)
     &               goto 70
   60             continue
                  badav(jfn) = .true.
   70             continue
               end do
            end do
            sumlam = 0.0d0
            sumsig = 0.0d0
            sumsc = 0.0d0
            do ke = 1, 3
               if (ispind(ke) .ne. 0) then
                  sumlam = sumlam + pi - tau(ke)
                  sumsig = sumsig + sigmaq(ke) - pi
                  sumsc = sumsc + sin(sigmaq(ke))*cos(sigmaq(ke))
               end if
            end do
            alens = 2.0d0 * pr**2 * (pi - sumlam - sin(rho)*(pi+sumsig))
            vint = alens * pr / 3.0d0
            vcone = pr * rm**2 * sin(rho) * (pi+sumsig) / 3.0d0
            vpyr = pr * rm**2 * sin(rho) * sumsc / 3.0d0
            vlens = vint - vcone + vpyr
            cora(ifn) = cora(ifn) + alens
            cora(jfn) = cora(jfn) + alens
            corv(ifn) = corv(ifn) + vlens
            corv(jfn) = corv(jfn) + vlens
c
c     check for vertex on opposing probe in face
c
            do kv = 1, 3
               vip(kv) = .false.
               ien = fnen(kv,jfn)
               iv = env(1,ien)
               do k = 1, 3
                  vect1(k) = vxyz(k,iv) - fncen(k,ifn)
               end do
               call vnorm (vect1,vect1)
               do ke = 1, 3
                  dt = dot(fnvect(1,ke,ifn),vxyz(1,iv))
                  if (dt .gt. 0.0d0)  goto 80
               end do
               vip(kv) = .true.
   80          continue
            end do
   90       continue
         end do
      end do
      do ifn = 1, nfn
         do ke = 1, 3
            if (nspt(ke,ifn) .gt. 1)  badt(ifn) = .true.
         end do
      end do
      do ifn = 1, nfn
         if (nlap(ifn) .le. 0)  goto 130
c
c     gather all overlapping probes
c
         nop = 0
         do jfn = 1, nfn
            if (ifn .ne. jfn) then
               dij2 = dist2(fncen(1,ifn),fncen(1,jfn))
               if (dij2 .le. 4.0d0*pr**2) then
                  if (depths(jfn) .le. pr) then
                     nop = nop + 1
                     if (nop .gt. maxop) then
                        call cerror ('NOP Overflow in VAM')
                     end if
                     ifnop(nop) = jfn
                     do k = 1, 3
                        cenop(k,nop) = fncen(k,jfn)
                     end do
                  end if
               end if
            end if
         end do
c
c     numerical calculation of the correction
c
         areado = 0.0d0
         voldo = 0.0d0
         scinc = 1.0d0 / nscale
         do isc = 1, nscale
            rsc = isc - 0.5d0
            dotv(isc) = pr * dota * rsc**2 * scinc**3
         end do
         do iop = 1, nop
            ate(iop) = .false.
         end do
         neatmx = 0
         do idot = 1, ndots
            do ke = 1, 3
               dt = dot(fnvect(1,ke,ifn),dots(1,idot))
               if (dt .gt. 0.0d0)  goto 120
            end do
            do k = 1, 3
               tdots(k,idot) = fncen(k,ifn) + dots(k,idot)
            end do
            do iop = 1, nop
               jfn = ifnop(iop)
               ds2 = dist2(tdots(1,idot),fncen(1,jfn))
               if (ds2 .lt. pr**2) then
                  areado = areado + dota
                  goto 100
               end if
            end do
  100       continue
            do isc = 1, nscale
               rsc = isc - 0.5d0
               do k = 1, 3
                  sdot(k) = fncen(k,ifn) + rsc*scinc*dots(k,idot)
               end do
               neat = 0
               do iop = 1, nop
                  jfn = ifnop(iop)
                  ds2 = dist2(sdot,fncen(1,jfn))
                  if (ds2 .lt. pr**2) then
                     do k = 1, 3
                        vect1(k) = sdot(k) - fncen(k,jfn)
                     end do
                     do ke = 1, 3
                        dt = dot(fnvect(1,ke,jfn),vect1)
                        if (dt .gt. 0.0d0)  goto 110
                     end do
                     neat = neat + 1
                     ate(iop) = .true.
  110                continue
                  end if
               end do
               if (neat .gt. neatmx)  neatmx = neat
               if (neat .gt. 0) then
                  voldo = voldo + dotv(isc) * (neat/(1.0d0+neat))
               end if
            end do
  120       continue
         end do
         coran = areado
         corvn = voldo
         nate = 0
         do iop = 1, nop
            if (ate(iop))  nate = nate + 1
         end do
c
c     use either the analytical or numerical correction
c
         usenum = (nate.gt.nlap(ifn) .or. neatmx.gt.1 .or. badt(ifn))
         if (usenum) then
            cora(ifn) = coran
            corv(ifn) = corvn
            alensn = alensn + cora(ifn)
            vlensn = vlensn + corv(ifn)
         else if (badav(ifn)) then
            corv(ifn) = corvn
            vlensn = vlensn + corv(ifn)
         end if
         alenst = alenst + cora(ifn)
         vlenst = vlenst + corv(ifn)
  130    continue
      end do
  140 continue
c
c     print out the decomposition of the area and volume
c
      if (debug) then
         write (iout,150)
  150    format (/,' Convex Surface Area for Individual Atoms :',/)
         k = 1
         do while (k .le. na)
            write (iout,160)  (ia,atmarea(ia),ia=k,min(k+4,na))
  160       format (1x,5(i7,f8.3))
            k = k + 5
         end do
         write (iout,170)
  170    format (/,' Surface Area and Volume by Geometry Type :')
         write (iout,180)  nfq,totaq,totvq
  180    format (/,' Convex Faces :',i12,5x,'Area :',f13.3,
     &              4x,'Volume :',f13.3)
         write (iout,190)  nfs,totas,totvs
  190    format (' Saddle Faces :',i12,5x,'Area :',f13.3,
     &              4x,'Volume :',f13.3)
         write (iout,200)  nfn,totan,totvn
  200    format (' Concave Faces :',i11,5x,'Area :',f13.3,
     &              4x,'Volume :',f13.3)
         write (iout,210)  hedron
  210    format (' Buried Polyhedra :',36x,'Volume :',f13.3)
         if (totasp.ne.0.0d0 .or. totvsp.ne.0.0d0 .or.
     &       alenst.ne.0.0d0 .or. vlenst.ne.0.0d0) then
            write (iout,220)  -totasp,-totvsp
  220       format (/,' Spindle Correction :',11x,'Area :',f13.3,
     &                 4x,'Volume :',f13.3)
            write (iout,230)  -alenst-alensn,vlenst-vlensn
  230       format (' Lens Analytical Correction :',3x,'Area :',f13.3,
     &                 4x,'Volume :',f13.3)
         end if
         if (alensn.ne.0.0d0 .or. vlensn.ne.0.0d0) then
            write (iout,240)  alensn,vlensn
  240       format (' Lens Numerical Correction :',4x,'Area :',f13.3,
     &                 4x,'Volume :',f13.3)
         end if
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (nlap)
      deallocate (enfs)
      deallocate (fnt)
      deallocate (nspt)
      deallocate (atmarea)
      deallocate (depths)
      deallocate (cora)
      deallocate (corv)
      deallocate (alts)
      deallocate (fncen)
      deallocate (fnvect)
      deallocate (badav)
      deallocate (badt)
      deallocate (fcins)
      deallocate (fcint)
      deallocate (fntrev)
c
c     finally, compute the total area and total volume
c
      area = totaq + totas + totan - totasp - alenst
      volume = totvq + totvs + totvn + hedron - totvsp + vlenst
      return
      end
c
c
c     ######################
c     ##                  ##
c     ##  function depth  ##
c     ##                  ##
c     ######################
c
c
      function depth (ip,alt)
      use faces
      implicit none
      integer k,ip,ia1,ia2,ia3
      real*8 depth,dot,alt(3)
      real*8 vect1(3),vect2(3)
      real*8 vect3(3),vect4(3)
c
c
      ia1 = pa(1,ip)
      ia2 = pa(2,ip)
      ia3 = pa(3,ip)
      do k = 1, 3
         vect1(k) = axyz(k,ia1) - axyz(k,ia3)
         vect2(k) = axyz(k,ia2) - axyz(k,ia3)
         vect3(k) = p(k,ip) - axyz(k,ia3)
      end do
      call vcross (vect1,vect2,vect4)
      call vnorm (vect4,vect4)
      depth = dot(vect4,vect3)
      do k = 1, 3
         alt(k) = vect4(k)
      end do
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine measpm  --  volume of interior polyhedron  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "measpm" computes the volume of a single prism section of
c     the full interior polyhedron
c
c
      subroutine measpm (ifn,prism)
      use faces
      implicit none
      integer k,ke,ien
      integer iv,ia,ip,ifn
      real*8 prism,height
      real*8 vect1(3)
      real*8 vect2(3)
      real*8 vect3(3)
      real*8 pav(3,3)
c
c
      height = 0.0d0
      do ke = 1, 3
         ien = fnen(ke,ifn)
         iv = env(1,ien)
         ia = va(iv)
         height = height + axyz(3,ia)
         ip = vp(iv)
         do k = 1, 3
            pav(k,ke) = axyz(k,ia) - p(k,ip)
         end do
      end do
      height = height / 3.0d0
      do k = 1, 3
         vect1(k) = pav(k,2) - pav(k,1)
         vect2(k) = pav(k,3) - pav(k,1)
      end do
      call vcross (vect1,vect2,vect3)
      prism = 0.5d0 * height * vect3(3)
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine measfq  ##
c     ##                     ##
c     #########################
c
c
      subroutine measfq (ifq,areaq,volq)
      use faces
      use math
      implicit none
      integer k,ke,ifq,ieq
      integer ia,ia2,ic
      integer it,iv1,iv2
      integer ncycle,ieuler
      integer icyptr,icy
      integer nedge
      real*8 areaq,volq
      real*8 dot,dt,gauss
      real*8 vecang,angle,geo
      real*8 pcurve,gcurve
      real*8 vect1(3)
      real*8 vect2(3)
      real*8 acvect(3)
      real*8 aavect(3)
      real*8 radial(3,mxcyeq)
      real*8 tanv(3,2,mxcyeq)
c
c
      ia = fqa(ifq)
      pcurve = 0.0d0
      gcurve = 0.0d0
      ncycle = fqncy(ifq)
      if (ncycle .gt. 0) then
         ieuler = 2 - ncycle
      else
         ieuler = 2
      end if
      do icyptr = 1, ncycle
         icy = fqcy(icyptr,ifq)
         nedge = cyneq(icy)
         do ke = 1, nedge
            ieq = cyeq(ke,icy)
            ic = eqc(ieq)
            it = ct(ic)
            if (ia .eq. ta(1,it)) then
               ia2 = ta(2,it)
            else
               ia2 = ta(1,it)
            end if
            do k = 1, 3
               acvect(k) = c(k,ic) - axyz(k,ia)
               aavect(k) = axyz(k,ia2) - axyz(k,ia)
            end do
            call vnorm (aavect,aavect)
            dt = dot(acvect,aavect)
            geo = -dt / (ar(ia)*cr(ic))
            iv1 = eqv(1,ieq)
            iv2 = eqv(2,ieq)
            if (iv1.eq.0 .or. iv2.eq.0) then
               angle = 2.0d0 * pi
            else
               do k = 1, 3
                  vect1(k) = vxyz(k,iv1) - c(k,ic)
                  vect2(k) = vxyz(k,iv2) - c(k,ic)
                  radial(k,ke) = vxyz(k,iv1) - axyz(k,ia)
               end do
               call vnorm (radial(1,ke),radial(1,ke))
               call vcross (vect1,aavect,tanv(1,1,ke))
               call vnorm (tanv(1,1,ke),tanv(1,1,ke))
               call vcross (vect2,aavect,tanv(1,2,ke))
               call vnorm (tanv(1,2,ke),tanv(1,2,ke))
               angle = vecang(vect1,vect2,aavect,-1.0d0)
            end if
            gcurve = gcurve + cr(ic)*angle*geo
            if (nedge .ne. 1) then
               if (ke .gt. 1) then
                  angle = vecang(tanv(1,2,ke-1),tanv(1,1,ke),
     &                               radial(1,ke),1.0d0)
                  if (angle .lt. 0.0d0) then
                     call cerror ('Negative Angle in MEASFQ')
                  end if
                  pcurve = pcurve + angle
               end if
            end if
         end do
         if (nedge .gt. 1) then
            angle = vecang(tanv(1,2,nedge),tanv(1,1,1),
     &                         radial(1,1),1.0d0)
            if (angle .lt. 0.0d0) then
               call cerror ('Negative Angle in MEASFQ')
            end if
            pcurve = pcurve + angle
         end if
      end do
      gauss = 2.0d0*pi*ieuler - pcurve - gcurve
      areaq = gauss * (ar(ia)**2)
      volq = areaq * ar(ia) / 3.0d0
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine measfs  ##
c     ##                     ##
c     #########################
c
c
      subroutine measfs (ifs,areas,vols,areasp,volsp)
      use faces
      use math
      implicit none
      integer k,ifs,ieq
      integer ic,ic1,ic2
      integer it,ia1,ia2
      integer iv1,iv2
      real*8 areas,vols
      real*8 areasp,volsp
      real*8 vecang,phi
      real*8 dot,d1,d2,w1,w2
      real*8 theta1,theta2
      real*8 rat,thetaq
      real*8 cone1,cone2
      real*8 term1,term2
      real*8 term3
      real*8 spin,volt
      real*8 vect1(3)
      real*8 vect2(3)
      real*8 aavect(3)
      logical cusp
c
c
      ieq = fseq(1,ifs)
      ic = eqc(ieq)
      it = ct(ic)
      ia1 = ta(1,it)
      ia2 = ta(2,it)
      do k = 1, 3
         aavect(k) = axyz(k,ia2) - axyz(k,ia1)
      end do
      call vnorm (aavect,aavect)
      iv1 = eqv(1,ieq)
      iv2 = eqv(2,ieq)
      if (iv1.eq.0 .or. iv2.eq.0) then
         phi = 2.0d0 * pi
      else
         do k = 1, 3
            vect1(k) = vxyz(k,iv1) - c(k,ic)
            vect2(k) = vxyz(k,iv2) - c(k,ic)
         end do
         phi = vecang(vect1,vect2,aavect,1.0d0)
      end if
      do k = 1, 3
         vect1(k) = axyz(k,ia1) - t(k,it)
         vect2(k) = axyz(k,ia2) - t(k,it)
      end do
      d1 = -dot(vect1,aavect)
      d2 = dot(vect2,aavect)
      theta1 = atan2(d1,tr(it))
      theta2 = atan2(d2,tr(it))
c
c     check for cusps
c
      if (tr(it).lt.pr .and. theta1.gt.0.0d0
     &                 .and. theta2.gt.0.0d0) then
         cusp = .true.
         rat = tr(it) / pr
         if (rat .gt. 1.0d0)  rat = 1.0d0
         if (rat .lt. -1.0d0)  rat = -1.0d0
         thetaq = acos(rat)
      else
         cusp = .false.
         thetaq = 0.0d0
         areasp = 0.0d0
         volsp = 0.0d0
      end if
      term1 = tr(it) * pr * (theta1+theta2)
      term2 = (pr**2) * (sin(theta1) + sin(theta2))
      areas = phi * (term1-term2)
      if (cusp) then
         spin = tr(it)*pr*thetaq - pr**2 * sin(thetaq)
         areasp = 2.0d0 * phi * spin
      end if
c
      ieq = fseq(1,ifs)
      ic2 = eqc(ieq)
      ieq = fseq(2,ifs)
      ic1 = eqc(ieq)
      if (ca(ic1) .ne. ia1) then
         call cerror ('IA1 Inconsistency in MEASFS')
      end if
      do k = 1, 3
         vect1(k) = c(k,ic1) - axyz(k,ia1)
         vect2(k) = c(k,ic2) - axyz(k,ia2)
      end do
      w1 = dot(vect1,aavect)
      w2 = -dot(vect2,aavect)
      cone1 = phi * (w1*cr(ic1)**2)/6.0d0
      cone2 = phi * (w2*cr(ic2)**2)/6.0d0
      term1 = (tr(it)**2) * pr * (sin(theta1)+sin(theta2))
      term2 = sin(theta1)*cos(theta1) + theta1
     &           + sin(theta2)*cos(theta2) + theta2
      term2 = tr(it) * (pr**2) * term2
      term3 = sin(theta1)*cos(theta1)**2 + 2.0d0*sin(theta1)
     &           + sin(theta2)*cos(theta2)**2 + 2.0d0*sin(theta2)
      term3 = (pr**3 / 3.0d0) * term3
      volt = (phi/2.0d0) * (term1-term2+term3)
      vols = volt + cone1 + cone2
      if (cusp) then
         term1 = (tr(it)**2) * pr * sin(thetaq)
         term2 = sin(thetaq)*cos(thetaq) + thetaq
         term2 = tr(it) * (pr**2) * term2
         term3 = sin(thetaq)*cos(thetaq)**2 + 2.0d0*sin(thetaq)
         term3 = (pr**3 / 3.0d0) * term3
         volsp = phi * (term1-term2+term3)
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine measfn  ##
c     ##                     ##
c     #########################
c
c
      subroutine measfn (ifn,arean,voln)
      use faces
      use math
      implicit none
      integer k,ke,je
      integer ifn,ien
      integer iv,ia,ip
      real*8 arean,voln
      real*8 vecang,triple
      real*8 defect,simplx
      real*8 angle(3)
      real*8 pvv(3,3)
      real*8 pav(3,3)
      real*8 planev(3,3)
c
c
      do ke = 1, 3
         ien = fnen(ke,ifn)
         iv = env(1,ien)
         ia = va(iv)
         ip = vp(iv)
         do k = 1, 3
            pvv(k,ke) = vxyz(k,iv) - p(k,ip)
            pav(k,ke) = axyz(k,ia) - p(k,ip)
         end do
         if (pr .gt. 0.0d0)  call vnorm (pvv(1,ke),pvv(1,ke))
      end do
      if (pr .le. 0.0d0) then
         arean = 0.0d0
      else
         do ke = 1, 3
            je = ke + 1
            if (je .gt. 3)  je = 1
            call vcross (pvv(1,ke),pvv(1,je),planev(1,ke))
            call vnorm (planev(1,ke),planev(1,ke))
         end do
         do ke = 1, 3
            je = ke - 1
            if (je .lt. 1)  je = 3
            angle(ke) = vecang(planev(1,je),planev(1,ke),
     &                             pvv(1,ke),-1.0d0)
            if (angle(ke) .lt. 0.0d0) then
               call cerror ('Negative Angle in MEASFN')
            end if
         end do
         defect = 2.0d0*pi - (angle(1)+angle(2)+angle(3))
         arean = (pr**2) * defect
      end if
      simplx = -triple(pav(1,1),pav(1,2),pav(1,3)) / 6.0d0
      voln = simplx - arean*pr/3.0d0
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine projct  ##
c     ##                     ##
c     #########################
c
c
      subroutine projct (pnt,unvect,icy,ia,spv,nedge,fail)
      use faces
      implicit none
      integer k,ke,icy,ia
      integer nedge,ieq,iv
      real*8 dot,dt,f
      real*8 polev(3)
      real*8 pnt(3)
      real*8 unvect(3)
      real*8 spv(3,*)
      logical fail
c
c
      fail = .false.
      nedge = cyneq(icy)
      do ke = 1, cyneq(icy)
c
c     vertex number (use first vertex of edge)
c
         ieq = cyeq(ke,icy)
         iv = eqv(1,ieq)
         if (iv .ne. 0) then
c
c     vector from north pole to vertex
c
            do k = 1, 3
               polev(k) = vxyz(k,iv) - pnt(k)
            end do
c
c     calculate multiplication factor
c
            dt = dot(polev,unvect)
            if (dt .eq. 0.0d0) then
               fail = .true.
               return
            end if
            f = (ar(ia)*2) / dt
            if (f .lt. 1.0d0) then
               fail = .true.
               return
            end if
c
c     projected vertex for this convex edge
c
            do k = 1, 3
               spv(k,ke) = pnt(k) + f*polev(k)
               continue
            end do
         end if
      end do
      return
      end
c
c
c     #######################
c     ##                   ##
c     ##  function ptincy  ##
c     ##                   ##
c     #######################
c
c
      function ptincy (pnt,unvect,icy)
      use faces
      implicit none
      integer k,ke,icy,ieq
      integer ic,it,iatom
      integer iaoth,nedge
      real*8 dot,rotang
      real*8 totang
      real*8 unvect(3)
      real*8 pnt(3)
      real*8 acvect(3)
      real*8 cpvect(3)
      real*8 spv(3,mxcyeq)
      real*8 equ(3,mxcyeq)
      logical ptincy,fail
c
c
c     check for eaten by neighbor
c
      do ke = 1, cyneq(icy)
         ieq = cyeq(ke,icy)
         ic = eqc(ieq)
         it = ct(ic)
         iatom = ca(ic)
         if (ta(1,it) .eq. iatom) then
            iaoth = ta(2,it)
         else
            iaoth = ta(1,it)
         end if
         do k = 1, 3
            acvect(k) = axyz(k,iaoth) - axyz(k,iatom)
            cpvect(k) = pnt(k) - c(k,ic)
         end do
         if (dot(acvect,cpvect) .ge. 0.0d0) then
            ptincy = .false.
            return
         end if
      end do
      if (cyneq(icy) .le. 2) then
         ptincy = .true.
         return
      end if
      call projct (pnt,unvect,icy,iatom,spv,nedge,fail)
      if (fail) then
         ptincy = .true.
         return
      end if
      call equclc (spv,nedge,equ)
      totang = rotang(equ,nedge,unvect)
      ptincy = (totang .gt. 0.0d0)
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine equclc  ##
c     ##                     ##
c     #########################
c
c
      subroutine equclc (spv,nedge,equ)
      implicit none
      integer k,ke,ke2,le
      integer nedge
      real*8 anorm,equn
      real*8 spv(3,*)
      real*8 equ(3,*)
c
c
c     calculate unit vectors along edges
c
      do ke = 1, nedge
c
c     get index of second edge of corner
c
         if (ke .lt. nedge) then
            ke2 = ke + 1
         else
            ke2 = 1
         end if
c
c     unit vector along edge of cycle
c
         do k = 1, 3
            equ(k,ke) = spv(k,ke2) - spv(k,ke)
         end do
         equn = anorm(equ(1,ke))
c        if (equn .le. 0.0d0)  call cerror ('Null Edge in Cycle')
c
c     normalize
c
         if (equn .gt. 0.0d0) then
            do k = 1, 3
               equ(k,ke) = equ(k,ke) / equn
            end do
         else
            do k = 1, 3
               equ(k,ke) = 0.0d0
            end do
         end if
      end do
c
c     vectors for null edges come from following or preceding edges
c
      do ke = 1, nedge
         if (anorm(equ(1,ke)) .le. 0.0d0) then
            le = ke - 1
            if (le .le. 0)  le = nedge
            do k = 1, 3
               equ(k,ke) = equ(k,le)
            end do
         end if
      end do
      return
      end
c
c
c     #######################
c     ##                   ##
c     ##  function rotang  ##
c     ##                   ##
c     #######################
c
c
      function rotang (equ,nedge,unvect)
      implicit none
      integer ke,nedge
      real*8 rotang,totang
      real*8 dot,dt,ang
      real*8 unvect(3)
      real*8 crs(3)
      real*8 equ(3,*)
c
c
      totang = 0.0d0
c
c     sum angles at vertices of cycle
c
      do ke = 1, nedge
         if (ke .lt. nedge) then
            dt = dot(equ(1,ke),equ(1,ke+1))
            call vcross (equ(1,ke),equ(1,ke+1),crs)
         else
c
c     closing edge of cycle
c
            dt = dot(equ(1,ke),equ(1,1))
            call vcross (equ(1,ke),equ(1,1),crs)
         end if
         if (dt .lt. -1.0d0)  dt = -1.0d0
         if (dt .gt. 1.0d0)  dt = 1.0d0
         ang = acos(dt)
         if (dot(crs,unvect) .gt. 0.0d0)  ang = -ang
c
c     add to total for cycle
c
         totang = totang + ang
      end do
      rotang = totang
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine vcross  --  find cross product of two vectors  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "vcross" finds the cross product of two vectors
c
c
      subroutine vcross (x,y,z)
      implicit none
      real*8 x(3),y(3),z(3)
c
c
      z(1) = x(2)*y(3) - x(3)*y(2)
      z(2) = x(3)*y(1) - x(1)*y(3)
      z(3) = x(1)*y(2) - x(2)*y(1)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  function dot  --  find the dot product of two vectors  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "dot" finds the dot product of two vectors
c
c
      function dot (x,y)
      implicit none
      real*8 dot,x(3),y(3)
c
c
      dot = x(1)*y(1) + x(2)*y(2) + x(3)*y(3)
      return
      end
c
c
c     #######################################################
c     ##                                                   ##
c     ##  function anorm  --  find the length of a vector  ##
c     ##                                                   ##
c     #######################################################
c
c
c     "anorm" finds the norm (length) of a vector; used as a
c     service routine by the Connolly surface area and volume
c     computation
c
c
      function anorm (x)
      implicit none
      real*8 anorm,x(3)
c
c
      anorm = x(1)**2 + x(2)**2 + x(3)**2
      if (anorm .lt. 0.0d0)  anorm = 0.0d0
      anorm = sqrt(anorm)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine vnorm  --  normalize a vector to unit length  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "vnorm" normalizes a vector to unit length; used as a
c     service routine by the Connolly surface area and volume
c     computation
c
c
      subroutine vnorm (x,xn)
      implicit none
      integer k
      real*8 ax,anorm
      real*8 x(3),xn(3)
c
c
      ax = anorm(x)
      do k = 1, 3
         xn(k) = x(k) / ax
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  function dist2  --  distance squared between two points  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "dist2" finds the distance squared between two points; used
c     as a service routine by the Connolly surface area and volume
c     computation
c
c
      function dist2 (x,y)
      implicit none
      real*8 dist2
      real*8 x(3),y(3)
c
c
      dist2 = (x(1)-y(1))**2 + (x(2)-y(2))**2 + (x(3)-y(3))**2
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  function triple  --  form triple product of three vectors  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "triple" finds the triple product of three vectors; used as
c     a service routine by the Connolly surface area and volume
c     computation
c
c
      function triple (x,y,z)
      implicit none
      real*8 triple,dot
      real*8 x(3),y(3)
      real*8 z(3),xy(3)
c
c
      call vcross (x,y,xy)
      triple = dot(xy,z)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function vecang  --  finds the angle between two vectors  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "vecang" finds the angle between two vectors handed with respect
c     to a coordinate axis; returns an angle in the range [0,2*pi]
c
c
      function vecang (v1,v2,axis,hand)
      use math
      implicit none
      real*8 vecang,hand
      real*8 angle,dt
      real*8 a1,a2,a12
      real*8 anorm,dot
      real*8 triple
      real*8 v1(3),v2(3)
      real*8 axis(3)
c
c
      a1 = anorm(v1)
      a2 = anorm(v2)
      dt = dot(v1,v2)
      a12 = a1 * a2
      if (abs(a12) .ne. 0.0d0)  dt = dt/a12
      if (dt .lt. -1.0d0)  dt = -1.0d0
      if (dt .gt. 1.0d0)  dt = 1.0d0
      angle = acos(dt)
      if (hand*triple(v1,v2,axis) .lt. 0.0d0) then
         vecang = 2.0d0*pi - angle
      else
         vecang = angle
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine cirpln  --  locate circle-plane intersection  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "cirpln" determines the points of intersection between a
c     specified circle and plane
c
c
      subroutine cirpln (circen,cirrad,cirvec,plncen,plnvec,
     &                        cinsp,cintp,xpnt1,xpnt2)
      implicit none
      integer k
      real*8 anorm,dot
      real*8 dcp,dir
      real*8 ratio,rlen
      real*8 cirrad
      real*8 circen(3)
      real*8 cirvec(3)
      real*8 plncen(3)
      real*8 plnvec(3)
      real*8 xpnt1(3)
      real*8 xpnt2(3)
      real*8 cpvect(3)
      real*8 pnt1(3)
      real*8 vect1(3)
      real*8 vect2(3)
      real*8 uvect1(3)
      real*8 uvect2(3)
      logical cinsp
      logical cintp
c
c
      do k = 1, 3
         cpvect(k) = plncen(k) - circen(k)
      end do
      dcp = dot(cpvect,plnvec)
      cinsp = (dcp .gt. 0.0d0)
      call vcross (plnvec,cirvec,vect1)
      if (anorm(vect1) .gt. 0.0d0) then
         call vnorm (vect1,uvect1)
         call vcross (cirvec,uvect1,vect2)
         if (anorm(vect2) .gt. 0.0d0) then
            call vnorm (vect2,uvect2)
            dir = dot(uvect2,plnvec)
            if (dir .ne. 0.0d0) then
               ratio = dcp / dir
               if (abs(ratio) .le. cirrad) then
                  do k = 1, 3
                     pnt1(k) = circen(k) + ratio*uvect2(k)
                  end do
                  rlen = cirrad**2 - ratio**2
                  if (rlen .lt. 0.0d0)  rlen = 0.0d0
                  rlen = sqrt(rlen)
                  do k = 1, 3
                     xpnt1(k) = pnt1(k) - rlen*uvect1(k)
                     xpnt2(k) = pnt1(k) + rlen*uvect1(k)
                  end do
                  cintp = .true.
                  return
               end if
            end if
         end if
      end if
      cintp = .false.
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine gendot  --  find surface points on unit sphere  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "gendot" finds the coordinates of a specified number of surface
c     points for a sphere with the input radius and coordinate center
c
c
      subroutine gendot (ndots,dots,radius,xcenter,ycenter,zcenter)
      use math
      implicit none
      integer i,j,k
      integer ndots
      integer nequat
      integer nvert
      integer nhoriz
      real*8 fi,fj
      real*8 x,y,z,xy
      real*8 xcenter
      real*8 ycenter
      real*8 zcenter
      real*8 radius
      real*8 dots(3,*)
c
c
      nequat = int(sqrt(pi*dble(ndots)))
      nvert = int(0.5d0*dble(nequat))
      if (nvert .lt. 1)  nvert = 1
      k = 0
      do i = 0, nvert
         fi = (pi * dble(i)) / dble(nvert)
         z = cos(fi)
         xy = sin(fi)
         nhoriz = int(dble(nequat)*xy)
         if (nhoriz .lt. 1)  nhoriz = 1
         do j = 0, nhoriz-1
            fj = (2.0d0 * pi * dble(j)) / dble(nhoriz)
            x = cos(fj) * xy
            y = sin(fj) * xy
            k = k + 1
            dots(1,k) = x*radius + xcenter
            dots(2,k) = y*radius + ycenter
            dots(3,k) = z*radius + zcenter
            if (k .ge. ndots)  goto 10
         end do
      end do
   10 continue
      ndots = k
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine cerror  --  surface area-volume error message  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "cerror" is the error handling routine for the Connolly
c     surface area and volume computation
c
c
      subroutine cerror (string)
      use iounit
      implicit none
      integer leng,trimtext
      character*(*) string
c
c
c     write out the error message and quit
c
      leng = trimtext (string)
      write (iout,10)  string(1:leng)
   10 format (/,' CONNOLLY  --  ',a)
      call fatal
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine control  --  set information and output types  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "control" gets initial values for parameters that determine
c     the output style and information level provided by Tinker
c
c
      subroutine control
      use argue
      use inform
      use keys
      use output
      implicit none
      integer i,next
      logical exist
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set default values for information and output variables
c
      digits = 4
      verbose = .false.
      debug = .false.
      holdup = .false.
      abort = .false.
      arcsave = .false.
      dcdsave = .false.
      cyclesave = .false.
      noversion = .false.
      overwrite = .false.
c
c     check for control parameters on the command line
c
      exist = .false.
      do i = 1, narg
         string = arg(i)
         call upcase (string)
         if (string(1:2) .eq. '-D') then
            debug = .true.
            verbose = .true.
         else if (string(1:2) .eq. '-V') then
            verbose = .true.
         end if
      end do
c
c     search keywords for various control parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'DIGITS ') then
            string = record(next:240)
            read (string,*,err=10,end=10)  digits
         else if (keyword(1:6) .eq. 'DEBUG ') then
            debug = .true.
            verbose = .true.
         else if (keyword(1:8) .eq. 'VERBOSE ') then
            verbose = .true.
         else if (keyword(1:11) .eq. 'EXIT-PAUSE ') then
            holdup = .true.
         else if (keyword(1:8) .eq. 'ARCHIVE ') then
            arcsave = .true.
            dcdsave = .false.
         else if (keyword(1:12) .eq. 'DCD-ARCHIVE ') then
            arcsave = .false.
            dcdsave = .true.
         else if (keyword(1:10) .eq. 'NOARCHIVE ') then
            arcsave = .false.
            dcdsave = .false.
            cyclesave = .false.
         else if (keyword(1:11) .eq. 'SAVE-CYCLE ') then
            dcdsave = .false.
            cyclesave = .true.
         else if (keyword(1:10) .eq. 'NOVERSION ') then
            noversion = .true.
         else if (keyword(1:10) .eq. 'OVERWRITE ') then
            overwrite = .true.
         end if
   10    continue
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  program correlate  --  time correlation of a property  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "correlate" computes the time correlation function of some
c     user-supplied property from individual snapshot frames taken
c     from a molecular dynamics or other trajectory
c
c
      program correlate
      use ascii
      use atoms
      use files
      use inform
      use iounit
      implicit none
      integer maxsite,maxblock
      parameter (maxsite=1000)
      parameter (maxblock=1000)
      integer i,j,k,m
      integer n1,n2,dt
      integer first,last,mode
      integer start,stop,step
      integer nframe,nblock,maxgap
      integer blksize,blkgap,blkdiff
      integer, allocatable :: t1(:)
      integer, allocatable :: t2(:)
      integer, allocatable :: icorr(:)
      real*8 value,property
      real*8, allocatable :: vcorr(:)
      real*8, allocatable :: x1(:,:)
      real*8, allocatable :: y1(:,:)
      real*8, allocatable :: z1(:,:)
      real*8, allocatable :: x2(:,:)
      real*8, allocatable :: y2(:,:)
      real*8, allocatable :: z2(:,:)
      logical exist,query,normal
      character*240 string
c
c
c     determine the desired type of time correlation function
c
      call initial
      mode = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  mode
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' The Tinker Correlation Function Utility Can :',
     &           //,4x,'(1) Find Velocity Autocorrelation Function',
     &           /,4x,'(2) Find Superposition Correlation Function')
         do while (mode.lt.1 .or. mode.gt.2)
            mode = 0
            write (iout,30)
   30       format (/,' Enter the Number of the Desired Choice :  ',$)
            read (input,40,err=50,end=50)  mode
   40       format (i10)
   50       continue
         end do
      end if
c
c     get the base name of user specified input structures
c
      call nextarg (filename,exist)
      if (.not. exist) then
         write (iout,60)
   60    format (/,' Enter Base Name of Coordinate Cycle Files :  ',$)
         read (input,70)  filename
   70    format (a240)
      end if
      call basefile (filename)
c
c     set first and last snapshot frames and step increment
c
      first = 0
      last = 0
      step = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=80,end=80)  first
         query = .false.
      end if
      call nextarg (string,exist)
      if (exist)  read (string,*,err=80,end=80)  last
      call nextarg (string,exist)
      if (exist)  read (string,*,err=80,end=80)  step
   80 continue
      if (query) then
         write (iout,90)
   90    format (/,' Numbers of First & Last File and Step',
     &              ' Increment :  ',$)
         read (input,100)  string
  100    format (a240)
         read (string,*,err=110,end=110)  first,last,step
  110    continue
      end if
      if (last .eq. 0)  last = first
      if (step .eq. 0)  step = 1
c
c     set the maximum frame separation to be used for correlation
c
      maxgap = last - first
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=120,end=120)  maxgap
         query = .false.
      end if
  120 continue
      if (query) then
         write (iout,130)
  130    format (/,' Maximum Frame Separation to be Used in',
     &              ' Correlation [ALL] :  ',$)
         read (input,140)  string
  140    format (a240)
         read (string,*,err=150,end=150)  maxgap
  150    continue
      end if
      if (maxgap .eq. 0)  maxgap = last - first
c
c     get the number of frame blocks from the total frames
c
      nframe = 1 + (last-first)/step
      nblock = 1 + (nframe-1)/maxblock
      blksize = maxblock * step
      blkgap = 1 + (maxgap-1)/blksize
      write (iout,160)  nblock,min(nframe,maxblock)
  160 format (/,' Correlation Function Computed using',i5,
     &           ' Blocks of',i6,' Frames')
c
c     perform dynamic allocation of some local arrays
c
      allocate (t1(maxblock))
      allocate (t2(maxblock))
      allocate (icorr(0:maxgap))
      allocate (vcorr(0:maxgap))
      allocate (x1(maxsite,maxblock))
      allocate (y1(maxsite,maxblock))
      allocate (z1(maxsite,maxblock))
      allocate (x2(maxsite,maxblock))
      allocate (y2(maxsite,maxblock))
      allocate (z2(maxsite,maxblock))
c
c     zero out the time correlation function cumulative values
c
      do i = 0, maxgap
         icorr(i) = 0
         vcorr(i) = 0.0d0
      end do
c
c     cycle over all pairs of snapshot frame blocks
c
      do i = 1, nblock
         start = first + (i-1) * blksize
         stop = start + blksize - step
         stop = min(last,stop)
         call readblk (mode,start,stop,step,n1,t1,x1,y1,z1)
         write (iout,170)  i
  170    format (/,3x,'Correlation within Frame Block :    ',i8)
c
c     compute time correlation for frames within single block
c
         do k = 1, n1
            do m = k, n1
               dt = t1(m) - t1(k)
               if (dt .le. maxgap) then
                  value = property (mode,k,x1,y1,z1,m,x1,y1,z1)
                  icorr(dt) = icorr(dt) + 1
                  vcorr(dt) = vcorr(dt) + value
               end if
            end do
         end do
c
c     compute time correlation for frames between two blocks
c
         do j = i+1, min(i+blkgap,nblock)
            start = first + (j-1) * blksize
            stop = start + blksize - step
            stop = min(last,stop)
            blkdiff = (j-i) * maxblock
            call readblk (mode,start,stop,step,n2,t2,x2,y2,z2)
            write (iout,180)  i,j
  180       format (3x,'Correlation between Frame Blocks :  ',2i8)
            do k = 1, n1
               do m = 1, n2
                  dt = t2(m) - t1(k) + blkdiff
                  if (dt .le. maxgap) then
                     value = property (mode,k,x1,y1,z1,m,x2,y2,z2)
                     icorr(dt) = icorr(dt) + 1
                     vcorr(dt) = vcorr(dt) + value
                  end if
               end do
            end do
         end do
      end do
c
c     compute the average correlation function values
c
      do i = 0, maxgap
         if (icorr(i) .ne. 0)  vcorr(i) = vcorr(i)/dble(icorr(i))
      end do
      normal = .false.
      if (vcorr(0) .ne. 0.0d0)  normal = .true.
c
c     print the final values of the correlation function
c
      if (normal) then
         write (iout,190)
  190    format (/,3x,'Separation',7x,'Samples',8x,'Average Value',
     &              7x,'Normalized',/)
         do i = 0, maxgap
            if (icorr(i) .ne. 0) then
               write (iout,200)  i*step,icorr(i),vcorr(i),
     &                           vcorr(i)/vcorr(0)
  200          format (i9,6x,i10,6x,2f17.6)
            end if
         end do
      else
         write (iout,210)
  210    format (/,3x,'Separation',7x,'Samples',8x,'Average Value',/)
         do i = 0, maxgap
            if (icorr(i) .ne. 0) then
               write (iout,220)  i*step,icorr(i),vcorr(i)
  220          format (i9,6x,i10,6x,f17.6)
            end if
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (t1)
      deallocate (t2)
      deallocate (icorr)
      deallocate (vcorr)
      deallocate (x1)
      deallocate (y1)
      deallocate (z1)
      deallocate (x2)
      deallocate (y2)
      deallocate (z2)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine readblk  --  read a block of snapshot frames  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "readblk" reads in a set of snapshot frames and transfers
c     the values to internal arrays for use in the computation
c     of time correlation functions
c
c
      subroutine readblk (mode,start,stop,step,nb,tb,xb,yb,zb)
      use atomid
      use atoms
      use files
      use iounit
      implicit none
      integer maxsite
      parameter (maxsite=1000)
      integer i,k,ixyz
      integer nt,nb,mode
      integer start,stop
      integer next,label
      integer step,lext
      integer freeunit
      integer tb(*)
      real*8 xb(maxsite,*)
      real*8 yb(maxsite,*)
      real*8 zb(maxsite,*)
      logical exist
      character*7 ext
      character*240 record
      character*240 string
      character*240 xyzfile
c
c
c     initialize the number of files and the numeral size
c
      nt = 0
      nb = 0
      lext = 3
c
c     cycle over all snapshot frames in the block of files
c
      do i = start, stop, step
         nt = nt + 1
         call numeral (i,ext,lext)
         if (mode .eq. 1) then
            xyzfile = filename(1:leng)//'.'//ext(1:lext)//'v'
         else if (mode .eq. 2) then
            xyzfile = filename(1:leng)//'.'//ext(1:lext)
         end if
         inquire (file=xyzfile,exist=exist)
c
c     add file to the current block and get number of atoms
c
         if (exist) then
            nb = nb + 1
            tb(nb) = nt
            ixyz = freeunit ()
            open (unit=ixyz,file=xyzfile,status='old')
            read (ixyz,10)  record
   10       format (a240)
            read (record,*)  n
c
c     check for too many correlation sites in the frame
c
            if (n .gt. maxsite) then
               write (iout,20)
   20          format (/,' READBLK  --  Too many Correlation Sites;',
     &                    ' Increase MAXSITE')
               call fatal
            end if
c
c     read the frame in the Tinker-generated coordinate format;
c     this is fast, but assumes the fixed format shown below
c
c           do k = 1, n
c              read (ixyz,30)  name(k),xb(k,nb),yb(k,nb),zb(k,nb)
c  30          format (8x,a3,3f12.6)
c           end do
c
c     alternatively, get each frame from a free formated file;
c     this is slow, but correctly handles any valid Tinker file
c
            do k = 1, n
               next = 1
               read (ixyz,30)  record
   30          format (a240)
               read (record,*)  label
               call getword (record,name(k),next)
               string = record(next:240)
               read (string,*)  xb(k,nb),yb(k,nb),zb(k,nb)
            end do
            close (unit=ixyz)
         end if
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  function property  --  compute correlation property value  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "property" takes two input snapshot frames and computes the
c     value of the property for which the correlation function is
c     being accumulated
c
c     this version of "property" finds the velocity autocorrelation
c     or the rms fit as a function of time, and is merely provided
c     as an example; the user will need to write a similar custom
c     function to compute other properties to be correlated
c
c
      function property (mode,i,xi,yi,zi,k,xk,yk,zk)
      use atoms
      implicit none
      integer maxsite
      parameter (maxsite=1000)
      integer i,j,k,mode
      real*8 property,value
      real*8, allocatable :: x1(:)
      real*8, allocatable :: y1(:)
      real*8, allocatable :: z1(:)
      real*8, allocatable :: x2(:)
      real*8, allocatable :: y2(:)
      real*8, allocatable :: z2(:)
      real*8 xi(maxsite,*)
      real*8 yi(maxsite,*)
      real*8 zi(maxsite,*)
      real*8 xk(maxsite,*)
      real*8 yk(maxsite,*)
      real*8 zk(maxsite,*)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (x1(maxsite))
      allocate (y1(maxsite))
      allocate (z1(maxsite))
      allocate (x2(maxsite))
      allocate (y2(maxsite))
      allocate (z2(maxsite))
c
c     transfer the input trajectory frames to local vectors
c
      value = 0.0d0
      do j = 1, n
         x1(j) = xi(j,i)
         y1(j) = yi(j,i)
         z1(j) = zi(j,i)
         x2(j) = xk(j,k)
         y2(j) = yk(j,k)
         z2(j) = zk(j,k)
      end do
c
c     sample code to find the velocity autocorrelation function
c
      if (mode .eq. 1) then
         do j = 1, n
            value = value + x1(j)*x2(j) + y1(j)*y2(j) + z1(j)*z2(j)
         end do
      end if
c
c     sample code to find the rms deviation upon superposition
c
      if (mode .eq. 2) then
         call impose (n,x1,y1,z1,n,x2,y2,z2,value)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (x1)
      deallocate (y1)
      deallocate (z1)
      deallocate (x2)
      deallocate (y2)
      deallocate (z2)
c
c     set property value to be returned for this frame pair
c
      property = value
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module couple  --  atom neighbor connectivity lists   ##
c     ##                                                        ##
c     ############################################################
c
c
c     n12      number of atoms directly bonded to each atom
c     n13      number of atoms in a 1-3 relation to each atom
c     n14      number of atoms in a 1-4 relation to each atom
c     n15      number of atoms in a 1-5 relation to each atom
c     i12      atom numbers of atoms 1-2 connected to each atom
c     i13      atom numbers of atoms 1-3 connected to each atom
c     i14      atom numbers of atoms 1-4 connected to each atom
c     i15      atom numbers of atoms 1-5 connected to each atom
c
c
      module couple
      use sizes
      implicit none
      integer n12(maxatm)
      integer, allocatable :: n13(:)
      integer, allocatable :: n14(:)
      integer, allocatable :: n15(:)
      integer i12(maxval,maxatm)
      integer, allocatable :: i13(:,:)
      integer, allocatable :: i14(:,:)
      integer, allocatable :: i15(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2020  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  program critical  --  stationary point by least squares  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "critical" finds a stationary point for a molecular system via
c     least squares minimization of the atomic gradient components
c
c
      program critical
      use sizes
      use atoms
      use files
      use freeze
      use inform
      use iounit
      use keys
      use minima
      use usage
      implicit none
      integer i,j,k,next
      integer nvar,nrsd
      integer imin,freeunit
      real*8 epot,grdmin
      real*8 gnorm,grms
      real*8, allocatable :: xx(:)
      real*8, allocatable :: xlo(:)
      real*8, allocatable :: xhi(:)
      real*8, allocatable :: rsd(:)
      real*8, allocatable :: grd(:)
      real*8, allocatable :: derivs(:,:)
      real*8, allocatable :: fjac(:,:)
      logical exist
      character*20 keyword
      character*240 minfile
      character*240 record
      character*240 string
      external critical1
      external critsave
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     search the keywords for output frequency parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:120)
         if (keyword(1:9) .eq. 'PRINTOUT ') then
            read (string,*,err=10,end=10)  iprint
         else if (keyword(1:9) .eq. 'WRITEOUT ') then
            read (string,*,err=10,end=10)  iwrite
         end if
   10    continue
      end do
c
c     get termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=20,end=20)  grdmin
   20 continue
      if (grdmin .le. 0.0d0) then
         write (iout,30)
   30    format (/,' Enter Residual Gradient Convergence Criterion',
     &              ' [1.0] :  ',$)
         read (input,40)  grdmin
   40    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 1.0d0
c
c     write out a copy of coordinates for later update
c
      imin = freeunit ()
      minfile = filename(1:leng)//'.xyz'
      call version (minfile,'new')
      open (unit=imin,file=minfile,status='new')
      call prtxyz (imin)
      close (unit=imin)
      outfile = minfile
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(3*n))
      allocate (derivs(3,n))
c
c     set active atom coordinates as optimization variables
c
      nvar = 0
      do i = 1, n
         k = iuse(i)
         nvar = nvar + 1
         xx(nvar) = x(k)
         nvar = nvar + 1
         xx(nvar) = y(k)
         nvar = nvar + 1
         xx(nvar) = z(k)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (xlo(3*n))
      allocate (xhi(3*n))
      allocate (rsd(3*n))
      allocate (grd(3*n))
      allocate (fjac(3*n,3*n))
c
c     make the call to the least squares optimization routine
c
      maxiter = 10000
      nrsd = nvar
      do i = 1, nvar
         xlo(i) = -1000000.0d0
         xhi(i) = 1000000.0d0
      end do
      call square (nvar,nrsd,xlo,xhi,xx,rsd,grd,fjac,
     &                grdmin,critical1,critsave)
c
c     perform deallocation of some local arrays
c
      deallocate (xlo)
      deallocate (xhi)
      deallocate (rsd)
      deallocate (grd)
      deallocate (fjac)
c
c     unpack the final coordinates for active atoms
c
      nvar = 0
      do i = 1, n
         k = iuse(i)
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     compute the final function and RMS gradient values
c
      call gradient (epot,derivs)
      if (use_freeze)  call shakeg (derivs)
      gnorm = 0.0d0
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            gnorm = gnorm + derivs(j,k)**2
         end do
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(nvar/3))
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      deallocate (derivs)
c
c     write out the final function and gradient values
c
      if (digits .ge. 8) then
         if (grms .gt. 1.0d-8) then
            write (iout,50)  epot,grms,gnorm
   50       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,f20.8,
     &              /,' Final Gradient Norm :',3x,f20.8)
         else
            write (iout,60)  epot,grms,gnorm
   60       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,d20.8,
     &              /,' Final Gradient Norm :',3x,d20.8)
         end if
      else if (digits .ge. 6) then
         if (grms .gt. 1.0d-6) then
            write (iout,70)  epot,grms,gnorm
   70       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,f18.6,
     &              /,' Final Gradient Norm :',3x,f18.6)
         else
            write (iout,80)  epot,grms,gnorm
   80       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,d18.6,
     &              /,' Final Gradient Norm :',3x,d18.6)
         end if
      else
         if (grms .gt. 1.0d-4) then
            write (iout,90)  epot,grms,gnorm
   90       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,f16.4,
     &              /,' Final Gradient Norm :',3x,f16.4)
         else
            write (iout,100)  epot,grms,gnorm
  100       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,d16.4,
     &              /,' Final Gradient Norm :',3x,d16.4)
         end if
      end if
c
c     write the final coordinates into a file
c
      imin = freeunit ()
      open (unit=imin,file=minfile,status='old')
      rewind (unit=imin)
      call prtxyz (imin)
      close (unit=imin)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine critical1  --  least squares gradient residual  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "trudge1" is a service routine to compute gradient components
c     for a least squares minimization to a stationary point
c
c
      subroutine critical1 (nvar,nrsd,xx,rsd)
      use sizes
      use atoms
      use freeze
      use usage
      implicit none
      integer i,k
      integer nvar
      integer nrsd
      real*8 epot 
      real*8 xx(*)
      real*8 rsd(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         x(k) = xx(nvar)
         nvar = nvar + 1
         y(k) = xx(nvar)
         nvar = nvar + 1
         z(k) = xx(nvar)
      end do
c
c     adjust atomic coordinates to satisfy distance constraints
c
      if (use_freeze)  call shake (x,y,z)
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute energy and gradient for the current structure
c
      call gradient (epot,derivs)
c
c     adjust gradient to remove components along constraints
c
      if (use_freeze)  call shakeg (derivs)
c
c     store the gradient components as the residual vector
c
      nvar = 0
      do i = 1, n
         k = iuse(i)
         nvar = nvar + 1
         xx(nvar) = x(k)
         rsd(nvar) = derivs(1,k)
         nvar = nvar + 1
         xx(nvar) = y(k)
         rsd(nvar) = derivs(2,k)
         nvar = nvar + 1
         xx(nvar) = z(k)
         rsd(nvar) = derivs(3,k)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine critsave  --  critical point output routine  ##
c     ##                                                          ##
c     ##############################################################
c
c
      subroutine critsave (niter,nrsd,xx,gs,rsd)
      use files
      use iounit
      use output
      implicit none
      integer niter,nrsd
      integer iopt,iend
      integer lext
      integer freeunit
      real*8 xx(*)
      real*8 gs(*)
      real*8 rsd(*)
      logical exist
      character*7 ext
      character*240 optfile
      character*240 endfile
c
c
c     get name of archive or intermediate coordinates file
c
      iopt = freeunit ()
      if (cyclesave) then
         if (archive) then
            optfile = filename(1:leng)
            call suffix (optfile,'arc','old')
            inquire (file=optfile,exist=exist)
            if (exist) then
               call openend (iopt,optfile)
            else
               open (unit=iopt,file=optfile,status='new')
            end if
         else
            lext = 3
            call numeral (niter,ext,lext)
            optfile = filename(1:leng)//'.'//ext(1:lext)
            call version (optfile,'new')
            open (unit=iopt,file=optfile,status='new')
         end if
      else
         optfile = outfile
         call version (optfile,'old')
         open (unit=iopt,file=optfile,status='old')
         rewind (unit=iopt)
      end if
c
c     update intermediate file with desired coordinate type
c
      call prtxyz (iopt)
      close (unit=iopt)
c
c     test for requested termination of the optimization
c
      endfile = 'tinker.end'
      inquire (file=endfile,exist=exist)
      if (.not. exist) then
         endfile = filename(1:leng)//'.end'
         inquire (file=endfile,exist=exist)
         if (exist) then
            iend = freeunit ()
            open (unit=iend,file=endfile,status='old')
            close (unit=iend,status='delete')
         end if
      end if
      if (exist) then
         write (iout,10)
   10    format (/,' CRITSAVE  --  Optimization Calculation Ending',
     &              ' due to User Request')
         call fatal
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program crystal  --  fractional coordinate manipulations  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "crystal" is a utility which converts between fractional and
c     Cartesian coordinates, and can generate full unit cells from
c     asymmetric units
c
c
      program crystal
      use atoms
      use bound
      use boxes
      use iounit
      use files
      implicit none
      integer maxspace
      parameter (maxspace=92)
      integer i,ixyz,mode
      integer na,nb,nc
      integer next,freeunit
      real*8 boxmax
      logical exist,query
      character*1 answer
      character*8 sgroup(maxspace)
      character*240 xyzfile
      character*240 record
      character*240 string
      data sgroup / 'P1      ', 'P2      ', 'P1(-)   ', 'P21     ',
     &              'C2      ', 'Pm      ', 'Pc      ', 'Cm      ',
     &              'Cc      ', 'P2/m    ', 'P21/m   ', 'C2/m    ',
     &              'P2/c    ', 'P21/c   ', 'P21/n   ', 'P21/a   ',
     &              'C2/c    ', 'P21212  ', 'P212121 ', 'C2221   ',
     &              'Pca21   ', 'Pmn21   ', 'Pna21   ', 'Pnn2    ',
     &              'Pn21a   ', 'Cmc21   ', 'Aba2    ', 'Fdd2    ',
     &              'Iba2    ', 'Pnna    ', 'Pmna    ', 'Pcca    ',
     &              'Pbam    ', 'Pccn    ', 'Pbcm    ', 'Pnnm    ',
     &              'Pmmn    ', 'Pbcn    ', 'Pbca    ', 'Pnma    ',
     &              'Cmcm    ', 'Cmca    ', 'Ccca    ', 'Fddd    ',
     &              'Ibam    ', 'Ibca    ', 'P41     ', 'P43     ',
     &              'I4(-)   ', 'P4/n    ', 'P42/n   ', 'I4/m    ',
     &              'I41/a   ', 'P41212  ', 'P43212  ', 'P4(-)21m',
     &              'P4(-)21c', 'P4(-)m2 ', 'I4(-)2d ', 'I41/amd ',
     &              'P31     ', 'P32     ', 'R3      ', 'P3(-)   ',
     &              'R3(-)   ', 'P3121   ', 'P3221   ', 'R3m     ',
     &              'R3c     ', 'R3(-)m  ', 'P3(-)c1 ', 'R3(-)c  ',
     &              'P61     ', 'P65     ', 'P63     ', 'P63/m   ',
     &              'P63/mmc ', 'Pa3(-)  ', 'P43m    ', 'I4(-)3m ',
     &              'P4(-)3n ', 'I4(-)3d ', 'Pm3(-)m ', 'Pn3(-)n ',
     &              'Pm3(-)n ', 'Pn3(-)m ', 'Fm3(-)m ', 'Fm3(-)c ',
     &              'Fd3(-)m ', 'Fm3(-)c ', 'Im3(-)m ', 'Im3(-)d '/
c
c
c     get and read the Cartesian coordinates file
c
      call initial
      call getxyz
c
c     find out which unit cell manipulation to perform
c
      mode = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  mode
         if (mode.ge.1 .and. mode.le.5)  query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' The Tinker Crystal Structure Utility Can :',
     &           //,4x,'(1) Convert Fractional to Cartesian Coords',
     &           /,4x,'(2) Convert Cartesian to Fractional Coords',
     &           /,4x,'(3) Move Any Stray Molecules into Unit Cell',
     &           /,4x,'(4) Make a Unit Cell from an Asymmetric Unit',
     &           /,4x,'(5) Make a Big Block from a Single Unit Cell')
         do while (mode.lt.1 .or. mode.gt.5)
            mode = 0
            write (iout,30)
   30       format (/,' Enter the Number of the Desired Choice :  ',$)
            read (input,40,err=50,end=50)  mode
   40       format (i10)
   50       continue
         end do
      end if
c
c     get any cell dimensions found in the keyword list
c
      call unitcell
c
c     determine the space group if it will be needed later
c
      if (mode .eq. 4) then
         do i = 1, maxspace
            if (spacegrp .eq. sgroup(i))  goto 120
         end do
   60    continue
         write (iout,70)  (sgroup(i),i=1,32)
   70    format (/,' Available Crystallographic Space Groups :',/,
     &           /,3x,'(1) ',a8,5x,'(2) ',a8,5x,'(3) ',a8,
     &              5x,'(4) ',a8,
     &           /,3x,'(5) ',a8,5x,'(6) ',a8,5x,'(7) ',a8,
     &              5x,'(8) ',a8,
     &           /,3x,'(9) ',a8,4x,'(10) ',a8,4x,'(11) ',a8,
     &              4x,'(12) ',a8,
     &           /,2x,'(13) ',a8,4x,'(14) ',a8,4x,'(15) ',a8,
     &              4x,'(16) ',a8,
     &           /,2x,'(17) ',a8,4x,'(18) ',a8,4x,'(19) ',a8,
     &              4x,'(20) ',a8,
     &           /,2x,'(21) ',a8,4x,'(22) ',a8,4x,'(23) ',a8,
     &              4x,'(24) ',a8,
     &           /,2x,'(25) ',a8,4x,'(26) ',a8,4x,'(27) ',a8,
     &              4x,'(28) ',a8,
     &           /,2x,'(29) ',a8,4x,'(30) ',a8,4x,'(31) ',a8,
     &              4x,'(32) ',a8)
         write (iout,80)  (sgroup(i),i=33,64)
   80    format (2x,'(33) ',a8,4x,'(34) ',a8,4x,'(35) ',a8,
     &              4x,'(36) ',a8,
     &           /,2x,'(37) ',a8,4x,'(38) ',a8,4x,'(39) ',a8,
     &              4x,'(40) ',a8,
     &           /,2x,'(41) ',a8,4x,'(42) ',a8,4x,'(43) ',a8,
     &              4x,'(44) ',a8,
     &           /,2x,'(45) ',a8,4x,'(46) ',a8,4x,'(47) ',a8,
     &              4x,'(48) ',a8,
     &           /,2x,'(49) ',a8,4x,'(50) ',a8,4x,'(51) ',a8,
     &              4x,'(52) ',a8,
     &           /,2x,'(53) ',a8,4x,'(54) ',a8,4x,'(55) ',a8,
     &              4x,'(56) ',a8,
     &           /,2x,'(57) ',a8,4x,'(58) ',a8,4x,'(59) ',a8,
     &              4x,'(60) ',a8,
     &           /,2x,'(61) ',a8,4x,'(62) ',a8,4x,'(63) ',a8,
     &              4x,'(64) ',a8)
         write (iout,90)  (sgroup(i),i=65,maxspace)
   90    format (2x,'(76) ',a8,4x,'(66) ',a8,4x,'(67) ',a8,
     &              4x,'(68) ',a8,
     &           /,2x,'(69) ',a8,4x,'(70) ',a8,4x,'(71) ',a8,
     &              4x,'(72) ',a8,
     &           /,2x,'(73) ',a8,4x,'(74) ',a8,4x,'(75) ',a8,
     &              4x,'(76) ',a8,
     &           /,2x,'(77) ',a8,4x,'(78) ',a8,4x,'(79) ',a8,
     &              4x,'(80) ',a8,
     &           /,2x,'(81) ',a8,4x,'(82) ',a8,4x,'(83) ',a8,
     &              4x,'(84) ',a8,
     &           /,2x,'(85) ',a8,4x,'(86) ',a8,4x,'(87) ',a8,
     &              4x,'(88) ',a8,
     &           /,2x,'(89) ',a8,4x,'(90) ',a8,4x,'(91) ',a8,
     &              4x,'(92) ',a8)
         write (iout,100)
  100    format (/,' Enter the Number of the Desired Choice :  ',$)
         read (input,110)  i
  110    format (i10)
         if (i.lt.1 .or. i.gt.maxspace)  goto 60
         spacegrp = sgroup(i)
  120    continue
      end if
c
c     if not in keyfile, get the unit cell axis lengths
c
      do while (xbox .eq. 0.0d0)
         write (iout,130)
  130    format (/,' Enter Unit Cell Axis Lengths :  ',$)
         read (input,140)  record
  140    format (a240)
         read (record,*,err=150,end=150)  xbox,ybox,zbox
  150    continue
         boxmax = max(xbox,ybox,zbox)
         if (boxmax .ne. 0.0d0)  use_bounds = .true.
         if (xbox .eq. 0.0d0)  xbox = boxmax
         if (ybox .eq. 0.0d0)  ybox = boxmax
         if (zbox .eq. 0.0d0)  zbox = boxmax
      end do
c
c     if not in keyfile, get the unit cell angle values
c
      do while (alpha .eq. 0.0d0)
         write (iout,160)
  160    format (/,' Enter Unit Cell Axis Angles :   ',$)
         read (input,170)  record
  170    format (a240)
         read (record,*,err=180,end=180)  alpha,beta,gamma
  180    continue
         if (alpha .eq. 0.0d0)  alpha = 90.0d0
         if (beta .eq. 0.0d0)  beta = alpha
         if (gamma .eq. 0.0d0)  gamma = alpha
         if (alpha.eq.90.0d0 .and. beta.eq.90.0d0
     &          .and. gamma.eq.90.0d0) then
            orthogonal = .true.
         else if (alpha.eq.90.0d0 .and. gamma.eq.90.0d0) then
            monoclinic = .true.
         else
            triclinic = .true.
         end if
      end do
c
c     find constants for coordinate interconversion
c
      call lattice
c
c     print out the initial cell dimensions to be used
c
      write (iout,190)  xbox,ybox,zbox,alpha,beta,gamma
  190 format (/,' Unit Cell Dimensions :       a     =',f12.4,
     &        /,'                              b     =',f12.4,
     &        /,'                              c     =',f12.4,
     &        /,'                             Alpha  =',f12.4,
     &        /,'                             Beta   =',f12.4,
     &        /,'                             Gamma  =',f12.4)
c
c     convert Cartesian to fractional coordinates
c
      if (mode.ne.1 .and. mode.ne.3) then
         do i = 1, n
            z(i) = (z(i)/gamma_term) / zbox
            y(i) = ((y(i)-z(i)*zbox*beta_term)/gamma_sin) / ybox
            x(i) = (x(i)-y(i)*ybox*gamma_cos-z(i)*zbox*beta_cos) / xbox
         end do
      end if
c
c     apply the appropriate space group symmetry operators
c
      if (mode .eq. 4) then
         write (iout,200)  spacegrp
  200    format (/,' Space Group Symbol :',8x,a8)
         call symmetry (spacegrp)
      end if
c
c     replicate the unit cell to make a block of unit cells
c
      if (mode .eq. 5) then
         na = 0
         nb = 0
         nc = 0
         write (iout,210)
  210    format (/,' Enter Number of Replicates along a-, b- and',
     &              ' c-Axes [1 1 1] :   ',$)
         read (input,220)  record
  220    format (a240)
         read (record,*,err=230,end=230)  na,nb,nc
  230    continue
         if (na .eq. 0)  na = 1
         if (nb .eq. 0)  nb = na
         if (nc .eq. 0)  nc = na
         if (na*nb*nc*n .gt. maxatm) then
            write (iout,240)  maxatm
  240       format (/,' CRYSTAL  --  The Maximum of',i9,' Atoms',
     &                 ' has been Exceeded')
            call fatal
         end if
         call bigblock (na,nb,nc)
         write (iout,250)  na,nb,nc,xbox,ybox,zbox
  250    format (/,' Dimensions of the',i3,' x',i3,' x',i3,
     &              ' Cell Block :',
     &           //,' New Cell Dimensions :       a    =',f10.4,
     &            /,'                             b    =',f10.4,
     &            /,'                             c    =',f10.4)
      end if
c
c     convert fractional to Cartesian coordinates
c
      if (mode.ne.2 .and. mode.ne.3) then
         do i = 1, n
            x(i) = x(i)*xbox + y(i)*ybox*gamma_cos + z(i)*zbox*beta_cos
            y(i) = y(i)*ybox*gamma_sin + z(i)*zbox*beta_term
            z(i) = z(i)*zbox*gamma_term
         end do
      end if
c
c     merge fragments to form complete connected molecules
c
      if (mode .eq. 4) then
         answer = ' '
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,260)
  260       format (/,' Attempt to Merge Fragments to Form Full',
     &                 ' Molecules [N] :   ',$)
            read (input,270)  record
  270       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  call molmerge
      end if
c
c     translate any stray molecules back into the unit cell
c
      if (mode .eq. 3) then
         call field
         call katom
         call molecule
         call bounds
      else if (mode .eq. 4) then
         answer = ' '
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,280)
  280       format (/,' Move Any Stray Molecules into Unit Cell',
     &                 ' [N] :   ',$)
            read (input,290)  record
  290       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y') then
            call field
            call katom
            call molecule
            call bounds
         end if
      end if
c
c     optionally move unit cell center to coordinate origin
c
      if (mode .eq. 4) then
         answer = ' '
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,300)
  300       format (/,' Locate Center of Unit Cell at Coordinate',
     &                 ' Origin [N] :   ',$)
            read (input,310)  record
  310       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y') then
            do i = 1, n
               z(i) = (z(i)/gamma_term) / zbox
               y(i) = ((y(i)-z(i)*zbox*beta_term)/gamma_sin) / ybox
               x(i) = (x(i)-y(i)*ybox*gamma_cos-z(i)*zbox*beta_cos)
     &                                  / xbox
            end do
            do i = 1, n
               x(i) = x(i) - 0.5d0
               y(i) = y(i) - 0.5d0
               z(i) = z(i) - 0.5d0
            end do
            do i = 1, n
               x(i) = x(i)*xbox + y(i)*ybox*gamma_cos
     &                   + z(i)*zbox*beta_cos
               y(i) = y(i)*ybox*gamma_sin + z(i)*zbox*beta_term
               z(i) = z(i)*zbox*gamma_term
            end do
         end if
      end if
c
c     write out the new coordinates to a file
c
      ixyz = freeunit ()
      if (mode .eq. 2) then
         xyzfile = filename(1:leng)//'.frac'
         call version (xyzfile,'new')
         open (unit=ixyz,file=xyzfile,status='new')
      else
         xyzfile = filename(1:leng)//'.xyz'
         call version (xyzfile,'new')
         open (unit=ixyz,file=xyzfile,status='new')
      end if
      call prtxyz (ixyz)
      close (unit=ixyz)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine molmerge  --  connect fragments into molecules  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "molmerge" connects fragments and removes duplicate atoms
c     during generation of a unit cell from an asymmetric unit
c
c
      subroutine molmerge
      use atomid
      use atoms
      use couple
      use molcul
      implicit none
      integer i,j,k,m,h
      integer im,km,in,kn
      real*8 r,eps
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      logical ih,kh
      logical merge,join
      logical, allocatable :: omit(:)
      logical, allocatable :: hydro(:)
c
c
c     parse the system to find molecules and fragments
c
      call molecule
c
c     perform dynamic allocation of some local arrays
c
      allocate (omit(n))
c
c     zero out the list of atoms to be deleted
c
      do i = 1, n
         omit(i) = .false.
      end do
c
c     first pass tests all pairs for duplicate atoms
c
      eps = 0.05d0
      do i = 1, n-1
         xi = x(i)
         yi = y(i)
         zi = z(i)
         do k = i+1, n
            km = molcule(k)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            call image (xr,yr,zr)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            merge = .false.
            if (r .lt. eps)  merge = .true.
c
c    translate molecular fragment to the closest image
c
            if (merge) then
               xr = xr - x(k) + xi
               yr = yr - y(k) + yi
               zr = zr - z(k) + zi
               do j = imol(1,km), imol(2,km)
                  m = kmol(j)
                  x(m) = x(m) + xr
                  y(m) = y(m) + yr
                  z(m) = z(m) + zr
               end do
c
c    connections between partially duplicated fragments
c
               omit(k) = .true.
               do j = 1, n12(k)
                  m = i12(j,k)
                  join = .true.
                  do h = 1, n12(m)
                     if (i12(h,m) .eq. i)  join = .false.
                  end do
                  if (join) then
                     n12(m) = n12(m) + 1
                     i12(n12(m),m) = i
                  end if
                  join = .true.
                  do h = 1, n12(i)
                     if (i12(h,i) .eq. m)  join = .false.
                  end do
                  if (join) then
                     n12(i) = n12(i) + 1
                     i12(n12(i),i) = m
                  end if
               end do
            end if
         end do
      end do
c
c     delete any duplicated atoms identical by symmetry
c
      j = n
      do i = j, 1, -1
         if (omit(i))  call delete (i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (omit)
c
c     parse the system to find molecules and fragments
c
      call molecule
c
c     perform dynamic allocation of some local arrays
c
      allocate (hydro(n))
c
c     find hydrogen atoms for use in connectivity assignment
c
      do i = 1, n
         hydro(i) = .false.
         if (atomic(i) .eq. 1)  hydro(i) = .true.
         if (name(i)(1:1) .eq. 'H')  hydro(i) = .true.
      end do
c
c     second pass tests all pairs for atoms to be bonded
c
      do i = 1, n-1
         im = molcule(i)
         in = n12(i)
         ih = hydro(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         do k = i+1, n
            km = molcule(k)
            kn = n12(k)
            kh = hydro(k)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            call image (xr,yr,zr)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            merge = .false.
            if (im .ne. km) then
               eps = 2.0d0
               if (ih .or. kh)  eps = 1.6d0
               if (ih .and. kh)  eps = 0.0d0
               if (r .lt. eps)  merge = .true.
            end if
c
c    translate molecular fragment to the closest image
c
            if (merge) then
               xr = xr - x(k) + xi
               yr = yr - y(k) + yi
               zr = zr - z(k) + zi
               do j = imol(1,km), imol(2,km)
                  m = kmol(j)
                  x(m) = x(m) + xr
                  y(m) = y(m) + yr
                  z(m) = z(m) + zr
               end do
c
c     connection between bonded atoms in different fragments
c
               n12(i) = n12(i) + 1
               i12(n12(i),i) = k
               n12(k) = n12(k) + 1
               i12(n12(k),k) = i
            end if
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (hydro)
c
c     sort the connected atom lists into ascending order
c
      do i = 1, n
         call sort (n12(i),i12(1,i))
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine cellatom  --  add new atom to the unit cell  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "cellatom" completes the addition of a symmetry related atom
c     to a unit cell by updating the atom type and attachment arrays
c
c
      subroutine cellatom (jj,j)
      use atomid
      use atoms
      use couple
      implicit none
      integer i,j,jj,delta
c
c
c     attachments of replicated atom are analogous to base atom
c
      delta = jj - j
      n12(jj) = n12(j)
      do i = 1, n12(j)
         i12(i,jj) = i12(i,j) + delta
      end do
      type(jj) = type(j)
      name(jj) = name(j)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine bigblock  --  create a block of unit cells  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "bigblock" replicates the coordinates of a single unit cell
c     to give a larger unit cell as a block of repeated units
c
c
      subroutine bigblock (na,nb,nc)
      use atoms
      use boxes
      implicit none
      integer i,j,k
      integer ii,jj,nsym
      integer na,nb,nc
      real*8, allocatable :: trans(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      nsym = na * nb * nc
      allocate (trans(3,nsym))
c
c     construct translation offsets for the replicated cells
c
      nsym = 0
      do i = (1-na)/2, na/2
         do j = (1-nb)/2, nb/2
            do k = (1-nc)/2, nc/2
               nsym = nsym + 1
               trans(1,nsym) = i
               trans(2,nsym) = j
               trans(3,nsym) = k
            end do
         end do
      end do
c
c     put the original cell at the top of the replica list
c
      do i = 1, nsym
         if (trans(1,i).eq.0 .and. trans(2,i).eq.0
     &           .and. trans(3,i).eq.0)  k = i
      end do
      do i = k, 2, -1
         trans(1,i) = trans(1,i-1)
         trans(2,i) = trans(2,i-1)
         trans(3,i) = trans(3,i-1)
      end do
      trans(1,1) = 0
      trans(2,1) = 0
      trans(3,1) = 0
c
c     translate the original unit cell to make a block of cells
c
      do i = 2, nsym
         ii = (i-1) * n
         do j = 1, n
            jj = j + ii
            x(jj) = x(j) + trans(1,i)
            y(jj) = y(j) + trans(2,i)
            z(jj) = z(j) + trans(3,i)
            call cellatom (jj,j)
         end do
      end do
      n = nsym * n
c
c     update the cell dimensions and fractional coordinates
c
      xbox = xbox * dble(na)
      ybox = ybox * dble(nb)
      zbox = zbox * dble(nc)
      do i = 1, n
         x(i) = x(i) / dble(na)
         y(i) = y(i) / dble(nb)
         z(i) = z(i) / dble(nc)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (trans)
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine symmetry  --  apply space group symmetry  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "symmetry" applies symmetry operators to the fractional
c     coordinates of the asymmetric unit in order to generate
c     the symmetry related atoms of the full unit cell
c
c
      subroutine symmetry (spacegrp)
      use atoms
      use math
      implicit none
      integer i,j,k
      integer ii,jj,kk
      integer nsym,noff
      real*8 one6,five6
      real*8 xoff,yoff,zoff
      character*10 spacegrp
c
c
c     P1 space group  (International Tables 1)
c
      if (spacegrp .eq. 'P1       ') then
         nsym = 1
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P1(-) space group  (International Tables 2)
c
      else if (spacegrp .eq. 'P1(-)   ') then
         nsym = 2
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P2 space group  (International Tables 3)
c
      else if (spacegrp .eq. 'P2      ') then
         nsym = 2
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = -z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P21 space group  (International Tables 4)
c
      else if (spacegrp .eq. 'P21     ') then
         nsym = 2
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     C2 space group  (International Tables 5)
c
      else if (spacegrp .eq. 'C2      ') then
         nsym = 2
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Pm space group  (International Tables 6)
c
      else if (spacegrp .eq. 'Pm      ') then
         nsym = 2
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pc space group  (International Tables 7)
c
      else if (spacegrp .eq. 'Pc      ') then
         nsym = 2
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Cm space group  (International Tables 8)
c
      else if (spacegrp .eq. 'Cm      ') then
         nsym = 2
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Cc space group  (International Tables 9)
c
      else if (spacegrp .eq. 'Cc      ') then
         nsym = 2
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + 0.5d0 + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     P2/m space group  (International Tables 10)
c
      else if (spacegrp .eq. 'P2/m    ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = -z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P21/m space group  (International Tables 11)
c
      else if (spacegrp .eq. 'P21/m   ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     C2/m space group  (International Tables 12)
c
      else if (spacegrp .eq. 'C2/m    ') then
         nsym = 4
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     P2/c space group  (International Tables 13)
c
      else if (spacegrp .eq. 'P2/c    ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P21/c space group  (International Tables 14)
c
      else if (spacegrp .eq. 'P21/c   ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P21/n space group  (International Tables 14)
c
      else if (spacegrp .eq. 'P21/n   ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P21/a space group  (International Tables 14)
c
      else if (spacegrp .eq. 'P21/a   ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     C2/c space group  (International Tables 15)
c
      else if (spacegrp .eq. 'C2/c    ') then
         nsym = 4
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     P21212 space group  (International Tables 18)
c
      else if (spacegrp .eq. 'P21212  ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = -z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P212121 space group  (International Tables 19)
c
      else if (spacegrp .eq. 'P212121 ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     C2221 space group  (International Tables 20)
c
      else if (spacegrp .eq. 'C2221   ') then
         nsym = 4
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Pca21 space group  (International Tables 29)
c
      else if (spacegrp .eq. 'Pca21   ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pmn21 space group  (International Tables 31)
c
      else if (spacegrp .eq. 'Pmn21   ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 4) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pna21 space group  (International Tables 33)
c
      else if (spacegrp .eq. 'Pna21   ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pn21a space group  (International Tables 33)
c
      else if (spacegrp .eq. 'Pn21a   ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pnn2 space group  (International Tables 34)
c
      else if (spacegrp .eq. 'Pnn2    ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Cmc21 space group  (International Tables 36)
c
      else if (spacegrp .eq. 'Cmc21   ') then
         nsym = 4
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Aba2 space group  (International Tables 41)
c
      else if (spacegrp .eq. 'Aba2    ') then
         nsym = 4
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.0d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Fdd2 space group  (International Tables 43)
c
      else if (spacegrp .eq. 'Fdd2    ') then
         nsym = 4
         noff = 4
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.0d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               else if (k .eq. 3) then
                  xoff = 0.5d0
                  yoff = 0.0d0
                  zoff = 0.5d0
               else if (k .eq. 4) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = 0.25d0 + x(j) + xoff
                     y(jj) = 0.25d0 - y(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = 0.25d0 - x(j) + xoff
                     y(jj) = 0.25d0 + y(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Iba2 space group  (International Tables 45)
c
      else if (spacegrp .eq. 'Iba2    ') then
         nsym = 4
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Pnna space group  (International Tables 52)
c
      else if (spacegrp .eq. 'Pnna    ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 5) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = y(j)
                  z(jj) = -z(j)
               else if (i .eq. 7) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 8) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pmna space group  (International Tables 53)
c
      else if (spacegrp .eq. 'Pmna    ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 7) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 8) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pcca space group  (International Tables 54)
c
      else if (spacegrp .eq. 'Pcca    ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 5) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = y(j)
                  z(jj) = -z(j)
               else if (i .eq. 7) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 8) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pbam space group  (International Tables 55)
c
      else if (spacegrp .eq. 'Pbam    ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = -z(j)
               else if (i .eq. 7) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = z(j)
               else if (i .eq. 8) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pccn space group  (International Tables 56)
c
      else if (spacegrp .eq. 'Pccn    ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 4) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 5) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 7) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 8) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pbcm space group  (International Tables 57)
c
      else if (spacegrp .eq. 'Pbcm    ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 7) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 8) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pnnm space group  (International Tables 58)
c
      else if (spacegrp .eq. 'Pnnm    ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 5) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = -z(j)
               else if (i .eq. 7) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 8) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pmmn space group  (International Tables 59)
c
      else if (spacegrp .eq. 'Pmmn    ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 7) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 8) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pbcn space group  (International Tables 60)
c
      else if (spacegrp .eq. 'Pbcn    ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 5) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 7) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = z(j)
               else if (i .eq. 8) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pbca space group  (International Tables 61)
c
      else if (spacegrp .eq. 'Pbca    ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 7) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 8) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pnma space group  (International Tables 62)
c
      else if (spacegrp .eq. 'Pnma    ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 5) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 7) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = z(j)
               else if (i .eq. 8) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Cmcm space group  (International Tables 63)
c
      else if (spacegrp .eq. 'Cmcm    ') then
         nsym = 8
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Cmca space group  (International Tables 64)
c
      else if (spacegrp .eq. 'Cmca    ') then
         nsym = 8
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Ccca space group  (International Tables 68)
c
      else if (spacegrp .eq. 'Ccca    ') then
         nsym = 8
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = -x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Fddd space group  (International Tables 70)
c
      else if (spacegrp .eq. 'Fddd    ') then
         nsym = 8
         noff = 4
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.0d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               else if (k .eq. 3) then
                  xoff = 0.5d0
                  yoff = 0.0d0
                  zoff = 0.5d0
               else if (k .eq. 4) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = 0.25d0 - x(j) + xoff
                     y(jj) = 0.25d0 - y(j) + yoff
                     z(jj) = 0.25d0 - z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = 0.25d0 + x(j) + xoff
                     y(jj) = 0.25d0 + y(j) + yoff
                     z(jj) = 0.25d0 - z(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = 0.25d0 + x(j) + xoff
                     y(jj) = 0.25d0 - y(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = 0.25d0 - x(j) + xoff
                     y(jj) = 0.25d0 + y(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Ibam space group  (International Tables 72)
c
      else if (spacegrp .eq. 'Ibam    ') then
         nsym = 8
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Ibca space group  (International Tables 73)
c
      else if (spacegrp .eq. 'Ibca    ') then
         nsym = 8
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     P41 space group  (International Tables 76)
c
      else if (spacegrp .eq. 'P41     ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = -y(j)
                  y(jj) = x(j)
                  z(jj) = 0.25d0 + z(j)
               else if (i .eq. 4) then
                  x(jj) = y(j)
                  y(jj) = -x(j)
                  z(jj) = 0.75d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P43 space group  (International Tables 78)
c
      else if (spacegrp .eq. 'P43     ') then
         nsym = 4
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = -y(j)
                  y(jj) = x(j)
                  z(jj) = 0.75d0 + z(j)
               else if (i .eq. 4) then
                  x(jj) = y(j)
                  y(jj) = -x(j)
                  z(jj) = 0.25d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     I4(-) space group  (International Tables 82)
c
      else if (spacegrp .eq. 'I4(-)   ') then
         nsym = 4
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     P4/n space group  (International Tables 85)
c
      else if (spacegrp .eq. 'P4/n    ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = z(j)
               else if (i .eq. 5) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 7) then
                  x(jj) = y(j)
                  y(jj) = -x(j)
                  z(jj) = -z(j)
               else if (i .eq. 8) then
                  x(jj) = -y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P42/n space group  (International Tables 86)
c
      else if (spacegrp .eq. 'P42/n   ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 5) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 7) then
                  x(jj) = y(j)
                  y(jj) = -x(j)
                  z(jj) = -z(j)
               else if (i .eq. 8) then
                  x(jj) = -y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     I4/m space group  (International Tables 87)
c
      else if (spacegrp .eq. 'I4/m    ') then
         nsym = 8
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     I41/a space group  (International Tables 88)
c
      else if (spacegrp .eq. 'I41/a   ') then
         nsym = 8
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -y(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = 0.75d0 + z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = -x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.25d0 - z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = 0.25d0 + x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.75d0 - z(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     P41212 space group  (International Tables 92)
c
      else if (spacegrp .eq. 'P41212  ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.25d0 + z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.75d0 + z(j)
               else if (i .eq. 5) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.25d0 - z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.75d0 - z(j)
               else if (i .eq. 7) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 8) then
                  x(jj) = -y(j)
                  y(jj) = -x(j)
                  z(jj) = 0.5d0 - z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P43212 space group  (International Tables 96)
c
      else if (spacegrp .eq. 'P43212  ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.75d0 + z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.25d0 + z(j)
               else if (i .eq. 5) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.75d0 - z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.25d0 - z(j)
               else if (i .eq. 7) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 8) then
                  x(jj) = -y(j)
                  y(jj) = -x(j)
                  z(jj) = 0.5d0 - z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P4(-)21m space group  (International Tables 113)
c
      else if (spacegrp .eq. 'P4(-)21m') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j)
                  y(jj) = -x(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = -y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = -z(j)
               else if (i .eq. 7) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = z(j)
               else if (i .eq. 8) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P4(-)21c space group  (International Tables 114)
c
      else if (spacegrp .eq. 'P4(-)21c') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j)
                  y(jj) = -x(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = -y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 7) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 8) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P4(-)m2 space group  (International Tables 115)
c
      else if (spacegrp .eq. 'P4(-)m2 ') then
         nsym = 8
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 5) then
                  x(jj) = -y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = y(j)
                  y(jj) = -x(j)
                  z(jj) = -z(j)
               else if (i .eq. 7) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 8) then
                  x(jj) = -y(j)
                  y(jj) = -x(j)
                  z(jj) = -z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     I4(-)2d space group  (International Tables 122)
c
      else if (spacegrp .eq. 'I4(-)2d ') then
         nsym = 8
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.75d0 - z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.75d0 - z(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = 0.75d0 + z(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = 0.75d0 + z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     I41/amd space group  (Intl. Tables 141, origin at center)
c
      else if (spacegrp .eq. 'I41/amd ') then
         nsym = 16
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = 0.25d0 - y(j) + xoff
                     y(jj) = 0.75d0 + x(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = 0.25d0 + y(j) + xoff
                     y(jj) = 0.25d0 - x(j) + yoff
                     z(jj) = 0.75d0 + z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = 0.25d0 + y(j) + xoff
                     y(jj) = 0.25d0 + x(j) + yoff
                     z(jj) = 0.25d0 - z(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = 0.25d0 - y(j) + xoff
                     y(jj) = 0.25d0 - x(j) + yoff
                     z(jj) = 0.75d0 - z(j) + zoff
                  else if (i .eq. 9) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 10) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 11) then
                     x(jj) = 0.75d0 + y(j) + xoff
                     y(jj) = 0.25d0 - x(j) + yoff
                     z(jj) = 0.75d0 - z(j) + zoff
                  else if (i .eq. 12) then
                     x(jj) = 0.75d0 - y(j) + xoff
                     y(jj) = 0.75d0 + x(j) + yoff
                     z(jj) = 0.25d0 - z(j) + zoff
                  else if (i .eq. 13) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 14) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 15) then
                     x(jj) = 0.75d0 - y(j) + xoff
                     y(jj) = 0.25d0 - x(j) + yoff
                     z(jj) = 0.75d0 + z(j) + zoff
                  else if (i .eq. 16) then
                     x(jj) = 0.75d0 + y(j) + xoff
                     y(jj) = 0.75d0 + x(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     P31 space group  (International Tables 144)
c
      else if (spacegrp .eq. 'P31     ') then
         nsym = 3
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = third + z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = third2 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P32 space group  (International Tables 145)
c
      else if (spacegrp .eq. 'P32     ') then
         nsym = 3
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = third2 + z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = third + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     R3 space group  (International Tables 146)
c
      else if (spacegrp .eq. 'R3      ') then
         nsym = 3
         noff = 3
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = third2
                  yoff = third
                  zoff = third
               else if (k .eq. 3) then
                  xoff = third
                  yoff = third2
                  zoff = third2
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) - y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = y(j) - x(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     P3(-) space group  (International Tables 147)
c
      else if (spacegrp .eq. 'P3(-)   ') then
         nsym = 6
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = z(j)
               else if (i .eq. 4) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = y(j)
                  y(jj) = y(j) - x(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = x(j) - y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     R3(-) space group  (Intl. Tables 148, Hexagonal Axes)
c
c     else if (spacegrp .eq. 'R3(-)   ') then
c        nsym = 6
c        noff = 3
c        do i = 1, nsym
c           ii = (i-1) * noff * n
c           do k = 1, noff
c              kk = ii + (k-1)*n
c              if (k .eq. 1) then
c                 xoff = 0.0d0
c                 yoff = 0.0d0
c                 zoff = 0.0d0
c              else if (k .eq. 2) then
c                 xoff = third2
c                 yoff = third
c                 zoff = third
c              else if (k .eq. 3) then
c                 xoff = third
c                 yoff = third2
c                 zoff = third2
c              end if
c              do j = 1, n
c                 jj = j + kk
c                 if (i .eq. 1) then
c                    x(jj) = x(j) + xoff
c                    y(jj) = y(j) + yoff
c                    z(jj) = z(j) + zoff
c                 else if (i .eq. 2) then
c                    x(jj) = -y(j) + xoff
c                    y(jj) = x(j) - y(j) + yoff
c                    z(jj) = z(j) + zoff
c                 else if (i .eq. 3) then
c                    x(jj) = y(j) - x(j) + xoff
c                    y(jj) = -x(j) + yoff
c                    z(jj) = z(j) + zoff
c                 else if (i .eq. 4) then
c                    x(jj) = -x(j) + xoff
c                    y(jj) = -y(j) + yoff
c                    z(jj) = -z(j) + zoff
c                 else if (i .eq. 5) then
c                    x(jj) = y(j) + xoff
c                    y(jj) = y(j) - x(j) + yoff
c                    z(jj) = -z(j) + zoff
c                 else if (i .eq. 6) then
c                    x(jj) = x(j) - y(j) + xoff
c                    y(jj) = x(j) + yoff
c                    z(jj) = -z(j) + zoff
c                 end if
c                 call cellatom (jj,j)
c              end do
c           end do
c        end do
c
c     R3(-) space group  (Intl. Tables 148, Rhombohedral Axes)
c
      else if (spacegrp .eq. 'R3(-)   ') then
         nsym = 6
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = z(j)
                  y(jj) = x(j)
                  z(jj) = y(j)
               else if (i .eq. 3) then
                  x(jj) = y(j)
                  y(jj) = z(j)
                  z(jj) = x(j)
               else if (i .eq. 4) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = -z(j)
                  y(jj) = -x(j)
                  z(jj) = -y(j)
               else if (i .eq. 6) then
                  x(jj) = -y(j)
                  y(jj) = -z(j)
                  z(jj) = -x(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P3121 space group  (International Tables 152)
c
      else if (spacegrp .eq. 'P3121   ') then
         nsym = 6
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = third + z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = third2 + z(j)
               else if (i .eq. 4) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = x(j) - y(j)
                  y(jj) = -y(j)
                  z(jj) = third2 - z(j)
               else if (i .eq. 6) then
                  x(jj) = -x(j)
                  y(jj) = y(j) - x(j)
                  z(jj) = third - z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P3221 space group  (International Tables 154)
c
      else if (spacegrp .eq. 'P3221   ') then
         nsym = 6
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = third2 + z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = third + z(j)
               else if (i .eq. 4) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = x(j) - y(j)
                  y(jj) = -y(j)
                  z(jj) = third - z(j)
               else if (i .eq. 6) then
                  x(jj) = -x(j)
                  y(jj) = y(j) - x(j)
                  z(jj) = third2 - z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     R3m space group  (International Tables 160)
c
      else if (spacegrp .eq. 'R3m     ') then
         nsym = 6
         noff = 3
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = third2
                  yoff = third
                  zoff = third
               else if (k .eq. 3) then
                  xoff = third
                  yoff = third2
                  zoff = third2
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) - y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = y(j) - x(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = y(j) - x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = x(j) + xoff
                     y(jj) = x(j) - y(j) + yoff
                     z(jj) = z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     R3c space group  (International Tables 161)
c
      else if (spacegrp .eq. 'R3c     ') then
         nsym = 6
         noff = 3
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = third2
                  yoff = third
                  zoff = third
               else if (k .eq. 3) then
                  xoff = third
                  yoff = third2
                  zoff = third2
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) - y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = y(j) - x(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = y(j) - x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = x(j) + xoff
                     y(jj) = x(j) - y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     P3(-)c1 space group  (International Tables 165)
c
      else if (spacegrp .eq. 'P3(-)c1 ') then
         nsym = 12
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = z(j)
               else if (i .eq. 4) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 5) then
                  x(jj) = x(i) - y(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 6) then
                  x(jj) = -x(j)
                  y(jj) = y(i) - x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 7) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 8) then
                  x(jj) = y(j)
                  y(jj) = y(j) - x(j)
                  z(jj) = -z(j)
               else if (i .eq. 9) then
                  x(jj) = x(j) - y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 10) then
                  x(jj) = -y(j)
                  y(jj) = -x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 11) then
                  x(jj) = y(j) - x(i)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 12) then
                  x(jj) = x(j)
                  y(jj) = x(j) - y(i)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     R3(-)m space group  (Intl. Tables 166, Rhombohedral Axes)
c
      else if (spacegrp .eq. 'R3(-)m  ') then
         nsym = 12
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = z(j)
                  y(jj) = x(j)
                  z(jj) = y(j)
               else if (i .eq. 3) then
                  x(jj) = y(j)
                  y(jj) = z(j)
                  z(jj) = x(j)
               else if (i .eq. 4) then
                  x(jj) = -z(j)
                  y(jj) = -y(j)
                  z(jj) = -x(j)
               else if (i .eq. 5) then
                  x(jj) = -y(j)
                  y(jj) = -x(j)
                  z(jj) = -z(j)
               else if (i .eq. 6) then
                  x(jj) = -x(j)
                  y(jj) = -z(j)
                  z(jj) = -y(j)
               else if (i .eq. 7) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 8) then
                  x(jj) = -z(j)
                  y(jj) = -x(j)
                  z(jj) = -y(j)
               else if (i .eq. 9) then
                  x(jj) = -y(j)
                  y(jj) = -z(j)
                  z(jj) = -x(j)
               else if (i .eq. 10) then
                  x(jj) = z(j)
                  y(jj) = y(j)
                  z(jj) = x(j)
               else if (i .eq. 11) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = z(j)
               else if (i .eq. 12) then
                  x(jj) = x(j)
                  y(jj) = z(j)
                  z(jj) = y(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     R3(-)c space group  (International Tables 167)
c
      else if (spacegrp .eq. 'R3(-)c  ') then
         nsym = 12
         noff = 3
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = third2
                  yoff = third
                  zoff = third
               else if (k .eq. 3) then
                  xoff = third
                  yoff = third2
                  zoff = third2
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) - y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = y(j) - x(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = x(j) - y(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) - x(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = y(j) + xoff
                     y(jj) = y(j) - x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 9) then
                     x(jj) = x(j) - y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 10) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 11) then
                     x(jj) = y(j) - x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 12) then
                     x(jj) = x(j) + xoff
                     y(jj) = x(j) - y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     P61 space group  (International Tables 169)
c
      else if (spacegrp .eq. 'P61     ') then
         nsym = 6
         noff = 1
         one6 = 1.0d0 / 6.0d0
         five6 = 5.0d0 / 6.0d0
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = third + z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = third2 + z(j)
               else if (i .eq. 4) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 5) then
                  x(jj) = y(j)
                  y(jj) = y(j) - x(i)
                  z(jj) = five6 + z(j)
               else if (i .eq. 6) then
                  x(jj) = x(j) - y(i)
                  y(jj) = x(j)
                  z(jj) = one6 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P65 space group  (International Tables 170)
c
      else if (spacegrp .eq. 'P65     ') then
         nsym = 6
         noff = 1
         one6 = 1.0d0 / 6.0d0
         five6 = 5.0d0 / 6.0d0
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = third2 + z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = third + z(j)
               else if (i .eq. 4) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 5) then
                  x(jj) = y(j)
                  y(jj) = y(j) - x(i)
                  z(jj) = one6 + z(j)
               else if (i .eq. 6) then
                  x(jj) = x(j) - y(i)
                  y(jj) = x(j)
                  z(jj) = five6 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P63 space group  (International Tables 173)
c
      else if (spacegrp .eq. 'P63     ') then
         nsym = 6
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = z(j)
               else if (i .eq. 4) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 5) then
                  x(jj) = y(j)
                  y(jj) = y(j) - x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 6) then
                  x(jj) = x(j) - y(j)
                  y(jj) = x(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P63/m space group  (International Tables 176)
c
      else if (spacegrp .eq. 'P63/m   ') then
         nsym = 12
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = z(j)
               else if (i .eq. 4) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 5) then
                  x(jj) = y(j)
                  y(jj) = y(j) - x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 6) then
                  x(jj) = x(j) - y(j)
                  y(jj) = x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 7) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 8) then
                  x(jj) = y(j)
                  y(jj) = y(j) - x(j)
                  z(jj) = -z(j)
               else if (i .eq. 9) then
                  x(jj) = x(j) - y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 10) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 11) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 12) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = 0.5d0 - z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P6(3)/mmc space group  (Intl. Tables 194, Hexagonal Close Packed)
c
      else if (spacegrp .eq. 'P63/mmc ') then
         nsym = 24
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = z(j)
               else if (i .eq. 4) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 5) then
                  x(jj) = y(j)
                  y(jj) = y(j) - x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 6) then
                  x(jj) = x(j) - y(j)
                  y(jj) = x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 7) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 8) then
                  x(jj) = x(j) - y(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 9) then
                  x(jj) = -x(j)
                  y(jj) = y(j) - x(j)
                  z(jj) = -z(j)
               else if (i .eq. 10) then
                  x(jj) = -y(j)
                  y(jj) = -x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 11) then
                  x(jj) = y(j) - x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 12) then
                  x(jj) = x(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 13) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 14) then
                  x(jj) = y(j)
                  y(jj) = y(j) - x(j)
                  z(jj) = -z(j)
               else if (i .eq. 15) then
                  x(jj) = x(j) - y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 16) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 17) then
                  x(jj) = -y(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 18) then
                  x(jj) = y(j) - x(j)
                  y(jj) = -x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 19) then
                  x(jj) = -y(j)
                  y(jj) = -x(j)
                  z(jj) = z(j)
               else if (i .eq. 20) then
                  x(jj) = y(j) - x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 21) then
                  x(jj) = x(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = z(j)
               else if (i .eq. 22) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 23) then
                  x(jj) = x(j) - y(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 24) then
                  x(jj) = -x(j)
                  y(jj) = y(j) - x(j)
                  z(jj) = 0.5d0 + z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pa3(-) space group  (International Tables 205)
c
      else if (spacegrp .eq. 'Pa3(-)  ') then
         nsym = 24
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 4) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = z(j)
                  y(jj) = x(j)
                  z(jj) = y(j)
               else if (i .eq. 6) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = -y(j)
               else if (i .eq. 7) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = -x(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 8) then
                  x(jj) = -z(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 9) then
                  x(jj) = y(j)
                  y(jj) = z(j)
                  z(jj) = x(j)
               else if (i .eq. 10) then
                  x(jj) = -y(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 11) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = -x(j)
               else if (i .eq. 12) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = -z(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 13) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 14) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 15) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 16) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = z(j)
               else if (i .eq. 17) then
                  x(jj) = -z(j)
                  y(jj) = -x(j)
                  z(jj) = -y(j)
               else if (i .eq. 18) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = y(j)
               else if (i .eq. 19) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = x(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 20) then
                  x(jj) = z(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 21) then
                  x(jj) = -y(j)
                  y(jj) = -z(j)
                  z(jj) = -x(j)
               else if (i .eq. 22) then
                  x(jj) = y(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 23) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = x(j)
               else if (i .eq. 24) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = z(j)
                  z(jj) = 0.5d0 - x(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P4(-)3m space group  (International Tables 215)
c
      else if (spacegrp .eq. 'P4(-)3m ') then
         nsym = 24
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = z(j)
                  y(jj) = x(j)
                  z(jj) = y(j)
               else if (i .eq. 6) then
                  x(jj) = z(j)
                  y(jj) = -x(j)
                  z(jj) = -y(j)
               else if (i .eq. 7) then
                  x(jj) = -z(j)
                  y(jj) = -x(j)
                  z(jj) = y(j)
               else if (i .eq. 8) then
                  x(jj) = -z(j)
                  y(jj) = x(j)
                  z(jj) = -y(j)
               else if (i .eq. 9) then
                  x(jj) = y(j)
                  y(jj) = z(j)
                  z(jj) = x(j)
               else if (i .eq. 10) then
                  x(jj) = -y(j)
                  y(jj) = z(j)
                  z(jj) = -x(j)
               else if (i .eq. 11) then
                  x(jj) = y(j)
                  y(jj) = -z(j)
                  z(jj) = -x(j)
               else if (i .eq. 12) then
                  x(jj) = -y(j)
                  y(jj) = -z(j)
                  z(jj) = x(j)
               else if (i .eq. 13) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = z(j)
               else if (i .eq. 14) then
                  x(jj) = -y(j)
                  y(jj) = -x(j)
                  z(jj) = z(j)
               else if (i .eq. 15) then
                  x(jj) = y(j)
                  y(jj) = -x(j)
                  z(jj) = -z(j)
               else if (i .eq. 16) then
                  x(jj) = -y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 17) then
                  x(jj) = x(j)
                  y(jj) = z(j)
                  z(jj) = y(j)
               else if (i .eq. 18) then
                  x(jj) = -x(j)
                  y(jj) = z(j)
                  z(jj) = -y(j)
               else if (i .eq. 19) then
                  x(jj) = -x(j)
                  y(jj) = -z(j)
                  z(jj) = y(j)
               else if (i .eq. 20) then
                  x(jj) = x(j)
                  y(jj) = -z(j)
                  z(jj) = -y(j)
               else if (i .eq. 21) then
                  x(jj) = z(j)
                  y(jj) = y(j)
                  z(jj) = x(j)
               else if (i .eq. 22) then
                  x(jj) = z(j)
                  y(jj) = -y(j)
                  z(jj) = -x(j)
               else if (i .eq. 23) then
                  x(jj) = -z(j)
                  y(jj) = y(j)
                  z(jj) = -x(j)
               else if (i .eq. 24) then
                  x(jj) = -z(j)
                  y(jj) = -y(j)
                  z(jj) = x(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     I4(-)3m space group  (Intl. Tables 217, Body Centered Cubic)
c
      else if (spacegrp .eq. 'I4(-)3m ') then
         nsym = 24
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = -z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 9) then
                     x(jj) = y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 10) then
                     x(jj) = -y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 11) then
                     x(jj) = y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 12) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 13) then
                     x(jj) = y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 14) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 15) then
                     x(jj) = y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 16) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 17) then
                     x(jj) = x(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 18) then
                     x(jj) = -x(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 19) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 20) then
                     x(jj) = x(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 21) then
                     x(jj) = z(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 22) then
                     x(jj) = z(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 23) then
                     x(jj) = -z(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 24) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = x(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     P4(-)3n space group  (International Tables 218)
c
      else if (spacegrp .eq. 'P4(-)3n ') then
         nsym = 24
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = z(j)
                  y(jj) = x(j)
                  z(jj) = y(j)
               else if (i .eq. 6) then
                  x(jj) = z(j)
                  y(jj) = -x(j)
                  z(jj) = -y(j)
               else if (i .eq. 7) then
                  x(jj) = -z(j)
                  y(jj) = -x(j)
                  z(jj) = y(j)
               else if (i .eq. 8) then
                  x(jj) = -z(j)
                  y(jj) = x(j)
                  z(jj) = -y(j)
               else if (i .eq. 9) then
                  x(jj) = y(j)
                  y(jj) = z(j)
                  z(jj) = x(j)
               else if (i .eq. 10) then
                  x(jj) = -y(j)
                  y(jj) = z(j)
                  z(jj) = -x(j)
               else if (i .eq. 11) then
                  x(jj) = y(j)
                  y(jj) = -z(j)
                  z(jj) = -x(j)
               else if (i .eq. 12) then
                  x(jj) = -y(j)
                  y(jj) = -z(j)
                  z(jj) = x(j)
               else if (i .eq. 13) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 14) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 15) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 16) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 17) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 18) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 19) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 20) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 21) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 22) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 23) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 24) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + x(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     I4(-)3d space group  (International Tables 220)
c
      else if (spacegrp .eq. 'I4(-)3d ') then
         nsym = 24
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = 0.5d0 + z(j) + xoff
                     y(jj) = 0.5d0 - x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = 0.5d0 - z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = 0.5d0 + y(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = -z(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = 0.5d0 - y(j) + zoff
                  else if (i .eq. 9) then
                     x(jj) = y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 10) then
                     x(jj) = -y(j) + xoff
                     y(jj) = 0.5d0 + z(j) + yoff
                     z(jj) = 0.5d0 - x(j) + zoff
                  else if (i .eq. 11) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = 0.5d0 - z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 12) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = 0.5d0 + x(j) + zoff
                  else if (i .eq. 13) then
                     x(jj) = 0.25d0 + y(j) + xoff
                     y(jj) = 0.25d0 + x(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  else if (i .eq. 14) then
                     x(jj) = 0.25d0 - y(j) + xoff
                     y(jj) = 0.75d0 - x(j) + yoff
                     z(jj) = 0.75d0 + z(j) + zoff
                  else if (i .eq. 15) then
                     x(jj) = 0.75d0 + y(j) + xoff
                     y(jj) = 0.25d0 - x(j) + yoff
                     z(jj) = 0.75d0 - z(j) + zoff
                  else if (i .eq. 16) then
                     x(jj) = 0.75d0 - y(j) + xoff
                     y(jj) = 0.75d0 + x(j) + yoff
                     z(jj) = 0.25d0 - z(j) + zoff
                  else if (i .eq. 17) then
                     x(jj) = 0.25d0 + x(j) + xoff
                     y(jj) = 0.25d0 + z(j) + yoff
                     z(jj) = 0.25d0 + y(j) + zoff
                  else if (i .eq. 18) then
                     x(jj) = 0.75d0 - x(j) + xoff
                     y(jj) = 0.75d0 + z(j) + yoff
                     z(jj) = 0.25d0 - y(j) + zoff
                  else if (i .eq. 19) then
                     x(jj) = 0.25d0 - x(j) + xoff
                     y(jj) = 0.75d0 - z(j) + yoff
                     z(jj) = 0.75d0 + y(j) + zoff
                  else if (i .eq. 20) then
                     x(jj) = 0.75d0 + x(j) + xoff
                     y(jj) = 0.25d0 - z(j) + yoff
                     z(jj) = 0.75d0 - y(j) + zoff
                  else if (i .eq. 21) then
                     x(jj) = 0.25d0 + z(j) + xoff
                     y(jj) = 0.25d0 + y(j) + yoff
                     z(jj) = 0.25d0 + x(j) + zoff
                  else if (i .eq. 22) then
                     x(jj) = 0.75d0 + z(j) + xoff
                     y(jj) = 0.25d0 - y(j) + yoff
                     z(jj) = 0.75d0 - x(j) + zoff
                  else if (i .eq. 23) then
                     x(jj) = 0.75d0 - z(j) + xoff
                     y(jj) = 0.75d0 + y(j) + yoff
                     z(jj) = 0.25d0 - x(j) + zoff
                  else if (i .eq. 24) then
                     x(jj) = 0.25d0 - z(j) + xoff
                     y(jj) = 0.75d0 - y(j) + yoff
                     z(jj) = 0.75d0 + x(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Pm3(-)m space group  (International Tables 221)
c
      else if (spacegrp .eq. 'Pm3(-)m ') then
         nsym = 48
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = z(j)
                  y(jj) = x(j)
                  z(jj) = y(j)
               else if (i .eq. 6) then
                  x(jj) = z(j)
                  y(jj) = -x(j)
                  z(jj) = -y(j)
               else if (i .eq. 7) then
                  x(jj) = -z(j)
                  y(jj) = -x(j)
                  z(jj) = y(j)
               else if (i .eq. 8) then
                  x(jj) = -z(j)
                  y(jj) = x(j)
                  z(jj) = -y(j)
               else if (i .eq. 9) then
                  x(jj) = y(j)
                  y(jj) = z(j)
                  z(jj) = x(j)
               else if (i .eq. 10) then
                  x(jj) = -y(j)
                  y(jj) = z(j)
                  z(jj) = -x(j)
               else if (i .eq. 11) then
                  x(jj) = y(j)
                  y(jj) = -z(j)
                  z(jj) = -x(j)
               else if (i .eq. 12) then
                  x(jj) = -y(j)
                  y(jj) = -z(j)
                  z(jj) = x(j)
               else if (i .eq. 13) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 14) then
                  x(jj) = -y(j)
                  y(jj) = -x(j)
                  z(jj) = -z(j)
               else if (i .eq. 15) then
                  x(jj) = y(j)
                  y(jj) = -x(j)
                  z(jj) = z(j)
               else if (i .eq. 16) then
                  x(jj) = -y(j)
                  y(jj) = x(j)
                  z(jj) = z(j)
               else if (i .eq. 17) then
                  x(jj) = x(j)
                  y(jj) = z(j)
                  z(jj) = -y(j)
               else if (i .eq. 18) then
                  x(jj) = -x(j)
                  y(jj) = z(j)
                  z(jj) = y(j)
               else if (i .eq. 19) then
                  x(jj) = -x(j)
                  y(jj) = -z(j)
                  z(jj) = -y(j)
               else if (i .eq. 20) then
                  x(jj) = x(j)
                  y(jj) = -z(j)
                  z(jj) = y(j)
               else if (i .eq. 21) then
                  x(jj) = z(j)
                  y(jj) = y(j)
                  z(jj) = -x(j)
               else if (i .eq. 22) then
                  x(jj) = z(j)
                  y(jj) = -y(j)
                  z(jj) = x(j)
               else if (i .eq. 23) then
                  x(jj) = -z(j)
                  y(jj) = y(j)
                  z(jj) = x(j)
               else if (i .eq. 24) then
                  x(jj) = -z(j)
                  y(jj) = -y(j)
                  z(jj) = -x(j)
               else if (i .eq. 25) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 26) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = -z(j)
               else if (i .eq. 27) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 28) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 29) then
                  x(jj) = -z(j)
                  y(jj) = -x(j)
                  z(jj) = -y(j)
               else if (i .eq. 30) then
                  x(jj) = -z(j)
                  y(jj) = x(j)
                  z(jj) = y(j)
               else if (i .eq. 31) then
                  x(jj) = z(j)
                  y(jj) = x(j)
                  z(jj) = -y(j)
               else if (i .eq. 32) then
                  x(jj) = z(j)
                  y(jj) = -x(j)
                  z(jj) = y(j)
               else if (i .eq. 33) then
                  x(jj) = -y(j)
                  y(jj) = -z(j)
                  z(jj) = -x(j)
               else if (i .eq. 34) then
                  x(jj) = y(j)
                  y(jj) = -z(j)
                  z(jj) = x(j)
               else if (i .eq. 35) then
                  x(jj) = -y(j)
                  y(jj) = z(j)
                  z(jj) = x(j)
               else if (i .eq. 36) then
                  x(jj) = y(j)
                  y(jj) = z(j)
                  z(jj) = -x(j)
               else if (i .eq. 37) then
                  x(jj) = -y(j)
                  y(jj) = -x(j)
                  z(jj) = z(j)
               else if (i .eq. 38) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = z(j)
               else if (i .eq. 39) then
                  x(jj) = -y(j)
                  y(jj) = x(j)
                  z(jj) = -z(j)
               else if (i .eq. 40) then
                  x(jj) = y(j)
                  y(jj) = -x(j)
                  z(jj) = -z(j)
               else if (i .eq. 41) then
                  x(jj) = -x(j)
                  y(jj) = -z(j)
                  z(jj) = y(j)
               else if (i .eq. 42) then
                  x(jj) = x(j)
                  y(jj) = -z(j)
                  z(jj) = -y(j)
               else if (i .eq. 43) then
                  x(jj) = x(j)
                  y(jj) = z(j)
                  z(jj) = y(j)
               else if (i .eq. 44) then
                  x(jj) = -x(j)
                  y(jj) = z(j)
                  z(jj) = -y(j)
               else if (i .eq. 45) then
                  x(jj) = -z(j)
                  y(jj) = -y(j)
                  z(jj) = x(j)
               else if (i .eq. 46) then
                  x(jj) = -z(j)
                  y(jj) = y(j)
                  z(jj) = -x(j)
               else if (i .eq. 47) then
                  x(jj) = z(j)
                  y(jj) = -y(j)
                  z(jj) = -x(j)
               else if (i .eq. 48) then
                  x(jj) = z(j)
                  y(jj) = y(j)
                  z(jj) = x(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pn3(-)n space group  (Intl. Tables 222, origin at center)
c
      else if (spacegrp .eq. 'Pn3(-)n ') then
         nsym = 48
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 5) then
                  x(jj) = z(j)
                  y(jj) = x(j)
                  z(jj) = y(j)
               else if (i .eq. 6) then
                  x(jj) = z(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 7) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = y(j)
               else if (i .eq. 8) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = x(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 9) then
                  x(jj) = y(j)
                  y(jj) = z(j)
                  z(jj) = x(j)
               else if (i .eq. 10) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = z(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 11) then
                  x(jj) = y(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 12) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = x(j)
               else if (i .eq. 13) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 14) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 15) then
                  x(jj) = y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = z(j)
               else if (i .eq. 16) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = x(j)
                  z(jj) = z(j)
               else if (i .eq. 17) then
                  x(jj) = x(j)
                  y(jj) = z(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 18) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = z(j)
                  z(jj) = y(j)
               else if (i .eq. 19) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 20) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = y(j)
               else if (i .eq. 21) then
                  x(jj) = z(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 22) then
                  x(jj) = z(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = x(j)
               else if (i .eq. 23) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = y(j)
                  z(jj) = x(j)
               else if (i .eq. 24) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 25) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 26) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 27) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 28) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 29) then
                  x(jj) = -z(j)
                  y(jj) = -x(j)
                  z(jj) = -y(j)
               else if (i .eq. 30) then
                  x(jj) = -z(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 31) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = -y(j)
               else if (i .eq. 32) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = -x(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 33) then
                  x(jj) = -y(j)
                  y(jj) = -z(j)
                  z(jj) = -x(j)
               else if (i .eq. 34) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = -z(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 35) then
                  x(jj) = -y(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 36) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = -x(j)
               else if (i .eq. 37) then
                  x(jj) = -y(j)
                  y(jj) = -x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 38) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 39) then
                  x(jj) = -y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = -z(j)
               else if (i .eq. 40) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = -x(j)
                  z(jj) = -z(j)
               else if (i .eq. 41) then
                  x(jj) = -x(j)
                  y(jj) = -z(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 42) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = -z(j)
                  z(jj) = -y(j)
               else if (i .eq. 43) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 44) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = -y(j)
               else if (i .eq. 45) then
                  x(jj) = -z(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 46) then
                  x(jj) = -z(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -x(j)
               else if (i .eq. 47) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = -y(j)
                  z(jj) = -x(j)
               else if (i .eq. 48) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + x(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pm3(-)n space group  (International Tables 223)
c
      else if (spacegrp .eq. 'Pm3(-)n ') then
         nsym = 48
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = -z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 5) then
                  x(jj) = z(j)
                  y(jj) = x(j)
                  z(jj) = y(j)
               else if (i .eq. 6) then
                  x(jj) = z(j)
                  y(jj) = -x(j)
                  z(jj) = -y(j)
               else if (i .eq. 7) then
                  x(jj) = -z(j)
                  y(jj) = -x(j)
                  z(jj) = y(j)
               else if (i .eq. 8) then
                  x(jj) = -z(j)
                  y(jj) = x(j)
                  z(jj) = -y(j)
               else if (i .eq. 9) then
                  x(jj) = y(j)
                  y(jj) = z(j)
                  z(jj) = x(j)
               else if (i .eq. 10) then
                  x(jj) = -y(j)
                  y(jj) = z(j)
                  z(jj) = -x(j)
               else if (i .eq. 11) then
                  x(jj) = y(j)
                  y(jj) = -z(j)
                  z(jj) = -x(j)
               else if (i .eq. 12) then
                  x(jj) = -y(j)
                  y(jj) = -z(j)
                  z(jj) = x(j)
               else if (i .eq. 13) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 14) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 15) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 16) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 17) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 18) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 19) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 20) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 21) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 22) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 23) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 24) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 25) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 26) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = -z(j)
               else if (i .eq. 27) then
                  x(jj) = x(j)
                  y(jj) = -y(j)
                  z(jj) = z(j)
               else if (i .eq. 28) then
                  x(jj) = -x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 29) then
                  x(jj) = -z(j)
                  y(jj) = -x(j)
                  z(jj) = -y(j)
               else if (i .eq. 30) then
                  x(jj) = -z(j)
                  y(jj) = x(j)
                  z(jj) = y(j)
               else if (i .eq. 31) then
                  x(jj) = z(j)
                  y(jj) = x(j)
                  z(jj) = -y(j)
               else if (i .eq. 32) then
                  x(jj) = z(j)
                  y(jj) = -x(j)
                  z(jj) = y(j)
               else if (i .eq. 33) then
                  x(jj) = -y(j)
                  y(jj) = -z(j)
                  z(jj) = -x(j)
               else if (i .eq. 34) then
                  x(jj) = y(j)
                  y(jj) = -z(j)
                  z(jj) = x(j)
               else if (i .eq. 35) then
                  x(jj) = -y(j)
                  y(jj) = z(j)
                  z(jj) = x(j)
               else if (i .eq. 36) then
                  x(jj) = y(j)
                  y(jj) = z(j)
                  z(jj) = -x(j)
               else if (i .eq. 37) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 38) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 39) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 40) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 41) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 42) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 43) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 44) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 45) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 46) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 47) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 48) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + x(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pn3(-)m space group  (Intl. Tables 224, origin at center)
c
      else if (spacegrp .eq. 'Pn3(-)m ') then
         nsym = 48
         noff = 1
         do i = 1, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 1) then
                  x(jj) = x(j)
                  y(jj) = y(j)
                  z(jj) = z(j)
               else if (i .eq. 2) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = z(j)
               else if (i .eq. 3) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 4) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 5) then
                  x(jj) = z(j)
                  y(jj) = x(j)
                  z(jj) = y(j)
               else if (i .eq. 6) then
                  x(jj) = z(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 7) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = y(j)
               else if (i .eq. 8) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = x(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 9) then
                  x(jj) = y(j)
                  y(jj) = z(j)
                  z(jj) = x(j)
               else if (i .eq. 10) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = z(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 11) then
                  x(jj) = y(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 12) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = x(j)
               else if (i .eq. 13) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = -z(j)
               else if (i .eq. 14) then
                  x(jj) = -y(j)
                  y(jj) = -x(j)
                  z(jj) = -z(j)
               else if (i .eq. 15) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = -x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 16) then
                  x(jj) = -y(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 17) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = -y(j)
               else if (i .eq. 18) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 19) then
                  x(jj) = -x(j)
                  y(jj) = -z(j)
                  z(jj) = -y(j)
               else if (i .eq. 20) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = -z(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 21) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -x(j)
               else if (i .eq. 22) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 23) then
                  x(jj) = -z(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 24) then
                  x(jj) = -z(j)
                  y(jj) = -y(j)
                  z(jj) = -x(j)
               else if (i .eq. 25) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 26) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 27) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = -y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 28) then
                  x(jj) = -x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 29) then
                  x(jj) = -z(j)
                  y(jj) = -x(j)
                  z(jj) = -y(j)
               else if (i .eq. 30) then
                  x(jj) = -z(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 31) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = 0.5d0 + x(j)
                  z(jj) = -y(j)
               else if (i .eq. 32) then
                  x(jj) = 0.5d0 + z(j)
                  y(jj) = -x(j)
                  z(jj) = 0.5d0 + y(j)
               else if (i .eq. 33) then
                  x(jj) = -y(j)
                  y(jj) = -z(j)
                  z(jj) = -x(j)
               else if (i .eq. 34) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = -z(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 35) then
                  x(jj) = -y(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = 0.5d0 + x(j)
               else if (i .eq. 36) then
                  x(jj) = 0.5d0 + y(j)
                  y(jj) = 0.5d0 + z(j)
                  z(jj) = -x(j)
               else if (i .eq. 37) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = z(j)
               else if (i .eq. 38) then
                  x(jj) = y(j)
                  y(jj) = x(j)
                  z(jj) = z(j)
               else if (i .eq. 39) then
                  x(jj) = 0.5d0 - y(j)
                  y(jj) = x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 40) then
                  x(jj) = y(j)
                  y(jj) = 0.5d0 - x(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 41) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = y(j)
               else if (i .eq. 42) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 - z(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 43) then
                  x(jj) = x(j)
                  y(jj) = z(j)
                  z(jj) = y(j)
               else if (i .eq. 44) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = z(j)
                  z(jj) = 0.5d0 - y(j)
               else if (i .eq. 45) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = x(j)
               else if (i .eq. 46) then
                  x(jj) = 0.5d0 - z(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 47) then
                  x(jj) = z(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - x(j)
               else if (i .eq. 48) then
                  x(jj) = z(j)
                  y(jj) = y(j)
                  z(jj) = x(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Fm3(-)m space group  (Intl. Tables 225, Face Centered Cubic)
c
      else if (spacegrp .eq. 'Fm3(-)m ') then
         nsym = 48
         noff = 4
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.0d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               else if (k .eq. 3) then
                  xoff = 0.5d0
                  yoff = 0.0d0
                  zoff = 0.5d0
               else if (k .eq. 4) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = -z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 9) then
                     x(jj) = y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 10) then
                     x(jj) = -y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 11) then
                     x(jj) = y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 12) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 13) then
                     x(jj) = y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 14) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 15) then
                     x(jj) = y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 16) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 17) then
                     x(jj) = x(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 18) then
                     x(jj) = -x(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 19) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 20) then
                     x(jj) = x(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 21) then
                     x(jj) = z(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 22) then
                     x(jj) = z(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 23) then
                     x(jj) = -z(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 24) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 25) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 26) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 27) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 28) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 29) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 30) then
                     x(jj) = -z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 31) then
                     x(jj) = z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 32) then
                     x(jj) = z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 33) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 34) then
                     x(jj) = y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 35) then
                     x(jj) = -y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 36) then
                     x(jj) = y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 37) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 38) then
                     x(jj) = y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 39) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 40) then
                     x(jj) = y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 41) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 42) then
                     x(jj) = x(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 43) then
                     x(jj) = x(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 44) then
                     x(jj) = -x(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 45) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 46) then
                     x(jj) = -z(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 47) then
                     x(jj) = z(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 48) then
                     x(jj) = z(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = x(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Fm3(-)c space group  (International Tables 226)
c
      else if (spacegrp .eq. 'Fm3(-)c ') then
         nsym = 48
         noff = 4
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.0d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               else if (k .eq. 3) then
                  xoff = 0.5d0
                  yoff = 0.0d0
                  zoff = 0.5d0
               else if (k .eq. 4) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = -z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 9) then
                     x(jj) = y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 10) then
                     x(jj) = -y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 11) then
                     x(jj) = y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 12) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 13) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 14) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = 0.5d0 - x(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 15) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = 0.5d0 - x(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 16) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 17) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 + z(j) + yoff
                     z(jj) = 0.5d0 - y(j) + zoff
                  else if (i .eq. 18) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 + z(j) + yoff
                     z(jj) = 0.5d0 + y(j) + zoff
                  else if (i .eq. 19) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 - z(j) + yoff
                     z(jj) = 0.5d0 - y(j) + zoff
                  else if (i .eq. 20) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 - z(j) + yoff
                     z(jj) = 0.5d0 + y(j) + zoff
                  else if (i .eq. 21) then
                     x(jj) = 0.5d0 + z(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.5d0 - x(j) + zoff
                  else if (i .eq. 22) then
                     x(jj) = 0.5d0 + z(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.5d0 + x(j) + zoff
                  else if (i .eq. 23) then
                     x(jj) = 0.5d0 - z(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.5d0 + x(j) + zoff
                  else if (i .eq. 24) then
                     x(jj) = 0.5d0 - z(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.5d0 - x(j) + zoff
                  else if (i .eq. 25) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 26) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 27) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 28) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 29) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 30) then
                     x(jj) = -z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 31) then
                     x(jj) = z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 32) then
                     x(jj) = z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 33) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 34) then
                     x(jj) = y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 35) then
                     x(jj) = -y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 36) then
                     x(jj) = y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 37) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = 0.5d0 - x(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 38) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 39) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 40) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = 0.5d0 - x(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 41) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 - z(j) + yoff
                     z(jj) = 0.5d0 + y(j) + zoff
                  else if (i .eq. 42) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 - z(j) + yoff
                     z(jj) = 0.5d0 - y(j) + zoff
                  else if (i .eq. 43) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 + z(j) + yoff
                     z(jj) = 0.5d0 + y(j) + zoff
                  else if (i .eq. 44) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 + z(j) + yoff
                     z(jj) = 0.5d0 - y(j) + zoff
                  else if (i .eq. 45) then
                     x(jj) = 0.5d0 - z(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.5d0 + x(j) + zoff
                  else if (i .eq. 46) then
                     x(jj) = 0.5d0 - z(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.5d0 - x(j) + zoff
                  else if (i .eq. 47) then
                     x(jj) = 0.5d0 + z(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.5d0 - x(j) + zoff
                  else if (i .eq. 48) then
                     x(jj) = 0.5d0 + z(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.5d0 + x(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Fd3(-)m space group  (Intl. Tables 227, origin at center)
c
      else if (spacegrp .eq. 'Fd3(-)m ') then
         nsym = 48
         noff = 4
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.0d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               else if (k .eq. 3) then
                  xoff = 0.5d0
                  yoff = 0.0d0
                  zoff = 0.5d0
               else if (k .eq. 4) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = 0.75d0 - x(j) + xoff
                     y(jj) = 0.25d0 - y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = 0.25d0 - x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.75d0 - z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.75d0 - y(j) + yoff
                     z(jj) = 0.25d0 - z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = 0.5d0 + z(j) + xoff
                     y(jj) = 0.75d0 - x(j) + yoff
                     z(jj) = 0.25d0 - y(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = 0.75d0 - z(j) + xoff
                     y(jj) = 0.25d0 - x(j) + yoff
                     z(jj) = 0.5d0 + y(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = 0.25d0 - z(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = 0.75d0 - y(j) + zoff
                  else if (i .eq. 9) then
                     x(jj) = y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 10) then
                     x(jj) = 0.25d0 - y(j) + xoff
                     y(jj) = 0.5d0 + z(j) + yoff
                     z(jj) = 0.75d0 - x(j) + zoff
                  else if (i .eq. 11) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = 0.75d0 - z(j) + yoff
                     z(jj) = 0.25d0 - x(j) + zoff
                  else if (i .eq. 12) then
                     x(jj) = 0.75d0 - y(j) + xoff
                     y(jj) = 0.25d0 - z(j) + yoff
                     z(jj) = 0.5d0 + x(j) + zoff
                  else if (i .eq. 13) then
                     x(jj) = 0.75d0 + y(j) + xoff
                     y(jj) = 0.25d0 + x(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 14) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 15) then
                     x(jj) = 0.25d0 + y(j) + xoff
                     y(jj) = 0.5d0 - x(j) + yoff
                     z(jj) = 0.75d0 + z(j) + zoff
                  else if (i .eq. 16) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = 0.75d0 + x(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  else if (i .eq. 17) then
                     x(jj) = 0.75d0 + x(j) + xoff
                     y(jj) = 0.25d0 + z(j) + yoff
                     z(jj) = 0.5d0 - y(j) + zoff
                  else if (i .eq. 18) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.75d0 + z(j) + yoff
                     z(jj) = 0.25d0 + y(j) + zoff
                  else if (i .eq. 19) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 20) then
                     x(jj) = 0.25d0 + x(j) + xoff
                     y(jj) = 0.5d0 - z(j) + yoff
                     z(jj) = 0.75d0 + y(j) + zoff
                  else if (i .eq. 21) then
                     x(jj) = 0.75d0 + z(j) + xoff
                     y(jj) = 0.25d0 + y(j) + yoff
                     z(jj) = 0.5d0 - x(j) + zoff
                  else if (i .eq. 22) then
                     x(jj) = 0.25d0 + z(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.75d0 + x(j) + zoff
                  else if (i .eq. 23) then
                     x(jj) = 0.5d0 - z(j) + xoff
                     y(jj) = 0.75d0 + y(j) + yoff
                     z(jj) = 0.25d0 + x(j) + zoff
                  else if (i .eq. 24) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 25) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 26) then
                     x(jj) = 0.25d0 + x(j) + xoff
                     y(jj) = 0.75d0 + y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 27) then
                     x(jj) = 0.75d0 + x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  else if (i .eq. 28) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.25d0 + y(j) + yoff
                     z(jj) = 0.75d0 + z(j) + zoff
                  else if (i .eq. 29) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 30) then
                     x(jj) = 0.5d0 - z(j) + xoff
                     y(jj) = 0.25d0 + x(j) + yoff
                     z(jj) = 0.75d0 + y(j) + zoff
                  else if (i .eq. 31) then
                     x(jj) = 0.25d0 + z(j) + xoff
                     y(jj) = 0.75d0 + x(j) + yoff
                     z(jj) = 0.5d0 - y(j) + zoff
                  else if (i .eq. 32) then
                     x(jj) = 0.75d0 + z(j) + xoff
                     y(jj) = 0.5d0 - x(j) + yoff
                     z(jj) = 0.25d0 + y(j) + zoff
                  else if (i .eq. 33) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 34) then
                     x(jj) = 0.75d0 + y(j) + xoff
                     y(jj) = 0.5d0 - z(j) + yoff
                     z(jj) = 0.25d0 + x(j) + zoff
                  else if (i .eq. 35) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = 0.25d0 + z(j) + yoff
                     z(jj) = 0.75d0 + x(j) + zoff
                  else if (i .eq. 36) then
                     x(jj) = 0.25d0 + y(j) + xoff
                     y(jj) = 0.75d0 + z(j) + yoff
                     z(jj) = 0.5d0 - x(j) + zoff
                  else if (i .eq. 37) then
                     x(jj) = 0.25d0 - y(j) + xoff
                     y(jj) = 0.75d0 - x(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 38) then
                     x(jj) = y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 39) then
                     x(jj) = 0.75d0 - y(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = 0.25d0 - z(j) + zoff
                  else if (i .eq. 40) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = 0.25d0 - x(j) + yoff
                     z(jj) = 0.75d0 - z(j) + zoff
                  else if (i .eq. 41) then
                     x(jj) = 0.25d0 - x(j) + xoff
                     y(jj) = 0.75d0 - z(j) + yoff
                     z(jj) = 0.5d0 + y(j) + zoff
                  else if (i .eq. 42) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.25d0 - z(j) + yoff
                     z(jj) = 0.75d0 - y(j) + zoff
                  else if (i .eq. 43) then
                     x(jj) = x(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 44) then
                     x(jj) = 0.75d0 - x(j) + xoff
                     y(jj) = 0.5d0 + z(j) + yoff
                     z(jj) = 0.25d0 - y(j) + zoff
                  else if (i .eq. 45) then
                     x(jj) = 0.25d0 - z(j) + xoff
                     y(jj) = 0.75d0 - y(j) + yoff
                     z(jj) = 0.5d0 + x(j) + zoff
                  else if (i .eq. 46) then
                     x(jj) = 0.75d0 - z(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.25d0 - x(j) + zoff
                  else if (i .eq. 47) then
                     x(jj) = 0.5d0 + z(j) + xoff
                     y(jj) = 0.25d0 - y(j) + yoff
                     z(jj) = 0.75d0 - x(j) + zoff
                  else if (i .eq. 48) then
                     x(jj) = z(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = x(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Fd3(-)c space group  (Intl. Tables 228, origin at center)
c
      else if (spacegrp .eq. 'Fd3(-)c ') then
         nsym = 48
         noff = 4
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.0d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               else if (k .eq. 3) then
                  xoff = 0.5d0
                  yoff = 0.0d0
                  zoff = 0.5d0
               else if (k .eq. 4) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.0d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = 0.25d0 - x(j) + xoff
                     y(jj) = 0.75d0 - y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = 0.75d0 - x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.25d0 - z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.25d0 - y(j) + yoff
                     z(jj) = 0.75d0 - z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = 0.5d0 + z(j) + xoff
                     y(jj) = 0.25d0 - x(j) + yoff
                     z(jj) = 0.75d0 - y(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = 0.25d0 - z(j) + xoff
                     y(jj) = 0.75d0 - x(j) + yoff
                     z(jj) = 0.5d0 + y(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = 0.75d0 - z(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = 0.25d0 - y(j) + zoff
                  else if (i .eq. 9) then
                     x(jj) = y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 10) then
                     x(jj) = 0.75d0 - y(j) + xoff
                     y(jj) = 0.5d0 + z(j) + yoff
                     z(jj) = 0.25d0 - x(j) + zoff
                  else if (i .eq. 11) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = 0.25d0 - z(j) + yoff
                     z(jj) = 0.75d0 - x(j) + zoff
                  else if (i .eq. 12) then
                     x(jj) = 0.25d0 - y(j) + xoff
                     y(jj) = 0.75d0 - z(j) + yoff
                     z(jj) = 0.5d0 + x(j) + zoff
                  else if (i .eq. 13) then
                     x(jj) = 0.75d0 + y(j) + xoff
                     y(jj) = 0.25d0 + x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 14) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = 0.5d0 - x(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 15) then
                     x(jj) = 0.25d0 + y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = 0.75d0 + z(j) + zoff
                  else if (i .eq. 16) then
                     x(jj) = -y(j) + xoff
                     y(jj) = 0.75d0 + x(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  else if (i .eq. 17) then
                     x(jj) = 0.75d0 + x(j) + xoff
                     y(jj) = 0.25d0 + z(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 18) then
                     x(jj) = -x(j) + xoff
                     y(jj) = 0.75d0 + z(j) + yoff
                     z(jj) = 0.25d0 + y(j) + zoff
                  else if (i .eq. 19) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 - z(j) + yoff
                     z(jj) = 0.5d0 - y(j) + zoff
                  else if (i .eq. 20) then
                     x(jj) = 0.25d0 + x(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = 0.75d0 + y(j) + zoff
                  else if (i .eq. 21) then
                     x(jj) = 0.75d0 + z(j) + xoff
                     y(jj) = 0.25d0 + y(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 22) then
                     x(jj) = 0.25d0 + z(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.75d0 + x(j) + zoff
                  else if (i .eq. 23) then
                     x(jj) = -z(j) + xoff
                     y(jj) = 0.75d0 + y(j) + yoff
                     z(jj) = 0.25d0 + x(j) + zoff
                  else if (i .eq. 24) then
                     x(jj) = 0.5d0 - z(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.5d0 - x(j) + zoff
                  else if (i .eq. 25) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 26) then
                     x(jj) = 0.75d0 + x(j) + xoff
                     y(jj) = 0.25d0 + y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 27) then
                     x(jj) = 0.25d0 + x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.75d0 + z(j) + zoff
                  else if (i .eq. 28) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.75d0 + y(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  else if (i .eq. 29) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 30) then
                     x(jj) = 0.5d0 - z(j) + xoff
                     y(jj) = 0.75d0 + x(j) + yoff
                     z(jj) = 0.25d0 + y(j) + zoff
                  else if (i .eq. 31) then
                     x(jj) = 0.75d0 + z(j) + xoff
                     y(jj) = 0.25d0 + x(j) + yoff
                     z(jj) = 0.5d0 - y(j) + zoff
                  else if (i .eq. 32) then
                     x(jj) = 0.25d0 + z(j) + xoff
                     y(jj) = 0.5d0 - x(j) + yoff
                     z(jj) = 0.75d0 + y(j) + zoff
                  else if (i .eq. 33) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 34) then
                     x(jj) = 0.25d0 + y(j) + xoff
                     y(jj) = 0.5d0 - z(j) + yoff
                     z(jj) = 0.75d0 + x(j) + zoff
                  else if (i .eq. 35) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = 0.75d0 + z(j) + yoff
                     z(jj) = 0.25d0 + x(j) + zoff
                  else if (i .eq. 36) then
                     x(jj) = 0.75d0 + y(j) + xoff
                     y(jj) = 0.25d0 + z(j) + yoff
                     z(jj) = 0.5d0 - x(j) + zoff
                  else if (i .eq. 37) then
                     x(jj) = 0.25d0 - y(j) + xoff
                     y(jj) = 0.75d0 - x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 38) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 39) then
                     x(jj) = 0.75d0 - y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = 0.25d0 - z(j) + zoff
                  else if (i .eq. 40) then
                     x(jj) = y(j) + xoff
                     y(jj) = 0.25d0 - x(j) + yoff
                     z(jj) = 0.75d0 - z(j) + zoff
                  else if (i .eq. 41) then
                     x(jj) = 0.25d0 - x(j) + xoff
                     y(jj) = 0.75d0 - z(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 42) then
                     x(jj) = x(j) + xoff
                     y(jj) = 0.25d0 - z(j) + yoff
                     z(jj) = 0.75d0 - y(j) + zoff
                  else if (i .eq. 43) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 + z(j) + yoff
                     z(jj) = 0.5d0 + y(j) + zoff
                  else if (i .eq. 44) then
                     x(jj) = 0.75d0 - x(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = 0.25d0 - y(j) + zoff
                  else if (i .eq. 45) then
                     x(jj) = 0.25d0 - z(j) + xoff
                     y(jj) = 0.75d0 - y(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 46) then
                     x(jj) = 0.75d0 - z(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.25d0 - x(j) + zoff
                  else if (i .eq. 47) then
                     x(jj) = z(j) + xoff
                     y(jj) = 0.25d0 - y(j) + yoff
                     z(jj) = 0.75d0 - x(j) + zoff
                  else if (i .eq. 48) then
                     x(jj) = 0.5d0 + z(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.5d0 + x(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Im3(-)m space group  (Intl. Tables 229, Body Centered Cubic)
c
      else if (spacegrp .eq. 'Im3(-)m ') then
         nsym = 48
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = -z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 9) then
                     x(jj) = y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 10) then
                     x(jj) = -y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 11) then
                     x(jj) = y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 12) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 13) then
                     x(jj) = y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 14) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 15) then
                     x(jj) = y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 16) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 17) then
                     x(jj) = x(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 18) then
                     x(jj) = -x(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 19) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 20) then
                     x(jj) = x(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 21) then
                     x(jj) = z(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 22) then
                     x(jj) = z(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 23) then
                     x(jj) = -z(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 24) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 25) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 26) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 27) then
                     x(jj) = x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 28) then
                     x(jj) = -x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 29) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 30) then
                     x(jj) = -z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 31) then
                     x(jj) = z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 32) then
                     x(jj) = z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 33) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 34) then
                     x(jj) = y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 35) then
                     x(jj) = -y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 36) then
                     x(jj) = y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 37) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 38) then
                     x(jj) = y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 39) then
                     x(jj) = -y(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 40) then
                     x(jj) = y(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 41) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 42) then
                     x(jj) = x(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 43) then
                     x(jj) = x(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 44) then
                     x(jj) = -x(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 45) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 46) then
                     x(jj) = -z(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 47) then
                     x(jj) = z(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 48) then
                     x(jj) = z(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = x(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
c
c     Ia3(-)d space group  (International Tables 230)
c
      else if (spacegrp .eq. 'Ia3(-)d ') then
         nsym = 48
         noff = 2
         do i = 1, nsym
            ii = (i-1) * noff * n
            do k = 1, noff
               kk = ii + (k-1)*n
               if (k .eq. 1) then
                  xoff = 0.0d0
                  yoff = 0.0d0
                  zoff = 0.0d0
               else if (k .eq. 2) then
                  xoff = 0.5d0
                  yoff = 0.5d0
                  zoff = 0.5d0
               end if
               do j = 1, n
                  jj = j + kk
                  if (i .eq. 1) then
                     x(jj) = x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 2) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 3) then
                     x(jj) = -x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 4) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 5) then
                     x(jj) = z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 6) then
                     x(jj) = 0.5d0 + z(j) + xoff
                     y(jj) = 0.5d0 - x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 7) then
                     x(jj) = 0.5d0 - z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = 0.5d0 + y(j) + zoff
                  else if (i .eq. 8) then
                     x(jj) = -z(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = 0.5d0 - y(j) + zoff
                  else if (i .eq. 9) then
                     x(jj) = y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 10) then
                     x(jj) = -y(j) + xoff
                     y(jj) = 0.5d0 + z(j) + yoff
                     z(jj) = 0.5d0 - x(j) + zoff
                  else if (i .eq. 11) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = 0.5d0 - z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 12) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = 0.5d0 + x(j) + zoff
                  else if (i .eq. 13) then
                     x(jj) = 0.75d0 + y(j) + xoff
                     y(jj) = 0.25d0 + x(j) + yoff
                     z(jj) = 0.25d0 - z(j) + zoff
                  else if (i .eq. 14) then
                     x(jj) = 0.75d0 - y(j) + xoff
                     y(jj) = 0.75d0 - x(j) + yoff
                     z(jj) = 0.75d0 - z(j) + zoff
                  else if (i .eq. 15) then
                     x(jj) = 0.25d0 + y(j) + xoff
                     y(jj) = 0.25d0 - x(j) + yoff
                     z(jj) = 0.75d0 + z(j) + zoff
                  else if (i .eq. 16) then
                     x(jj) = 0.25d0 - y(j) + xoff
                     y(jj) = 0.75d0 + x(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  else if (i .eq. 17) then
                     x(jj) = 0.75d0 + x(j) + xoff
                     y(jj) = 0.25d0 + z(j) + yoff
                     z(jj) = 0.25d0 - y(j) + zoff
                  else if (i .eq. 18) then
                     x(jj) = 0.25d0 - x(j) + xoff
                     y(jj) = 0.75d0 + z(j) + yoff
                     z(jj) = 0.25d0 + y(j) + zoff
                  else if (i .eq. 19) then
                     x(jj) = 0.75d0 - x(j) + xoff
                     y(jj) = 0.75d0 - z(j) + yoff
                     z(jj) = 0.75d0 - y(j) + zoff
                  else if (i .eq. 20) then
                     x(jj) = 0.25d0 + x(j) + xoff
                     y(jj) = 0.25d0 - z(j) + yoff
                     z(jj) = 0.75d0 + y(j) + zoff
                  else if (i .eq. 21) then
                     x(jj) = 0.75d0 + z(j) + xoff
                     y(jj) = 0.25d0 + y(j) + yoff
                     z(jj) = 0.25d0 - x(j) + zoff
                  else if (i .eq. 22) then
                     x(jj) = 0.25d0 + z(j) + xoff
                     y(jj) = 0.25d0 - y(j) + yoff
                     z(jj) = 0.75d0 + x(j) + zoff
                  else if (i .eq. 23) then
                     x(jj) = 0.25d0 - z(j) + xoff
                     y(jj) = 0.75d0 + y(j) + yoff
                     z(jj) = 0.25d0 + x(j) + zoff
                  else if (i .eq. 24) then
                     x(jj) = 0.75d0 - z(j) + xoff
                     y(jj) = 0.75d0 - y(j) + yoff
                     z(jj) = 0.75d0 - x(j) + zoff
                  else if (i .eq. 25) then
                     x(jj) = -x(j) + xoff
                     y(jj) = -y(j) + yoff
                     z(jj) = -z(j) + zoff
                  else if (i .eq. 26) then
                     x(jj) = 0.5d0 + x(j) + xoff
                     y(jj) = y(j) + yoff
                     z(jj) = 0.5d0 - z(j) + zoff
                  else if (i .eq. 27) then
                     x(jj) = x(j) + xoff
                     y(jj) = 0.5d0 - y(j) + yoff
                     z(jj) = 0.5d0 + z(j) + zoff
                  else if (i .eq. 28) then
                     x(jj) = 0.5d0 - x(j) + xoff
                     y(jj) = 0.5d0 + y(j) + yoff
                     z(jj) = z(j) + zoff
                  else if (i .eq. 29) then
                     x(jj) = -z(j) + xoff
                     y(jj) = -x(j) + yoff
                     z(jj) = -y(j) + zoff
                  else if (i .eq. 30) then
                     x(jj) = 0.5d0 - z(j) + xoff
                     y(jj) = 0.5d0 + x(j) + yoff
                     z(jj) = y(j) + zoff
                  else if (i .eq. 31) then
                     x(jj) = 0.5d0 + z(j) + xoff
                     y(jj) = x(j) + yoff
                     z(jj) = 0.5d0 - y(j) + zoff
                  else if (i .eq. 32) then
                     x(jj) = z(j) + xoff
                     y(jj) = 0.5d0 - x(j) + yoff
                     z(jj) = 0.5d0 + y(j) + zoff
                  else if (i .eq. 33) then
                     x(jj) = -y(j) + xoff
                     y(jj) = -z(j) + yoff
                     z(jj) = -x(j) + zoff
                  else if (i .eq. 34) then
                     x(jj) = y(j) + xoff
                     y(jj) = 0.5d0 - z(j) + yoff
                     z(jj) = 0.5d0 + x(j) + zoff
                  else if (i .eq. 35) then
                     x(jj) = 0.5d0 - y(j) + xoff
                     y(jj) = 0.5d0 + z(j) + yoff
                     z(jj) = x(j) + zoff
                  else if (i .eq. 36) then
                     x(jj) = 0.5d0 + y(j) + xoff
                     y(jj) = z(j) + yoff
                     z(jj) = 0.5d0 - x(j) + zoff
                  else if (i .eq. 37) then
                     x(jj) = 0.25d0 - y(j) + xoff
                     y(jj) = 0.75d0 - x(j) + yoff
                     z(jj) = 0.75d0 + z(j) + zoff
                  else if (i .eq. 38) then
                     x(jj) = 0.25d0 + y(j) + xoff
                     y(jj) = 0.25d0 + x(j) + yoff
                     z(jj) = 0.25d0 + z(j) + zoff
                  else if (i .eq. 39) then
                     x(jj) = 0.75d0 - y(j) + xoff
                     y(jj) = 0.75d0 + x(j) + yoff
                     z(jj) = 0.25d0 - z(j) + zoff
                  else if (i .eq. 40) then
                     x(jj) = 0.75d0 + y(j) + xoff
                     y(jj) = 0.25d0 - x(j) + yoff
                     z(jj) = 0.75d0 - z(j) + zoff
                  else if (i .eq. 41) then
                     x(jj) = 0.25d0 - x(j) + xoff
                     y(jj) = 0.75d0 - z(j) + yoff
                     z(jj) = 0.75d0 + y(j) + zoff
                  else if (i .eq. 42) then
                     x(jj) = 0.75d0 + x(j) + xoff
                     y(jj) = 0.25d0 - z(j) + yoff
                     z(jj) = 0.75d0 - y(j) + zoff
                  else if (i .eq. 43) then
                     x(jj) = 0.25d0 + x(j) + xoff
                     y(jj) = 0.25d0 + z(j) + yoff
                     z(jj) = 0.25d0 + y(j) + zoff
                  else if (i .eq. 44) then
                     x(jj) = 0.75d0 - x(j) + xoff
                     y(jj) = 0.75d0 + z(j) + yoff
                     z(jj) = 0.25d0 - y(j) + zoff
                  else if (i .eq. 45) then
                     x(jj) = 0.25d0 - z(j) + xoff
                     y(jj) = 0.75d0 - y(j) + yoff
                     z(jj) = 0.75d0 + x(j) + zoff
                  else if (i .eq. 46) then
                     x(jj) = 0.75d0 - z(j) + xoff
                     y(jj) = 0.75d0 + y(j) + yoff
                     z(jj) = 0.25d0 - x(j) + zoff
                  else if (i .eq. 47) then
                     x(jj) = 0.75d0 + z(j) + xoff
                     y(jj) = 0.25d0 - y(j) + yoff
                     z(jj) = 0.75d0 - x(j) + zoff
                  else if (i .eq. 48) then
                     x(jj) = 0.25d0 + z(j) + xoff
                     y(jj) = 0.25d0 + y(j) + yoff
                     z(jj) = 0.25d0 + x(j) + zoff
                  end if
                  call cellatom (jj,j)
               end do
            end do
         end do
      end if
c
c     set the total number of atoms in the full unit cell
c
      n = nsym * noff * n
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine cspline  --  periodic interpolating cube spline  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "cspline" computes coefficients for a periodic interpolating
c     cubic spline
c
c     literature reference:
c
c     G. Engeln-Mullges and F. Uhlig, Numerical Algorithms with
c     Fortran, Springer Verlag, 1996  (Section 10.1.2; "isplpe"]
c
c
      subroutine cspline (n,xn,fn,b,c,d,h,du,dm,rc,rs)
      use iounit
      implicit none
      integer i,n,iflag
      real*8 eps,average
      real*8 temp1,temp2
      real*8 xn(0:*)
      real*8 fn(0:*)
      real*8 b(0:*)
      real*8 c(0:*)
      real*8 d(0:*)
      real*8 h(0:*)
      real*8 du(0:*)
      real*8 dm(0:*)
      real*8 rc(0:*)
      real*8 rs(0:*)
c
c
c     check the periodicity of fn, and for subsequent call
c
      eps = 0.000001d0
      if (abs(fn(n)-fn(0)) .gt. eps) then
         write (iout,10)  fn(0),fn(n)
   10    format (/,' CSPLINE  --  Warning, Non-Periodic Input',
     &              ' Values',2f12.5)
      end if
      average = 0.5d0 * (fn(0) + fn(n))
      fn(0) = average
      fn(n) = average
c
c     get auxiliary variables and matrix elements on first call
c
      do i = 0, n-1
         h(i) = xn(i+1) - xn(i)
      end do
      h(n) = h(0)
      do i = 1, n-1
         du(i) = h(i)
      end do
      du(n) = h(0)
      do i = 1, n
         dm(i) = 2.0d0 * (h(i-1)+h(i))
      end do
c
c     compute the right hand side
c
      temp1 = (fn(1)-fn(0)) / h(0)
      do i = 1, n-1, 1
         temp2 = (fn(i+1)-fn(i)) / h(i)
         rs(i) = 3.0d0 * (temp2-temp1)
         temp1 = temp2
      end do
      rs(n) = 3.0d0 * ((fn(1)-fn(0))/h(0)-temp1)
c
c     solve the linear system with factorization
c
      call cytsy (n,dm,du,rc,rs,c,iflag)
      if (iflag .ne. 1)  return
c
c     compute remaining spline coefficients
c
      c(0) = c(n)
      do i = 0, n-1
         b(i) = (fn(i+1)-fn(i))/h(i) - h(i)/3.0d0*(c(i+1)+2.0d0*c(i))
         d(i) = (c(i+1)-c(i)) / (3.0d0*h(i))
      end do
      b(n) = (fn(1)-fn(n))/h(n) - h(n)/3.0d0*(c(1)+2.0d0*c(n))
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine cytsy  --  solve cyclic tridiagonal system  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "cytsy" solves a system of linear equations for a cyclically
c     tridiagonal, symmetric, positive definite matrix
c
c     literature reference:
c
c     G. Engeln-Mullges and F. Uhlig, Numerical Algorithms with
c     Fortran, Springer Verlag, 1996, Section 4.11.2
c
c
      subroutine cytsy (n,dm,du,cr,rs,x,iflag)
      implicit none
      integer n,iflag
      real*8 dm(0:*)
      real*8 du(0:*)
      real*8 cr(0:*)
      real*8 rs(0:*)
      real*8 x(0:*)
c
c
c     factorization of the input matrix
c
      iflag = -2
      if (n .lt. 3)  return
      call cytsyp (n,dm,du,cr,iflag)
c
c     update and back substitute as necessary
c
      if (iflag .eq. 1)  call cytsys (n,dm,du,cr,rs,x)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine cytsyp  --  tridiagonal Cholesky factorization  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "cytsyp" finds Cholesky factors of a cyclically tridiagonal
c     symmetric, positive definite matrix given by two vectors
c
c     literature reference:
c
c     G. Engeln-Mullges and F. Uhlig, Numerical Algorithms with
c     Fortran, Springer Verlag, 1996, Section 4.11.2
c
c
      subroutine cytsyp (n,dm,du,cr,iflag)
      implicit none
      integer i,n,iflag
      real*8 eps,row,d
      real*8 temp1,temp2
      real*8 dm(0:*)
      real*8 du(0:*)
      real*8 cr(0:*)
c
c
c     set error bound and test for condition n greater than 2
c
      eps = 0.00000001d0
      iflag = -2
      if (n .lt. 3)  return
c
c     checking to see if matrix is positive definite
c
      row = abs(dm(1)) + abs(du(1)) + abs(du(n))
      if (row .eq. 0.0d0) then
         iflag = 0
         return
      end if
      d = 1.0d0 / row
      if (dm(1) .lt. 0.0d0) then
         iflag = -1
         return
      else if (abs(dm(1))*d .le. eps) then
         iflag = 0
         return
      end if
c
c     factoring a while checking for a positive definite and strong
c     nonsingular matrix a
c
      temp1 = du(1)
      du(1) = du(1) / dm(1)
      cr(1) = du(n) / dm(1)
      do i = 2, n-1
         row = abs(dm(i)) + abs(du(i)) + abs(temp1)
         if (row .eq. 0.0d0) then
            iflag = 0
            return
         end if
         d = 1.0d0 / row
         dm(i) = dm(i) - temp1*du(i-1)
         if (dm(i) .lt. 0.0d0) then
            iflag = -1
            return
         else if (abs(dm(i))*d .le. eps) then
            iflag = 0
            return
         end if
         if (i .lt. (n-1)) then
            cr(i) = -temp1 * cr(i-1) / dm(i)
            temp1 = du(i)
            du(i) = du(i) / dm(i)
         else
            temp2 = du(i)
            du(i) = (du(i) - temp1*cr(i-1)) / dm(i)
         end if
      end do
      row = abs(du(n)) + abs(dm(n)) + abs(temp2)
      if (row .eq. 0.0d0) then
         iflag = 0
         return
      end if
      d = 1.0d0 / row
      dm(n) = dm(n) - dm(n-1)*du(n-1)*du(n-1)
      temp1 = 0.0d0
      do i = 1, n-2
         temp1 = temp1 + dm(i)*cr(i)*cr(i)
      end do
      dm(n) = dm(n) - temp1
      if (dm(n) .lt. 0) then
         iflag = -1
         return
      else if (abs(dm(n))*d .le. eps) then
         iflag = 0
         return
      end if
      iflag = 1
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine cytsys  --  tridiagonal solution from factors  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "cytsys" solves a cyclically tridiagonal linear system
c     given the Cholesky factors
c
c     literature reference:
c
c     G. Engeln-Mullges and F. Uhlig, Numerical Algorithms with
c     Fortran, Springer Verlag, 1996, Section 4.11.2
c
c
      subroutine cytsys (n,dm,du,cr,rs,x)
      implicit none
      integer i,n
      real*8 sum,temp
      real*8 dm(0:*)
      real*8 du(0:*)
      real*8 cr(0:*)
      real*8 rs(0:*)
      real*8 x(0:*)
c
c
c     updating phase
c
      temp = rs(1)
      rs(1) = temp / dm(1)
      sum = cr(1) * temp
      do i = 2, n-1
         temp = rs(i) - du(i-1)*temp
         rs(i) = temp / dm(i)
         if (i .ne. (n-1))  sum = sum + cr(i)*temp
      end do
      temp = rs(n) - du(n-1)*temp
      temp = temp - sum
      rs(n) = temp / dm(n)
c
c     back substitution phase
c
      x(n) = rs(n)
      x(n-1) = rs(n-1) - du(n-1)*x(n)
      do i = n-2, 1, -1
         x(i) = rs(i) - du(i)*x(i+1) - cr(i)*x(n)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2019  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module ctrpot  --  charge transfer functional form details  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     ctrntyp   type of charge transfer term (SEPARATE or COMBINED)
c
c
      module ctrpot
      character*8 ctrntyp
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine cutoffs  --  distance cutoffs & neighbor lists  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "cutoffs" initializes and stores spherical energy cutoff
c     distance windows, Hessian element and Ewald sum cutoffs,
c     and allocates pairwise neighbor lists
c
c
      subroutine cutoffs
      use atoms
      use bound
      use hescut
      use keys
      use limits
      use neigh
      use polpot
      use tarray
      implicit none
      integer i,next
      integer limit
      real*8 big,value
      logical truncate
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set defaults for spherical energy cutoff distances
c
      big = 1.0d12
      if (use_bounds) then
         vdwcut = 9.0d0
         dispcut = 9.0d0
         chgcut = 9.0d0
         dplcut = 9.0d0
         mpolecut = 9.0d0
      else
         vdwcut = big
         dispcut = big
         chgcut = big
         dplcut = big
         mpolecut = big
      end if
      repcut = 6.0d0
      ctrncut = 6.0d0
      ewaldcut = 7.0d0
      dewaldcut = 7.0d0
      usolvcut = 4.5d0
c
c     set defaults for tapering, Hessian cutoff and neighbor buffers
c
      vdwtaper = 0.90d0
      reptaper = 0.90d0
      disptaper = 0.90d0
      chgtaper = 0.65d0
      dpltaper = 0.75d0
      mpoletaper = 0.65d0
      ctrntaper = 0.90d0
      hesscut = 0.0d0
      lbuffer = 2.0d0
      pbuffer = 2.0d0
c
c     set defaults for Ewald sum, tapering style and neighbor method
c
      use_ewald = .false.
      use_dewald = .false.
      truncate = .false.
      use_lights = .false.
      use_list = .false.
      use_vlist = .false.
      use_dlist = .false.
      use_clist = .false.
      use_mlist = .false.
      use_ulist = .false.
      dovlst = .true.
      dodlst = .true.
      doclst = .true.
      domlst = .true.
      doulst = .true.
c
c     search the keywords for various cutoff parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
c
c     get values related to use of Ewald for electrostatics
c
         if (keyword(1:6) .eq. 'EWALD ') then
            use_ewald = .true.
         else if (keyword(1:13) .eq. 'EWALD-CUTOFF ') then
            read (string,*,err=10,end=10)  ewaldcut
c
c     get values related to use of Ewald for dispersion
c
         else if (keyword(1:7) .eq. 'DEWALD ') then
            use_dewald = .true.
         else if (keyword(1:14) .eq. 'DEWALD-CUTOFF ') then
            read (string,*,err=10,end=10)  dewaldcut
c
c     get values for the tapering style and neighbor method
c
         else if (keyword(1:9) .eq. 'TRUNCATE ') then
            truncate = .true.
         else if (keyword(1:7) .eq. 'LIGHTS ') then
            use_lights = .true.
         else if (keyword(1:14) .eq. 'NEIGHBOR-LIST ') then
            use_list = .true.
            use_vlist = .true.
            use_dlist = .true.
            use_clist = .true.
            use_mlist = .true.
            use_ulist = .true.
         else if (keyword(1:9) .eq. 'VDW-LIST ') then
            use_list = .true.
            use_vlist = .true.
         else if (keyword(1:10) .eq. 'DISP-LIST ') then
            use_list = .true.
            use_dlist = .true.
         else if (keyword(1:12) .eq. 'CHARGE-LIST ') then
            use_list = .true.
            use_clist = .true.
         else if (keyword(1:11) .eq. 'MPOLE-LIST ') then
            use_list = .true.
            use_mlist = .true.
            use_ulist = .true.
c
c     get values for the dipole solver preconditioner
c
         else if (keyword(1:12) .eq. 'USOLVE-LIST ') then
            use_list = .true.
            use_ulist = .true.
         else if (keyword(1:14) .eq. 'USOLVE-CUTOFF ') then
            if (usolvcut .ne. 0.0d0) then
               read (string,*,err=10,end=10)  usolvcut
            end if
         else if (keyword(1:16) .eq. 'USOLVE-DIAGONAL ') then
            usolvcut = 0.0d0
c
c     get cutoff for the magnitude of Hessian elements
c
         else if (keyword(1:15) .eq. 'HESSIAN-CUTOFF ') then
            read (string,*,err=10,end=10)  hesscut
c
c     get the cutoff radii for potential energy functions
c
         else if (keyword(1:7) .eq. 'CUTOFF ') then
            read (string,*,err=10,end=10)  value
            vdwcut = value
            repcut = value
            dispcut = value
            chgcut = value
            dplcut = value
            mpolecut = value
            ewaldcut = value
            dewaldcut = value
            ctrncut = value
         else if (keyword(1:11) .eq. 'VDW-CUTOFF ') then
            read (string,*,err=10,end=10)  vdwcut
         else if (keyword(1:14) .eq. 'REPULS-CUTOFF ') then
            read (string,*,err=10,end=10)  repcut
         else if (keyword(1:12) .eq. 'DISP-CUTOFF ') then
            read (string,*,err=10,end=10)  dispcut
         else if (keyword(1:14) .eq. 'CHARGE-CUTOFF ') then
            read (string,*,err=10,end=10)  chgcut
         else if (keyword(1:14) .eq. 'DIPOLE-CUTOFF ') then
            read (string,*,err=10,end=10)  dplcut
         else if (keyword(1:13) .eq. 'MPOLE-CUTOFF ') then
            read (string,*,err=10,end=10)  mpolecut
         else if (keyword(1:14) .eq. 'CHGTRN-CUTOFF ') then
            read (string,*,err=10,end=10)  ctrncut
c
c     get distance for initialization of energy switching
c
         else if (keyword(1:6) .eq. 'TAPER ') then
            read (string,*,err=10,end=10)  value
            vdwtaper = value
            reptaper = value
            disptaper = value
            chgtaper = value
            dpltaper = value
            mpoletaper = value
            ctrntaper = value
         else if (keyword(1:10) .eq. 'VDW-TAPER ') then
            read (string,*,err=10,end=10)  vdwtaper
         else if (keyword(1:13) .eq. 'REPULS-TAPER ') then
            read (string,*,err=10,end=10)  reptaper
         else if (keyword(1:11) .eq. 'DISP-TAPER ') then
            read (string,*,err=10,end=10)  disptaper
         else if (keyword(1:13) .eq. 'CHARGE-TAPER ') then
            read (string,*,err=10,end=10)  chgtaper
         else if (keyword(1:13) .eq. 'DIPOLE-TAPER ') then
            read (string,*,err=10,end=10)  dpltaper
         else if (keyword(1:12) .eq. 'MPOLE-TAPER ') then
            read (string,*,err=10,end=10)  mpoletaper
         else if (keyword(1:13) .eq. 'CHGTRN-TAPER ') then
            read (string,*,err=10,end=10)  ctrntaper
c
c     get buffer width for use with pairwise neighbor lists
c
         else if (keyword(1:12) .eq. 'LIST-BUFFER ') then
            read (string,*,err=10,end=10)  lbuffer
         else if (keyword(1:14) .eq. 'USOLVE-BUFFER ') then
            read (string,*,err=10,end=10)  pbuffer
         end if
   10    continue
      end do
c
c     check to see if preconditioner list should be disabled
c
      if (poltyp .eq. 'DIRECT')  use_ulist = .false.
      if (usolvcut .le. 0.0d0)  use_ulist = .false.
      if (use_list)  usolvcut = usolvcut - pbuffer
c
c     apply any Ewald cutoff to dispersion and electrostatics
c
      if (use_ewald) then
         chgcut = ewaldcut
         mpolecut = ewaldcut
      end if
      if (use_dewald) then
         dispcut = dewaldcut
      end if
c
c     convert any tapering percentages to absolute distances
c
      if (vdwtaper .lt. 1.0d0)  vdwtaper = vdwtaper * vdwcut
      if (reptaper .lt. 1.0d0)  reptaper = reptaper * repcut
      if (disptaper .lt. 1.0d0)  disptaper = disptaper * dispcut
      if (chgtaper .lt. 1.0d0)  chgtaper = chgtaper * chgcut
      if (dpltaper .lt. 1.0d0)  dpltaper = dpltaper * dplcut
      if (mpoletaper .lt. 1.0d0)  mpoletaper = mpoletaper * mpolecut
      if (ctrntaper .lt. 1.0d0)  ctrntaper = ctrntaper * ctrncut
c
c     apply truncation cutoffs if they were requested
c
      if (truncate) then
         vdwtaper = big
         reptaper = big
         disptaper = big
         chgtaper = big
         dpltaper = big
         mpoletaper = big
         ctrntaper = big
      end if
c
c     set buffer region limits for pairwise neighbor lists
c
      lbuf2 = (0.5d0*lbuffer)**2
      pbuf2 = (0.5d0*pbuffer)**2
      vbuf2 = (vdwcut+lbuffer)**2
      dbuf2 = (dispcut+lbuffer)**2
      cbuf2 = (chgcut+lbuffer)**2
      mbuf2 = (mpolecut+lbuffer)**2
      ubuf2 = (usolvcut+pbuffer)**2
      vbufx = (vdwcut+2.0d0*lbuffer)**2
      dbufx = (dispcut+2.0d0*lbuffer)**2
      cbufx = (chgcut+2.0d0*lbuffer)**2
      mbufx = (mpolecut+2.0d0*lbuffer)**2
      ubufx = (usolvcut+2.0d0*pbuffer)**2
c
c     specify maximum size for each of the neighbor lists
c
      maxvlst = 2500
      if (vdwcut.ne.big .and. dispcut.ne.big) then
         limit = int(sqrt(max(vbuf2,dbuf2))**3) + 100
         maxvlst = min(limit,maxvlst)
      else if (vdwcut .ne. big) then
         limit = int(sqrt(vbuf2)**3) + 100
         maxvlst = min(limit,maxvlst)
      else if (dispcut .ne. big) then
         limit = int(sqrt(dbuf2)**3) + 100
         maxvlst = min(limit,maxvlst)
      end if
      maxelst = 2500
      if (chgcut.ne.big .and. mpolecut.ne.big) then
         limit = int(sqrt(max(cbuf2,mbuf2))**3) + 100
         maxelst = min(limit,maxelst)
      else if (chgcut .ne. big) then
         limit = int(sqrt(cbuf2)**3) + 100
         maxelst = min(limit,maxelst)
      else if (mpolecut .ne. big) then
         limit = int(sqrt(mbuf2)**3) + 100
         maxelst = min(limit,maxelst)
      end if
      maxulst = 500
      limit = int(sqrt(ubuf2)**3) + 100
      maxulst = min(limit,maxulst)
c
c     perform dynamic allocation of some global arrays
c
      if (use_vlist .or. use_dlist) then
         if (allocated(nvlst))  deallocate (nvlst)
         if (allocated(vlst))  deallocate (vlst)
         if (allocated(xvold))  deallocate (xvold)
         if (allocated(yvold))  deallocate (yvold)
         if (allocated(zvold))  deallocate (zvold)
         allocate (nvlst(n))
         allocate (vlst(maxvlst,n))
         allocate (xvold(n))
         allocate (yvold(n))
         allocate (zvold(n))
      end if
      if (use_clist .or. use_mlist) then
         if (allocated(nelst))  deallocate (nelst)
         if (allocated(elst))  deallocate (elst)
         if (allocated(xeold))  deallocate (xeold)
         if (allocated(yeold))  deallocate (yeold)
         if (allocated(zeold))  deallocate (zeold)
         allocate (nelst(n))
         allocate (elst(maxelst,n))
         allocate (xeold(n))
         allocate (yeold(n))
         allocate (zeold(n))
         if (poltyp .ne. 'DIRECT') then
            if (allocated(tindex))  deallocate (tindex)
            if (allocated(tdipdip))  deallocate (tdipdip)
            allocate (tindex(2,n*maxelst))
            allocate (tdipdip(6,n*maxelst))
         end if
      end if
      if (use_ulist) then
         if (allocated(nulst))  deallocate (nulst)
         if (allocated(ulst))  deallocate (ulst)
         if (allocated(xuold))  deallocate (xuold)
         if (allocated(yuold))  deallocate (yuold)
         if (allocated(zuold))  deallocate (zuold)
         allocate (nulst(n))
         allocate (ulst(maxulst,n))
         allocate (xuold(n))
         allocate (yuold(n))
         allocate (zuold(n))
      end if
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ## 
c     ############################################################ 
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine dampewald  --  find Ewald damping coefficients  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "dampewald" finds coefficients for error function damping used
c     for Ewald real space interactions
c
c
      subroutine dampewald (rorder,r,r2,scale,dmpe)
      use ewald
      use math
      implicit none
      integer i,niter
      integer rorder
      real*8 r,r2,scale
      real*8 bfac,erfc
      real*8 aesq2,afac
      real*8 expterm,ra
      real*8 bn(0:5)
      real*8 dmpe(*)
      external erfc
c
c
c     initialize the Ewald damping factor coefficients
c
      do i = 1, rorder
         dmpe(i) = scale
      end do
c     
c     compute the successive Ewald damping factors
c
      ra = aewald * r
      bn(0) = erfc(ra) / r
      dmpe(1) = scale * bn(0)
      expterm = exp(-ra*ra)
      aesq2 = 2.0d0 * aewald * aewald
      afac = 0.0d0
      if (aewald .gt. 0.0d0)  afac = 1.0d0 / (rootpi*aewald)
      niter = (rorder-1) / 2
      do i = 1, niter
         bfac = dble(2*i-1)
         afac = aesq2 * afac
         bn(i) = (bfac*bn(i-1)+afac*expterm) / r2
         dmpe(2*i+1) = scale * bn(i)
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine dampthole  --  original Thole damping values  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "dampthole" finds coefficients for the original Thole damping
c     function used by AMOEBA and for mutual polarization by AMOEBA+
c
c     literature reference:
c
c     B. T. Thole, "Molecular Polarizabilities Calculated with a
c     Modified Dipole Interaction", Chemical Physics, 59, 341-350 (1981)
c
c
      subroutine dampthole (i,k,rorder,r,dmpik)
      use atoms
      use mpole
      use polar
      implicit none
      integer i,j,k
      integer it,kt
      integer rorder
      real*8 r,damp
      real*8 damp2
      real*8 damp3
      real*8 expdamp
      real*8 pgamma
      real*8 dmpik(*)
c
c
c     initialize the Thole damping factors to a value of one
c
      do j = 1, rorder
         dmpik(j) = 1.0d0
      end do
c
c     use original Thole polarization model damping factors
c
      damp = pdamp(i) * pdamp(k)
      it = jpolar(i)
      kt = jpolar(k)
      pgamma = thlval(it,kt)
      if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
         damp = pgamma * (r/damp)**3
         if (damp .lt. 50.0d0) then
            expdamp = exp(-damp)
            dmpik(3) = 1.0d0 - expdamp
            dmpik(5) = 1.0d0 - expdamp*(1.0d0+damp)
            if (rorder .ge. 7) then
               damp2 = damp * damp
               dmpik(7) = 1.0d0 - expdamp*(1.0d0+damp+0.6d0*damp2)
               if (rorder .ge. 9) then
                  damp3 = damp * damp2
                  dmpik(9) = 1.0d0 - expdamp*(1.0d0+damp
     &                                  +(18.0d0/35.0d0)*damp2
     &                                  +(9.0d0/35.0d0)*damp3)
               end if
            end if
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine damptholed  --  alternate Thole damping values  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "damptholed" finds coefficients for the original Thole damping
c     function used by AMOEBA or for the alternate direct polarization
c     damping used by AMOEBA+
c
c     literature reference:
c
c     B. T. Thole, "Molecular Polarizabilities Calculated with a
c     Modified Dipole Interaction", Chemical Physics, 59, 341-350 (1981)
c
c
      subroutine damptholed (i,k,rorder,r,dmpik)
      use atoms
      use mpole
      use polar
      use polpot
      implicit none
      integer i,j,k
      integer it,kt
      integer rorder
      real*8 r,damp
      real*8 damp2
      real*8 damp3
      real*8 expdamp
      real*8 pgamma
      real*8 dmpik(*)
c
c
c     initialize the Thole damping factors to a value of one
c
      do j = 1, rorder
         dmpik(j) = 1.0d0
      end do
c
c     use alternate Thole model for AMOEBA+ direct polarization
c
      damp = pdamp(i) * pdamp(k)
      if (use_tholed) then
         it = jpolar(i)
         kt = jpolar(k)
         pgamma = thdval(it,kt)
         if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
            damp = pgamma * (r/damp)**(1.5d0)
            if (damp .lt. 50.0d0) then
               expdamp = exp(-damp)
               dmpik(3) = 1.0d0 - expdamp
               dmpik(5) = 1.0d0 - expdamp*(1.0d0+0.5d0*damp)
               if (rorder .ge. 7) then
                  damp2 = damp * damp
                  dmpik(7) = 1.0d0 - expdamp*(1.0d0+0.65d0*damp
     &                                  +0.15d0*damp2)
               end if
            end if
         end if
c
c     use original Thole polarization model damping factors
c
      else
         it = jpolar(i)
         kt = jpolar(k)
         pgamma = thlval(it,kt)
         if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
            damp = pgamma * (r/damp)**3
            if (damp .lt. 50.0d0) then
               expdamp = exp(-damp)
               dmpik(3) = 1.0d0 - expdamp
               dmpik(5) = 1.0d0 - expdamp*(1.0d0+damp)
               if (rorder .ge. 7) then
                  damp2 = damp * damp
                  dmpik(7) = 1.0d0 - expdamp*(1.0d0+damp+0.6d0*damp2)
                  if (rorder .ge. 9) then
                     damp3 = damp * damp2
                     dmpik(9) = 1.0d0 - expdamp*(1.0d0+damp
     &                                     +(18.0d0/35.0d0)*damp2
     &                                     +(9.0d0/35.0d0)*damp3)
                  end if
               end if
            end if
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine damppole  --  penetration damping coefficents  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "damppole" finds coefficients for two alternative Gordon charge
c     penetration damping function
c
c     literature references:
c
c     L. V. Slipchenko and M. S. Gordon, "Electrostatic Energy in the
c     Effective Fragment Potential Method: Theory and Application to
c     the Benzene Dimer", Journal of Computational Chemistry, 28,
c     276-291 (2007)  [Gordon f1 and f2 models]
c
c     J. A. Rackers, Q. Wang, C. Liu, J.-P. Piquemal, P. Ren and
c     J. W. Ponder, "An Optimized Charge Penetration Model for Use with
c     the AMOEBA Force Field", Physical Chemistry Chemical Physics, 19,
c     276-291 (2017)
c
c
      subroutine damppole (r,rorder,alphai,alphak,dmpi,dmpk,dmpik)
      use mplpot
      implicit none
      integer rorder
      real*8 termi,termk
      real*8 termi2,termk2
      real*8 alphai,alphak
      real*8 alphai2,alphak2
      real*8 r,eps,diff
      real*8 expi,expk
      real*8 dampi,dampk
      real*8 dampi2,dampi3
      real*8 dampi4,dampi5
      real*8 dampi6,dampi7
      real*8 dampi8
      real*8 dampk2,dampk3
      real*8 dampk4,dampk5
      real*8 dampk6
      real*8 dmpi(*)
      real*8 dmpk(*)
      real*8 dmpik(*)
c
c
c     compute tolerance and exponential damping factors
c
      eps = 0.001d0
      diff = abs(alphai-alphak)
      dampi = alphai * r
      dampk = alphak * r
      expi = exp(-dampi)
      expk = exp(-dampk)
c
c     core-valence charge penetration damping for Gordon f1
c
      if (pentyp .eq. 'GORDON1') then
         dampi2 = dampi * dampi
         dampi3 = dampi * dampi2
         dampi4 = dampi2 * dampi2
         dampi5 = dampi2 * dampi3
         dmpi(1) = 1.0d0 - (1.0d0 + 0.5d0*dampi)*expi
         dmpi(3) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2)*expi
         dmpi(5) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                + dampi3/6.0d0)*expi
         dmpi(7) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                + dampi3/6.0d0 + dampi4/30.0d0)*expi
         dmpi(9) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                + dampi3/6.0d0 + 4.0d0*dampi4/105.0d0
     &                + dampi5/210.0d0)*expi
         if (diff .lt. eps) then
            dmpk(1) = dmpi(1)
            dmpk(3) = dmpi(3)
            dmpk(5) = dmpi(5)
            dmpk(7) = dmpi(7)
            dmpk(9) = dmpi(9)
         else
            dampk2 = dampk * dampk
            dampk3 = dampk * dampk2
            dampk4 = dampk2 * dampk2
            dampk5 = dampk2 * dampk3
            dmpk(1) = 1.0d0 - (1.0d0 + 0.5d0*dampk)*expk
            dmpk(3) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2)*expk
            dmpk(5) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2
     &                   + dampk3/6.0d0)*expk
            dmpk(7) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2
     &                   + dampk3/6.0d0 + dampk4/30.0d0)*expk
            dmpk(9) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2
     &                   + dampk3/6.0d0 + 4.0d0*dampk4/105.0d0
     &                   + dampk5/210.0d0)*expk
         end if
c
c     valence-valence charge penetration damping for Gordon f1
c
         if (diff .lt. eps) then
            dampi6 = dampi3 * dampi3
            dampi7 = dampi3 * dampi4
            dmpik(1) = 1.0d0 - (1.0d0 + 11.0d0*dampi/16.0d0
     &                    + 3.0d0*dampi2/16.0d0
     &                    + dampi3/48.0d0)*expi
            dmpik(3) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                    + 7.0d0*dampi3/48.0d0
     &                    + dampi4/48.0d0)*expi
            dmpik(5) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                    + dampi3/6.0d0 + dampi4/24.0d0
     &                    + dampi5/144.0d0)*expi
            dmpik(7) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                    + dampi3/6.0d0 + dampi4/24.0d0
     &                    + dampi5/120.0d0 + dampi6/720.0d0)*expi
            dmpik(9) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                    + dampi3/6.0d0 + dampi4/24.0d0
     &                    + dampi5/120.0d0 + dampi6/720.0d0
     &                    + dampi7/5040.0d0)*expi
            if (rorder .ge. 11) then
               dampi8 = dampi4 * dampi4
               dmpik(11) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                        + dampi3/6.0d0 + dampi4/24.0d0
     &                        + dampi5/120.0d0 + dampi6/720.0d0
     &                        + dampi7/5040.0d0 + dampi8/45360.0d0)*expi
            end if
         else
            alphai2 = alphai * alphai
            alphak2 = alphak * alphak
            termi = alphak2 / (alphak2-alphai2)
            termk = alphai2 / (alphai2-alphak2)
            termi2 = termi * termi
            termk2 = termk * termk
            dmpik(1) = 1.0d0 - termi2*(1.0d0 + 2.0d0*termk
     &                    + 0.5d0*dampi)*expi
     &                 - termk2*(1.0d0 + 2.0d0*termi
     &                      + 0.5d0*dampk)*expk
            dmpik(3) = 1.0d0 - termi2*(1.0d0+dampi+0.5d0*dampi2)*expi
     &                    - termk2*(1.0d0+dampk+0.5d0*dampk2)*expk
     &                    - 2.0d0*termi2*termk*(1.0d0+dampi)*expi
     &                    - 2.0d0*termk2*termi*(1.0d0+dampk)*expk
            dmpik(5) = 1.0d0 - termi2*(1.0d0 + dampi + 0.5d0*dampi2
     &                    + dampi3/6.0d0)*expi
     &                 - termk2*(1.0d0 + dampk + 0.5d0*dampk2
     &                      + dampk3/6.0d0)*expk
     &                 - 2.0d0*termi2*termk
     &                      *(1.0d0 + dampi + dampi2/3.0d0)*expi
     &                 - 2.0d0*termk2*termi
     &                      *(1.0d0 + dampk + dampk2/3.0d0)*expk
            dmpik(7) = 1.0d0 - termi2*(1.0d0 + dampi + 0.5d0*dampi2
     &                    + dampi3/6.0d0 + dampi4/30.0d0)*expi
     &                 - termk2*(1.0d0 + dampk + 0.5d0*dampk2
     &                      + dampk3/6.0d0 + dampk4/30.0d0)*expk
     &                 - 2.0d0*termi2*termk*(1.0d0 + dampi
     &                      + 2.0d0*dampi2/5.0d0 + dampi3/15.0d0)*expi
     &                 - 2.0d0*termk2*termi*(1.0d0 + dampk
     &                      + 2.0d0*dampk2/5.0d0 + dampk3/15.0d0)*expk
            dmpik(9) = 1.0d0 - termi2*(1.0d0 + dampi + 0.5d0*dampi2
     &                    + dampi3/6.0d0 + 4.0d0*dampi4/105.0d0
     &                    + dampi5/210.0d0)*expi
     &                 - termk2*(1.0d0 + dampk + 0.5d0*dampk2
     &                      + dampk3/6.0d0 + 4.0d0*dampk4/105.0d0
     &                      + dampk5/210.0d0)*expk
     &                 - 2.0d0*termi2*termk*(1.0d0 + dampi
     &                      + 3.0d0*dampi2/7.0d0
     &                      + 2.0d0*dampi3/21.0d0
     &                      + dampi4/105.0d0)*expi 
     &                 - 2.0d0*termk2*termi*(1.0d0 + dampk
     &                      + 3.0d0*dampk2/7.0d0
     &                      + 2.0d0*dampk3/21.0d0
     &                      + dampk4/105.0d0)*expk
            if (rorder .ge. 11) then
               dampi6 = dampi3 * dampi3
               dampk6 = dampk3 * dampk3
               dmpik(11) = 1.0d0 - termi2*(1.0d0 + dampi
     &                        + 0.5d0*dampi2 + dampi3/6.0d0
     &                        + 5.0d0*dampi4/126.0d0
     &                        + 2.0d0*dampi5/315.0d0
     &                        + dampi6/1890.0d0)*expi
     &                     - termk2*(1.0d0 + dampk
     &                          + 0.5d0*dampk2 + dampk3/6.0d0
     &                          + 5.0d0*dampk4/126.0d0
     &                          + 2.0d0*dampk5/315.0d0
     &                          + dampk6/1890.0d0)*expk
     &                     - 2.0d0*termi2*termk*(1.0d0 + dampi
     &                          + 4.0d0*dampi2/9.0d0 + dampi3/9.0d0
     &                          + dampi4/63.0d0 + dampi5/945.0d0)*expi
     &                     - 2.0d0*termk2*termi*(1.0d0 + dampk
     &                          + 4.0d0*dampk2/9.0d0 + dampk3/9.0d0
     &                          + dampk4/63.0d0 + dampk5/945.0d0)*expk 
            end if
         end if
c
c     core-valence charge penetration damping for Gordon f2
c
      else if (pentyp .eq. 'GORDON2') then
         dampi2 = dampi * dampi
         dampi3 = dampi * dampi2
         dmpi(1) = 1.0d0 - expi
         dmpi(3) = 1.0d0 - (1.0d0 + dampi)*expi
         dmpi(5) = 1.0d0 - (1.0d0 + dampi + dampi2/3.0d0)*expi
         dmpi(7) = 1.0d0 - (1.0d0 + dampi + 0.4d0*dampi2
     &                + dampi3/15.0d0)*expi
         if (diff .lt. eps) then
            dmpk(1) = dmpi(1)
            dmpk(3) = dmpi(3)
            dmpk(5) = dmpi(5)
            dmpk(7) = dmpi(7)
         else
            dampk2 = dampk * dampk
            dampk3 = dampk * dampk2
            dmpk(1) = 1.0d0 - expk
            dmpk(3) = 1.0d0 - (1.0d0 + dampk)*expk
            dmpk(5) = 1.0d0 - (1.0d0 + dampk + dampk2/3.0d0)*expk
            dmpk(7) = 1.0d0 - (1.0d0 + dampk + 0.4d0*dampk2
     &                   + dampk3/15.0d0)*expk
         end if
c
c     valence-valence charge penetration damping for Gordon f2
c
         dampi4 = dampi2 * dampi2
         dampi5 = dampi2 * dampi3
         if (diff .lt. eps) then
            dampi6 = dampi3 * dampi3
            dmpik(1) = 1.0d0 - (1.0d0 + 0.5d0*dampi)*expi
            dmpik(3) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2)*expi
            dmpik(5) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                    + dampi3/6.0d0)*expi
            dmpik(7) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                    + dampi3/6.0d0 + dampi4/30.0d0)*expi
            dmpik(9) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                    + dampi3/6.0d0 + 4.0d0*dampi4/105.0d0
     &                    + dampi5/210.0d0)*expi
            if (rorder .ge. 11) then
               dmpik(11) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                        + dampi3/6.0d0 + 5.0d0*dampi4/126.0d0
     &                        + 2.0d0*dampi5/315.0d0
     &                        + dampi6/1890.0d0)*expi
            end if
         else
            dampk4 = dampk2 * dampk2
            dampk5 = dampk2 * dampk3
            alphai2 = alphai * alphai
            alphak2 = alphak * alphak
            termi = alphak2 / (alphak2-alphai2)
            termk = alphai2 / (alphai2-alphak2)
            dmpik(1) = 1.0d0 - termi*expi - termk*expk
            dmpik(3) = 1.0d0 - termi*(1.0d0 + dampi)*expi
     &                    - termk*(1.0d0 + dampk)*expk
            dmpik(5) = 1.0d0 - termi*(1.0d0 + dampi + dampi2/3.0d0)*expi
     &                    - termk*(1.0d0 + dampk + dampk2/3.0d0)*expk
            dmpik(7) = 1.0d0 - termi*(1.0d0 + dampi + 0.4d0*dampi2
     &                    + dampi3/15.0d0)*expi
     &                 - termk*(1.0d0 + dampk + 0.4d0*dampk2
     &                      + dampk3/15.0d0)*expk
            dmpik(9) = 1.0d0 - termi*(1.0d0 + dampi + 3.0d0*dampi2/7.0d0
     &                    + 2.0d0*dampi3/21.0d0 + dampi4/105.0d0)*expi
     &                 - termk*(1.0d0 + dampk + 3.0d0*dampk2/7.0d0
     &                      + 2.0d0*dampk3/21.0d0 + dampk4/105.0d0)*expk
            if (rorder .ge. 11) then
               dmpik(11) = 1.0d0 - termi*(1.0d0 + dampi
     &                        + 4.0d0*dampi2/9.0d0 + dampi3/9.0d0
     &                        + dampi4/63.0d0 + dampi5/945.0d0)*expi
     &                     - termk*(1.0d0 + dampk
     &                          + 4.0d0*dampk2/9.0d0 + dampk3/9.0d0
     &                          + dampk4/63.0d0 + dampk5/945.0d0)*expk
            end if
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine dampdir  --  direct field damping coefficents  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "dampdir" finds coefficients for two alternative Gordon direct
c     field damping functions
c
c
      subroutine dampdir (r,alphai,alphak,dmpi,dmpk)
      use mplpot
      implicit none
      real*8 alphai,alphak
      real*8 r,eps,diff
      real*8 expi,expk
      real*8 dampi,dampk
      real*8 dampi2,dampk2
      real*8 dampi3,dampk3
      real*8 dampi4,dampk4
      real*8 dmpi(*)
      real*8 dmpk(*)
c
c
c     compute tolerance and exponential damping factors
c
      eps = 0.001d0
      diff = abs(alphai-alphak)
      dampi = alphai * r
      dampk = alphak * r
      expi = exp(-dampi)
      expk = exp(-dampk)
c
c     core-valence charge penetration damping for Gordon f1
c
      if (pentyp .eq. 'GORDON1') then
         dampi2 = dampi * dampi
         dampi3 = dampi * dampi2
         dampi4 = dampi2 * dampi2
         dmpi(3) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2)*expi
         dmpi(5) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 
     &                + dampi3/6.0d0)*expi
         dmpi(7) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                + dampi3/6.0d0 + dampi4/30.0d0)*expi
         if (diff .lt. eps) then
            dmpk(3) = dmpi(3)
            dmpk(5) = dmpi(5)
            dmpk(7) = dmpi(7)
         else
            dampk2 = dampk * dampk
            dampk3 = dampk * dampk2
            dampk4 = dampk2 * dampk2
            dmpk(3) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2)*expk
            dmpk(5) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2
     &                   + dampk3/6.0d0)*expk
            dmpk(7) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2
     &                   + dampk3/6.0d0 + dampk4/30.0d0)*expk
         end if
c
c     core-valence charge penetration damping for Gordon f2
c
      else if (pentyp .eq. 'GORDON2') then
         dampi2 = dampi * dampi
         dampi3 = dampi * dampi2
         dmpi(3) = 1.0d0 - (1.0d0 + dampi)*expi
         dmpi(5) = 1.0d0 - (1.0d0 + dampi + dampi2/3.0d0)*expi
         dmpi(7) = 1.0d0 - (1.0d0 + dampi + 0.4d0*dampi2
     &                + dampi3/15.0d0)*expi
         if (diff .lt. eps) then
            dmpk(3) = dmpi(3)
            dmpk(5) = dmpi(5)
            dmpk(7) = dmpi(7)
         else
            dampk2 = dampk * dampk
            dampk3 = dampk * dampk2
            dmpk(3) = 1.0d0 - (1.0d0 + dampk)*expk
            dmpk(5) = 1.0d0 - (1.0d0 + dampk + dampk2/3.0d0)*expk
            dmpk(7) = 1.0d0 - (1.0d0 + dampk + 0.4d0*dampk2
     &                   + dampk3/15.0d0)*expk
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine dampmut  --  mutual field damping coefficents  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "dampmut" finds coefficients for two alternative Gordon mutual
c     field damping functions
c
c
      subroutine dampmut (r,alphai,alphak,dmpik)
      use mplpot
      implicit none
      real*8 termi,termk
      real*8 termi2,termk2
      real*8 alphai,alphak
      real*8 alphai2,alphak2
      real*8 r,eps,diff
      real*8 expi,expk
      real*8 dampi,dampk
      real*8 dampi2,dampi3
      real*8 dampi4,dampi5
      real*8 dampk2,dampk3
      real*8 dmpik(*)
c
c
c     compute tolerance and exponential damping factors
c
      eps = 0.001d0
      diff = abs(alphai-alphak)
      dampi = alphai * r
      dampk = alphak * r
      expi = exp(-dampi)
      expk = exp(-dampk)
c
c     valence-valence charge penetration damping for Gordon f1
c
      if (pentyp .eq. 'GORDON1') then
         dampi2 = dampi * dampi
         dampi3 = dampi * dampi2
         if (diff .lt. eps) then
            dampi4 = dampi2 * dampi2
            dampi5 = dampi2 * dampi3
            dmpik(3) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                    + 7.0d0*dampi3/48.0d0
     &                    + dampi4/48.0d0)*expi
            dmpik(5) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                    + dampi3/6.0d0 + dampi4/24.0d0
     &                    + dampi5/144.0d0)*expi
         else
            dampk2 = dampk * dampk
            dampk3 = dampk * dampk2
            alphai2 = alphai * alphai
            alphak2 = alphak * alphak
            termi = alphak2 / (alphak2-alphai2)
            termk = alphai2 / (alphai2-alphak2)
            termi2 = termi * termi
            termk2 = termk * termk
            dmpik(3) = 1.0d0 - termi2*(1.0d0+dampi+0.5d0*dampi2)*expi
     &                    - termk2*(1.0d0+dampk+0.5d0*dampk2)*expk
     &                    - 2.0d0*termi2*termk*(1.0d0+dampi)*expi
     &                    - 2.0d0*termk2*termi*(1.0d0+dampk)*expk
            dmpik(5) = 1.0d0 - termi2*(1.0d0+dampi+0.5d0*dampi2
     &                            +dampi3/6.0d0)*expi
     &                    - termk2*(1.0d0+dampk+0.5d0*dampk2
     &                         +dampk3/6.00)*expk
     &                    - 2.0d0*termi2*termk
     &                         *(1.0+dampi+dampi2/3.0d0)*expi
     &                    - 2.0d0*termk2*termi
     &                         *(1.0+dampk+dampk2/3.0d0)*expk
         end if
c
c     valence-valence charge penetration damping for Gordon f2
c
      else if (pentyp .eq. 'GORDON2') then
         dampi2 = dampi * dampi
         if (diff .lt. eps) then
            dampi3 = dampi * dampi2
            dmpik(3) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2)*expi
            dmpik(5) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2
     &                    + dampi3/6.0d0)*expi
         else
            dampk2 = dampk * dampk
            alphai2 = alphai * alphai
            alphak2 = alphak * alphak
            termi = alphak2 / (alphak2-alphai2)
            termk = alphai2 / (alphai2-alphak2)
            dmpik(3) = 1.0d0 - termi*(1.0d0 + dampi)*expi
     &                    - termk*(1.0d0 + dampk)*expk
            dmpik(5) = 1.0d0 - termi*(1.0d0 + dampi + dampi2/3.0d0)*expi
     &                    - termk*(1.0d0 + dampk + dampk2/3.0d0)*expk
         end if
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine damppot  --  electrostatic potential damping  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "damppot" finds coefficients for two alternative Gordon charge
c     penetration damping functions for the electrostatic potential
c
c
      subroutine damppot (r,alphak,dmpk)
      use mplpot
      implicit none
      real*8 r,alphak
      real*8 expk,dampk
      real*8 dampk2,dampk3
      real*8 dmpk(*)
c
c
c     compute common exponential factors for damping
c
      dampk = alphak * r
      expk = exp(-dampk)
c
c     core-valence charge penetration damping for Gordon f1
c
      if (pentyp .eq. 'GORDON1') then
         dampk2 = dampk * dampk
         dampk3 = dampk * dampk2
         dmpk(1) = 1.0d0 - (1.0d0 + 0.5d0*dampk)*expk
         dmpk(3) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2)*expk
         dmpk(5) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2
     &                + dampk3/6.0d0)*expk
c
c     core-valence charge penetration damping for Gordon f2
c
      else if (pentyp .eq. 'GORDON2') then
         dampk2 = dampk * dampk
         dmpk(1) = 1.0d0 - expk
         dmpk(3) = 1.0d0 - (1.0d0 + dampk)*expk
         dmpk(5) = 1.0d0 - (1.0d0 + dampk + dampk2/3.0d0)*expk
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine damprep  --  Pauli exchange repulsion damping  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "damprep" finds coefficients for the Pauli repulsion damping
c     function used by HIPPO
c
c     literature reference:
c
c     J. A. Rackers and J. W. Ponder, "Classical Pauli Repulsion: An
c     Anisotropic, Atomic Multipole Model", Journal of Chemical Physics,
c     150, 084104 (2019)
c
c
      subroutine damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11,
     &                       rorder,dmpi,dmpk,dmpik)
      implicit none
      integer rorder
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7,r8
      real*8 rr1,rr3,rr5
      real*8 rr7,rr9,rr11
      real*8 s,ds,d2s
      real*8 d3s,d4s,d5s
      real*8 dmpi,dmpk
      real*8 dmpi2,dmpk2
      real*8 dmpi22,dmpi23
      real*8 dmpi24,dmpi25
      real*8 dmpi26,dmpi27
      real*8 dmpk22,dmpk23
      real*8 dmpk24,dmpk25
      real*8 dmpk26
      real*8 eps,diff
      real*8 expi,expk
      real*8 dampi,dampk
      real*8 pre,term,tmp
      real*8 dmpik(*)
c
c
c     compute tolerance value for damping exponents
c
      eps = 0.001d0
      diff = abs(dmpi-dmpk)
c
c     treat the case where alpha damping exponents are equal
c
      if (diff .lt. eps) then
         r3 = r2 * r
         r4 = r3 * r
         r5 = r4 * r
         r6 = r5 * r
         dmpi2 = 0.5d0 * dmpi
         dampi = dmpi2 * r
         expi = exp(-dampi)
         dmpi22 = dmpi2 * dmpi2
         dmpi23 = dmpi22 * dmpi2
         dmpi24 = dmpi23 * dmpi2
         dmpi25 = dmpi24 * dmpi2
         pre = 2.0d0
         s = (r + dmpi2*r2 + dmpi22*r3/3.0d0) * expi
         ds = (dmpi22*r3 + dmpi23*r4) * expi / 3.0d0
         d2s = dmpi24 * expi * r5 / 9.0d0
         d3s = dmpi25 * expi * r6 / 45.0d0
         if (rorder .ge. 9) then
            r7 = r6 * r
            dmpi26 = dmpi25 * dmpi2
            d4s = (dmpi25*r6 + dmpi26*r7) * expi / 315.0d0
            if (rorder .ge. 11) then
               r8 = r7 * r
               dmpi27 = dmpi2 * dmpi26
               d5s = (dmpi25*r6 + dmpi26*r7 + dmpi27*r8/3.0d0)
     &                   * expi / 945.0d0
            end if
         end if
c
c     treat the case where alpha damping exponents are unequal
c
      else
         r3 = r2 * r
         r4 = r3 * r
         dmpi2 = 0.5d0 * dmpi
         dmpk2 = 0.5d0 * dmpk
         dampi = dmpi2 * r
         dampk = dmpk2 * r
         expi = exp(-dampi)
         expk = exp(-dampk)
         dmpi22 = dmpi2 * dmpi2
         dmpi23 = dmpi22 * dmpi2
         dmpi24 = dmpi23 * dmpi2
         dmpk22 = dmpk2 * dmpk2
         dmpk23 = dmpk22 * dmpk2
         dmpk24 = dmpk23 * dmpk2
         term = dmpi22 - dmpk22
         pre = 128.0d0 * dmpi23 * dmpk23 / term**4
         tmp = 4.0d0 * dmpi2 * dmpk2 / term
         s = (dampi-tmp)*expk + (dampk+tmp)*expi
         ds = (dmpi2*dmpk2*r2 - 4.0d0*dmpi2*dmpk22*r/term
     &            - 4.0d0*dmpi2*dmpk2/term) * expk
     &      + (dmpi2*dmpk2*r2 + 4.0d0*dmpi22*dmpk2*r/term
     &            + 4.0d0*dmpi2*dmpk2/term) * expi
         d2s = (dmpi2*dmpk2*r2/3.0d0
     &             + dmpi2*dmpk22*r3/3.0d0
     &             - (4.0d0/3.0d0)*dmpi2*dmpk23*r2/term
     &             - 4.0d0*dmpi2*dmpk22*r/term
     &             - 4.0d0*dmpi2*dmpk2/term) * expk
     &       + (dmpi2*dmpk2*r2/3.0d0
     &             + dmpi22*dmpk2*r3/3.0d0
     &             + (4.0d0/3.0d0)*dmpi23*dmpk2*r2/term
     &             + 4.0d0*dmpi22*dmpk2*r/term
     &             + 4.0d0*dmpi2*dmpk2/term) * expi
         d3s = (dmpi2*dmpk23*r4/15.0d0
     &             + dmpi2*dmpk22*r3/5.0d0
     &             + dmpi2*dmpk2*r2/5.0d0
     &             - (4.0d0/15.0d0)*dmpi2*dmpk24*r3/term
     &             - (8.0d0/5.0d0)*dmpi2*dmpk23*r2/term
     &             - 4.0d0*dmpi2*dmpk22*r/term
     &             - 4.0d0/term*dmpi2*dmpk2) * expk
     &       + (dmpi23*dmpk2*r4/15.0d0 
     &             + dmpi22*dmpk2*r3/5.0d0
     &             + dmpi2*dmpk2*r2/5.0d0 
     &             + (4.0d0/15.0d0)*dmpi24*dmpk2*r3/term
     &             + (8.0d0/5.0d0)*dmpi23*dmpk2*r2/term
     &             + 4.0d0*dmpi22*dmpk2*r/term
     &             + 4.0d0/term*dmpi2*dmpk2) * expi
         if (rorder .ge. 9) then
            r5 = r4 * r
            dmpi25 = dmpi24 * dmpi2
            dmpk25 = dmpk24 * dmpk2
            d4s = (dmpi2*dmpk24*r5/105.0d0
     &                + (2.0d0/35.0d0)*dmpi2*dmpk23*r4
     &                + dmpi2*dmpk22*r3/7.0d0
     &                + dmpi2*dmpk2*r2/7.0d0
     &                - (4.0d0/105.0d0)*dmpi2*dmpk25*r4/term
     &                - (8.0d0/21.0d0)*dmpi2*dmpk24*r3/term
     &                - (12.0d0/7.0d0)*dmpi2*dmpk23*r2/term
     &                - 4.0d0*dmpi2*dmpk22*r/term
     &                - 4.0d0*dmpi2*dmpk2/term) * expk
     &          + (dmpi24*dmpk2*r5/105.0d0
     &                + (2.0d0/35.0d0)*dmpi23*dmpk2*r4
     &                + dmpi22*dmpk2*r3/7.0d0
     &                + dmpi2*dmpk2*r2/7.0d0
     &                + (4.0d0/105.0d0)*dmpi25*dmpk2*r4/term
     &                + (8.0d0/21.0d0)*dmpi24*dmpk2*r3/term
     &                + (12.0d0/7.0d0)*dmpi23*dmpk2*r2/term
     &                + 4.0d0*dmpi22*dmpk2*r/term
     &                + 4.0d0*dmpi2*dmpk2/term) * expi
            if (rorder .ge. 11) then
               r6 = r5 * r
               dmpi26 = dmpi25 * dmpi2
               dmpk26 = dmpk25 * dmpk2
               d5s = (dmpi2*dmpk25*r6/945.0d0
     &                   + (2.0d0/189.0d0)*dmpi2*dmpk24*r5
     &                   + dmpi2*dmpk23*r4/21.0d0
     &                   + dmpi2*dmpk22*r3/9.0d0
     &                   + dmpi2*dmpk2*r2/9.0d0
     &                   - (4.0d0/945.0d0)*dmpi2*dmpk26*r5/term
     &                   - (4.0d0/63.0d0)*dmpi2*dmpk25*r4/term
     &                   - (4.0d0/9.0d0)*dmpi2*dmpk24*r3/term
     &                   - (16.0d0/9.0d0)*dmpi2*dmpk23*r2/term
     &                   - 4.0d0*dmpi2*dmpk22*r/term
     &                   - 4.0d0*dmpi2*dmpk2/term) * expk
     &             + (dmpi25*dmpk2*r6/945.0d0
     &                   + (2.0d0/189.0d0)*dmpi24*dmpk2*r5
     &                   + dmpi23*dmpk2*r4/21.0d0
     &                   + dmpi22*dmpk2*r3/9.0d0
     &                   + dmpi2*dmpk2*r2/9.0d0
     &                   + (4.0d0/945.0d0)*dmpi26*dmpk2*r5/term
     &                   + (4.0d0/63.0d0)*dmpi25*dmpk2*r4/term
     &                   + (4.0d0/9.0d0)*dmpi24*dmpk2*r3/term
     &                   + (16.0d0/9.0d0)*dmpi23*dmpk2*r2/term
     &                   + 4.0d0*dmpi22*dmpk2*r/term
     &                   + 4.0d0*dmpi2*dmpk2/term) * expi
            end if
         end if
      end if
c
c     convert partial derivatives into full derivatives
c
      s = s * rr1
      ds = ds * rr3
      d2s = d2s * rr5
      d3s = d3s * rr7
      dmpik(1) = 0.5d0 * pre * s * s
      dmpik(3) = pre * s * ds
      dmpik(5) = pre * (s*d2s + ds*ds)
      dmpik(7) = pre * (s*d3s + 3.0d0*ds*d2s)
      if (rorder .ge. 9) then
         d4s = d4s * rr9
         dmpik(9) = pre * (s*d4s + 4.0d0*ds*d3s + 3.0d0*d2s*d2s)
         if (rorder .ge. 11) then
            d5s = d5s * rr11
            dmpik(11) = pre * (s*d5s + 5.0d0*ds*d4s + 10.0d0*d2s*d3s)
         end if
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine dampexpl  --  exchange polarization damping  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "dampexpl" finds the overlap value for exchange polarization
c     damping function
c
c
      subroutine dampexpl (r,preik,alphai,alphak,s2,ds2)
      use polpot
      implicit none
      real*8 r,s,s2,ds2
      real*8 alphai,alphak
      real*8 alphaik
      real*8 dmpi2,dmpk2
      real*8 dmpi22,dmpk22
      real*8 dmpik2
      real*8 dampik,dampik2
      real*8 eps,diff
      real*8 expi,expk,expik
      real*8 dampi,dampk,dampi2
      real*8 pre,term,preik
c
c
      if (scrtyp .eq. 'S2U') then
         alphaik = sqrt(alphai * alphak)
         dmpik2 = 0.5d0 * alphaik
         dampik = dmpik2 * r
         dampik2 = dampik * dampik
         expik = exp(-dampik)
         s =(1+dampik+dampik2/3.0d0)*expik
         s2 = s*s
         ds2 = s * (-alphaik/3.0d0)*(dampik+dampik2)*expik
c
c     compute tolerance value for overlap-based damping
c
      else if (scrtyp .eq. 'S2 ') then
         eps = 0.001d0
         diff = abs(alphai-alphak)
c
c     treat the case where alpha damping exponents are equal
c
         if (diff .lt. eps) then
            dmpi2 = 0.5d0 * alphai
            dampi = dmpi2 * r
            dampi2 = dampi * dampi
            expi = exp(-dampi)
            s = (1+dampi+dampi2/3.0d0)*expi
            ds2 = s * (-alphai/3.0d0)*(dampi+dampi2)*expi
c
c     treat the case where alpha damping exponents are unequal
c
         else
            dmpi2 = 0.5d0 * alphai
            dmpk2 = 0.5d0 * alphak
            dampi = dmpi2 * r
            dampk = dmpk2 * r
            expi = exp(-dampi)
            expk = exp(-dampk)
            dmpi22 = dmpi2 * dmpi2
            dmpk22 = dmpk2 * dmpk2
            term = dmpi22 - dmpk22
            pre = sqrt(alphai**3 * alphak**3) / (r * term**3)
            s = pre*(dmpi2*(r*term - 4*dmpk2) * expk
     &            + dmpk2*(r*term + 4*dmpi2) * expi)
            ds2 = 2.0d0*s*pre*dmpi2*dmpk2 *
     &               ((4.0d0/r-(r*term-4.0d0*dmpk2))*expk
     &                  - ((4.0d0/r+(r*term+4.0d0*dmpi2))*expi))
         end if
         s2 = s*s
c
c     use simple gaussian-based damping functions
c
      else if (scrtyp .eq. 'G  ') then
         alphaik = sqrt(alphai * alphak)
         s2 = exp(-alphaik/10.0d0 * r**2)
         ds2 = (-alphaik/5.0d0)*r*s2
      end if
      s2 = preik*s2
      ds2 = preik*ds2
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2020 by Chengwen Liu & Jay W. Ponder  ##
c     ##                 All Rights Reserved                  ##
c     ##########################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine dcflux  --  charge flux gradient chain rule  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "dcflux" takes as input the electrostatic potential at each
c     atomic site and calculates gradient chain rule terms due to
c     charge flux coupling with bond stretching and angle bending
c
c     literature reference:
c
c     C. Liu, J.-P. Piquemal and P. Ren, "Implementation of Geometry-
c     Dependent Charge Flux into the Polarizable AMOEBA+ Potential",
c     Journal of Physical Chemistry Letters, 11, 419-426 (2020)
c
c
      subroutine dcflux (pot,dcfx,dcfy,dcfz)
      use sizes
      use angbnd
      use atoms
      use bndstr
      use bound
      use cflux
      implicit none
      integer i,ia,ib,ic
      real*8 xa,ya,za
      real*8 xb,yb,zb
      real*8 xc,yc,zc
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab,rab2,rab3
      real*8 rcb,rcb2,rcb3
      real*8 dpot,dpota,dpotc
      real*8 fx,fy,fz
      real*8 fxa1,fya1,fza1
      real*8 fxb1,fyb1,fzb1
      real*8 fxc1,fyc1,fzc1
      real*8 fxa2,fya2,fza2
      real*8 fxb2,fyb2,fzb2
      real*8 fxc2,fyc2,fzc2
      real*8 pb,pb1,pb2
      real*8 pa1,pa2
      real*8 eps,dot
      real*8 rabc,dra3,drc3
      real*8 term,fterm
      real*8 termxa,termxc
      real*8 termya,termyc
      real*8 termza,termzc
      real*8 pot(*)
      real*8 dcfx(*)
      real*8 dcfy(*)
      real*8 dcfz(*)
c
c
c     zero out the charge flux correction forces
c
      do i = 1, n
         dcfx(i) = 0.0d0
         dcfy(i) = 0.0d0
         dcfz(i) = 0.0d0
      end do
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     calculate the charge flux forces due to bond stretches
c
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         pb = bflx(i)
         xa = x(ia)
         ya = y(ia)
         za = z(ia)
         xb = x(ib)
         yb = y(ib)
         zb = z(ib)
         xab = xa - xb
         yab = ya - yb
         zab = za - zb
         if (use_polymer)  call image (xab,yab,zab)
         rab2 = max(xab*xab+yab*yab+zab*zab,eps)
         dpot = pot(ib) - pot(ia)
         pb = pb * dpot / sqrt(rab2)
         fx = pb * xab
         fy = pb * yab
         fz = pb * zab
         dcfx(ia) = dcfx(ia) + fx
         dcfy(ia) = dcfy(ia) + fy
         dcfz(ia) = dcfz(ia) + fz
         dcfx(ib) = dcfx(ib) - fx
         dcfy(ib) = dcfy(ib) - fy
         dcfz(ib) = dcfz(ib) - fz
      end do
c
c     calculate the charge flux forces due to angle bends
c
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         pa1 = aflx(1,i)
         pa2 = aflx(2,i)
         pb1 = abflx(1,i)
         pb2 = abflx(2,i)
         xa = x(ia)
         ya = y(ia)
         za = z(ia)
         xb = x(ib)
         yb = y(ib)
         zb = z(ib)
         xc = x(ic)
         yc = y(ic)
         zc = z(ic)
         xab = xa - xb
         yab = ya - yb
         zab = za - zb
         xcb = xc - xb
         ycb = yc - yb
         zcb = zc - zb
         if (use_polymer) then
            call image (xab,yab,zab)
            call image (xcb,ycb,zcb)
         end if
         rab2 = max(xab*xab+yab*yab+zab*zab,eps)
         rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
         rab = sqrt(rab2)
         rcb = sqrt(rcb2)
c
c     get terms corresponding to asymmetric bond stretches
c
         dpota = pot(ia) - pot(ib)
         dpotc = pot(ic) - pot(ib)
         pb1 = dpota * pb1
         pb2 = dpotc * pb2
         fxa1 = pb2 * xab/rab
         fya1 = pb2 * yab/rab
         fza1 = pb2 * zab/rab
         fxc1 = pb1 * xcb/rcb
         fyc1 = pb1 * ycb/rcb
         fzc1 = pb1 * zcb/rcb
         fxb1 = -fxa1 - fxc1
         fyb1 = -fya1 - fyc1
         fzb1 = -fza1 - fzc1
c
c     get terms corresponding to bond angle bending
c
         rabc = rab * rcb
         rab3 = rab2 * rab
         rcb3 = rcb2 * rcb
         dot = xab*xcb + yab*ycb + zab*zcb
         dra3 = dot / (rab3*rcb)
         drc3 = dot / (rab*rcb3)
         term = -rabc / max(sqrt(rab2*rcb2-dot*dot),eps)
         fterm = term * (dpota*pa1+dpotc*pa2)
         termxa = xcb/rabc - xab*dra3
         termya = ycb/rabc - yab*dra3
         termza = zcb/rabc - zab*dra3
         termxc = xab/rabc - xcb*drc3
         termyc = yab/rabc - ycb*drc3
         termzc = zab/rabc - zcb*drc3
         fxa2 = fterm * termxa
         fya2 = fterm * termya
         fza2 = fterm * termza
         fxc2 = fterm * termxc
         fyc2 = fterm * termyc
         fzc2 = fterm * termzc
         fxb2 = -fxa2 - fxc2
         fyb2 = -fya2 - fyc2
         fzb2 = -fza2 - fzc2
         dcfx(ia) = dcfx(ia) + fxa1 + fxa2
         dcfy(ia) = dcfy(ia) + fya1 + fya2
         dcfz(ia) = dcfz(ia) + fza1 + fza2
         dcfx(ib) = dcfx(ib) + fxb1 + fxb2
         dcfy(ib) = dcfy(ib) + fyb1 + fyb2
         dcfz(ib) = dcfz(ib) + fzb1 + fzb2
         dcfx(ic) = dcfx(ic) + fxc1 + fxc2
         dcfy(ic) = dcfy(ic) + fyc1 + fyc2
         dcfz(ic) = dcfz(ic) + fzc1 + fzc2
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine deflate  --  eigenvalues by method of deflation  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "deflate" uses the power method with deflation to compute the
c     few largest eigenvalues and eigenvectors of a symmetric matrix
c
c     n      dimension of the matrix to be diagonalized
c     nv     number of largest eigenvalues to be extracted
c     a      input with the matrix to be diagonalized; only
c               the lower triangle and diagonal are required
c     ev     returned with the eigenvalues in descending order
c     vec    returned with the eigenvectors of the matrix
c     work   local vector containing temporary work space
c
c
      subroutine deflate (n,nv,a,ev,vec)
      use iounit
      implicit none
      integer i,j,k,n,nv
      integer iter,maxiter
      real*8 random,eps
      real*8 dot1,dot2,ratio
      real*8 ev(*)
      real*8, allocatable :: work(:)
      real*8 a(n,*)
      real*8 vec(n,*)
      external random
c
c
c     initialize number of iterations and convergence criteria
c
      maxiter = 500
      eps = 1.0d-6
c
c     use identity vector as initial guess for eigenvectors
c
      do j = 1, nv
         do i = 1, n
            vec(i,j) = 1.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (work(n))
c
c     find the few largest eigenvalues and eigenvectors
c
      do k = 1, nv
         ev(k) = 0.0d0
         dot1 = 0.0d0
         do i = 1, n
            work(i) = 0.0d0
            do j = 1, i-1
               work(i) = work(i) + a(i,j)*vec(j,k)
            end do
            do j = i, n
               work(i) = work(i) + a(j,i)*vec(j,k)
            end do
            dot1 = dot1 + work(i)**2
         end do
c
c     if in or near null space, use random guess as eigenvector
c
         if (dot1 .le. 100.0d0*eps*dble(n)) then
            do i = 1, n
               work(i) = random ()
            end do
         end if
c
c     find the current eigenvalue by iterating to convergence;
c     first multiply vector by matrix and compute dot products
c
         do iter = 1, maxiter
            dot1 = 0.0d0
            dot2 = 0.0d0
            do i = 1, n
               vec(i,k) = 0.0d0
               do j = 1, i-1
                  vec(i,k) = vec(i,k) + a(i,j)*work(j)
               end do
               do j = i, n
                  vec(i,k) = vec(i,k) + a(j,i)*work(j)
               end do
               dot1 = dot1 + vec(i,k)**2
               dot2 = dot2 + vec(i,k)*work(i)
            end do
c
c     normalize new eigenvector and substitute for old one
c
            ratio = abs((ev(k)-dot2) / dot2)
            ev(k) = dot2
            dot1 = sqrt(dot1)
            do i = 1, n
               vec(i,k) = vec(i,k) / dot1
               work(i) = vec(i,k)
            end do
            if (ratio .lt. eps)  goto 20
         end do
         write (iout,10)  k
   10    format (/,' DEFLATE  --  Eigenvalue',i3,' not Fully Converged')
c
c     eliminate the current eigenvalue from the matrix
c
   20    continue
         do i = 1, n
            do j = i, n
               a(j,i) = a(j,i) - ev(k)*vec(i,k)*vec(j,k)
            end do
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (work)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine delete  --  remove atom from coordinates list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "delete" removes a specified atom from the Cartesian
c     coordinates list and shifts the remaining atoms
c
c
      subroutine delete (iatom)
      use atomid
      use atoms
      use couple
      use inform
      use iounit
      implicit none
      integer i,j,k,m,iatom
c
c
c     reduce by one the total number of atoms
c
      n = n - 1
c
c     shift the atom coordinates, types and connectivities
c
      do i = iatom, n
         name(i) = name(i+1)
         x(i) = x(i+1)
         y(i) = y(i+1)
         z(i) = z(i+1)
         type(i) = type(i+1)
         n12(i) = n12(i+1)
         do j = 1, n12(i)
            i12(j,i) = i12(j,i+1)
         end do
      end do
c
c     remove connections to deleted atom and shift the lists
c
      do i = 1, n
         m = 0
         do j = 1, n12(i)
            if (i12(j,i) .eq. iatom) then
               m = m + 1
               do k = j, n12(i)-1
                  i12(k,i) = i12(k+1,i)
               end do
            end if
         end do
         n12(i) = n12(i) - m
         do j = 1, n12(i)
            if (i12(j,i) .gt. iatom)  i12(j,i) = i12(j,i) - 1
         end do
      end do
c
c     write a message to describe the atom deletion
c
      if (debug) then
         write (iout,10)  iatom
   10    format (' DELETE  --  Deleting Atom Number :',i9)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module deriv  --  Cartesian coord derivative components  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     desum   total energy Cartesian coordinate derivatives
c     deb     bond stretch Cartesian coordinate derivatives
c     dea     angle bend Cartesian coordinate derivatives
c     deba    stretch-bend Cartesian coordinate derivatives
c     deub    Urey-Bradley Cartesian coordinate derivatives
c     deaa    angle-angle Cartesian coordinate derivatives
c     deopb   out-of-plane bend Cartesian coordinate derivatives
c     deopd   out-of-plane distance Cartesian coordinate derivatives
c     deid    improper dihedral Cartesian coordinate derivatives
c     deit    improper torsion Cartesian coordinate derivatives
c     det     torsional Cartesian coordinate derivatives
c     dept    pi-system torsion Cartesian coordinate derivatives
c     debt    stretch-torsion Cartesian coordinate derivatives
c     deat    angle-torsion Cartesian coordinate derivatives
c     dett    torsion-torsion Cartesian coordinate derivatives
c     dev     van der Waals Cartesian coordinate derivatives
c     der     Pauli repulsion Cartesian coordinate derivatives
c     dedsp   damped dispersion Cartesian coordinate derivatives
c     dec     charge-charge Cartesian coordinate derivatives
c     decd    charge-dipole Cartesian coordinate derivatives
c     ded     dipole-dipole Cartesian coordinate derivatives
c     dem     multipole Cartesian coordinate derivatives
c     dep     polarization Cartesian coordinate derivatives
c     dect    charge transfer Cartesian coordinate derivatives
c     derxf   reaction field Cartesian coordinate derivatives
c     des     solvation Cartesian coordinate derivatives
c     delf    metal ligand field Cartesian coordinate derivatives
c     deg     geometric restraint Cartesian coordinate derivatives
c     dex     extra energy term Cartesian coordinate derivatives
c
c
      module deriv
      implicit none
      real*8, allocatable :: desum(:,:)
      real*8, allocatable :: deb(:,:)
      real*8, allocatable :: dea(:,:)
      real*8, allocatable :: deba(:,:)
      real*8, allocatable :: deub(:,:)
      real*8, allocatable :: deaa(:,:)
      real*8, allocatable :: deopb(:,:)
      real*8, allocatable :: deopd(:,:)
      real*8, allocatable :: deid(:,:)
      real*8, allocatable :: deit(:,:)
      real*8, allocatable :: det(:,:)
      real*8, allocatable :: dept(:,:)
      real*8, allocatable :: debt(:,:)
      real*8, allocatable :: deat(:,:)
      real*8, allocatable :: dett(:,:)
      real*8, allocatable :: dev(:,:)
      real*8, allocatable :: der(:,:)
      real*8, allocatable :: dedsp(:,:)
      real*8, allocatable :: dec(:,:)
      real*8, allocatable :: decd(:,:)
      real*8, allocatable :: ded(:,:)
      real*8, allocatable :: dem(:,:)
      real*8, allocatable :: dep(:,:)
      real*8, allocatable :: dect(:,:)
      real*8, allocatable :: derxf(:,:)
      real*8, allocatable :: des(:,:)
      real*8, allocatable :: delf(:,:)
      real*8, allocatable :: deg(:,:)
      real*8, allocatable :: dex(:,:)
      save
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2022 by Moses Chung, Zhi Wang & Jay Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine dexpol  --  variable polarizability chain rule  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "dexpol" computes the chain rule terms to account for variable
c     polarizability in exchange polarization
c
c     literature reference:
c
c     M. K. J. Chung, Z. Wang, J. A. Rackers and J. W. Ponder,
c     "Classical Exchange Polarization: An Anisotropic Variable
c     Polarizability Model", Journal of Physical Chemistry B, 126,
c     7579-7594 (2022)
c
c
      subroutine dexpol
      use limits
      implicit none
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_mlist) then
         call dexpol1b
      else
         call dexpol1a
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine dexpol1a  --  exch-polar chain rule via loop  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "dexpol1a" finds variable polarizability chain rule gradient
c     components due to exchange polarization using a double loop
c
c
      subroutine dexpol1a
      use atoms
      use bound
      use cell
      use chgpot
      use couple
      use deriv
      use expol
      use mpole
      use polar
      use polgrp
      use polpot
      use shunt
      use units
      use virial
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4,r5
      real*8 sizi,sizk,sizik
      real*8 alphai,alphak
      real*8 springi,springk
      real*8 f,s2,ds2
      real*8 s2i,s2k
      real*8 ds2i,ds2k
      real*8 taper,dtaper
      real*8 uix,uiy,uiz
      real*8 ukx,uky,ukz
      real*8 uixl,ukxl
      real*8 uiyl,ukyl
      real*8 uizl,ukzl
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 frcil(3)
      real*8 frckl(3)
      real*8 frcxi,frcyi,frczi
      real*8 frcxk,frcyk,frczk
      real*8 frcx,frcy,frcz
      real*8 tqxil,tqyil
      real*8 tqxkl,tqykl
      real*8 ai(3,3)
      real*8 ak(3,3)
      real*8, allocatable :: pscale(:)
      logical epli,eplk
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'REPULS'
      call switch (mode)
c
c     set array needed to scale atom and group interactions
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     find the exchange polarization gradient
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         springi = kpep(i) / polarity(i)
         sizi = prepep(i)
         alphai = dmppep(i)
         epli = lpep(i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            eplk = lpep(k)
            if (epli .or. eplk) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  springk = kpep(k) / polarity(k)
                  sizk = prepep(k)
                  alphak = dmppep(k)
                  sizik = sizi * sizk
                  ukx = uind(1,k)
                  uky = uind(2,k)
                  ukz = uind(3,k)
                  call dampexpl (r,sizik,alphai,alphak,s2,ds2)
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     ds2 = ds2*taper + s2*dtaper
                     s2 = s2 * taper
                  end if
                  s2i = springi * s2 * pscale(k)
                  s2k = springk * s2 * pscale(k)
                  ds2i = springi * ds2 * pscale(k)
                  ds2k = springk * ds2 * pscale(k)
                  call rotdexpl (r,xr,yr,zr,ai,ak)
                  uixl = uix*ai(1,1) + uiy*ai(1,2) + uiz*ai(1,3)
                  uiyl = uix*ai(2,1) + uiy*ai(2,2) + uiz*ai(2,3)
                  uizl = uix*ai(3,1) + uiy*ai(3,2) + uiz*ai(3,3)
                  ukxl = -ukx*ak(1,1) - uky*ak(1,2) - ukz*ak(1,3)
                  ukyl = -ukx*ak(2,1) - uky*ak(2,2) - ukz*ak(2,3)
                  ukzl = -ukx*ak(3,1) - uky*ak(3,2) - ukz*ak(3,3)
                  frcil(3) = uizl**2 * ds2i
                  frckl(3) = ukzl**2 * ds2k
c
c     compute the torque in the local frame
c
                  tqxil = 2.0d0 * uiyl * uizl * s2i
                  tqyil = -2.0d0 * uixl * uizl * s2i
                  tqxkl = 2.0d0 * ukyl * ukzl * s2k
                  tqykl = -2.0d0 * ukxl * ukzl * s2k
c
c     convert the torque into force components
c
                  frcil(1) = -tqyil / r
                  frcil(2) = tqxil / r
                  frckl(1) = -tqykl / r
                  frckl(2) = tqxkl / r
c
c     rotate the force components into the global frame
c
                  frcxi = 0.0d0
                  frcyi = 0.0d0
                  frczi = 0.0d0
                  frcxk = 0.0d0
                  frcyk = 0.0d0
                  frczk = 0.0d0
                  do j = 1, 3
                     frcxi = frcxi + ai(j,1)*frcil(j)
                     frcyi = frcyi + ai(j,2)*frcil(j)
                     frczi = frczi + ai(j,3)*frcil(j)
                     frcxk = frcxk + ak(j,1)*frckl(j)
                     frcyk = frcyk + ak(j,2)*frckl(j)
                     frczk = frczk + ak(j,3)*frckl(j)
                  end do
                  frcx = f * (frcxk-frcxi)
                  frcy = f * (frcyk-frcyi)
                  frcz = f * (frczk-frczi)
c
c     increment force-based gradient on the interaction sites
c
                  dep(1,i) = dep(1,i) + frcx
                  dep(2,i) = dep(2,i) + frcy
                  dep(3,i) = dep(3,i) + frcz
                  dep(1,k) = dep(1,k) - frcx
                  dep(2,k) = dep(2,k) - frcy
                  dep(3,k) = dep(3,k) - frcz
c
c     increment the virial due to pairwise Cartesian forces
c
                  vxx = -xr * frcx
                  vxy = -0.5d0 * (yr*frcx+xr*frcy)
                  vxz = -0.5d0 * (zr*frcx+xr*frcz)
                  vyy = -yr * frcy
                  vyz = -0.5d0 * (zr*frcy+yr*frcz)
                  vzz = -zr * frcz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vxy
                  vir(3,1) = vir(3,1) + vxz
                  vir(1,2) = vir(1,2) + vxy
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vyz
                  vir(1,3) = vir(1,3) + vxz
                  vir(2,3) = vir(2,3) + vyz
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction components with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            springi = kpep(i) / polarity(i)
            sizi = prepep(i)
            alphai = dmppep(i)
            epli = lpep(i)
            uix = uind(1,i)
            uiy = uind(2,i)
            uiz = uind(3,i)
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               eplk = lpep(k)
               if (epli .or. eplk) then
                  do jcell = 2, ncell
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     call imager (xr,yr,zr,jcell)
                     r2 = xr*xr + yr*yr + zr*zr
                     if (r2 .le. off2) then
                        r = sqrt(r2)
                        springk = kpep(k) / polarity(k)
                        sizk = prepep(k)
                        alphak = dmppep(k)
                        sizik = sizi * sizk
                        ukx = uind(1,k)
                        uky = uind(2,k)
                        ukz = uind(3,k)
                        call dampexpl (r,sizik,alphai,alphak,s2,ds2)
c
c     use energy switching if near the cutoff distance
c
                        if (r2 .gt. cut2) then
                           r3 = r2 * r
                           r4 = r2 * r2
                           r5 = r2 * r3
                           taper = c5*r5 + c4*r4 + c3*r3
     &                                + c2*r2 + c1*r + c0
                           dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                                 + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                           ds2 = ds2*taper + s2*dtaper
                           s2 = s2 * taper
                        end if
c
c     interaction of an atom with its own image counts half
c
                        if (i .eq. k) then
                           s2 = 0.5d0 * s2
                           ds2 = 0.5d0 * ds2
                        end if
                        s2i = springi * s2 * pscale(k)
                        s2k = springk * s2 * pscale(k)
                        ds2i = springi * ds2 * pscale(k)
                        ds2k = springk * ds2 * pscale(k)
                        call rotdexpl (r,xr,yr,zr,ai,ak)
                        uixl = uix*ai(1,1) + uiy*ai(1,2) + uiz*ai(1,3)
                        uiyl = uix*ai(2,1) + uiy*ai(2,2) + uiz*ai(2,3)
                        uizl = uix*ai(3,1) + uiy*ai(3,2) + uiz*ai(3,3)
                        ukxl = -ukx*ak(1,1) - uky*ak(1,2) - ukz*ak(1,3)
                        ukyl = -ukx*ak(2,1) - uky*ak(2,2) - ukz*ak(2,3)
                        ukzl = -ukx*ak(3,1) - uky*ak(3,2) - ukz*ak(3,3)
                        frcil(3) = uizl**2 * ds2i
                        frckl(3) = ukzl**2 * ds2k
c
c     compute the torque in the local frame
c
                        tqxil = 2.0d0 * uiyl * uizl * s2i
                        tqyil = -2.0d0 * uixl * uizl * s2i
                        tqxkl = 2.0d0 * ukyl * ukzl * s2k
                        tqykl = -2.0d0 * ukxl * ukzl * s2k
c
c     convert the torque into force components
c
                        frcil(1) = -tqyil / r
                        frcil(2) = tqxil / r
                        frckl(1) = -tqykl / r
                        frckl(2) = tqxkl / r
c
c     rotate the force components into the global frame
c
                        frcxi = 0.0d0
                        frcyi = 0.0d0
                        frczi = 0.0d0
                        frcxk = 0.0d0
                        frcyk = 0.0d0
                        frczk = 0.0d0
                        do j = 1, 3
                           frcxi = frcxi + ai(j,1)*frcil(j)
                           frcyi = frcyi + ai(j,2)*frcil(j)
                           frczi = frczi + ai(j,3)*frcil(j)
                           frcxk = frcxk + ak(j,1)*frckl(j)
                           frcyk = frcyk + ak(j,2)*frckl(j)
                           frczk = frczk + ak(j,3)*frckl(j)
                        end do
                        frcx = f * (frcxk-frcxi)
                        frcy = f * (frcyk-frcyi)
                        frcz = f * (frczk-frczi)
c
c     increment force-based gradient on the interaction sites
c
                        dep(1,i) = dep(1,i) + frcx
                        dep(2,i) = dep(2,i) + frcy
                        dep(3,i) = dep(3,i) + frcz
                        dep(1,k) = dep(1,k) - frcx
                        dep(2,k) = dep(2,k) - frcy
                        dep(3,k) = dep(3,k) - frcz
c
c     increment the virial due to pairwise Cartesian forces
c
                        vxx = -xr * frcx
                        vxy = -0.5d0 * (yr*frcx+xr*frcy)
                        vxz = -0.5d0 * (zr*frcx+xr*frcz)
                        vyy = -yr * frcy
                        vyz = -0.5d0 * (zr*frcy+yr*frcz)
                        vzz = -zr * frcz
                        vir(1,1) = vir(1,1) + vxx
                        vir(2,1) = vir(2,1) + vxy
                        vir(3,1) = vir(3,1) + vxz
                        vir(1,2) = vir(1,2) + vxy
                        vir(2,2) = vir(2,2) + vyy
                        vir(3,2) = vir(3,2) + vyz
                        vir(1,3) = vir(1,3) + vxz
                        vir(2,3) = vir(2,3) + vyz
                        vir(3,3) = vir(3,3) + vzz
                     end if
                  end do
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine dexpol1b  --  exch-polar chain rule via list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "dexpol1b" finds variable polarizability chain rule gradient
c     components due to exchange polarization using a neighbor list
c
c
      subroutine dexpol1b
      use atoms
      use bound
      use chgpot
      use couple
      use deriv
      use expol
      use mpole
      use neigh
      use polar
      use polgrp
      use polpot
      use shunt
      use units
      use virial
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4,r5
      real*8 sizi,sizk,sizik
      real*8 f,alphai,alphak
      real*8 springi,springk
      real*8 s2,ds2
      real*8 s2i, s2k
      real*8 ds2i, ds2k
      real*8 taper,dtaper
      real*8 uix,uiy,uiz
      real*8 ukx,uky,ukz
      real*8 uixl,ukxl
      real*8 uiyl,ukyl
      real*8 uizl,ukzl
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 frcil(3)
      real*8 frckl(3)
      real*8 frcxi,frcyi,frczi
      real*8 frcxk,frcyk,frczk
      real*8 frcx,frcy,frcz
      real*8 tqxil,tqyil
      real*8 tqxkl,tqykl
      real*8 ai(3,3)
      real*8 ak(3,3)
      real*8, allocatable :: pscale(:)
      logical epli,eplk
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'REPULS'
      call switch (mode)
c
c     set array needed to scale atom and group interactions
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,x,y,z,kpep,prepep,dmppep,lpep,np11,ip11,n12,
!$OMP& i12,n13,i13,n14,i14,n15,i15,p2scale,p3scale,p4scale,p5scale,
!$OMP& p2iscale,p3iscale,p4iscale,p5iscale,nelst,elst,use_bounds,
!$OMP& cut2,off2,c0,c1,c2,c3,c4,c5,polarity,f,uind)
!$OMP& firstprivate(pscale)
!$OMP& shared (dep,vir)
!$OMP DO reduction(+:dep,vir)
c
c     find the exchange polarization gradient
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         springi = kpep(i) / polarity(i)
         sizi = prepep(i)
         alphai = dmppep(i)
         epli = lpep(i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            eplk = lpep(k)
            if (epli .or. eplk) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  springk = kpep(k) / polarity(k)
                  sizk = prepep(k)
                  alphak = dmppep(k)
                  sizik = sizi * sizk
                  ukx = uind(1,k)
                  uky = uind(2,k)
                  ukz = uind(3,k)
                  call dampexpl (r,sizik,alphai,alphak,s2,ds2)
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     ds2 = ds2*taper + s2*dtaper
                     s2 = s2 * taper
                  end if
                  s2i = springi * s2 * pscale(k)
                  s2k = springk * s2 * pscale(k)
                  ds2i = springi * ds2 * pscale(k)
                  ds2k = springk * ds2 * pscale(k)
                  call rotdexpl (r,xr,yr,zr,ai,ak)
                  uixl = uix*ai(1,1) + uiy*ai(1,2) + uiz*ai(1,3)
                  uiyl = uix*ai(2,1) + uiy*ai(2,2) + uiz*ai(2,3)
                  uizl = uix*ai(3,1) + uiy*ai(3,2) + uiz*ai(3,3)
                  ukxl = -ukx*ak(1,1) - uky*ak(1,2) - ukz*ak(1,3)
                  ukyl = -ukx*ak(2,1) - uky*ak(2,2) - ukz*ak(2,3)
                  ukzl = -ukx*ak(3,1) - uky*ak(3,2) - ukz*ak(3,3)
                  frcil(3) = uizl**2 * ds2i
                  frckl(3) = ukzl**2 * ds2k
c
c     compute the torque in the local frame
c
                  tqxil = 2.0d0 * uiyl * uizl * s2i
                  tqyil = -2.0d0 * uixl * uizl * s2i
                  tqxkl = 2.0d0 * ukyl * ukzl * s2k
                  tqykl = -2.0d0 * ukxl * ukzl * s2k
c
c     convert the torque into force components
c
                  frcil(1) = -tqyil / r
                  frcil(2) = tqxil / r
                  frckl(1) = -tqykl / r
                  frckl(2) = tqxkl / r
c
c     rotate the force conponents into the global frame
c
                  frcxi = 0.0d0
                  frcyi = 0.0d0
                  frczi = 0.0d0
                  frcxk = 0.0d0
                  frcyk = 0.0d0
                  frczk = 0.0d0
                  do j = 1, 3
                     frcxi = frcxi + ai(j,1)*frcil(j)
                     frcyi = frcyi + ai(j,2)*frcil(j)
                     frczi = frczi + ai(j,3)*frcil(j)
                     frcxk = frcxk + ak(j,1)*frckl(j)
                     frcyk = frcyk + ak(j,2)*frckl(j)
                     frczk = frczk + ak(j,3)*frckl(j)
                  end do
                  frcx = f * (frcxk-frcxi)
                  frcy = f * (frcyk-frcyi)
                  frcz = f * (frczk-frczi)
c
c     increment force-based gradient on the interaction sites
c
                  dep(1,i) = dep(1,i) + frcx
                  dep(2,i) = dep(2,i) + frcy
                  dep(3,i) = dep(3,i) + frcz
                  dep(1,k) = dep(1,k) - frcx
                  dep(2,k) = dep(2,k) - frcy
                  dep(3,k) = dep(3,k) - frcz
c
c     increment the virial due to pairwise Cartesian forces
c
                  vxx = -xr * frcx
                  vxy = -0.5d0 * (yr*frcx+xr*frcy)
                  vxz = -0.5d0 * (zr*frcx+xr*frcz)
                  vyy = -yr * frcy
                  vyz = -0.5d0 * (zr*frcy+yr*frcz)
                  vzz = -zr * frcz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vxy
                  vir(3,1) = vir(3,1) + vxz
                  vir(1,2) = vir(1,2) + vxy
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vyz
                  vir(1,3) = vir(1,3) + vxz
                  vir(2,3) = vir(2,3) + vyz
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine rotdexpl  --  rotation matrix for expol derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "rotdexpl" finds rotation matrices for variable polarizability
c     in the exchange polarization gradient
c
c
      subroutine rotdexpl (r,xr,yr,zr,ai,ak)
      use atoms
      use math
      use mpole
      use polpot
      implicit none
      real*8 r,xr,yr,zr
      real*8 dr,dot,eps
      real*8 dx,dy,dz
      real*8 ai(3,3)
      real*8 ak(3,3)
c
c
c     compute the rotation matrix elements
c
      ai(3,1) = xr / r
      ai(3,2) = yr / r
      ai(3,3) = zr / r
      dx = 1.0d0
      dy = 0.0d0
      dz = 0.0d0
      dot = ai(3,1)
      eps = 1.0d0 / root2
      if (abs(dot) .gt. eps) then
         dx = 0.0d0
         dy = 1.0d0
         dot = ai(3,2)
      end if
      dx = dx - dot*ai(3,1)
      dy = dy - dot*ai(3,2)
      dz = dz - dot*ai(3,3)
      dr = sqrt(dx*dx + dy*dy + dz*dz)
c
c     matrix "ai" rotates a vector from global to local frame
c
      ai(1,1) = dx / dr
      ai(1,2) = dy / dr
      ai(1,3) = dz / dr
      ai(2,1) = ai(1,3)*ai(3,2) - ai(1,2)*ai(3,3)
      ai(2,2) = ai(1,1)*ai(3,3) - ai(1,3)*ai(3,1)
      ai(2,3) = ai(1,2)*ai(3,1) - ai(1,1)*ai(3,2)
      ak(1,1) = ai(1,1)
      ak(1,2) = ai(1,2)
      ak(1,3) = ai(1,3)
      ak(2,1) = -ai(2,1)
      ak(2,2) = -ai(2,2)
      ak(2,3) = -ai(2,3)
      ak(3,1) = -ai(3,1)
      ak(3,2) = -ai(3,2)
      ak(3,3) = -ai(3,3)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine diagq  --  fast matrix diagonalization routine  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "diagq" is a matrix diagonalization routine which is derived
c     from the classical given, housec, and eigen algorithms with
c     several modifications to increase efficiency and accuracy
c
c     variables and parameters:
c
c     n         dimension of the matrix to be diagonalized
c     nv        number of eigenvalues and eigenvectors desired
c     dd        upper triangle of the matrix to be diagonalized
c     ev        returned with the eigenvalues in ascending order
c     vec       returned with the eigenvectors of the matrix
c     a,b,p,w   local vectors containing temporary work space
c     ta,tb,y   local vectors containing temporary work space
c
c     literature reference:
c
c     adapted from an original routine written by Bernie Brooks,
c     National Institutes of Health, Bethesda, MD
c
c
      subroutine diagq (n,nv,dd,ev,vec)
      implicit none
      integer i,j,k,m,n
      integer ia,ii,ji
      integer mi,mj,mk
      integer nn,nv,ntot
      integer nom,nomtch
      integer ipt,iter,j1
      integer mi1,mj1,mk1
      real*8 alimit,anorm
      real*8 eta,theta,eps
      real*8 rho,delta,gamma
      real*8 zeta,sigma
      real*8 bx,elim1,elim2
      real*8 epr,f0,factor
      real*8 rvalue,rand1
      real*8 rpower,rpow1
      real*8 root,rootx
      real*8 s,sgn,sum1
      real*8 t,term,temp
      real*8 trial,xnorm
      real*8 dd(*)
      real*8 ev(*)
      real*8, allocatable :: a(:)
      real*8, allocatable :: b(:)
      real*8, allocatable :: p(:)
      real*8, allocatable :: w(:)
      real*8, allocatable :: ta(:)
      real*8, allocatable :: tb(:)
      real*8, allocatable :: y(:)
      real*8 vec(n,*)
      logical done
c
c
c     initialization of some necessary parameters
c
      eta = 1.0d-16
      theta = 1.0d37
      eps = 100.0d0 * eta
      rho = eta / 100.0d0
      delta = 100.0d0 * eta**2
      gamma = eta**2 / 100.0d0
      zeta = 1000.0d0 / theta
      sigma = theta * delta / 1000.0d0
      rvalue = 4099.0d0
      rpower = 8388608.0d0
      rpow1 = 0.5d0 * rpower
      rand1 = rpower - 3.0d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (a(n))
      allocate (b(n))
      allocate (p(n))
      allocate (w(n))
      allocate (ta(n))
      allocate (tb(n))
      allocate (y(n))
c
c     get norm of the input matrix and scale
c
      factor = 0.0d0
      ntot = n*(n+1) / 2
      do i = 1, ntot
         factor = max(factor,abs(dd(i)))
      end do
      if (factor .eq. 0.0d0)  return
      k = 0
      anorm = 0.0d0
      do i = 1, n
         do j = i, n
            k = k + 1
            term = (dd(k)/factor)**2
            if (i .eq. j)  term = 0.5d0 * term
            anorm = anorm + term
         end do
      end do
      anorm = factor * sqrt(2.0d0*anorm)
      do i = 1, ntot
         dd(i) = dd(i) / anorm
      end do
c
c     compute the tridiagonalization of the matrix
c
      nn = n - 1
      mi = 0
      mi1 = n - 1
      do i = 1, nn
         sum1 = 0.0d0
         b(i) = 0.0d0
         ji = i + 1
         ipt = mi + i
         a(i) = dd(ipt)
         ipt = ipt + 1
         bx = dd(ipt)
         do j = ji+1, n
            ipt = ipt + 1
            sum1 = sum1 + dd(ipt)*dd(ipt)
         end do
         if (sum1 .lt. gamma) then
            b(i) = bx
            dd(mi+ji) = 0.0d0
         else
            s = sqrt(sum1+bx*bx)
            sgn = 1.0d0
            if (bx .lt. 0.0)  sgn = -1.0d0
            temp = abs(bx)
            w(ji) = sqrt(0.5d0*(1.0d0+(temp/s)))
            ipt = mi + ji
            dd(ipt) = w(ji)
            ii = i + 2
            if (ii .le. n) then
               temp = sgn / (2.0d0*w(ji)*s)
               do j = ii, n
                  ipt = ipt + 1
                  w(j) = temp * dd(ipt)
                  dd(ipt) = w(j)
               end do
            end if
            b(i) = -sgn * s
            do j = ji, n
               p(j) = 0.0d0
            end do
            mk = mi + mi1
            mk1 = mi1 - 1
            do k = ji, n
               ipt = mk + k
               do m = k, n
                  bx = dd(ipt)
                  p(k) = p(k) + bx*w(m)
                  if (k .ne. m)  p(m) = p(m) + bx*w(k)
                  ipt = ipt + 1
               end do
               mk = mk + mk1
               mk1 = mk1 - 1
            end do
            term = 0.0d0
            do k = ji, n
               term = term + w(k)*p(k)
            end do
            do k = ji, n
               p(k) = p(k) - term*w(k)
            end do
            mj = mi + mi1
            mj1 = mi1 - 1
            do j = ji, n
               do k = j, n
                  dd(mj+k) = dd(mj+k) - 2.0d0*(p(j)*w(k)+p(k)*w(j))
               end do
               mj = mj + mj1
               mj1 = mj1 - 1
            end do
         end if
         mi = mi + mi1
         mi1 = mi1 - 1
      end do
c
c     find the eigenvalues via the Sturm bisection method
c
      a(n) = dd(mi+n)
      b(n) = 0.0d0
      alimit = 1.0d0
      do i = 1, n
         w(i) = b(i)
         b(i) = b(i) * b(i)
      end do
      do i = 1, nv
         ev(i) = alimit
      end do
      root = -alimit
      do i = 1, nv
         rootx = alimit
         do j = i, nv
            rootx = min(rootx,ev(j))
         end do
         ev(i) = rootx
         trial = 0.5d0 * (root+ev(i))
         do while (abs(trial-root).ge.eps .and. abs(trial-ev(i)).ge.eps)
            nomtch = n
            j = 1
            do while (j .le. n)
               f0 = a(j) - trial
               do while (abs(f0) .ge. zeta)
                  if (f0 .ge. 0.0d0)  nomtch = nomtch - 1
                  j = j + 1
                  if (j .gt. n)  goto 10
                  f0 = a(j) - trial - b(j-1)/f0
               end do
               j = j + 2
               nomtch = nomtch - 1
            end do
   10       continue
            if (nomtch .lt. i) then
               root = trial
            else
               ev(i) = trial
               nom = min(nv,nomtch)
               ev(nom) = trial
            end if
            trial = 0.5d0 * (root+ev(i))
         end do
      end do
c
c     find the eigenvectors via a backtransformation step
c
      ia = -1
      do i = 1, nv
         root = ev(i)
         do j = 1, n
            y(j) = 1.0d0
         end do
         ia = ia + 1
         if (i .ne. 1) then
            if (abs(ev(i-1)-root) .ge. eps)  ia = 0
         end if
         elim1 = a(1) - root
         elim2 = w(1)
         do j = 1, nn
            if (abs(elim1) .le. abs(w(j))) then
               ta(j) = w(j)
               tb(j) = a(j+1) - root
               p(j) = w(j+1)
               temp = 1.0d0
               if (abs(w(j)) .gt. zeta)  temp = elim1 / w(j)
               elim1 = elim2 - temp*tb(j)
               elim2 = -temp * w(j+1)
            else
               ta(j) = elim1
               tb(j) = elim2
               p(j) = 0.0d0
               temp = w(j) / elim1
               elim1 = a(j+1) - root - temp*elim2
               elim2 = w(j+1)
            end if
            b(j) = temp
         end do
         ta(n) = elim1
         tb(n) = 0.0d0
         p(n) = 0.0d0
         if (nn .ne. 0)  p(nn) = 0.0d0
         iter = 1
         if (ia .ne. 0)  goto 40
   20    continue
         m = n + 1
         do j = 1, n
            m = m - 1
            done = .false.
            do while (.not. done)
               done = .true.
               k = n - m - 1
               if (k .lt. 0) then
                  elim1 = y(m)
               else if (k .eq. 0) then
                  elim1 = y(m) - y(m+1)*tb(m)
               else
                  elim1 = y(m) - y(m+1)*tb(m) - y(m+2)*p(m)
               end if
               if (abs(elim1) .le. sigma) then
                  temp = ta(m)
                  if (abs(temp) .lt. delta)  temp = delta
                  y(m) = elim1 / temp
               else
                  do k = 1, n
                     y(k) = y(k) / sigma
                  end do
                  done = .false.
               end if
            end do
         end do
         if (iter .eq. 2)  goto 50
         iter = iter + 1
   30    continue
         elim1 = y(1)
         do j = 1, nn
            if (ta(j) .ne. w(j)) then
               y(j) = elim1
               elim1 = y(j+1) - elim1*b(j)
            else
               y(j) = y(j+1)
               elim1 = elim1 - y(j+1)*b(j)
            end if
         end do
         y(n) = elim1
         goto 20
   40    continue
         do j = 1, n
            rand1 = mod(rvalue*rand1,rpower)
            y(j) = rand1/rpow1 - 1.0d0
         end do
         goto 20
   50    continue
         if (ia .ne. 0) then
            do j1 = 1, ia
               k = i - j1
               temp = 0.0d0
               do j = 1, n
                  temp = temp + y(j)*vec(j,k)
               end do
               do j = 1, n
                  y(j) = y(j) - temp*vec(j,k)
               end do
            end do
         end if
         if (iter .eq. 1)  goto 30
         elim1 = 0.0d0
         do j = 1, n
            elim1 = max(elim1,abs(y(j)))
         end do
         temp = 0.0d0
         do j = 1, n
            elim2 = y(j) / elim1
            temp = temp + elim2*elim2
         end do
         temp = 1.0d0 / (sqrt(temp)*elim1)
         do j = 1, n
            y(j) = y(j) * temp
            if (abs(y(j)) .lt. rho)  y(j) = 0.0d0
         end do
         do j = 1, n
            vec(j,i) = y(j)
         end do
      end do
c
c     normalization of the eigenvalues and eigenvectors
c
      do i = 1, nv
         do j = 1, n
            y(j) = vec(j,i)
         end do
         mk = (n*(n-1))/2 - 3
         mk1 = 3
         do j = 1, n-2
            t = 0.0d0
            m = n - j
            do k = m, n
               t = t + dd(mk+k)*y(k)
            end do
            do k = m, n
               epr = t * dd(mk+k)
               y(k) = y(k) - 2.0d0*epr
            end do
            mk = mk - mk1
            mk1 = mk1 + 1
         end do
         t = 0.0d0
         do j = 1, n
            t = t + y(j)*y(j)
         end do
         xnorm = sqrt(t)
         do j = 1, n
            y(j) = y(j) / xnorm
         end do
         do j = 1, n
            vec(j,i) = y(j)
         end do
      end do
      do i = 1, n
         ev(i) = ev(i) * anorm
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (a)
      deallocate (b)
      deallocate (p)
      deallocate (w)
      deallocate (ta)
      deallocate (tb)
      deallocate (y)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine diffeq  --  differential equation integration  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "diffeq" performs the numerical integration of an ordinary
c     differential equation using an adaptive stepsize method to
c     solve the corresponding coupled first-order equations of the
c     general form dyi/dx = f(x,y1,...,yn) for yi = y1,...,yn
c
c     variables and parameters:
c
c     nvar      number of coupled first-order differential equations
c     y         contains the values of the dependent variables
c     x1        value of the beginning integration limit
c     x2        value of the ending integration limit
c     eps       relative accuracy required of the integration steps
c     h1        initial guess for the first integration stepsize
c     hmin      minimum allowed integration stepsize
c     nok       number of initially successful integration steps
c     nbad      number of integration steps that required retry
c
c     required external routines :
c
c     gvalue    subroutine to find the right-hand side of the
c                  first-order differential equations
c
c
      subroutine diffeq (nvar,y,x1,x2,eps,h1,hmin,nok,nbad,gvalue)
      use iounit
      implicit none
      real*8 tiny
      parameter (tiny=1.0d-30)
      integer i,nvar,nok,nbad
      integer nstep,maxstep
      real*8 x,x1,x2,h,h1
      real*8 eps,hnext
      real*8 hmin,hdid
      real*8 y(*)
      real*8, allocatable :: dydx(:)
      real*8, allocatable :: yscal(:)
      logical terminate
      character*7 status
      external gvalue
c
c
c     initialize starting limit, step size and status counters
c
      terminate = .false.
      x = x1
      h = sign(h1,x2-x1)
      nstep = 0
      nok = 0
      nbad = 0
      maxstep = 1000
c
c     perform dynamic allocation of some local arrays
c
      allocate (dydx(nvar))
      allocate (yscal(nvar))
c
c     perform a series of individual integration steps
c
      do while (.not. terminate)
         call gvalue (x,y,dydx)
         do i = 1, nvar
            yscal(i) = abs(y(i)) + abs(h*dydx(i)) + tiny
         end do
c
c     set the final step to stop at the integration limit
c
         if ((x+h-x2)*(x+h-x1) .gt. 0.0d0)  h = x2 - x
c
c     take a Bulirsch-Stoer integration step
c
         call bsstep (nvar,x,dydx,y,h,eps,yscal,hdid,hnext,gvalue)
c
c     mark the current step as either good or bad
c
         if (hdid .eq. h) then
            nok = nok + 1
            status = 'Success'
         else
            nbad = nbad + 1
            status = ' Retry '
         end if
c
c     update stepsize and get information about the current step
c
         h = hnext
         nstep = nstep + 1
         call gdastat (nstep,x,y,status)
c
c     test for convergence to the final integration limit
c
         if ((x-x2)*(x2-x1) .ge. 0.0d0) then
            write (iout,10)
   10       format (/,' DIFFEQ  --  Normal Termination',
     &                 ' at Integration Limit')
            terminate = .true.
         end if
c
c     test for a trial stepsize that is too small
c
         if (abs(hnext) .lt. hmin) then
            write (iout,20)
   20       format (/,' DIFFEQ  --  Incomplete Integration',
     &                 ' due to SmallStep')
            terminate = .true.
         end if
c
c     test for too many total integration steps
c
         if (nstep .ge. maxstep) then
            write (iout,30)
   30       format (/,' DIFFEQ  --  Incomplete Integration',
     &                 ' due to IterLimit')
            terminate = .true.
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (dydx)
      deallocate (yscal)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine bsstep  --  Bulirsch-Stoer integration step  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "bsstep" takes a single Bulirsch-Stoer step with monitoring
c     of local truncation error to ensure accuracy
c
c     literature reference:
c
c     W. H. Press, S. A. Teukolsky, W. T. Vetterling and B. P.
c     Flannery, Numerical Recipes (Fortran), 2nd Ed., Cambridge
c     University Press, 1992, Section 16.4
c
c
      subroutine bsstep (nvar,x,dydx,y,htry,eps,yscal,hdid,hnext,gvalue)
      use iounit
      implicit none
      integer kmaxx,imax
      real*8 safe1,safe2
      real*8 redmax,redmin
      real*8 tiny,scalmx
      parameter (kmaxx=8)
      parameter (imax=kmaxx+1)
      parameter (safe1=0.25d0)
      parameter (safe2=0.7d0)
      parameter (redmax=1.0d-5)
      parameter (redmin=0.7d0)
      parameter (tiny=1.0d-30)
      parameter (scalmx=0.1d0)
      integer i,iq,k,kk,nvar
      integer km,kmax,kopt
      integer nseq(imax)
      real*8 eps,eps1,epsold
      real*8 h,hdid,hnext,htry
      real*8 errmax,fact,red
      real*8 scale,work,wrkmin
      real*8 x,xest,xnew
      real*8 dydx(*)
      real*8 y(*)
      real*8 yscal(*)
      real*8 a(imax)
      real*8 err(kmaxx)
      real*8 alf(kmaxx,kmaxx)
      real*8, allocatable :: yerr(:)
      real*8, allocatable :: ysav(:)
      real*8, allocatable :: yseq(:)
      logical first,reduct
      save a,alf,epsold,first
      save kmax,kopt,nseq,xnew
      external gvalue
      data first  / .true. /
      data epsold / -1.0d0 /
      data nseq   / 2,4,6,8,10,12,14,16,18 /
c
c
c     setup prior to the Bulirsch-Stoer integration step
c
      if (eps .ne. epsold) then
         hnext = -1.0d29
         xnew = -1.0d29
         eps1 = safe1 * eps
         a(1) = 1.0d0 + dble(nseq(1))
         do k = 1, kmaxx
            a(k+1) = a(k) + dble(nseq(k+1))
         end do
         do iq = 2, kmaxx
            do k = 1, iq-1
               alf(k,iq) = eps1**((a(k+1)-a(iq+1))/((a(iq+1)-a(1)+1.0d0)
     &                                                 *(2*k+1)))
            end do
         end do
         epsold = eps
         do kopt = 2, kmaxx-1
            kmax = kopt
            if (a(kopt+1) .gt. a(kopt)*alf(kopt-1,kopt))  goto 10
         end do
   10    continue
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (yerr(nvar))
      allocate (ysav(nvar))
      allocate (yseq(nvar))
c
c     make an integration step using Bulirsch-Stoer method
c
      h = htry
      do i = 1, nvar
         ysav(i) = y(i)
      end do
      if (h.ne.hnext .or. x.ne.xnew) then
         first = .true.
         kopt = kmax
      end if
      reduct = .false.
   20 continue
      do k = 1, kmax
         xnew = x + h
         if (xnew .eq. x) then
            write (iout,30)
   30       format (' BSSTEP  --  Underflow of Step Size')
            call fatal
         end if
         call mmid (nseq(k),h,nvar,x,dydx,ysav,yseq,gvalue)
         xest = (h/dble(nseq(k)))**2
         call pzextr (k,nvar,xest,yseq,y,yerr)
         if (k .ne. 1) then
            errmax = tiny
            do i = 1, nvar
               errmax = max(errmax,abs(yerr(i)/yscal(i)))
            end do
            errmax = errmax / eps
            km = k - 1
            err(km) = (errmax/safe1)**(1.0d0/(2*km+1))
         end if
         if (k.ne.1 .and. (k.ge.kopt-1 .or. first)) then
            if (errmax .lt. 1.0d0)  goto 50
            if (k.eq.kmax .or. k.eq.kopt+1) then
               red = safe2 / err(km)
               goto 40
            else if (k .eq. kopt) then
               if (alf(kopt-1,kopt) .lt. err(km)) then
                  red = 1.0d0 / err(km)
                  goto 40
               end if
            else if (kopt .eq. kmax) then
               if (alf(km,kmax-1) .lt. err(km)) then
                  red = alf(km,kmax-1) * safe2 / err(km)
                  goto 40
               end if
            else if (alf(km,kopt) .lt. err(km)) then
               red = alf(km,kopt-1) / err(km)
               goto 40
            end if
         end if
      end do
   40 continue
      red = min(red,redmin)
      red = max(red,redmax)
      h = h * red
      reduct = .true.
      goto 20
   50 continue
      x = xnew
      hdid = h
      first = .false.
      wrkmin = 1.0d35
      do kk = 1, km
         fact = max(err(kk),scalmx)
         work = fact * a(kk+1)
         if (work .lt. wrkmin) then
            scale = fact
            wrkmin = work
            kopt = kk + 1
         end if
      end do
      hnext = h / scale
      if (kopt.ge.k .and. kopt.ne.kmax .and. .not.reduct) then
         fact = max(scale/alf(kopt-1,kopt),scalmx)
         if (a(kopt+1)*fact .le. wrkmin) then
            hnext = h / fact
            kopt = kopt + 1
         end if
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (yerr)
      deallocate (ysav)
      deallocate (yseq)
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine mmid  --  takes a modified midpoint step  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "mmid" implements a modified midpoint method to advance the
c     integration of a set of first order differential equations
c
c
      subroutine mmid (nstep,htot,nvar,xs,dydx,y,yout,gvalue)
      implicit none
      integer i,k
      integer nstep,nvar
      real*8 htot,h,h2
      real*8 xs,x,temp
      real*8 dydx(*)
      real*8 y(*)
      real*8 yout(*)
      real*8, allocatable :: ym(:)
      real*8, allocatable :: yn(:)
      external gvalue
c
c
c     set substep size based on number of steps to be taken
c
      h = htot / dble(nstep)
      h2 = 2.0d0 * h
c
c     perform dynamic allocation of some local arrays
c
      allocate (ym(nvar))
      allocate (yn(nvar))
c
c     take the first substep and get values at ends of step
c
      do i = 1, nvar
         ym(i) = y(i)
         yn(i) = y(i) + h*dydx(i)
      end do
      x = xs + h
      call gvalue (x,yn,yout)
c
c     take the second and subsequent substeps
c
      do k = 2, nstep
         do i = 1, nvar
            temp = ym(i) + h2*yout(i)
            ym(i) = yn(i)
            yn(i) = temp
         end do
         x = x + h
         call gvalue (x,yn,yout)
      end do
c
c     complete the update of values for the last substep
c
      do i = 1, nvar
         yout(i) = 0.5d0 * (ym(i)+yn(i)+h*yout(i))
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (ym)
      deallocate (yn)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine pzextr  --  polynomial extrapolation method  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "pzextr" is a polynomial extrapolation routine used during
c     Bulirsch-Stoer integration of ordinary differential equations
c
c
      subroutine pzextr (iest,nvar,xest,yest,yz,dy)
      implicit none
      integer imax
      parameter (imax=13)
      integer i,j,iest,nvar
      real*8 xest,delta
      real*8 f1,f2,q
      real*8 x(imax)
      real*8 yz(*)
      real*8 dy(*)
      real*8 yest(*)
      real*8, allocatable :: d(:)
      real*8, allocatable, save :: qcol(:,:)
      save x
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (d(nvar))
      if (.not. allocated(qcol))  allocate (qcol(nvar,imax))
c
c     polynomial extrapolation needed for Bulirsch-Stoer step
c
      x(iest) = xest
      do j = 1, nvar
         dy(j) = yest(j)
         yz(j) = yest(j)
      end do
      if (iest .eq. 1) then
         do j = 1, nvar
            qcol(j,1) = yest(j)
         end do
      else
         do j = 1, nvar
            d(j) = yest(j)
         end do
         do i = 1, iest-1
            delta = 1.0d0 / (x(iest-i)-xest)
            f1 = xest * delta
            f2 = x(iest-i) * delta
            do j = 1, nvar
               q = qcol(j,i)
               qcol(j,i) = dy(j)
               delta = d(j) - q
               dy(j) = f1 * delta
               d(j) = f2 * delta
               yz(j) = yz(j) + dy(j)
            end do
         end do
         do j = 1, nvar
            qcol(j,iest) = dy(j)
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (d)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine gdastat  --  results for GDA integration step  ##
c     ##                                                            ##
c     ################################################################
c
c     "gdastat" finds the energy, radius of gyration, and average M2
c     for a GDA integration step; also saves the coordinates
c
c
      subroutine gdastat (nstep,beta,xx,status)
      use atoms
      use iounit
      use math
      use warp
      implicit none
      integer i,nvar
      integer nstep
      real*8 beta
      real*8 e,energy
      real*8 rg,m2ave
      real*8 xx(*)
      character*7 status
c
c
c     convert optimization parameters to coordinates and M2's
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
      do i = 1, n
         nvar = nvar + 1
         m2(i) = abs(xx(nvar))
      end do
c
c     get some info about the current integration step
c
      e = energy ()
      call gyrate (rg)
      m2ave = 0.0d0
      do i = 1, n
         m2ave = m2ave + m2(i)
      end do
      m2ave = m2ave / dble(n)
      write (iout,10)  nstep,log(beta)/logten,e,rg,
     &                 log(m2ave)/logten,status
   10 format (i6,2x,4f13.4,6x,a7)
c
c     save the current coordinates to an external file
c
      call optsave (nstep,e,xx)
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 1995 by Yong Kong & Jay William Ponder  ##
c     ##                  All Rights Reserved                   ##
c     ############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program diffuse  --  find liquid self-diffusion constant  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "diffuse" finds the self-diffusion constant for a homogeneous
c     liquid via the Einstein relation from a set of stored molecular
c     dynamics frames; molecular centers of mass are unfolded and mean
c     squared displacements are computed versus time separation
c
c     the estimate for the self-diffusion constant in 10-5 cm**2/sec
c     is printed in the far right column of output and can be checked
c     by plotting mean squared displacements as a function of the time
c     separation; values for very large time separation are inaccurate
c     due to the small amount of data
c
c
      program diffuse
      use atomid
      use atoms
      use bound
      use inform
      use iounit
      use molcul
      use usage
      implicit none
      integer i,j,k,m
      integer nframe,iframe
      integer iarc,start,stop
      integer step,skip,size
      integer nave,nstart,nstop
      integer, allocatable :: list(:)
      integer, allocatable :: ntime(:)
      real*8 xmid,ymid,zmid
      real*8 xold,yold,zold
      real*8 xdiff,ydiff,zdiff
      real*8 xr,yr,zr,weigh
      real*8 tstep,dunits,delta
      real*8 xvalue,yvalue,zvalue
      real*8 rvalue,counts
      real*8 dvalue,dave
      real*8, allocatable :: xmsd(:)
      real*8, allocatable :: ymsd(:)
      real*8, allocatable :: zmsd(:)
      real*8, allocatable :: xcm(:,:)
      real*8, allocatable :: ycm(:,:)
      real*8, allocatable :: zcm(:,:)
      logical exist,query
      logical first
      character*240 record
      character*240 string
c
c
c     perform the standard initialization functions
c
      call initial
c
c     open the trajectory archive and read the initial frame
c
      call getarc (iarc)
c
c     get the atom parameters, lattice type and molecule count
c
      call field
      call unitcell
      call lattice
      call katom
      call molecule
c
c     get numbers of the coordinate frames to be processed
c
      start = 1
      stop = 100000
      step = 1
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  start
         query = .false.
      end if
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  stop
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  step
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' Numbers of First & Last Frame and Step',
     &              ' Increment :  ',$)
         read (input,30)  record
   30    format (a240)
         read (record,*,err=40,end=40)  start,stop,step
   40    continue
      end if
c
c     get the time increment between frames in picoseconds
c
      tstep = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=50,end=50)  tstep
   50 continue
      if (tstep .le. 0.0d0) then
         write (iout,60)
   60    format (/,' Enter the Time Increment in Picoseconds',
     &              ' [1.0] :  ',$)
         read (input,70)  tstep
   70    format (f20.0)
      end if
      if (tstep .le. 0.0d0)  tstep = 1.0d0
c
c     perform dynamic allocation of some local arrays
c
      size = 40
      allocate (list(size))
c
c     find atoms and molecules to be excluded from consideration
c
      call active
      if (nuse .eq. n) then
         do i = 1, size
            list(i) = 0
         end do
         i = 0
         do while (exist)
            call nextarg (string,exist)
            if (exist) then
               read (string,*,err=80,end=80)  list(i+1)
               i = i + 1
            end if
         end do
   80    continue
         if (i .eq. 0) then
            write (iout,90)
   90       format (/,' Numbers of any Atoms to be Excluded :  ',$)
            read (input,100)  record
  100       format (a240)
            read (record,*,err=110,end=110)  (list(i),i=1,size)
  110       continue
         end if
         i = 1
         do while (list(i) .ne. 0)
            list(i) = max(-n,min(n,list(i)))
            if (list(i) .gt. 0) then
               k = list(i)
               if (use(k)) then
                  use(k) = .false.
                  nuse = nuse - 1
               end if
               i = i + 1
            else
               list(i+1) = max(-n,min(n,list(i+1)))
               do k = abs(list(i)), abs(list(i+1))
                  if (use(k)) then
                     use(k) = .false.
                     nuse = nuse - 1
                  end if
               end do
               i = i + 2
            end if
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (list)
c
c     alter the molecule list to include only active molecules
c
      do i = 1, nmol
         do j = imol(1,i), imol(2,i)
            k = kmol(j)
            if (.not. use(k))  imol(1,i) = 0
         end do
      end do
      k = 0
      do i = 1, nmol
         if (imol(1,i) .ne. 0) then
            k = k + 1
            imol(1,k) = imol(1,i)
            imol(2,k) = imol(2,i)
            molmass(k) = molmass(i)
         end if
      end do
      nmol = k
      write (iout,120)  nmol
  120 format (/,' Total Number of Molecules :',i16)
c
c     count the number of coordinate frames in the archive file
c
      abort = .false.
      rewind (unit=iarc)
      first = .true.
      nframe = 0
      do while (.not. abort)
         call readcart (iarc,first)
         nframe = nframe + 1
      end do
      nframe = nframe - 1
      stop = min(nframe,stop)
      nframe = (stop-start)/step + 1
      write (iout,130)  nframe
  130 format (/,' Number of Coordinate Frames :',i14)
c
c     perform dynamic allocation of some local arrays
c
      allocate (ntime(nframe))
      allocate (xmsd(nframe))
      allocate (ymsd(nframe))
      allocate (zmsd(nframe))
      allocate (xcm(nmol,nframe))
      allocate (ycm(nmol,nframe))
      allocate (zcm(nmol,nframe))
c
c     get the archived coordinates for each frame in turn
c
      write (iout,140)
  140 format (/,' Reading the Coordinates Archive File :',/)
      rewind (unit=iarc)
      first = .true.
      nframe = 0
      iframe = start
      skip = start
      do while (iframe.ge.start .and. iframe.le.stop)
         do j = 1, skip-1
            call readcart (iarc,first)
         end do
         iframe = iframe + step
         skip = step
         call readcart (iarc,first)
         if (n .eq. 0)  goto 160
         nframe = nframe + 1
         if (mod(nframe,100) .eq. 0) then
            write (iout,150)  nframe
  150       format (4x,'Processing Coordinate Frame',i13)
         end if
c
c     unfold each molecule to get its corrected center of mass
c
         do i = 1, nmol
            xmid = 0.0d0
            ymid = 0.0d0
            zmid = 0.0d0
            do j = imol(1,i), imol(2,i)
               k = kmol(j)
               weigh = mass(k)
               xmid = xmid + x(k)*weigh
               ymid = ymid + y(k)*weigh
               zmid = zmid + z(k)*weigh
            end do
            weigh = molmass(i)
            xmid = xmid / weigh
            ymid = ymid / weigh
            zmid = zmid / weigh
            if (nframe .eq. 1) then
               xold = xmid
               yold = ymid
               zold = zmid
            else
               xold = xcm(i,nframe-1)
               yold = ycm(i,nframe-1)
               zold = zcm(i,nframe-1)
            end if
            xr = xmid - xold
            yr = ymid - yold
            zr = zmid - zold
            if (use_bounds)  call image (xr,yr,zr)
            xcm(i,nframe) = xold + xr
            ycm(i,nframe) = yold + yr
            zcm(i,nframe) = zold + zr
         end do
      end do
  160 continue
      close (unit=iarc)
      if (mod(nframe,100) .ne. 0) then
         write (iout,170)  nframe
  170    format (4x,'Processing Coordinate Frame',i13)
      end if
c
c     increment the squared displacements for each frame pair
c
      do i = 1, nframe
         ntime(i) = 0
         xmsd(i) = 0.0d0
         ymsd(i) = 0.0d0
         zmsd(i) = 0.0d0
      end do
      do i = 1, nframe-1
         do j = i+1, nframe
            m = j - i
            ntime(m) = ntime(m) + 1
            do k = 1, nmol
               xdiff = xcm(k,j) - xcm(k,i)
               ydiff = ycm(k,j) - ycm(k,i)
               zdiff = zcm(k,j) - zcm(k,i)
               xmsd(m) = xmsd(m) + xdiff*xdiff
               ymsd(m) = ymsd(m) + ydiff*ydiff
               zmsd(m) = zmsd(m) + zdiff*zdiff
            end do
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xcm)
      deallocate (ycm)
      deallocate (zcm)
c
c     get mean squared displacements and convert units;
c     conversion is from sq. Ang/ps to 10-5 sq. cm/sec
c
      dunits = 10.0d0
      do i = 1, nframe-1
         counts = dble(nmol) * dble(ntime(i))
         xmsd(i) = xmsd(i) * (dunits/counts)
         ymsd(i) = ymsd(i) * (dunits/counts)
         zmsd(i) = zmsd(i) * (dunits/counts)
      end do
c
c     estimate the diffusion constant via the Einstein relation
c
      write (iout,180)
  180 format (/,' Mean Squared Displacements and Self-Diffusion',
     &           ' Constant :',
     &        //,5x,'Time Gap',6x,'X MSD',7x,'Y MSD',7x,'Z MSD',
     &           7x,'R MSD',4x,'Diff Const',
     &        /,7x,'(ps)',9x,'(/2)',8x,'(/2)',8x,'(/2)',8x,'(/6)',
     &           5x,'(x 10^5)',/)
      nstart = nint(dble(nframe-1)/3.0d0)
      nstop = 2 * nstart
      nave = nstop - nstart + 1
      dave = 0.0d0
      do i = 1, nframe-1
         delta = tstep * dble(i)
         xvalue = xmsd(i) / 2.0d0
         yvalue = ymsd(i) / 2.0d0
         zvalue = zmsd(i) / 2.0d0
         rvalue = (xmsd(i) + ymsd(i) + zmsd(i)) / 6.0d0
         dvalue = rvalue / delta
         if (i.ge.nstart .and. i.le.nstop)  dave = dave + dvalue/nave
         write (iout,190)  delta,xvalue,yvalue,zvalue,rvalue,dvalue
  190    format (f12.2,4f12.2,f12.4)
      end do
      if (nave .ge. 8) then
         write (iout,200)  dave
  200    format (/,' Self-Diffusion Constant :',f12.4,' x 10^-5 cm^2/s')     
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (ntime)
      deallocate (xmsd)
      deallocate (ymsd)
      deallocate (zmsd)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module dipole  --  bond dipoles in current structure  ##
c     ##                                                        ##
c     ############################################################
c
c
c     ndipole   total number of dipoles in the system
c     idpl      numbers of atoms that define each dipole
c     bdpl      magnitude of each of the dipoles (Debye)
c     sdpl      position of each dipole between defining atoms
c
c
      module dipole
      implicit none
      integer ndipole
      integer, allocatable :: idpl(:,:)
      real*8, allocatable :: bdpl(:)
      real*8, allocatable :: sdpl(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module disgeo  --  distance geometry bounds & parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     vdwmax      maximum value of hard sphere sum for an atom pair
c     compact     index of local distance compaction on embedding
c     pathmax     maximum value of upper bound after smoothing
c     dbnd        distance geometry upper and lower bounds matrix
c     georad      hard sphere radii for distance geometry atoms
c     use_invert  flag to use enantiomer closest to input structure
c     use_anneal  flag to use simulated annealing refinement
c
c
      module disgeo
      implicit none
      real*8 vdwmax
      real*8 compact
      real*8 pathmax
      real*8, allocatable :: dbnd(:,:)
      real*8, allocatable :: georad(:)
      logical use_invert
      logical use_anneal
      save
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module disp  --  damped dispersion in current structure  ##        
c     ##                                                           ##
c     ###############################################################
c
c
c     ndisp     total number of dispersion sites in the system
c     idisp     number of the atom for each dispersion site
c     csixpr    pairwise sum of C6 dispersion coefficients
c     csix      C6 dispersion coefficient value for each atom
c     adisp     alpha dispersion damping value for each atom
c
c
      module disp
      implicit none
      integer ndisp
      integer, allocatable :: idisp(:)
      real*8 csixpr
      real*8, allocatable :: csix(:)
      real*8, allocatable :: adisp(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  program distgeom  --  produce distance geometry structures  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "distgeom" uses a metric matrix distance geometry procedure to
c     generate structures with interpoint distances that lie within
c     specified bounds, with chiral centers that maintain chirality,
c     and with torsional angles restrained to desired values; the
c     user also has the ability to interactively inspect and alter
c     the triangle smoothed bounds matrix prior to embedding
c
c
      program distgeom
      use angbnd
      use atomid
      use atoms
      use bndstr
      use couple
      use disgeo
      use files
      use inform
      use iounit
      use kvdws
      use math
      use refer
      use restrn
      use tors
      implicit none
      integer i,j,k,ja,kb
      integer ia,ib,ic,id
      integer swap,lext
      integer next,freeunit
      integer igeo,ngeo,nhyd
      integer r1,r2,r3,r4,b1,b2
      real*8 cosine,weigh
      real*8 hbond1,hbond2
      real*8 bndfac,angfac
      real*8 radi,rmsvalue
      real*8 wall,cpu
      real*8 rab,rbc,rac,t1,t2
      real*8 qab,qbc,qcd,qac,qbd
      real*8 bndmin,bndmax
      real*8 tormin,tormax
      real*8 uppermax,big1,big2
      real*8 cosmin,cosmax
      real*8 cosabc,sinabc
      real*8 cosbcd,sinbcd
      logical exist,header,done
      logical query,info,quit
      character*1 answer
      character*1 letter
      character*7 ext
      character*240 geofile
      character*240 title
      character*240 record
      character*240 string
c
c
c     get the input structure file for the embedding
c
      call initial
      call getxyz
c
c     set the lists of attached atoms and local interactions
c
      call attach
      call active
      call bonds
      call angles
      call torsions
c
c     get force field vdw radii and any modifications
c
      call field
      call kvdw
c
c     get distance bound and torsional angle restraints
c
      call kgeom
c
c     store the input structure for later comparison
c
      call makeref (1)
c
c     perform dynamic allocation of some global arrays
c
      allocate (dbnd(n,n))
      allocate (georad(n))
c
c     assign approximate radii based on the atom names
c
      do i = 1, n
         letter = name(i)(1:1)
         if (name(i) .eq. 'CH ') then
            georad(i) = 1.5d0
         else if (name(i) .eq. 'CH2') then
            georad(i) = 1.6d0
         else if (name(i) .eq. 'CH3') then
            georad(i) = 1.7d0
         else if (letter .eq. 'H') then
            georad(i) = 0.95d0
         else if (letter .eq. 'C') then
            georad(i) = 1.45d0
         else if (letter .eq. 'N') then
            georad(i) = 1.35d0
         else if (letter .eq. 'O') then
            georad(i) = 1.35d0
         else if (letter .eq. 'P') then
            georad(i) = 1.8d0
         else if (letter .eq. 'S') then
            georad(i) = 1.8d0
         else
            georad(i) = 0.5d0
         end if
      end do
c
c     optionally, assign atomic radii from force field vdw radii
c
c     do i = 1, n
c        if (type(i) .ne. 0) then
c           if (vdwindex .eq. 'CLASS') then
c              georad(i) = rad(class(i))
c           else
c              georad(i) = rad(type(i))
c           end if
c        end if
c     end do
c
c     find maximum value of vdw radii sum for an atom pair
c
      big1 = 0.0d0
      big2 = 0.0d0
      do i = 1, n
         radi = georad(i)
         if (radi .gt. big1) then
            big2 = big1
            big1 = radi
         else if (radi .gt. big2) then
            big2 = radi
         end if
      end do
      vdwmax = big1 + big2
c
c     set number of distance geometry structures to generate
c
      ngeo = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  ngeo
   10 continue
      if (ngeo .le. 0) then
         write (iout,20)
   20    format (/,' Number of Distance Geometry Structures',
     &              ' Desired [1] :  ',$)
         read (input,30)  ngeo
   30    format (i10)
         if (ngeo .le. 0)  ngeo = 1
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(ichir))  deallocate(ichir)
      if (allocated(chir))  deallocate(chir)
      allocate (ichir(4,n))
      allocate (chir(3,n))
c
c     enforce the original chirality of tetravalent atoms
c
      nchir = 0
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,40)
   40    format (/,' Impose Chirality Constraints on Tetrahedral',
     &              ' Atoms [Y] :  ',$)
         read (input,50)  record
   50    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .ne. 'N') then
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,60)
   60       format (/,' Use "Floating" Chirality for -XH2- and -XH3',
     &                 ' Groups [N] :  ',$)
            read (input,70)  record
   70       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         do i = 1, n
            if (n12(i) .eq. 4) then
               nhyd = 0
               if (answer .eq. 'Y') then
                  do j = 1, 4
                     letter = name(i12(j,i))(1:1)
                     if (letter .eq. 'H')  nhyd = nhyd + 1
                  end do
               end if
               if (nhyd .lt. 2) then
                  nchir = nchir + 1
                  do j = 1, 4
                     ichir(j,nchir) = i12(j,i)
                  end do
               end if
            end if
         end do
      end if
c
c     enforce the planarity or chirality of trigonal centers
c
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,80)
   80    format (/,' Impose Planarity and/or Chirality of Trigonal',
     &              ' Atoms [Y] :  ',$)
         read (input,90)  record
   90    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .ne. 'N') then
         do i = 1, n
            if (n12(i) .eq. 3) then
               nchir = nchir + 1
               do j = 1, 3
                  ichir(j,nchir) = i12(j,i)
               end do
               ichir(4,nchir) = i
            end if
         end do
      end if
c
c     enforce torsional planarity on adjacent trigonal sites
c
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,100)
  100    format (/,' Impose Torsional Planarity on Adjacent Trigonal',
     &              ' Atoms [Y] :  ',$)
         read (input,110)  record
  110    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .ne. 'N') then
         do i = 1, nbond
            ia = ibnd(1,i)
            ib = ibnd(2,i)
            if (n12(ia).eq.3 .and. n12(ib).eq.3) then
               do j = 1, n12(ia)
                  ja = i12(j,ia)
                  do k = 1, n12(ib)
                     kb = i12(k,ib)
                     if (ja.ne.ib .and. kb.ne.ia) then
                        nchir = nchir + 1
                        ichir(1,nchir) = ja
                        ichir(2,nchir) = kb
                        ichir(3,nchir) = ia
                        ichir(4,nchir) = ib
                     end if
                  end do
               end do
            end if
         end do
      end if
c
c     optionally inspect and alter the smoothed bounds matrix
c
      query = .false.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,120)
  120    format (/,' Do You Wish to Examine or Alter the Bounds',
     &              ' Matrix [N] :  ',$)
         read (input,130)  record
  130    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'Y')  query = .true.
c
c     choose the global enantiomer nearest to the original
c
      use_invert = .false.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,140)
  140    format (/,' Select the Enantiomer Closest to the Input',
     &              ' Structure [N] :  ',$)
         read (input,150)  record
  150    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'Y')  use_invert = .true.
c
c     set the type of refinement to be used after embedding
c
      use_anneal = .true.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,160)
  160    format (/,' Refinement via Minimization or Annealing',
     &              ' [M or A, <Enter>=A] :  ',$)
         read (input,170)  record
  170    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'M')  use_anneal = .false.
c
c     initialize chirality and planarity restraint values
c
      call kchiral
c
c     change the default distance restraint force constant
c
      do i = 1, ndfix
         if (dfix(1,i) .eq. 100.0d0)  dfix(1,i) = 1.0d0
      end do
c
c     print lists of the interatomic distance restraints
c
      if (verbose) then
         header = .true.
         do i = 1, ndfix
            ia = idfix(1,i)
            ib = idfix(2,i)
            weigh = dfix(1,i)
            bndmin = dfix(2,i)
            bndmax = dfix(3,i)
            if (header) then
               header = .false.
               write (iout,180)
  180          format (/,' Interatomic Distance Bound Restraints :',
     &                 //,12x,'Atom Numbers',7x,'LowerBound',
     &                    4x,'UpperBound',7x,'Weight',/)
            end if
            if (weigh .eq. 1.0d0) then
               write (iout,190)  i,ia,ib,bndmin,bndmax
  190          format (i6,5x,2i6,3x,2f14.4)
            else
               write (iout,200)  i,ia,ib,bndmin,bndmax,weigh
  200          format (i6,5x,2i6,3x,3f14.4)
            end if
         end do
c
c     print lists of the torsional angle restraints
c
         header = .true.
         do i = 1, ntfix
            ia = itfix(1,i)
            ib = itfix(2,i)
            ic = itfix(3,i)
            id = itfix(4,i)
            weigh = tfix(1,i)
            tormin = tfix(2,i)
            tormax = tfix(3,i)
            if (header) then
               header = .false.
               write (iout,210)
  210          format (/,' Intramolecular Torsional Angle Restraints :',
     &                 //,18x,'Atom Numbers',16x,'Torsion Range',
     &                    9x,'Weight',/)
            end if
            write (iout,220)  i,ia,ib,ic,id,tormin,tormax,weigh
  220       format (i6,5x,4i6,3x,3f12.4)
         end do
      end if
c
c     initialize the upper and lower bounds matrix
c
      do i = 1, n
         dbnd(i,i) = 0.0d0
      end do
      uppermax = 1000000.0d0
      do i = 1, n
         do j = 1, i-1
            dbnd(j,i) = uppermax
         end do
      end do
      do i = 1, n-1
         radi = georad(i)
         do j = i+1, n
            dbnd(j,i) = radi + georad(j)
         end do
      end do
c
c     set the upper and lower bounds for 1-2 distances
c
      bndfac = 0.0d0
c     bndfac = 0.01d0
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         rab = sqrt((x(ia)-x(ib))**2 + (y(ia)-y(ib))**2
     &                     + (z(ia)-z(ib))**2)
         bndmin = (1.0d0 - bndfac) * rab
         bndmax = (1.0d0 + bndfac) * rab
         if (ia .gt. ib) then
            dbnd(ia,ib) = bndmin
            dbnd(ib,ia) = bndmax
         else
            dbnd(ia,ib) = bndmax
            dbnd(ib,ia) = bndmin
         end if
      end do
c
c     set the upper and lower bounds for 1-3 distances
c
      angfac = 0.0d0
c     angfac = 0.01d0
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         rab = sqrt((x(ia)-x(ib))**2 + (y(ia)-y(ib))**2
     &                    + (z(ia)-z(ib))**2)
         rbc = sqrt((x(ib)-x(ic))**2 + (y(ib)-y(ic))**2
     &                    + (z(ib)-z(ic))**2)
         rac = sqrt((x(ia)-x(ic))**2 + (y(ia)-y(ic))**2
     &                    + (z(ia)-z(ic))**2)
         cosine = (rab**2+rbc**2-rac**2) / (2.0d0*rab*rbc)
         cosmin = min(1.0d0,cosine+angfac)
         cosmax = max(-1.0d0,cosine-angfac)
         qab = min(dbnd(ia,ib),dbnd(ib,ia))
         qbc = min(dbnd(ic,ib),dbnd(ib,ic))
         bndmin = qab**2 + qbc**2 - 2.0d0*qab*qbc*cosmin
         bndmin = sqrt(max(0.0d0,bndmin))
         qab = max(dbnd(ia,ib),dbnd(ib,ia))
         qbc = max(dbnd(ic,ib),dbnd(ib,ic))
         bndmax = qab**2 + qbc**2 - 2.0d0*qab*qbc*cosmax
         bndmax = sqrt(max(0.0d0,bndmax))
         if (ia .gt. ic) then
            dbnd(ia,ic) = bndmin
            dbnd(ic,ia) = bndmax
         else
            dbnd(ia,ic) = bndmax
            dbnd(ic,ia) = bndmin
         end if
      end do
c
c     set the upper and lower bounds for 1-4 distances
c
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         cosmin = 1.0d0
         cosmax = -1.0d0
         do j = 1, ntfix
            r1 = itfix(1,j)
            r2 = itfix(2,j)
            r3 = itfix(3,j)
            r4 = itfix(4,j)
            if ((ia.eq.r1 .and. ib.eq.r2 .and.
     &           ic.eq.r3 .and. id.eq.r4) .or.
     &          (ia.eq.r4 .and. ib.eq.r3 .and.
     &           ic.eq.r2 .and. id.eq.r1)) then
               t1 = tfix(2,j) / radian
               t2 = tfix(3,j) / radian
               if (t2.ge.0.0d0 .and. t1.le.0.0d0) then
                  cosmin = 1.0d0
                  cosmax = min(cos(t1),cos(t2))
               else if (t1.ge.0.0d0 .and. t2.le.0.0d0) then
                  cosmin = max(cos(t1),cos(t2))
                  cosmax = -1.0d0
               else if (t1.ge.0.0d0 .and. t2.ge.t1) then
                  cosmin = cos(t1)
                  cosmax = cos(t2)
               else if (t2.le.0.0d0 .and. t1.le.t2) then
                  cosmin = cos(t2)
                  cosmax = cos(t1)
               end if
               goto 230
            end if
         end do
  230    continue
         qab = min(dbnd(ia,ib),dbnd(ib,ia))
         qbc = min(dbnd(ib,ic),dbnd(ic,ib))
         qcd = min(dbnd(ic,id),dbnd(id,ic))
         qac = min(dbnd(ia,ic),dbnd(ic,ia))
         qbd = min(dbnd(ib,id),dbnd(id,ib))
         cosabc = (qab**2+qbc**2-qac**2)/(2.0d0*qab*qbc)
         sinabc = sqrt(max(0.0d0,1.0d0-cosabc**2))
         cosbcd = (qbc**2+qcd**2-qbd**2)/(2.0d0*qbc*qcd)
         sinbcd = sqrt(max(0.0d0,1.0d0-cosbcd**2))
         bndmin = qab**2 + qbc**2 + qcd**2
     &               + 2.0d0*qab*qcd*cosabc*cosbcd
     &               - 2.0d0*qab*qcd*sinabc*sinbcd*cosmin
     &               - 2.0d0*qbc*(qab*cosabc+qcd*cosbcd)
         bndmin = sqrt(max(0.0d0,bndmin))
         qab = max(dbnd(ia,ib),dbnd(ib,ia))
         qbc = max(dbnd(ib,ic),dbnd(ic,ib))
         qcd = max(dbnd(ic,id),dbnd(id,ic))
         qac = max(dbnd(ia,ic),dbnd(ic,ia))
         qbd = max(dbnd(ib,id),dbnd(id,ib))
         cosabc = (qab**2+qbc**2-qac**2)/(2.0d0*qab*qbc)
         sinabc = sqrt(max(0.0d0,1.0d0-cosabc**2))
         cosbcd = (qbc**2+qcd**2-qbd**2)/(2.0d0*qbc*qcd)
         sinbcd = sqrt(max(0.0d0,1.0d0-cosbcd**2))
         bndmax = qab**2 + qbc**2 + qcd**2
     &               + 2.0d0*qab*qcd*cosabc*cosbcd
     &               - 2.0d0*qab*qcd*sinabc*sinbcd*cosmax
     &               - 2.0d0*qbc*(qab*cosabc+qcd*cosbcd)
         bndmax = sqrt(max(0.0d0,bndmax))
         if (ia .gt. id) then
            dbnd(ia,id) = bndmin
            dbnd(id,ia) = bndmax
         else
            dbnd(ia,id) = bndmax
            dbnd(id,ia) = bndmin
         end if
      end do
c
c     convert distance restraints into bounds matrix elements
c
      do i = 1, ndfix
         ia = idfix(1,i)
         ib = idfix(2,i)
         bndmin = dfix(2,i)
         bndmax = dfix(3,i)
         if (ia .gt. ib) then
            dbnd(ia,ib) = bndmin
            dbnd(ib,ia) = bndmax
         else
            dbnd(ia,ib) = bndmax
            dbnd(ib,ia) = bndmin
         end if
      end do
c
c     modify lower bounds to allow hydrogen bond formation
c
      hbond1 = 1.7d0
      hbond2 = 2.55d0
      do i = 1, n
         letter = name(i)(1:1)
         if (letter.eq.'N' .or. letter.eq.'O') then
            do j = 1, n
               letter = name(j)(1:1)
               if (letter .eq. 'H') then
                  k = i12(1,j)
                  letter = name(k)(1:1)
                  if (letter.eq.'N' .or. letter.eq.'O') then
                     if (j .gt. i) then
                        dbnd(j,i) = min(hbond1,dbnd(j,i))
                     else
                        dbnd(i,j) = min(hbond1,dbnd(i,j))
                     end if
                     if (k .gt. i) then
                        dbnd(k,i) = min(hbond2,dbnd(k,i))
                     else
                        dbnd(i,k) = min(hbond2,dbnd(i,k))
                     end if
                  end if
               end if
            end do
         end if
      end do
c
c     use the triangle inequalities to smooth the bounds
c
      if (verbose .and. n.le.130) then
         title = 'Input Distance Bounds :'
         call grafic (n,dbnd,title)
      end if
      write (iout,240)
  240 format (/,' Bounds Smoothing via Triangle and Inverse',
     &           ' Triangle Inequality :')
      if (verbose)  call settime
      call geodesic
c     call triangle
      if (verbose) then
         call gettime (wall,cpu)
         write (iout,250)  wall
  250    format (/,' Time Required for Bounds Smoothing :',4x,
     &              f12.2,' seconds')
      end if
c
c     allow interactive alteration of the bounds matrix
c
      done = .false.
      do while (query .and. .not.done)
         done = .true.
         write (iout,260)
  260    format (/,' Enter an Atom Pair to Display Bounds',
     &              ' [<Enter>=Done] :  ',$)
         read (input,270)  record
  270    format (a240)
         read (record,*,err=320,end=320)  b1,b2
         done = .false.
         if (b1.lt.1 .or. b2.gt.n .or. b1.eq.b2)  goto 320
         if (b1 .gt. b2) then
            swap = b1
            b1 = b2
            b2 = swap
         end if
         write (iout,280)  dbnd(b2,b1),dbnd(b1,b2)
  280    format (/,' Lower Bound :',f8.3,8x,'Upper Bound :',f8.3)
  290    continue
         write (iout,300)
  300    format (/,' Enter New Bound Values [<Enter>=Unchanged] :  ',$)
         read (input,310)  record
  310    format (a240)
         read (record,*,err=320,end=320)  bndmin,bndmax
         if (bndmin .gt. bndmax)  goto 290
         dbnd(b2,b1) = bndmin
         dbnd(b1,b2) = bndmax
         call trifix (b1,b2)
  320    continue
      end do
c
c     display the smoothed upper and lower bounds matrix
c
      if (verbose .and. n.le.130) then
         title = 'Triangle Smoothed Bounds :'
         call grafic (n,dbnd,title)
      end if
c
c     find the largest value of an upper bound between atoms
c
      pathmax = 0.0d0
      do i = 1, n
         do j = 1, i-1
            if (pathmax .lt. dbnd(j,i))  pathmax = dbnd(j,i)
         end do
      end do
      write (iout,330)  pathmax
  330 format (/,' Largest Upper Bound Distance :',15x,f15.4)
c
c     check for any atoms that have no distance restraints
c
      quit = .false.
      do i = 1, n
         do j = 1, i-1
            if (dbnd(j,i) .ne. uppermax)  goto 350
         end do
         do j = i+1, n
            if (dbnd(i,j) .ne. uppermax)  goto 350
         end do
         quit = .true.
         write (iout,340)  i
  340    format (/,' DISTGEOM  --  Atom',i6,' has no Distance',
     &              ' Constraints')
  350    continue
      end do
      if (quit)  call fatal
c
c     generate the desired number of distance geometry structures
c
      do j = 1, ngeo
         write (iout,360)  j
  360    format (/,' Generation via Distance Geometry of Structure',i5)
         call embed
c
c     superpose the distance geometry structure on input structure
c
         info = verbose
         verbose = .false.
         call impose (n,xref,yref,zref,n,x,y,z,rmsvalue)
         verbose = info
c
c     write out the final optimized distance geometry structure
c
         lext = 3
         call numeral (j,ext,lext)
         geofile = filename(1:leng)//'.'//ext(1:lext)
         call version (geofile,'new')
         igeo = freeunit ()
         open (unit=igeo,file=geofile,status='new')
         call prtxyz (igeo)
         close (unit=igeo)
      end do
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2005  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module dma  --  QM spherical harmonic multipole moments  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     mp        atomic monopole charge values from DMA
c     dpx       atomic dipole moment x-component from DMA
c     dpy       atomic dipole moment y-component from DMA
c     dpz       atomic dipole moment z-component from DMA
c     q20       atomic Q20 quadrupole component from DMA (zz)
c     q21c      atomic Q21c quadrupole component from DMA (xz)
c     q21s      atomic Q21s quadrupole component from DMA (yz)
c     q22c      atomic Q22c quadrupole component from DMA (xx-yy)
c     q22s      atomic Q22s quadrupole component from DMA (xy)
c
c
      module dma
      implicit none
      real*8, allocatable :: mp(:)
      real*8, allocatable :: dpx(:)
      real*8, allocatable :: dpy(:)
      real*8, allocatable :: dpz(:)
      real*8, allocatable :: q20(:)
      real*8, allocatable :: q21c(:)
      real*8, allocatable :: q21s(:)
      real*8, allocatable :: q22c(:)
      real*8, allocatable :: q22s(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  program document  --  make documentation lists from source  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "document" generates a formatted description of all the routines
c     and modules, an index of routines called by each source file, a
c     list of all valid keywords, a list of include file dependencies
c     as needed by a Unix-style Makefile, or a formatted force field
c     parameter summary
c
c     note the logical variable "sphinx" should be set true to make
c     output suitable for inclusion in the Tinker User's Guide built
c     via the Sphinx documentation generator
c
c
      program document
      use iounit
      implicit none
      integer maxline
      integer maxunit
      integer maxword
      integer maxfunc
      parameter (maxline=1000)
      parameter (maxunit=10000)
      parameter (maxword=10000)
      parameter (maxfunc=75)
      integer i,j,k,mode
      integer isrc,itxt,next
      integer nkey,nunit
      integer leng,size
      integer start,last
      integer freeunit
      integer trimtext
      integer nexttext
      integer, allocatable :: nline(:)
      integer, allocatable :: link(:)
      logical exist,done,sphinx
      character*20 module
      character*20 keyword
      character*20 keylast
      character*20 fname1,fname2
      character*20 fname(maxfunc)
      character*20, allocatable :: key(:)
      character*240 srcfile
      character*240 txtfile
      character*240 record
      character*240 string
      character*230, allocatable :: routine(:)
      character*240, allocatable :: info(:,:)
      character*2048 field
c
c     list of the Fortran functions in the Tinker package
c
      data fname / 'ADJACENT',  'ANGGUESS',  'ANORM',     'BETACF',
     &             'BETAI',     'BMAX',      'BNDERR',    'BNDGUESS',
     &             'BOXMIN1',   'CHIRER',    'CHKAROM',   'CJKM',
     &             'D1D2',      'DEPTH',     'DIST2',     'DOT',
     &             'ENERGY',    'ERF',       'ERFC',      'ERFINV',
     &             'FREEUNIT',  'GAMMLN',    'GDA2',      'GEOMETRY',
     &             'INITERR',   'INVBETA',   'LOCERR',    'MAXWELL',
     &             'MCM1',      'MCMSTEP',   'MIDERR',    'MINIMIZ1',
     &             'MINIROT1',  'MINRIGID1', 'NEWTON1',   'NEWTROT1',
     &             'NEXTTEXT',  'NORMAL',    'NUMBER',    'OPBGUESS',
     &             'OPTFIT',    'OPTIMIZ1',  'OPTIROT1',  'OPTRIGID1',
     &             'PATH1',     'PAULING1',  'POTNRG',    'PRIORITY',
     &             'PROPERTY',  'PSS1',      'PSSRGD1',   'PSSROT1',
     &             'PTINCY',    'RANDOM',    'RMSFIT',    'ROTANG',
     &             'ROTCHECK',  'SADDLE1',   'SCAN1',     'SIGMOID',
     &             'SNIFFER1',  'TORFIT1',   'TORSER',    'TOTERR',
     &             'TRANSIT',   'TRIMTEXT',  'TRIPLE',    'URYGUESS',
     &             'VALFIT1',   'VALMIN1',   'VALRMS',    'VDWERR',
     &             'VECANG',    'WATSON1',   'XTALMIN1' /
c
c
c     select the type of documentation that is to be generated
c
      call initial
      write (iout,10)
   10 format (/,' The Tinker Documentation Utility Can :',
     &        //,4x,'(1) List Routines Contained in a Source File',
     &        /,4x,'(2) Generate List of Calls made by Routines',
     &        /,4x,'(3) List Global Variables from a Module',
     &        /,4x,'(4) Generate List of Tinker Keyword Options',
     &        /,4x,'(5) Construct a Module Dependency List',
     &        /,4x,'(6) Produce a Summary from a Parameter File')
      mode = 0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=20,end=20)  mode
   20 continue
      do while (mode.lt.1 .or. mode.gt.6)
         write (iout,30)
   30    format (/,' Enter the Number of the Desired Choice :  ',$)
         read (input,40,err=20)  mode
   40    format (i10)
      end do
c
c     get the filename and open the input source code file
c
      if (mode .ne. 6) then
         isrc = freeunit ()
         call nextarg (srcfile,exist)
         if (exist) then
            call suffix (srcfile,'txt','old')
            inquire (file=srcfile,exist=exist)
         end if
         do while (.not. exist)
            write (iout,50)
   50       format (/,' Enter Name of Source Code Listing File :  ',$)
            read (input,60)  srcfile
   60       format (a240)
            call suffix (srcfile,'txt','old')
            inquire (file=srcfile,exist=exist)
         end do
         open (unit=isrc,file=srcfile,status='old')
      end if
c
c     choose to make output for Sphinx documentation generator
c
      sphinx = .true.
c
c     perform dynamic allocation of some local arrays
c
      allocate (nline(maxunit))
      allocate (link(maxunit))
      allocate (routine(maxunit))
      allocate (info(maxline,maxunit))
c
c     get a list of routines and descriptions from source code
c
      if (mode .eq. 1) then
         nunit = 0
         do while (.true.)
            read (isrc,70,err=100,end=100)  record
   70       format (a240)
            if (record(1:9) .eq. 'c     ## ') then
               next = 10
               call getword (record,module,next)
               call lowcase (module)
               call upcase (module(1:1))
               if (module.eq.'Subroutine' .or. module.eq.'Function'
     &                      .or. module.eq.'Program') then
                  nunit = nunit + 1
                  call getword (record,routine(nunit),next)
                  call upcase (routine(nunit))
                  leng = trimtext (routine(nunit))
                  routine(nunit) = routine(nunit)(1:leng)//' '//module
                  read (isrc,80,err=100,end=100)
   80             format (///)
                  k = 0
                  done = .false.
                  do while (.not. done)
                     read (isrc,90,err=100,end=100)  record
   90                format (a240)
                     leng = trimtext (record)
                     if (leng .lt. 7) then
                        done = .true.
                     else if (record(1:1) .eq. ' ') then
                        done = .true.
                     else
                        k = k + 1
                        info(k,nunit) = record(7:leng)//'      '
                     end if
                  end do
                  nline(nunit) = k
               end if
            end if
         end do
  100    continue
         close (unit=isrc)
         call sort7 (nunit,routine,link)
         itxt = freeunit ()
         txtfile = 'routines.doc'
         call version (txtfile,'new')
         open (unit=itxt,file=txtfile,status='new')
         do i = 1, nunit
            string = routine(i)
            leng = trimtext (string)
            if (sphinx) then
               write (itxt,110)  string(1:leng)
  110          format ('**',a,'**',/)
            else
               write (itxt,120)  string(1:leng)
  120          format (a,/)
            end if
            last = 0
            j = link(i)
            do k = 1, nline(j)
               string = info(k,j)
               leng = trimtext (string)
               write (itxt,130)  string(1:leng)
  130          format (a)
            end do
            if (nline(j) .ne. 0) then
               write (itxt,140)
  140          format ()
            end if
         end do
         close (unit=itxt)
         write (iout,150)  txtfile(1:trimtext(txtfile))
  150    format (/,' Source Documentation Written To :  ',a)
      end if
c
c     get a list of the calls made by each source code routine
c
      if (mode .eq. 2) then
         nunit = 0
         do while (.true.)
            read (isrc,160,err=170,end=170)  record
  160       format (a240)
            call upcase (record)
            if (record(1:1) .ne. 'C') then
               next = 1
               call getword (record,module,next)
               if (module.eq.'SUBROUTINE' .or. module.eq.'FUNCTION'
     &                      .or. module.eq.'PROGRAM') then
                  nunit = nunit + 1
                  call getword (record,routine(nunit),next)
                  nline(nunit) = 0
               else
                  next = index (record,' CALL ')
                  if (next .ne. 0) then
                     next = next + 6
                     call getword (record,keyword,next)
                     nline(nunit) = nline(nunit) + 1
                     info(nline(nunit),nunit) = keyword
                  else
                     do i = 1, maxfunc
                        leng = trimtext (fname(i))
                        fname1 = fname(i)(1:leng)//'('
                        fname2 = fname(i)(1:leng)//' ('
                        if (index(record,fname1(1:leng+1)).ne.0 .or.
     &                      index(record,fname2(1:leng+2)).ne.0) then
                           nline(nunit) = nline(nunit) + 1
                           info(nline(nunit),nunit) = fname(i)
                        end if
                     end do
                  end if
               end if
            end if
         end do
  170    continue
         close (unit=isrc)
         call sort7 (nunit,routine,link)
         itxt = freeunit ()
         txtfile = 'calls.doc'
         call version (txtfile,'new')
         open (unit=itxt,file=txtfile,status='new')
         do i = 1, nunit
            string = routine(i)
            leng = trimtext (string)
            j = link(i)
            call sort10 (nline(j),info(1,j))
            write (itxt,180)  string(1:leng)
  180       format (a)
            do k = 1, nline(j)
               string = info(k,j)
               leng = trimtext (string)
               write (itxt,190)  string(1:leng)
  190          format (5x,a)
            end do
         end do
         close (unit=itxt)
         write (iout,200)  txtfile(1:trimtext(txtfile))
  200    format (/,' Source Documentation Written To :  ',a)
      end if
c
c     get a list of global variables from contents of modules
c
      if (mode .eq. 3) then
         nunit = 0
         do while (.true.)
            read (isrc,210,err=240,end=240)  record
  210       format (a240)
            call upcase (record(1:17))
            if (record(1:17) .eq. 'C     ##  MODULE ') then
               next = index (record,'  --')
               if (next .ne. 0) then
                  nunit = nunit + 1
                  leng = trimtext (record)
                  call upcase (record(18:next-1))
                  string(1:next-11) = record(11:next-1)
                  start = 17
                  string(start:240) = record(next+6:leng-4)
                  routine(nunit) = string
                  read (isrc,220,err=240,end=240)
  220             format (///)
                  k = 0
                  done = .false.
                  do while (.not. done)
                     read (isrc,230,err=240,end=240)  record
  230                format (a240)
                     leng = trimtext (record)
                     if (record(1:1) .eq. ' ') then
                        done = .true.
                     else if (leng .ge. 7) then
                        k = k + 1
                        next = 7
                        call getword (record,string,next)
                        record = record(next:leng)
                        next = nexttext (record)
                        leng = trimtext (record)
                        start = 17
                        string(start:240) = record(next:leng)
                        info(k,nunit) = string
                     end if
                  end do
                  nline(nunit) = k
               end if
            end if
         end do
  240    continue
         close (unit=isrc)
         call sort7 (nunit,routine,link)
         itxt = freeunit ()
         txtfile = 'modules.doc'
         call version (txtfile,'new')
         open (unit=itxt,file=txtfile,status='new')
         do i = 1, nunit
            string = routine(i)
            leng = trimtext (string)
            if (sphinx) then
               size = trimtext(string(8:16))
               write (itxt,250)  string(8:7+size),
     &                           string(17:leng)//'**'
  250          format (/,'**',a,' Module','^^^^^^^^',a,
     &                 //,'.. code-block:: text',/)
            else
               write (itxt,260)  string(1:leng)
  260          format (/,a)
            end if
            j = link(i)
            do k = 1, nline(j)
               string = info(k,j)
               leng = trimtext (string)
               if (sphinx) then
                  write (itxt,270)  string(1:leng)
  270             format (' ',a)
               else
                  write (itxt,280)  string(1:leng)
  280             format (a)
               end if
            end do
         end do
         close (unit=itxt)
         write (iout,290)  txtfile(1:trimtext(txtfile))
  290    format (/,' Source Documentation Written To :  ',a)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (nline)
      deallocate (link)
      deallocate (routine)
      deallocate (info)
c
c     perform dynamic allocation of some local arrays
c
      allocate (key(maxword))
c
c     get the keyword values from the source code listing
c
      if (mode .eq. 4) then
         nkey = 0
         do while (.true.)
            read (isrc,300,err=310,end=310)  record
  300       format (a240)
            next = index (record,'if (keyword(')
            if (next .ne. 0) then
               next = index (record,'.eq.')
               if (next .ne. 0) then
                  next = index (record,'''')
                  if (next .ne. 0) then
                     next = next + 1
                     call getword (record,keyword,next)
                     call upcase (keyword)
                     nkey = nkey + 1
                     key(nkey) = keyword
                  end if
               end if
            end if
         end do
  310    continue
         close (unit=isrc)
         call sort6 (nkey,key)
         keylast = '                    '
         itxt = freeunit ()
         txtfile = 'keyword.doc'
         call version (txtfile,'new')
         open (unit=itxt,file=txtfile,status='new')
         do i = 1, nkey
            keyword = key(i)
            leng = trimtext (keyword)
            if (keyword .ne. keylast) then
               write (itxt,320)  keyword(1:leng)
  320          format (a)
               keylast = keyword
            end if
         end do
         close (unit=itxt)
         write (iout,330)  txtfile(1:trimtext(txtfile))
  330    format (/,' Keyword Listing Written To :  ',a)
      end if
c
c     get the used modules from the source code listing
c
      if (mode .eq. 5) then
         nkey = 0
         do while (.true.)
            read (isrc,340,err=350,end=350)  record
  340       format (a240)
            next = 1
            call getword (record,keyword,next)
            if (keyword .eq. 'use') then
               call gettext (record,keyword,next)
               keyword = keyword(1:trimtext(keyword))//'.o'
               nkey = nkey + 1
               key(nkey) = keyword
            end if
         end do
  350    continue
         close (unit=isrc)
         call sort6 (nkey,key)
         keylast = '                    '
         leng = index (srcfile,'.')
         field = srcfile(1:leng-1)//'.o:'
         do i = 1, nkey
            keyword = key(i)
            leng = trimtext (keyword)
            if (keyword .ne. keylast) then
               last = trimtext (field)
               field = field(1:last)//' '//keyword(1:leng)
               keylast = keyword
            end if
         end do
         write (iout,360)
  360    format (/,' File Dependencies in Makefile Format :',/)
         leng = trimtext (field)
         write (iout,370)  field (1:leng)
  370    format (a)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (key)
c
c     get a force field parameter file and write a listing
c
      if (mode .eq. 6) then
         call getprm
         itxt = freeunit ()
         txtfile = 'parameter.txt'
         call version (txtfile,'new')
         open (unit=itxt,file=txtfile,status='new')
         call prtprm (itxt)
         close (unit=itxt)
         write (iout,380)  txtfile(1:trimtext(txtfile))
  380    format (/,' Parameter Listing Written To :  ',a)
      end if
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module domega  --  derivative components over torsions  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     tesum   total energy derivatives over torsions
c     teb     bond stretch derivatives over torsions
c     tea     angle bend derivatives over torsions
c     teba    stretch-bend derivatives over torsions
c     teub    Urey-Bradley derivatives over torsions
c     teaa    angle-angle derivatives over torsions
c     teopb   out-of-plane bend derivatives over torsions
c     teopd   out-of-plane distance derivatives over torsions
c     teid    improper dihedral derivatives over torsions
c     teit    improper torsion derivatives over torsions
c     tet     torsional derivatives over torsions
c     tept    pi-system torsion derivatives over torsions
c     tebt    stretch-torsion derivatives over torsions
c     teat    angle-torsion derivatives over torsions
c     tett    torsion-torsion derivatives over torsions
c     tev     van der Waals derivatives over torsions
c     ter     Pauli repulsion derivatives over torsions
c     tedsp   dampled dispersion derivatives over torsions
c     tec     charge-charge derivatives over torsions
c     tecd    charge-dipole derivatives over torsions
c     ted     dipole-dipole derivatives over torsions
c     tem     atomic multipole derivatives over torsions
c     tep     polarization derivatives over torsions
c     tect    charge transfer derivatives over torsions
c     terxf   reaction field derivatives over torsions
c     tes     solvation derivatives over torsions
c     telf    metal ligand field derivatives over torsions
c     teg     geometric restraint derivatives over torsions
c     tex     extra energy term derivatives over torsions
c
c
      module domega
      implicit none
      real*8, allocatable :: tesum(:)
      real*8, allocatable :: teb(:)
      real*8, allocatable :: tea(:)
      real*8, allocatable :: teba(:)
      real*8, allocatable :: teub(:)
      real*8, allocatable :: teaa(:)
      real*8, allocatable :: teopb(:)
      real*8, allocatable :: teopd(:)
      real*8, allocatable :: teid(:)
      real*8, allocatable :: teit(:)
      real*8, allocatable :: tet(:)
      real*8, allocatable :: tept(:)
      real*8, allocatable :: tebt(:)
      real*8, allocatable :: teat(:)
      real*8, allocatable :: tett(:)
      real*8, allocatable :: tev(:)
      real*8, allocatable :: ter(:)
      real*8, allocatable :: tedsp(:)
      real*8, allocatable :: tec(:)
      real*8, allocatable :: tecd(:)
      real*8, allocatable :: ted(:)
      real*8, allocatable :: tem(:)
      real*8, allocatable :: tep(:)
      real*8, allocatable :: tect(:)
      real*8, allocatable :: terxf(:)
      real*8, allocatable :: tes(:)
      real*8, allocatable :: telf(:)
      real*8, allocatable :: teg(:)
      real*8, allocatable :: tex(:)
      save
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module dsppot  --  dispersion interaction scale factors  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     dsp2scale   scale factor for 1-2 dispersion energy interactions
c     dsp3scale   scale factor for 1-3 dispersion energy interactions
c     dsp4scale   scale factor for 1-4 dispersion energy interactions
c     dsp5scale   scale factor for 1-5 dispersion energy interactions
c     use_dcorr   flag to use long range dispersion correction
c
c
      module dsppot
      implicit none
      real*8 dsp2scale
      real*8 dsp3scale
      real*8 dsp4scale
      real*8 dsp5scale
      logical use_dcorr
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program dynamic  --  run molecular or stochastic dynamics  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "dynamic" computes a molecular or stochastic dynamics trajectory
c     in one of the standard statistical mechanical ensembles and using
c     any of several possible integration methods
c
c
      program dynamic
      use atoms
      use bath
      use bndstr
      use bound
      use inform
      use iounit
      use keys
      use mdstuf
      use potent
      use stodyn
      use usage
      implicit none
      integer i,next,mode
      integer istep,nstep
      real*8 dt,dtsave
      logical exist
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set up the structure and molecular mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     initialize the temperature, pressure and coupling baths
c
      kelvin = 0.0d0
      atmsph = 0.0d0
      isothermal = .false.
      isobaric = .false.
c
c     check for keywords containing any altered parameters
c
      integrate = 'BEEMAN'
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:11) .eq. 'INTEGRATOR ') then
            call getword (record,integrate,next)
            call upcase (integrate)
         end if
      end do
c
c     initialize the simulation length as number of time steps
c
      nstep = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  nstep
   10 continue
      do while (nstep .lt. 0)
         write (iout,20)
   20    format (/,' Enter the Number of Dynamics Steps to be',
     &              ' Taken :  ',$)
         read (input,30,err=40)  nstep
   30    format (i10)
         if (nstep .lt. 0)  nstep = 0
   40    continue
      end do
c
c     get the length of the dynamics time step in picoseconds
c
      dt = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=50,end=50)  dt
   50 continue
      do while (dt .lt. 0.0d0)
         write (iout,60)
   60    format (/,' Enter the Time Step Length in Femtoseconds',
     &              ' [1.0] :  ',$)
         read (input,70,err=80)  dt
   70    format (f20.0)
         if (dt .le. 0.0d0)  dt = 1.0d0
   80    continue
      end do
      dt = 0.001d0 * dt
c
c     enforce bounds on thermostat and barostat coupling times
c
      tautemp = max(tautemp,dt)
      taupres = max(taupres,dt)
c
c     set the time between trajectory snapshot coordinate saves
c
      dtsave = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=90,end=90)  dtsave
   90 continue
      do while (dtsave .lt. 0.0d0)
         write (iout,100)
  100    format (/,' Enter Time between Saves in Picoseconds',
     &              ' [0.1] :  ',$)
         read (input,110,err=120)  dtsave
  110    format (f20.0)
         if (dtsave .le. 0.0d0)  dtsave = 0.1d0
  120    continue
      end do
      iwrite = nint(dtsave/dt)
c
c     get choice of statistical ensemble for periodic system
c
      if (use_bounds) then
         mode = -1
         call nextarg (string,exist)
         if (exist)  read (string,*,err=130,end=130)  mode
  130    continue
         do while (mode.lt.1 .or. mode.gt.4)
            write (iout,140)
  140       format (/,' Available Statistical Mechanical Ensembles :',
     &              //,4x,'(1) Microcanonical (NVE)',
     &              /,4x,'(2) Canonical (NVT)',
     &              /,4x,'(3) Isoenthalpic-Isobaric (NPH)',
     &              /,4x,'(4) Isothermal-Isobaric (NPT)',
     &              //,' Enter the Number of the Desired Choice',
     &                 ' [1] :  ',$)
            read (input,150,err=160)  mode
  150       format (i10)
            if (mode .le. 0)  mode = 1
  160       continue
         end do
         if (integrate.eq.'NOSE-HOOVER' .or. integrate.eq.'GHMC') then
            if (mode .ne. 4) then
               mode = 4
               write (iout,170)
  170          format (/,' Switching to NPT Ensemble as Required',
     &                    ' by Chosen Integrator')
            end if
         end if
         if (mode.eq.2 .or. mode.eq.4) then
            isothermal = .true.
            kelvin = -1.0d0
            call nextarg (string,exist)
            if (exist)  read (string,*,err=180,end=180)  kelvin
  180       continue
            do while (kelvin .le. 0.0d0)
               write (iout,190)
  190          format (/,' Enter the Desired Temperature in Degrees',
     &                    ' K [298] :  ',$)
               read (input,200,err=210)  kelvin
  200          format (f20.0)
               if (kelvin .le. 0.0d0)  kelvin = 298.0d0
  210          continue
            end do
         end if
         if (mode.eq.3 .or. mode.eq.4) then
            isobaric = .true.
            atmsph = -1.0d0
            call nextarg (string,exist)
            if (exist)  read (string,*,err=220,end=220)  atmsph
  220       continue
            do while (atmsph .eq. -1.0d0)
               write (iout,230)
  230          format (/,' Enter the Desired Pressure in Atm',
     &                    ' [1.0] :  ',$)
               read (input,240,err=250)  atmsph
  240          format (f20.0)
               if (atmsph .eq. -1.0d0)  atmsph = 1.0d0
  250          continue
            end do
         end if
      end if
c
c     use constant energy or temperature for nonperiodic system
c
      if (.not. use_bounds) then
         mode = -1
         call nextarg (string,exist)
         if (exist)  read (string,*,err=260,end=260)  mode
  260    continue
         do while (mode.lt.1 .or. mode.gt.2)
            write (iout,270)
  270       format (/,' Available Simulation Control Modes :',
     &              //,4x,'(1) Constant Total Energy Value (E)',
     &              /,4x,'(2) Constant Temperature via Thermostat (T)',
     &              //,' Enter the Number of the Desired Choice',
     &                 ' [1] :  ',$)
            read (input,280,err=290)  mode
  280       format (i10)
            if (mode .le. 0)  mode = 1
  290       continue
         end do
         if (mode .eq. 2) then
            isothermal = .true.
            kelvin = -1.0d0
            call nextarg (string,exist)
            if (exist)  read (string,*,err=300,end=300)  kelvin
  300       continue
            do while (kelvin .le. 0.0d0)
               write (iout,310)
  310          format (/,' Enter the Desired Temperature in Degrees',
     &                    ' K [298] :  ',$)
               read (input,320,err=330)  kelvin
  320          format (f20.0)
               if (kelvin .le. 0.0d0)  kelvin = 298.0d0
  330          continue
            end do
         end if
      end if
c
c     perform the setup functions needed to run dynamics
c
      call mdinit (dt)
c
c     print out a header line for the dynamics computation
c
      if (integrate .eq. 'VERLET') then
         write (iout,340)
  340    format (/,' Molecular Dynamics Trajectory via',
     &              ' Velocity Verlet Algorithm')
      else if (integrate .eq. 'BEEMAN') then
         write (iout,350)
  350    format (/,' Molecular Dynamics Trajectory via',
     &              ' Modified Beeman Algorithm')
      else if (integrate .eq. 'BAOAB') then
         write (iout,360)
  360    format (/,' Stochastic Dynamics Trajectory via',
     &              ' BAOAB Algorithm')
      else if (integrate .eq. 'OBABO') then
         write (iout,370)
  370    format (/,' Stochastic Dynamics Trajectory via',
     &              ' OBABO Algorithm')
      else if (integrate .eq. 'NOSE-HOOVER') then
         write (iout,380)
  380    format (/,' Molecular Dynamics Trajectory via',
     &              ' Nose-Hoover NPT Algorithm')
      else if (integrate .eq. 'STOCHASTIC') then
         write (iout,390)
  390    format (/,' Stochastic Dynamics Trajectory via',
     &              ' Velocity Verlet Algorithm')
      else if (integrate .eq. 'GHMC') then
         write (iout,400)
  400    format (/,' Stochastic Dynamics Trajectory via',
     &              ' Generalized Hybrid Monte Carlo')
      else if (integrate .eq. 'RIGIDBODY') then
         write (iout,410)
  410    format (/,' Molecular Dynamics Trajectory via',
     &              ' Rigid Body Algorithm')
      else if (integrate .eq. 'VRESPA') then
         write (iout,420)
  420    format (/,' Molecular Dynamics Trajectory via',
     &              ' Verlet r-RESPA MTS Algorithm')
      else if (integrate .eq. 'BRESPA') then
         write (iout,430)
  430    format (/,' Molecular Dynamics Trajectory via',
     &              ' Beeman r-RESPA MTS Algorithm')
      else if (integrate .eq. 'SRESPA') then
         write (iout,440)
  440    format (/,' Molecular Dynamics Trajectory via',
     &              ' BAOAB r-RESPA MTS Algorithm')
      else
         write (iout,450)
  450    format (/,' Molecular Dynamics Trajectory via',
     &              ' Modified Beeman Algorithm')
      end if
      flush (iout)
c
c     integrate equations of motion to take a time step
c
      do istep = 1, nstep
         if (integrate .eq. 'VERLET') then
            call verlet (istep,dt)
         else if (integrate .eq. 'BEEMAN') then
            call beeman (istep,dt)
         else if (integrate .eq. 'BAOAB') then
            call baoab (istep,dt)
         else if (integrate .eq. 'OBABO') then
            call obabo (istep,dt)
         else if (integrate .eq. 'NOSE-HOOVER') then
            call nose (istep,dt)
         else if (integrate .eq. 'STOCHASTIC') then
            call sdstep (istep,dt)
         else if (integrate .eq. 'GHMC') then
            call ghmcstep (istep,dt)
         else if (integrate .eq. 'RIGIDBODY') then
            call rgdstep (istep,dt)
         else if (integrate .eq. 'VRESPA') then
            call vrespa (istep,dt)
         else if (integrate .eq. 'BRESPA') then
            call brespa (istep,dt)
         else if (integrate .eq. 'SRESPA') then
            call srespa (istep,dt)
         else
            call beeman (istep,dt)
         end if
      end do
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine eangang  --  angle-angle cross term energy  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "eangang" calculates the angle-angle potential energy
c
c
      subroutine eangang
      use angang
      use angbnd
      use angpot
      use atoms
      use bound
      use energi
      use group
      use math
      use usage
      implicit none
      integer i,k,iangang
      integer ia,ib,ic,id,ie
      real*8 e,angle
      real*8 eps,fgrp
      real*8 dt1,dt2
      real*8 dot,cosine
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xie,yie,zie
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 xdb,ydb,zdb
      real*8 xeb,yeb,zeb
      real*8 rab2,rcb2
      real*8 rdb2,reb2
      logical proceed
c
c
c     zero out the angle-angle cross term energy
c
      eaa = 0.0d0
      if (nangang .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nangang,iaa,iang,
!$OMP& use,x,y,z,anat,kaa,aaunit,eps,use_group,use_polymer)
!$OMP& shared(eaa)
!$OMP DO reduction(+:eaa)
c
c     calculate the angle-angle interaction energy term
c
      do iangang = 1, nangang
         i = iaa(1,iangang)
         k = iaa(2,iangang)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         id = iang(1,k)
         ie = iang(3,k)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,ie,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic)
     &                               .or. use(id) .or. use(ie))
c
c     get the coordinates of the atoms in the 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)
            xie = x(ie)
            yie = y(ie)
            zie = z(ie)
c
c     compute the values of the two bond angles
c
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            xeb = xie - xib
            yeb = yie - yib
            zeb = zie - zib
            if (use_polymer) then
               call image (xab,yab,zab)
               call image (xcb,ycb,zcb)
               call image (xdb,ydb,zdb)
               call image (xeb,yeb,zeb)
            end if
            rab2 = max(xab*xab+yab*yab+zab*zab,eps)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
            rdb2 = max(xdb*xdb+ydb*ydb+zdb*zdb,eps)
            reb2 = max(xeb*xeb+yeb*yeb+zeb*zeb,eps)
            dot = xab*xcb + yab*ycb + zab*zcb
            cosine = dot / sqrt(rab2*rcb2)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            dt1 = angle - anat(i)
            dot = xdb*xeb + ydb*yeb + zdb*zeb
            cosine = dot / sqrt(rdb2*reb2)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            dt2 = angle - anat(k)
c
c     get the angle-angle interaction energy
c
            e = aaunit * kaa(iangang) * dt1 * dt2
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total angle-angle energy
c
            eaa = eaa + e
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine eangang1  --  angle-angle energy & derivatives  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "eangang1" calculates the angle-angle potential energy and
c     first derivatives with respect to Cartesian coordinates
c
c
      subroutine eangang1
      use angang
      use angbnd
      use angpot
      use atoms
      use bound
      use deriv
      use energi
      use group
      use math
      use usage
      use virial
      implicit none
      integer i,k,iangang
      integer ia,ib,ic,id,ie
      real*8 e,angle
      real*8 eps,fgrp
      real*8 dot,cosine
      real*8 dt1,deddt1
      real*8 dt2,deddt2
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xie,yie,zie
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 xdb,ydb,zdb
      real*8 xeb,yeb,zeb
      real*8 rab2,rcb2
      real*8 rdb2,reb2
      real*8 xp,yp,zp,rp
      real*8 xq,yq,zq,rq
      real*8 terma,termc
      real*8 termd,terme
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 dedxie,dedyie,dedzie
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out the angle-angle energy and first derivatives
c
      eaa = 0.0d0
      do i = 1, n
         deaa(1,i) = 0.0d0
         deaa(2,i) = 0.0d0
         deaa(3,i) = 0.0d0
      end do
      if (nangang .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nangang,iaa,iang,
!$OMP& use,x,y,z,anat,kaa,aaunit,eps,use_group,use_polymer)
!$OMP& shared(eaa,deaa,vir)
!$OMP DO reduction(+:eaa,deaa,vir)
c
c     find the energy of each angle-angle interaction
c
      do iangang = 1, nangang
         i = iaa(1,iangang)
         k = iaa(2,iangang)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         id = iang(1,k)
         ie = iang(3,k)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,ie,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic)
     &                               .or. use(id) .or. use(ie))
c
c     get the coordinates of the atoms in the 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)
            xie = x(ie)
            yie = y(ie)
            zie = z(ie)
c
c     compute the values of the two bond angles
c
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            xeb = xie - xib
            yeb = yie - yib
            zeb = zie - zib
            if (use_polymer) then
               call image (xab,yab,zab)
               call image (xcb,ycb,zcb)
               call image (xdb,ydb,zdb)
               call image (xeb,yeb,zeb)
            end if
            rab2 = max(xab*xab+yab*yab+zab*zab,eps)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
            rdb2 = max(xdb*xdb+ydb*ydb+zdb*zdb,eps)
            reb2 = max(xeb*xeb+yeb*yeb+zeb*zeb,eps)
            xp = ycb*zab - zcb*yab
            yp = zcb*xab - xcb*zab
            zp = xcb*yab - ycb*xab
            xq = yeb*zdb - zeb*ydb
            yq = zeb*xdb - xeb*zdb
            zq = xeb*ydb - yeb*xdb
            rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps))
            rq = sqrt(max(xq*xq+yq*yq+zq*zq,eps))
            dot = xab*xcb + yab*ycb + zab*zcb
            cosine = dot / sqrt(rab2*rcb2)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            dt1 = angle - anat(i)
            dot = xdb*xeb + ydb*yeb + zdb*zeb
            cosine = dot / sqrt(rdb2*reb2)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            dt2 = angle - anat(k)
c
c     get the energy and master chain rule terms for derivatives
c
            e = aaunit * kaa(iangang) * dt1 * dt2
            deddt1 = radian * e / dt1
            deddt2 = radian * e / dt2
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e = e * fgrp
               deddt1 = deddt1 * fgrp
               deddt2 = deddt2 * fgrp
            end if
c
c     find chain rule terms for the first bond angle deviation
c
            terma = -deddt1 / (rab2*rp)
            termc = deddt1 / (rcb2*rp)
            dedxia = terma * (yab*zp-zab*yp)
            dedyia = terma * (zab*xp-xab*zp)
            dedzia = terma * (xab*yp-yab*xp)
            dedxic = termc * (ycb*zp-zcb*yp)
            dedyic = termc * (zcb*xp-xcb*zp)
            dedzic = termc * (xcb*yp-ycb*xp)
c
c     find chain rule terms for the second bond angle deviation
c
            termd = -deddt2 / (rdb2*rq)
            terme = deddt2 / (reb2*rq)
            dedxid = termd * (ydb*zq-zdb*yq)
            dedyid = termd * (zdb*xq-xdb*zq)
            dedzid = termd * (xdb*yq-ydb*xq)
            dedxie = terme * (yeb*zq-zeb*yq)
            dedyie = terme * (zeb*xq-xeb*zq)
            dedzie = terme * (xeb*yq-yeb*xq)
c
c     get the central atom derivative terms by difference
c
            dedxib = -dedxia - dedxic - dedxid - dedxie
            dedyib = -dedyia - dedyic - dedyid - dedyie
            dedzib = -dedzia - dedzic - dedzid - dedzie
c
c     increment the total angle-angle energy and derivatives
c
            eaa = eaa + e
            deaa(1,ia) = deaa(1,ia) + dedxia
            deaa(2,ia) = deaa(2,ia) + dedyia
            deaa(3,ia) = deaa(3,ia) + dedzia
            deaa(1,ib) = deaa(1,ib) + dedxib
            deaa(2,ib) = deaa(2,ib) + dedyib
            deaa(3,ib) = deaa(3,ib) + dedzib
            deaa(1,ic) = deaa(1,ic) + dedxic
            deaa(2,ic) = deaa(2,ic) + dedyic
            deaa(3,ic) = deaa(3,ic) + dedzic
            deaa(1,id) = deaa(1,id) + dedxid
            deaa(2,id) = deaa(2,id) + dedyid
            deaa(3,id) = deaa(3,id) + dedzid
            deaa(1,ie) = deaa(1,ie) + dedxie
            deaa(2,ie) = deaa(2,ie) + dedyie
            deaa(3,ie) = deaa(3,ie) + dedzie
c
c     increment the internal virial tensor components
c
            vxx = xab*dedxia + xcb*dedxic + xdb*dedxid + xeb*dedxie
            vyx = yab*dedxia + ycb*dedxic + ydb*dedxid + yeb*dedxie
            vzx = zab*dedxia + zcb*dedxic + zdb*dedxid + zeb*dedxie
            vyy = yab*dedyia + ycb*dedyic + ydb*dedyid + yeb*dedyie
            vzy = zab*dedyia + zcb*dedyic + zdb*dedyid + zeb*dedyie
            vzz = zab*dedzia + zcb*dedzic + zdb*dedzid + zeb*dedzie
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eangang2  --  angle-angle Hessian; numerical  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "eangang2" calculates the angle-angle potential energy
c     second derivatives with respect to Cartesian coordinates
c     using finite difference methods
c
c
      subroutine eangang2 (i)
      use angang
      use angbnd
      use atoms
      use group
      use hessn
      implicit none
      integer i,j,k,iangang
      integer ia,ib,ic,id,ie
      real*8 eps,fgrp
      real*8 old,term
      real*8, allocatable :: de(:,:)
      real*8, allocatable :: d0(:,:)
      logical proceed
      logical twosided
c
c
c     set stepsize for derivatives and default group weight
c
      eps = 1.0d-5
      fgrp = 1.0d0
      twosided = .false.
      if (n .le. 50)  twosided = .true.
c
c     perform dynamic allocation of some local arrays
c
      allocate (de(3,n))
      allocate (d0(3,n))
c
c     compute numerical angle-angle Hessian for current atom
c
      do iangang = 1, nangang
         j = iaa(1,iangang)
         k = iaa(2,iangang)
         ia = iang(1,j)
         ib = iang(2,j)
         ic = iang(3,j)
         id = iang(1,k)
         ie = iang(3,k)
c
c     decide whether to compute the current interaction
c
         proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic
     &                 .or. i.eq.id .or. i.eq.ie)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,id,ie,0)
c
c     eliminate any duplicate atoms in the pair of angles
c
         if (proceed) then
            if (id.eq.ia .or. id.eq.ic)  then
               id = ie
               ie = 0
            else if (ie.eq.ia .or. ie.eq.ic) then
               ie = 0
            end if
            term = fgrp / eps
c
c     find first derivatives for the base structure
c
            if (.not. twosided) then
               call eangang2a (iangang,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
                  if (ie .ne. 0)  d0(j,ie) = de(j,ie)
               end do
            end if
c
c     find numerical x-components via perturbed structures
c
            old = x(i)
            if (twosided) then
               x(i) = x(i) - 0.5d0*eps
               call eangang2a (iangang,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
                  if (ie .ne. 0)  d0(j,ie) = de(j,ie)
               end do
            end if
            x(i) = x(i) + eps
            call eangang2a (iangang,de)
            x(i) = old
            do j = 1, 3
               hessx(j,ia) = hessx(j,ia) + term*(de(j,ia)-d0(j,ia))
               hessx(j,ib) = hessx(j,ib) + term*(de(j,ib)-d0(j,ib))
               hessx(j,ic) = hessx(j,ic) + term*(de(j,ic)-d0(j,ic))
               hessx(j,id) = hessx(j,id) + term*(de(j,id)-d0(j,id))
               if (ie .ne. 0)
     &            hessx(j,ie) = hessx(j,ie) + term*(de(j,ie)-d0(j,ie))
            end do
c
c     find numerical y-components via perturbed structures
c
            old = y(i)
            if (twosided) then
               y(i) = y(i) - 0.5d0*eps
               call eangang2a (iangang,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
                  if (ie .ne. 0)  d0(j,ie) = de(j,ie)
               end do
            end if
            y(i) = y(i) + eps
            call eangang2a (iangang,de)
            y(i) = old
            do j = 1, 3
               hessy(j,ia) = hessy(j,ia) + term*(de(j,ia)-d0(j,ia))
               hessy(j,ib) = hessy(j,ib) + term*(de(j,ib)-d0(j,ib))
               hessy(j,ic) = hessy(j,ic) + term*(de(j,ic)-d0(j,ic))
               hessy(j,id) = hessy(j,id) + term*(de(j,id)-d0(j,id))
               if (ie .ne. 0)
     &            hessy(j,ie) = hessy(j,ie) + term*(de(j,ie)-d0(j,ie))
            end do
c
c     find numerical z-components via perturbed structures
c
            old = z(i)
            if (twosided) then
               z(i) = z(i) - 0.5d0*eps
               call eangang2a (iangang,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
                  if (ie .ne. 0)  d0(j,ie) = de(j,ie)
               end do
            end if
            z(i) = z(i) + eps
            call eangang2a (iangang,de)
            z(i) = old
            do j = 1, 3
               hessz(j,ia) = hessz(j,ia) + term*(de(j,ia)-d0(j,ia))
               hessz(j,ib) = hessz(j,ib) + term*(de(j,ib)-d0(j,ib))
               hessz(j,ic) = hessz(j,ic) + term*(de(j,ic)-d0(j,ic))
               hessz(j,id) = hessz(j,id) + term*(de(j,id)-d0(j,id))
               if (ie .ne. 0)
     &            hessz(j,ie) = hessz(j,ie) + term*(de(j,ie)-d0(j,ie))
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (de)
      deallocate (d0)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eangang2a  --  angle-angle interaction derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "eangang2a" calculates the angle-angle first derivatives for
c     a single interaction with respect to Cartesian coordinates;
c     used in computation of finite difference second derivatives
c
c
      subroutine eangang2a (i,de)
      use angang
      use angbnd
      use angpot
      use atoms
      use bound
      use math
      implicit none
      integer i,j,k
      integer ia,ib,ic,id,ie
      real*8 angle
      real*8 eps,term
      real*8 dot,cosine
      real*8 dt1,deddt1
      real*8 dt2,deddt2
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xie,yie,zie
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 xdb,ydb,zdb
      real*8 xeb,yeb,zeb
      real*8 rab2,rcb2
      real*8 rdb2,reb2
      real*8 xp,yp,zp,rp
      real*8 xq,yq,zq,rq
      real*8 terma,termc
      real*8 termd,terme
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 dedxie,dedyie,dedzie
      real*8 de(3,*)
c
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     set the coordinates of the involved atoms
c
      j = iaa(1,i)
      k = iaa(2,i)
      ia = iang(1,j)
      ib = iang(2,j)
      ic = iang(3,j)
      id = iang(1,k)
      ie = iang(3,k)
      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)
      xie = x(ie)
      yie = y(ie)
      zie = z(ie)
c
c     zero out the first derivative components
c
      de(1,ia) = 0.0d0
      de(2,ia) = 0.0d0
      de(3,ia) = 0.0d0
      de(1,ib) = 0.0d0
      de(2,ib) = 0.0d0
      de(3,ib) = 0.0d0
      de(1,ic) = 0.0d0
      de(2,ic) = 0.0d0
      de(3,ic) = 0.0d0
      de(1,id) = 0.0d0
      de(2,id) = 0.0d0
      de(3,id) = 0.0d0
      de(1,ie) = 0.0d0
      de(2,ie) = 0.0d0
      de(3,ie) = 0.0d0
c
c     compute the values of the two bond angles
c
      xab = xia - xib
      yab = yia - yib
      zab = zia - zib
      xcb = xic - xib
      ycb = yic - yib
      zcb = zic - zib
      xdb = xid - xib
      ydb = yid - yib
      zdb = zid - zib
      xeb = xie - xib
      yeb = yie - yib
      zeb = zie - zib
      if (use_polymer) then
         call image (xab,yab,zab)
         call image (xcb,ycb,zcb)
         call image (xdb,ydb,zdb)
         call image (xeb,yeb,zeb)
      end if
      rab2 = max(xab*xab+yab*yab+zab*zab,eps)
      rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
      rdb2 = max(xdb*xdb+ydb*ydb+zdb*zdb,eps)
      reb2 = max(xeb*xeb+yeb*yeb+zeb*zeb,eps)
      xp = ycb*zab - zcb*yab
      yp = zcb*xab - xcb*zab
      zp = xcb*yab - ycb*xab
      xq = yeb*zdb - zeb*ydb
      yq = zeb*xdb - xeb*zdb
      zq = xeb*ydb - yeb*xdb
      rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps))
      rq = sqrt(max(xq*xq+yq*yq+zq*zq,eps))
      dot = xab*xcb + yab*ycb + zab*zcb
      cosine = dot / sqrt(rab2*rcb2)
      cosine = min(1.0d0,max(-1.0d0,cosine))
      angle = radian * acos(cosine)
      dt1 = angle - anat(j)
      dot = xdb*xeb + ydb*yeb + zdb*zeb
      cosine = dot / sqrt(rdb2*reb2)
      cosine = min(1.0d0,max(-1.0d0,cosine))
      angle = radian * acos(cosine)
      dt2 = angle - anat(k)
c
c     get the energy and master chain rule terms for derivatives
c
      term = radian * aaunit * kaa(i)
      deddt1 = term * dt2
      deddt2 = term * dt1
c
c     find chain rule terms for the first bond angle deviation
c
      terma = -deddt1 / (rab2*rp)
      termc = deddt1 / (rcb2*rp)
      dedxia = terma * (yab*zp-zab*yp)
      dedyia = terma * (zab*xp-xab*zp)
      dedzia = terma * (xab*yp-yab*xp)
      dedxic = termc * (ycb*zp-zcb*yp)
      dedyic = termc * (zcb*xp-xcb*zp)
      dedzic = termc * (xcb*yp-ycb*xp)
c
c     find chain rule terms for the second bond angle deviation
c
      termd = -deddt2 / (rdb2*rq)
      terme = deddt2 / (reb2*rq)
      dedxid = termd * (ydb*zq-zdb*yq)
      dedyid = termd * (zdb*xq-xdb*zq)
      dedzid = termd * (xdb*yq-ydb*xq)
      dedxie = terme * (yeb*zq-zeb*yq)
      dedyie = terme * (zeb*xq-xeb*zq)
      dedzie = terme * (xeb*yq-yeb*xq)
c
c     get the central atom derivative terms by difference
c
      dedxib = -dedxia - dedxic - dedxid - dedxie
      dedyib = -dedyia - dedyic - dedyid - dedyie
      dedzib = -dedzia - dedzic - dedzid - dedzie
c
c     set the angle-angle interaction first derivatives
c
      de(1,ia) = de(1,ia) + dedxia
      de(2,ia) = de(2,ia) + dedyia
      de(3,ia) = de(3,ia) + dedzia
      de(1,ib) = de(1,ib) + dedxib
      de(2,ib) = de(2,ib) + dedyib
      de(3,ib) = de(3,ib) + dedzib
      de(1,ic) = de(1,ic) + dedxic
      de(2,ic) = de(2,ic) + dedyic
      de(3,ic) = de(3,ic) + dedzic
      de(1,id) = de(1,id) + dedxid
      de(2,id) = de(2,id) + dedyid
      de(3,id) = de(3,id) + dedzid
      de(1,ie) = de(1,ie) + dedxie
      de(2,ie) = de(2,ie) + dedyie
      de(3,ie) = de(3,ie) + dedzie
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eangang3  --  angle-angle energy and analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "eangang3" calculates the angle-angle potential energy;
c     also partitions the energy among the atoms
c
c
      subroutine eangang3
      use action
      use analyz
      use angang
      use angbnd
      use angpot
      use atomid
      use atoms
      use bound
      use energi
      use group
      use inform
      use iounit
      use math
      use usage
      implicit none
      integer i,k,iangang
      integer ia,ib,ic,id,ie
      real*8 e,angle
      real*8 eps,fgrp
      real*8 dt1,dt2
      real*8 dot,cosine
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xie,yie,zie
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 xdb,ydb,zdb
      real*8 xeb,yeb,zeb
      real*8 rab2,rcb2
      real*8 rdb2,reb2
      logical proceed
      logical header,huge
c
c
c     zero out the angle-angle cross term energy
c
      neaa = 0
      eaa = 0.0d0
      do i = 1, n
         aeaa(i) = 0.0d0
      end do
      if (nangang .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nangang.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Angle-Angle Interactions :',
     &           //,' Type',10x,'Center',6x,'Angle1',
     &              6x,'Angle2',4x,'dAngle1',
     &              3x,'dAngle2',6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nangang,iaa,iang,
!$OMP& use,x,y,z,anat,kaa,aaunit,eps,use_group,use_polymer,
!$OMP& name,verbose,debug,header,iout)
!$OMP& shared(eaa,neaa,aeaa)
!$OMP DO reduction(+:eaa,neaa,aeaa)
c
c     find the energy of each angle-angle interaction
c
      do iangang = 1, nangang
         i = iaa(1,iangang)
         k = iaa(2,iangang)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         id = iang(1,k)
         ie = iang(3,k)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,ie,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic)
     &                               .or. use(id) .or. use(ie))
c
c     get the coordinates of the atoms in the 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)
            xie = x(ie)
            yie = y(ie)
            zie = z(ie)
c
c     compute the values of the two bond angles
c
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            xeb = xie - xib
            yeb = yie - yib
            zeb = zie - zib
            if (use_polymer) then
               call image (xab,yab,zab)
               call image (xcb,ycb,zcb)
               call image (xdb,ydb,zdb)
               call image (xeb,yeb,zeb)
            end if
            rab2 = max(xab*xab+yab*yab+zab*zab,eps)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
            rdb2 = max(xdb*xdb+ydb*ydb+zdb*zdb,eps)
            reb2 = max(xeb*xeb+yeb*yeb+zeb*zeb,eps)
            dot = xab*xcb + yab*ycb + zab*zcb
            cosine = dot / sqrt(rab2*rcb2)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            dt1 = angle - anat(i)
            dot = xdb*xeb + ydb*yeb + zdb*zeb
            cosine = dot / sqrt(rdb2*reb2)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            dt2 = angle - anat(k)
c
c     get the angle-angle interaction energy
c
            e = aaunit * kaa(iangang) * dt1 * dt2
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total angle-angle energy
c
            neaa = neaa + 1
            eaa = eaa + e
            aeaa(ib) = aeaa(ib) + e
c
c     print a message if the energy of this interaction is large
c
            huge = (e .gt. 5.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Individual Angle-Angle Interactions :',
     &                    //,' Type',10x,'Center',6x,'Angle1',
     &                       6x,'Angle2',4x,'dAngle1',
     &                       3x,'dAngle2',6x,'Energy',/)
               end if
               write (iout,30)  ib,name(ib),ia,ic,id,ie,dt1,dt2,e
   30          format (' AngAng',4x,i7,'-',a3,4i6,2f10.4,f12.4)
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine eangle  --  angle bending potential energy  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "eangle" calculates the angle bending potential energy;
c     projected in-plane angles at trigonal centers, special
c     linear or Fourier angle bending terms are optionally used
c
c
      subroutine eangle
      use angbnd
      use angpot
      use atoms
      use bound
      use energi
      use group
      use math
      use usage
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps
      real*8 ideal,force
      real*8 fold,factor
      real*8 dot,cosine
      real*8 angle,fgrp
      real*8 dt,dt2,dt3,dt4
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 xip,yip,zip
      real*8 xap,yap,zap
      real*8 xcp,ycp,zcp
      real*8 rab2,rcb2
      real*8 rap2,rcp2
      real*8 xt,yt,zt
      real*8 rt2,delta
      logical proceed
c
c
c     zero out the angle bending energy component
c
      ea = 0.0d0
      if (nangle .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nangle,iang,anat,ak,afld,
!$OMP& use,x,y,z,cang,qang,pang,sang,angtyp,angunit,eps,use_group,
!$OMP& use_polymer)
!$OMP& shared(ea)
!$OMP DO reduction(+:ea)
c
c     calculate the bond angle bending energy term
c
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         id = iang(4,i)
         ideal = anat(i)
         force = ak(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (angtyp(i) .eq. 'IN-PLANE') then
            if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
            if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                                 use(ic) .or. use(id))
         else
            if (use_group)  call groups (proceed,fgrp,ia,ib,ic,0,0,0)
            if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic))
         end if
c
c     get the coordinates of the atoms in the 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)
c
c     compute the bond angle bending energy
c
            if (angtyp(i) .ne. 'IN-PLANE') then
               xab = xia - xib
               yab = yia - yib
               zab = zia - zib
               xcb = xic - xib
               ycb = yic - yib
               zcb = zic - zib
               if (use_polymer) then
                  call image (xab,yab,zab)
                  call image (xcb,ycb,zcb)
               end if
               rab2 = max(xab*xab+yab*yab+zab*zab,eps)
               rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
               dot = xab*xcb + yab*ycb + zab*zcb
               cosine = dot / sqrt(rab2*rcb2)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               if (angtyp(i) .eq. 'HARMONIC') then
                  dt = angle - ideal
                  dt2 = dt * dt
                  dt3 = dt2 * dt
                  dt4 = dt2 * dt2
                  e = angunit * force * dt2
     &                   * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4)
               else if (angtyp(i) .eq. 'LINEAR') then
                  factor = 2.0d0 * angunit * radian**2
                  e = factor * force * (1.0d0+cosine)
               else if (angtyp(i) .eq. 'FOURIER') then
                  fold = afld(i)
                  factor = 2.0d0 * angunit * (radian/fold)**2
                  cosine = cos((fold*angle-ideal)/radian)
                  e = factor * force * (1.0d0+cosine)
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the total bond angle bending energy
c
               ea = ea + e
c
c     compute the projected in-plane angle bend energy
c
            else
               xid = x(id)
               yid = y(id)
               zid = z(id)
               xad = xia - xid
               yad = yia - yid
               zad = zia - zid
               xbd = xib - xid
               ybd = yib - yid
               zbd = zib - zid
               xcd = xic - xid
               ycd = yic - yid
               zcd = zic - zid
               if (use_polymer) then
                  call image (xad,yad,zad)
                  call image (xbd,ybd,zbd)
                  call image (xcd,ycd,zcd)
               end if
               xt = yad*zcd - zad*ycd
               yt = zad*xcd - xad*zcd
               zt = xad*ycd - yad*xcd
               rt2 = xt*xt + yt*yt + zt*zt
               delta = -(xt*xbd + yt*ybd + zt*zbd) / rt2
               xip = xib + xt*delta
               yip = yib + yt*delta
               zip = zib + zt*delta
               xap = xia - xip
               yap = yia - yip
               zap = zia - zip
               xcp = xic - xip
               ycp = yic - yip
               zcp = zic - zip
               if (use_polymer) then
                  call image (xap,yap,zap)
                  call image (xcp,ycp,zcp)
               end if
               rap2 = max(xap*xap+yap*yap+zap*zap,eps)
               rcp2 = max(xcp*xcp+ycp*ycp+zcp*zcp,eps)
               dot = xap*xcp + yap*ycp + zap*zcp
               cosine = dot / sqrt(rap2*rcp2)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               dt = angle - ideal
               dt2 = dt * dt
               dt3 = dt2 * dt
               dt4 = dt2 * dt2
               e = angunit * force * dt2
     &                * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4)
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the total bond angle bending energy
c
               ea = ea + e
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine eangle1  --  angle bend energy and derivatives  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "eangle1" calculates the angle bending potential energy and
c     the first derivatives with respect to Cartesian coordinates;
c     projected in-plane angles at trigonal centers, special linear
c     or Fourier angle bending terms are optionally used
c
c
      subroutine eangle1
      use angbnd
      use angpot
      use atoms
      use bound
      use deriv
      use energi
      use group
      use math
      use usage
      use virial
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps
      real*8 ideal,force
      real*8 fold,factor,dot
      real*8 cosine,sine
      real*8 angle,fgrp
      real*8 dt,dt2,dt3,dt4
      real*8 deddt,term
      real*8 terma,termc
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 xp,yp,zp,rp
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 xip,yip,zip
      real*8 xap,yap,zap
      real*8 xcp,ycp,zcp
      real*8 rab2,rcb2
      real*8 rap2,rcp2
      real*8 xt,yt,zt
      real*8 rt2,ptrt2
      real*8 xm,ym,zm,rm
      real*8 delta,delta2
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 dedxip,dedyip,dedzip
      real*8 dpdxia,dpdyia,dpdzia
      real*8 dpdxic,dpdyic,dpdzic
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out energy and first derivative components
c
      ea = 0.0d0
      do i = 1, n
         dea(1,i) = 0.0d0
         dea(2,i) = 0.0d0
         dea(3,i) = 0.0d0
      end do
      if (nangle .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nangle,iang,anat,ak,afld,
!$OMP& use,x,y,z,cang,qang,pang,sang,angtyp,angunit,eps,use_group,
!$OMP& use_polymer)
!$OMP& shared(ea,dea,vir)
!$OMP DO reduction(+:ea,dea,vir)
c
c     calculate the bond angle bending energy term
c
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         id = iang(4,i)
         ideal = anat(i)
         force = ak(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (angtyp(i) .eq. 'IN-PLANE') then
            if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
            if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                                 use(ic) .or. use(id))
         else
            if (use_group)  call groups (proceed,fgrp,ia,ib,ic,0,0,0)
            if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic))
         end if
c
c     get the coordinates of the atoms in the 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)
c
c     compute the bond angle bending energy and gradient
c
            if (angtyp(i) .ne. 'IN-PLANE') then
               xab = xia - xib
               yab = yia - yib
               zab = zia - zib
               xcb = xic - xib
               ycb = yic - yib
               zcb = zic - zib
               if (use_polymer) then
                  call image (xab,yab,zab)
                  call image (xcb,ycb,zcb)
               end if
               rab2 = max(xab*xab+yab*yab+zab*zab,eps)
               rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
               xp = ycb*zab - zcb*yab
               yp = zcb*xab - xcb*zab
               zp = xcb*yab - ycb*xab
               rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps))
               dot = xab*xcb + yab*ycb + zab*zcb
               cosine = dot / sqrt(rab2*rcb2)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
c
c     get the energy and master chain rule term for derivatives
c
               if (angtyp(i) .eq. 'HARMONIC') then
                  dt = angle - ideal
                  dt2 = dt * dt
                  dt3 = dt2 * dt
                  dt4 = dt2 * dt2
                  e = angunit * force * dt2
     &                   * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4)
                  deddt = angunit * force * dt * radian
     &                       * (2.0d0 + 3.0d0*cang*dt + 4.0d0*qang*dt2
     &                            + 5.0d0*pang*dt3 + 6.0d0*sang*dt4)
               else if (angtyp(i) .eq. 'LINEAR') then
                  factor = 2.0d0 * angunit * radian**2
                  sine = sqrt(1.0d0-cosine*cosine)
                  e = factor * force * (1.0d0+cosine)
                  deddt = -factor * force * sine
               else if (angtyp(i) .eq. 'FOURIER') then
                  fold = afld(i)
                  factor = 2.0d0 * angunit * (radian/fold)**2
                  cosine = cos((fold*angle-ideal)/radian)
                  sine = sin((fold*angle-ideal)/radian)
                  e = factor * force * (1.0d0+cosine)
                  deddt = -factor * force * fold * sine
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  e = e * fgrp
                  deddt = deddt * fgrp
               end if
c
c     compute derivative components for this interaction
c
               terma = -deddt / (rab2*rp)
               termc = deddt / (rcb2*rp)
               dedxia = terma * (yab*zp-zab*yp)
               dedyia = terma * (zab*xp-xab*zp)
               dedzia = terma * (xab*yp-yab*xp)
               dedxic = termc * (ycb*zp-zcb*yp)
               dedyic = termc * (zcb*xp-xcb*zp)
               dedzic = termc * (xcb*yp-ycb*xp)
               dedxib = -dedxia - dedxic
               dedyib = -dedyia - dedyic
               dedzib = -dedzia - dedzic
c
c     increment the total bond angle energy and derivatives
c
               ea = ea + e
               dea(1,ia) = dea(1,ia) + dedxia
               dea(2,ia) = dea(2,ia) + dedyia
               dea(3,ia) = dea(3,ia) + dedzia
               dea(1,ib) = dea(1,ib) + dedxib
               dea(2,ib) = dea(2,ib) + dedyib
               dea(3,ib) = dea(3,ib) + dedzib
               dea(1,ic) = dea(1,ic) + dedxic
               dea(2,ic) = dea(2,ic) + dedyic
               dea(3,ic) = dea(3,ic) + dedzic
c
c     increment the internal virial tensor components
c
               vxx = xab*dedxia + xcb*dedxic
               vyx = yab*dedxia + ycb*dedxic
               vzx = zab*dedxia + zcb*dedxic
               vyy = yab*dedyia + ycb*dedyic
               vzy = zab*dedyia + zcb*dedyic
               vzz = zab*dedzia + zcb*dedzic
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vyx
               vir(3,1) = vir(3,1) + vzx
               vir(1,2) = vir(1,2) + vyx
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vzy
               vir(1,3) = vir(1,3) + vzx
               vir(2,3) = vir(2,3) + vzy
               vir(3,3) = vir(3,3) + vzz
c
c     compute the projected in-plane angle energy and gradient
c
            else
               xid = x(id)
               yid = y(id)
               zid = z(id)
               xad = xia - xid
               yad = yia - yid
               zad = zia - zid
               xbd = xib - xid
               ybd = yib - yid
               zbd = zib - zid
               xcd = xic - xid
               ycd = yic - yid
               zcd = zic - zid
               if (use_polymer) then
                  call image (xad,yad,zad)
                  call image (xbd,ybd,zbd)
                  call image (xcd,ycd,zcd)
               end if
               xt = yad*zcd - zad*ycd
               yt = zad*xcd - xad*zcd
               zt = xad*ycd - yad*xcd
               rt2 = max(xt*xt+yt*yt+zt*zt,eps)
               delta = -(xt*xbd + yt*ybd + zt*zbd) / rt2
               xip = xib + xt*delta
               yip = yib + yt*delta
               zip = zib + zt*delta
               xap = xia - xip
               yap = yia - yip
               zap = zia - zip
               xcp = xic - xip
               ycp = yic - yip
               zcp = zic - zip
               if (use_polymer) then
                  call image (xap,yap,zap)
                  call image (xcp,ycp,zcp)
               end if
               rap2 = max(xap*xap+yap*yap+zap*zap,eps)
               rcp2 = max(xcp*xcp+ycp*ycp+zcp*zcp,eps)
               xm = ycp*zap - zcp*yap
               ym = zcp*xap - xcp*zap
               zm = xcp*yap - ycp*xap
               rm = sqrt(max(xm*xm+ym*ym+zm*zm,eps))
               dot = xap*xcp + yap*ycp + zap*zcp
               cosine = dot / sqrt(rap2*rcp2)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
c
c     get the energy and master chain rule term for derivatives
c
               dt = angle - ideal
               dt2 = dt * dt
               dt3 = dt2 * dt
               dt4 = dt2 * dt2
               e = angunit * force * dt2
     &                * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4)
               deddt = angunit * force * dt * radian
     &                    * (2.0d0 + 3.0d0*cang*dt + 4.0d0*qang*dt2
     &                         + 5.0d0*pang*dt3 + 6.0d0*sang*dt4)
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  e = e * fgrp
                  deddt = deddt * fgrp
               end if
c
c     chain rule terms for first derivative components
c
               terma = -deddt / (rap2*rm)
               termc = deddt / (rcp2*rm)
               dedxia = terma * (yap*zm-zap*ym)
               dedyia = terma * (zap*xm-xap*zm)
               dedzia = terma * (xap*ym-yap*xm)
               dedxic = termc * (ycp*zm-zcp*ym)
               dedyic = termc * (zcp*xm-xcp*zm)
               dedzic = termc * (xcp*ym-ycp*xm)
               dedxip = -dedxia - dedxic
               dedyip = -dedyia - dedyic
               dedzip = -dedzia - dedzic
c
c     chain rule components for the projection of the central atom
c
               delta2 = 2.0d0 * delta
               ptrt2 = (dedxip*xt + dedyip*yt + dedzip*zt) / rt2
               term = (zcd*ybd-ycd*zbd) + delta2*(yt*zcd-zt*ycd)
               dpdxia = delta*(ycd*dedzip-zcd*dedyip) + term*ptrt2
               term = (xcd*zbd-zcd*xbd) + delta2*(zt*xcd-xt*zcd)
               dpdyia = delta*(zcd*dedxip-xcd*dedzip) + term*ptrt2
               term = (ycd*xbd-xcd*ybd) + delta2*(xt*ycd-yt*xcd)
               dpdzia = delta*(xcd*dedyip-ycd*dedxip) + term*ptrt2
               term = (yad*zbd-zad*ybd) + delta2*(zt*yad-yt*zad)
               dpdxic = delta*(zad*dedyip-yad*dedzip) + term*ptrt2
               term = (zad*xbd-xad*zbd) + delta2*(xt*zad-zt*xad)
               dpdyic = delta*(xad*dedzip-zad*dedxip) + term*ptrt2
               term = (xad*ybd-yad*xbd) + delta2*(yt*xad-xt*yad)
               dpdzic = delta*(yad*dedxip-xad*dedyip) + term*ptrt2
c
c     compute derivative components for this interaction
c
               dedxia = dedxia + dpdxia
               dedyia = dedyia + dpdyia
               dedzia = dedzia + dpdzia
               dedxib = dedxip
               dedyib = dedyip
               dedzib = dedzip
               dedxic = dedxic + dpdxic
               dedyic = dedyic + dpdyic
               dedzic = dedzic + dpdzic
               dedxid = -dedxia - dedxib - dedxic
               dedyid = -dedyia - dedyib - dedyic
               dedzid = -dedzia - dedzib - dedzic
c
c     increment the total bond angle energy and derivatives
c
               ea = ea + e
               dea(1,ia) = dea(1,ia) + dedxia
               dea(2,ia) = dea(2,ia) + dedyia
               dea(3,ia) = dea(3,ia) + dedzia
               dea(1,ib) = dea(1,ib) + dedxib
               dea(2,ib) = dea(2,ib) + dedyib
               dea(3,ib) = dea(3,ib) + dedzib
               dea(1,ic) = dea(1,ic) + dedxic
               dea(2,ic) = dea(2,ic) + dedyic
               dea(3,ic) = dea(3,ic) + dedzic
               dea(1,id) = dea(1,id) + dedxid
               dea(2,id) = dea(2,id) + dedyid
               dea(3,id) = dea(3,id) + dedzid
c
c     increment the internal virial tensor components
c
               vxx = xad*dedxia + xbd*dedxib + xcd*dedxic
               vyx = yad*dedxia + ybd*dedxib + ycd*dedxic
               vzx = zad*dedxia + zbd*dedxib + zcd*dedxic
               vyy = yad*dedyia + ybd*dedyib + ycd*dedyic
               vzy = zad*dedyia + zbd*dedyib + zcd*dedyic
               vzz = zad*dedzia + zbd*dedzib + zcd*dedzic
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vyx
               vir(3,1) = vir(3,1) + vzx
               vir(1,2) = vir(1,2) + vyx
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vzy
               vir(1,3) = vir(1,3) + vzx
               vir(2,3) = vir(2,3) + vzy
               vir(3,3) = vir(3,3) + vzz
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eangle2  --  atom-by-atom angle bend Hessian  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "eangle2" calculates second derivatives of the angle bending
c     energy for a single atom using a mixture of analytical and
c     finite difference methods; projected in-plane angles at trigonal
c     centers, special linear or Fourier angle bending terms are
c     optionally used
c
c
      subroutine eangle2 (i)
      use angbnd
      use angpot
      use atoms
      use group
      use hessn
      implicit none
      integer i,j,k
      integer ia,ib,ic,id
      real*8 eps,fgrp
      real*8 old,term
      real*8, allocatable :: de(:,:)
      real*8, allocatable :: d0(:,:)
      logical proceed
      logical twosided
c
c
c     compute analytical angle bending Hessian elements
c
      call eangle2a (i)
c
c     set stepsize for derivatives and default group weight
c
      eps = 1.0d-5
      fgrp = 1.0d0
      twosided = .false.
      if (n .le. 50)  twosided = .true.
c
c     perform dynamic allocation of some local arrays
c
      allocate (de(3,n))
      allocate (d0(3,n))
c
c     calculate numerical in-plane bend Hessian for current atom
c
      do k = 1, nangle
         proceed = .false.
         if (angtyp(k) .eq. 'IN-PLANE') then
            ia = iang(1,k)
            ib = iang(2,k)
            ic = iang(3,k)
            id = iang(4,k)
            proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic .or. i.eq.id)
            if (proceed .and. use_group)
     &         call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         end if
         if (proceed) then
            term = fgrp / eps
c
c     find first derivatives for the base structure
c
            if (.not. twosided) then
               call eangle2b (k,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
               end do
            end if
c
c     find numerical x-components via perturbed structures
c
            old = x(i)
            if (twosided) then
               x(i) = x(i) - 0.5d0*eps
               call eangle2b (k,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
               end do
            end if
            x(i) = x(i) + eps
            call eangle2b (k,de)
            x(i) = old
            do j = 1, 3
               hessx(j,ia) = hessx(j,ia) + term*(de(j,ia)-d0(j,ia))
               hessx(j,ib) = hessx(j,ib) + term*(de(j,ib)-d0(j,ib))
               hessx(j,ic) = hessx(j,ic) + term*(de(j,ic)-d0(j,ic))
               hessx(j,id) = hessx(j,id) + term*(de(j,id)-d0(j,id))
            end do
c
c     find numerical y-components via perturbed structures
c
            old = y(i)
            if (twosided) then
               y(i) = y(i) - 0.5d0*eps
               call eangle2b (k,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
               end do
            end if
            y(i) = y(i) + eps
            call eangle2b (k,de)
            y(i) = old
            do j = 1, 3
               hessy(j,ia) = hessy(j,ia) + term*(de(j,ia)-d0(j,ia))
               hessy(j,ib) = hessy(j,ib) + term*(de(j,ib)-d0(j,ib))
               hessy(j,ic) = hessy(j,ic) + term*(de(j,ic)-d0(j,ic))
               hessy(j,id) = hessy(j,id) + term*(de(j,id)-d0(j,id))
            end do
c
c     find numerical z-components via perturbed structures
c
            old = z(i)
            if (twosided) then
               z(i) = z(i) - 0.5d0*eps
               call eangle2b (k,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
               end do
            end if
            z(i) = z(i) + eps
            call eangle2b (k,de)
            z(i) = old
            do j = 1, 3
               hessz(j,ia) = hessz(j,ia) + term*(de(j,ia)-d0(j,ia))
               hessz(j,ib) = hessz(j,ib) + term*(de(j,ib)-d0(j,ib))
               hessz(j,ic) = hessz(j,ic) + term*(de(j,ic)-d0(j,ic))
               hessz(j,id) = hessz(j,id) + term*(de(j,id)-d0(j,id))
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (de)
      deallocate (d0)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine eangle2a  --  angle bending Hessian; analytical  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "eangle2a" calculates bond angle bending potential energy
c     second derivatives with respect to Cartesian coordinates
c
c
      subroutine eangle2a (iatom)
      use angbnd
      use angpot
      use atoms
      use bound
      use group
      use hessn
      use math
      implicit none
      integer i,iatom
      integer ia,ib,ic
      real*8 eps,seps
      real*8 ideal,force
      real*8 fold,factor,dot
      real*8 cosine,sine
      real*8 angle,fgrp
      real*8 dt,dt2,dt3,dt4
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rcb2
      real*8 xpo,ypo,zpo
      real*8 xp,yp,zp,rp,rp2
      real*8 xrab,yrab,zrab
      real*8 xrcb,yrcb,zrcb
      real*8 xabp,yabp,zabp
      real*8 xcbp,ycbp,zcbp
      real*8 deddt,d2eddt2
      real*8 terma,termc
      real*8 ddtdxia,ddtdyia,ddtdzia
      real*8 ddtdxib,ddtdyib,ddtdzib
      real*8 ddtdxic,ddtdyic,ddtdzic
      real*8 dxiaxia,dxiayia,dxiazia
      real*8 dxibxib,dxibyib,dxibzib
      real*8 dxicxic,dxicyic,dxiczic
      real*8 dyiayia,dyiazia,dziazia
      real*8 dyibyib,dyibzib,dzibzib
      real*8 dyicyic,dyiczic,dziczic
      real*8 dxibxia,dxibyia,dxibzia
      real*8 dyibxia,dyibyia,dyibzia
      real*8 dzibxia,dzibyia,dzibzia
      real*8 dxibxic,dxibyic,dxibzic
      real*8 dyibxic,dyibyic,dyibzic
      real*8 dzibxic,dzibyic,dzibzic
      real*8 dxiaxic,dxiayic,dxiazic
      real*8 dyiaxic,dyiayic,dyiazic
      real*8 dziaxic,dziayic,dziazic
      logical proceed,linear
c
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
      seps = sqrt(eps)
c
c     calculate the bond angle bending energy term
c
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         ideal = anat(i)
         force = ak(i)
c
c     decide whether to compute the current interaction
c
         proceed = (iatom.eq.ia .or. iatom.eq.ib .or. iatom.eq.ic)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,0,0,0)
c
c     get the coordinates of the atoms in the 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)
c
c     compute the bond angle bending Hessian elements
c
            if (angtyp(i) .ne. 'IN-PLANE') then
               xab = xia - xib
               yab = yia - yib
               zab = zia - zib
               xcb = xic - xib
               ycb = yic - yib
               zcb = zic - zib
               if (use_polymer) then
                  call image (xab,yab,zab)
                  call image (xcb,ycb,zcb)
               end if
               rab2 = max(xab*xab+yab*yab+zab*zab,eps)
               rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
               xp = ycb*zab - zcb*yab
               yp = zcb*xab - xcb*zab
               zp = xcb*yab - ycb*xab
               rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps))
               dot = xab*xcb + yab*ycb + zab*zcb
               cosine = dot / sqrt(rab2*rcb2)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
c
c     get the master chain rule terms for derivatives
c
               if (angtyp(i) .eq. 'HARMONIC') then
                  dt = angle - ideal
                  dt2 = dt * dt
                  dt3 = dt2 * dt
                  dt4 = dt3 * dt
                  deddt = angunit * force * dt * radian
     &                       * (2.0d0 + 3.0d0*cang*dt + 4.0d0*qang*dt2
     &                            + 5.0d0*pang*dt3 + 6.0d0*sang*dt4)
                  d2eddt2 = angunit * force * radian**2
     &                     * (2.0d0 + 6.0d0*cang*dt + 12.0d0*qang*dt2
     &                          + 20.0d0*pang*dt3 + 30.0d0*sang*dt4)
               else if (angtyp(i) .eq. 'LINEAR') then
                  factor = 2.0d0 * angunit * radian**2
                  sine = sqrt(1.0d0-cosine*cosine)
                  deddt = -factor * force * sine
                  d2eddt2 = -factor * force * cosine
               else if (angtyp(i) .eq. 'FOURIER') then
                  fold = afld(i)
                  factor = 2.0d0 * angunit * (radian**2/fold)
                  cosine = cos((fold*angle-ideal)/radian)
                  sine = sin((fold*angle-ideal)/radian)
                  deddt = -factor * force * sine
                  d2eddt2 = -factor * force * fold * cosine
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  deddt = deddt * fgrp
                  d2eddt2 = d2eddt2 * fgrp
               end if
c
c     construct an orthogonal direction for linear angles
c
               linear = .false.
               if (rp .le. seps) then
                  linear = .true.
                  if (xab.ne.0.0d0 .and. yab.ne.0.0d0) then
                     xp = -yab
                     yp = xab
                     zp = 0.0d0
                  else if (xab.eq.0.0d0 .and. yab.eq.0.0d0) then
                     xp = 1.0d0
                     yp = 0.0d0
                     zp = 0.0d0
                  else if (xab.ne.0.0d0 .and. yab.eq.0.0d0) then
                     xp = 0.0d0
                     yp = 1.0d0
                     zp = 0.0d0
                  else if (xab.eq.0.0d0 .and. yab.ne.0.0d0) then
                     xp = 1.0d0
                     yp = 0.0d0
                     zp = 0.0d0
                  end if
                  rp = sqrt(xp*xp + yp*yp + zp*zp)
               end if
c
c     first derivatives of bond angle with respect to coordinates
c
   10          continue
               terma = -1.0d0 / (rab2*rp)
               termc = 1.0d0 / (rcb2*rp)
               ddtdxia = terma * (yab*zp-zab*yp)
               ddtdyia = terma * (zab*xp-xab*zp)
               ddtdzia = terma * (xab*yp-yab*xp)
               ddtdxic = termc * (ycb*zp-zcb*yp)
               ddtdyic = termc * (zcb*xp-xcb*zp)
               ddtdzic = termc * (xcb*yp-ycb*xp)
               ddtdxib = -ddtdxia - ddtdxic
               ddtdyib = -ddtdyia - ddtdyic
               ddtdzib = -ddtdzia - ddtdzic
c
c     abbreviations used in defining chain rule terms
c
               xrab = 2.0d0 * xab / rab2
               yrab = 2.0d0 * yab / rab2
               zrab = 2.0d0 * zab / rab2
               xrcb = 2.0d0 * xcb / rcb2
               yrcb = 2.0d0 * ycb / rcb2
               zrcb = 2.0d0 * zcb / rcb2
               rp2 = 1.0d0 / (rp*rp)
               xabp = (yab*zp-zab*yp) * rp2
               yabp = (zab*xp-xab*zp) * rp2
               zabp = (xab*yp-yab*xp) * rp2
               xcbp = (ycb*zp-zcb*yp) * rp2
               ycbp = (zcb*xp-xcb*zp) * rp2
               zcbp = (xcb*yp-ycb*xp) * rp2
c
c     chain rule terms for second derivative components
c
               dxiaxia = terma*(xab*xcb-dot) + ddtdxia*(xcbp-xrab)
               dxiayia = terma*(zp+yab*xcb) + ddtdxia*(ycbp-yrab)
               dxiazia = terma*(zab*xcb-yp) + ddtdxia*(zcbp-zrab)
               dyiayia = terma*(yab*ycb-dot) + ddtdyia*(ycbp-yrab)
               dyiazia = terma*(xp+zab*ycb) + ddtdyia*(zcbp-zrab)
               dziazia = terma*(zab*zcb-dot) + ddtdzia*(zcbp-zrab)
               dxicxic = termc*(dot-xab*xcb) - ddtdxic*(xabp+xrcb)
               dxicyic = termc*(zp-ycb*xab) - ddtdxic*(yabp+yrcb)
               dxiczic = -termc*(yp+zcb*xab) - ddtdxic*(zabp+zrcb)
               dyicyic = termc*(dot-yab*ycb) - ddtdyic*(yabp+yrcb)
               dyiczic = termc*(xp-zcb*yab) - ddtdyic*(zabp+zrcb)
               dziczic = termc*(dot-zab*zcb) - ddtdzic*(zabp+zrcb)
               dxiaxic = terma*(yab*yab+zab*zab) - ddtdxia*xabp
               dxiayic = -terma*xab*yab - ddtdxia*yabp
               dxiazic = -terma*xab*zab - ddtdxia*zabp
               dyiaxic = -terma*xab*yab - ddtdyia*xabp
               dyiayic = terma*(xab*xab+zab*zab) - ddtdyia*yabp
               dyiazic = -terma*yab*zab - ddtdyia*zabp
               dziaxic = -terma*xab*zab - ddtdzia*xabp
               dziayic = -terma*yab*zab - ddtdzia*yabp
               dziazic = terma*(xab*xab+yab*yab) - ddtdzia*zabp
c
c     get some second derivative chain rule terms by difference
c
               dxibxia = -dxiaxia - dxiaxic
               dxibyia = -dxiayia - dyiaxic
               dxibzia = -dxiazia - dziaxic
               dyibxia = -dxiayia - dxiayic
               dyibyia = -dyiayia - dyiayic
               dyibzia = -dyiazia - dziayic
               dzibxia = -dxiazia - dxiazic
               dzibyia = -dyiazia - dyiazic
               dzibzia = -dziazia - dziazic
               dxibxic = -dxicxic - dxiaxic
               dxibyic = -dxicyic - dxiayic
               dxibzic = -dxiczic - dxiazic
               dyibxic = -dxicyic - dyiaxic
               dyibyic = -dyicyic - dyiayic
               dyibzic = -dyiczic - dyiazic
               dzibxic = -dxiczic - dziaxic
               dzibyic = -dyiczic - dziayic
               dzibzic = -dziczic - dziazic
               dxibxib = -dxibxia - dxibxic
               dxibyib = -dxibyia - dxibyic
               dxibzib = -dxibzia - dxibzic
               dyibyib = -dyibyia - dyibyic
               dyibzib = -dyibzia - dyibzic
               dzibzib = -dzibzia - dzibzic
c
c     increment diagonal and off-diagonal Hessian elements
c
               if (ia .eq. iatom) then
                  hessx(1,ia) = hessx(1,ia) + deddt*dxiaxia
     &                               + d2eddt2*ddtdxia*ddtdxia
                  hessx(2,ia) = hessx(2,ia) + deddt*dxiayia
     &                               + d2eddt2*ddtdxia*ddtdyia
                  hessx(3,ia) = hessx(3,ia) + deddt*dxiazia
     &                               + d2eddt2*ddtdxia*ddtdzia
                  hessy(1,ia) = hessy(1,ia) + deddt*dxiayia
     &                               + d2eddt2*ddtdyia*ddtdxia
                  hessy(2,ia) = hessy(2,ia) + deddt*dyiayia
     &                               + d2eddt2*ddtdyia*ddtdyia
                  hessy(3,ia) = hessy(3,ia) + deddt*dyiazia
     &                               + d2eddt2*ddtdyia*ddtdzia
                  hessz(1,ia) = hessz(1,ia) + deddt*dxiazia
     &                               + d2eddt2*ddtdzia*ddtdxia
                  hessz(2,ia) = hessz(2,ia) + deddt*dyiazia
     &                               + d2eddt2*ddtdzia*ddtdyia
                  hessz(3,ia) = hessz(3,ia) + deddt*dziazia
     &                               + d2eddt2*ddtdzia*ddtdzia
                  hessx(1,ib) = hessx(1,ib) + deddt*dxibxia
     &                               + d2eddt2*ddtdxia*ddtdxib
                  hessx(2,ib) = hessx(2,ib) + deddt*dyibxia
     &                               + d2eddt2*ddtdxia*ddtdyib
                  hessx(3,ib) = hessx(3,ib) + deddt*dzibxia
     &                               + d2eddt2*ddtdxia*ddtdzib
                  hessy(1,ib) = hessy(1,ib) + deddt*dxibyia
     &                               + d2eddt2*ddtdyia*ddtdxib
                  hessy(2,ib) = hessy(2,ib) + deddt*dyibyia
     &                               + d2eddt2*ddtdyia*ddtdyib
                  hessy(3,ib) = hessy(3,ib) + deddt*dzibyia
     &                               + d2eddt2*ddtdyia*ddtdzib
                  hessz(1,ib) = hessz(1,ib) + deddt*dxibzia
     &                               + d2eddt2*ddtdzia*ddtdxib
                  hessz(2,ib) = hessz(2,ib) + deddt*dyibzia
     &                               + d2eddt2*ddtdzia*ddtdyib
                  hessz(3,ib) = hessz(3,ib) + deddt*dzibzia
     &                               + d2eddt2*ddtdzia*ddtdzib
                  hessx(1,ic) = hessx(1,ic) + deddt*dxiaxic
     &                               + d2eddt2*ddtdxia*ddtdxic
                  hessx(2,ic) = hessx(2,ic) + deddt*dxiayic
     &                               + d2eddt2*ddtdxia*ddtdyic
                  hessx(3,ic) = hessx(3,ic) + deddt*dxiazic
     &                               + d2eddt2*ddtdxia*ddtdzic
                  hessy(1,ic) = hessy(1,ic) + deddt*dyiaxic
     &                               + d2eddt2*ddtdyia*ddtdxic
                  hessy(2,ic) = hessy(2,ic) + deddt*dyiayic
     &                               + d2eddt2*ddtdyia*ddtdyic
                  hessy(3,ic) = hessy(3,ic) + deddt*dyiazic
     &                               + d2eddt2*ddtdyia*ddtdzic
                  hessz(1,ic) = hessz(1,ic) + deddt*dziaxic
     &                               + d2eddt2*ddtdzia*ddtdxic
                  hessz(2,ic) = hessz(2,ic) + deddt*dziayic
     &                               + d2eddt2*ddtdzia*ddtdyic
                  hessz(3,ic) = hessz(3,ic) + deddt*dziazic
     &                               + d2eddt2*ddtdzia*ddtdzic
               else if (ib .eq. iatom) then
                  hessx(1,ib) = hessx(1,ib) + deddt*dxibxib
     &                               + d2eddt2*ddtdxib*ddtdxib
                  hessx(2,ib) = hessx(2,ib) + deddt*dxibyib
     &                               + d2eddt2*ddtdxib*ddtdyib
                  hessx(3,ib) = hessx(3,ib) + deddt*dxibzib
     &                               + d2eddt2*ddtdxib*ddtdzib
                  hessy(1,ib) = hessy(1,ib) + deddt*dxibyib
     &                               + d2eddt2*ddtdyib*ddtdxib
                  hessy(2,ib) = hessy(2,ib) + deddt*dyibyib
     &                               + d2eddt2*ddtdyib*ddtdyib
                  hessy(3,ib) = hessy(3,ib) + deddt*dyibzib
     &                               + d2eddt2*ddtdyib*ddtdzib
                  hessz(1,ib) = hessz(1,ib) + deddt*dxibzib
     &                               + d2eddt2*ddtdzib*ddtdxib
                  hessz(2,ib) = hessz(2,ib) + deddt*dyibzib
     &                               + d2eddt2*ddtdzib*ddtdyib
                  hessz(3,ib) = hessz(3,ib) + deddt*dzibzib
     &                               + d2eddt2*ddtdzib*ddtdzib
                  hessx(1,ia) = hessx(1,ia) + deddt*dxibxia
     &                               + d2eddt2*ddtdxib*ddtdxia
                  hessx(2,ia) = hessx(2,ia) + deddt*dxibyia
     &                               + d2eddt2*ddtdxib*ddtdyia
                  hessx(3,ia) = hessx(3,ia) + deddt*dxibzia
     &                               + d2eddt2*ddtdxib*ddtdzia
                  hessy(1,ia) = hessy(1,ia) + deddt*dyibxia
     &                               + d2eddt2*ddtdyib*ddtdxia
                  hessy(2,ia) = hessy(2,ia) + deddt*dyibyia
     &                               + d2eddt2*ddtdyib*ddtdyia
                  hessy(3,ia) = hessy(3,ia) + deddt*dyibzia
     &                               + d2eddt2*ddtdyib*ddtdzia
                  hessz(1,ia) = hessz(1,ia) + deddt*dzibxia
     &                               + d2eddt2*ddtdzib*ddtdxia
                  hessz(2,ia) = hessz(2,ia) + deddt*dzibyia
     &                               + d2eddt2*ddtdzib*ddtdyia
                  hessz(3,ia) = hessz(3,ia) + deddt*dzibzia
     &                               + d2eddt2*ddtdzib*ddtdzia
                  hessx(1,ic) = hessx(1,ic) + deddt*dxibxic
     &                               + d2eddt2*ddtdxib*ddtdxic
                  hessx(2,ic) = hessx(2,ic) + deddt*dxibyic
     &                               + d2eddt2*ddtdxib*ddtdyic
                  hessx(3,ic) = hessx(3,ic) + deddt*dxibzic
     &                               + d2eddt2*ddtdxib*ddtdzic
                  hessy(1,ic) = hessy(1,ic) + deddt*dyibxic
     &                               + d2eddt2*ddtdyib*ddtdxic
                  hessy(2,ic) = hessy(2,ic) + deddt*dyibyic
     &                               + d2eddt2*ddtdyib*ddtdyic
                  hessy(3,ic) = hessy(3,ic) + deddt*dyibzic
     &                               + d2eddt2*ddtdyib*ddtdzic
                  hessz(1,ic) = hessz(1,ic) + deddt*dzibxic
     &                               + d2eddt2*ddtdzib*ddtdxic
                  hessz(2,ic) = hessz(2,ic) + deddt*dzibyic
     &                               + d2eddt2*ddtdzib*ddtdyic
                  hessz(3,ic) = hessz(3,ic) + deddt*dzibzic
     &                               + d2eddt2*ddtdzib*ddtdzic
               else if (ic .eq. iatom) then
                  hessx(1,ic) = hessx(1,ic) + deddt*dxicxic
     &                               + d2eddt2*ddtdxic*ddtdxic
                  hessx(2,ic) = hessx(2,ic) + deddt*dxicyic
     &                               + d2eddt2*ddtdxic*ddtdyic
                  hessx(3,ic) = hessx(3,ic) + deddt*dxiczic
     &                               + d2eddt2*ddtdxic*ddtdzic
                  hessy(1,ic) = hessy(1,ic) + deddt*dxicyic
     &                               + d2eddt2*ddtdyic*ddtdxic
                  hessy(2,ic) = hessy(2,ic) + deddt*dyicyic
     &                               + d2eddt2*ddtdyic*ddtdyic
                  hessy(3,ic) = hessy(3,ic) + deddt*dyiczic
     &                               + d2eddt2*ddtdyic*ddtdzic
                  hessz(1,ic) = hessz(1,ic) + deddt*dxiczic
     &                               + d2eddt2*ddtdzic*ddtdxic
                  hessz(2,ic) = hessz(2,ic) + deddt*dyiczic
     &                               + d2eddt2*ddtdzic*ddtdyic
                  hessz(3,ic) = hessz(3,ic) + deddt*dziczic
     &                               + d2eddt2*ddtdzic*ddtdzic
                  hessx(1,ib) = hessx(1,ib) + deddt*dxibxic
     &                               + d2eddt2*ddtdxic*ddtdxib
                  hessx(2,ib) = hessx(2,ib) + deddt*dyibxic
     &                               + d2eddt2*ddtdxic*ddtdyib
                  hessx(3,ib) = hessx(3,ib) + deddt*dzibxic
     &                               + d2eddt2*ddtdxic*ddtdzib
                  hessy(1,ib) = hessy(1,ib) + deddt*dxibyic
     &                               + d2eddt2*ddtdyic*ddtdxib
                  hessy(2,ib) = hessy(2,ib) + deddt*dyibyic
     &                               + d2eddt2*ddtdyic*ddtdyib
                  hessy(3,ib) = hessy(3,ib) + deddt*dzibyic
     &                               + d2eddt2*ddtdyic*ddtdzib
                  hessz(1,ib) = hessz(1,ib) + deddt*dxibzic
     &                               + d2eddt2*ddtdzic*ddtdxib
                  hessz(2,ib) = hessz(2,ib) + deddt*dyibzic
     &                               + d2eddt2*ddtdzic*ddtdyib
                  hessz(3,ib) = hessz(3,ib) + deddt*dzibzic
     &                               + d2eddt2*ddtdzic*ddtdzib
                  hessx(1,ia) = hessx(1,ia) + deddt*dxiaxic
     &                               + d2eddt2*ddtdxic*ddtdxia
                  hessx(2,ia) = hessx(2,ia) + deddt*dyiaxic
     &                               + d2eddt2*ddtdxic*ddtdyia
                  hessx(3,ia) = hessx(3,ia) + deddt*dziaxic
     &                               + d2eddt2*ddtdxic*ddtdzia
                  hessy(1,ia) = hessy(1,ia) + deddt*dxiayic
     &                               + d2eddt2*ddtdyic*ddtdxia
                  hessy(2,ia) = hessy(2,ia) + deddt*dyiayic
     &                               + d2eddt2*ddtdyic*ddtdyia
                  hessy(3,ia) = hessy(3,ia) + deddt*dziayic
     &                               + d2eddt2*ddtdyic*ddtdzia
                  hessz(1,ia) = hessz(1,ia) + deddt*dxiazic
     &                               + d2eddt2*ddtdzic*ddtdxia
                  hessz(2,ia) = hessz(2,ia) + deddt*dyiazic
     &                               + d2eddt2*ddtdzic*ddtdyia
                  hessz(3,ia) = hessz(3,ia) + deddt*dziazic
     &                               + d2eddt2*ddtdzic*ddtdzia
               end if
c
c     construct a second orthogonal direction for linear angles
c
               if (linear) then
                  linear = .false.
                  xpo = xp
                  ypo = yp
                  zpo = zp
                  xp = ypo*zab - zpo*yab
                  yp = zpo*xab - xpo*zab
                  zp = xpo*yab - ypo*xab
                  rp = sqrt(xp*xp + yp*yp + zp*zp)
                  goto 10
               end if
            end if
         end if
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine eangle2b  --  in-plane bend Hessian; numerical  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "eangle2b" computes projected in-plane bending first derivatives
c     for a single angle with respect to Cartesian coordinates;
c     used in computation of finite difference second derivatives
c
c
      subroutine eangle2b (i,de)
      use angbnd
      use angpot
      use atoms
      use bound
      use math
      implicit none
      integer i,ia,ib,ic,id
      real*8 eps,ideal,force
      real*8 dot,cosine,angle
      real*8 dt,dt2,dt3,dt4
      real*8 deddt,term
      real*8 terma,termc
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 xip,yip,zip
      real*8 xap,yap,zap
      real*8 xcp,ycp,zcp
      real*8 rap2,rcp2
      real*8 xt,yt,zt
      real*8 rt2,ptrt2
      real*8 xm,ym,zm,rm
      real*8 delta,delta2
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 dedxip,dedyip,dedzip
      real*8 dpdxia,dpdyia,dpdzia
      real*8 dpdxic,dpdyic,dpdzic
      real*8 de(3,*)
c
c
c     set the atom numbers and parameters for this angle
c
      ia = iang(1,i)
      ib = iang(2,i)
      ic = iang(3,i)
      id = iang(4,i)
      ideal = anat(i)
      force = ak(i)
c
c     get the coordinates of the atoms in the angle
c
      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)
c
c     zero out the first derivative components
c
      de(1,ia) = 0.0d0
      de(2,ia) = 0.0d0
      de(3,ia) = 0.0d0
      de(1,ib) = 0.0d0
      de(2,ib) = 0.0d0
      de(3,ib) = 0.0d0
      de(1,ic) = 0.0d0
      de(2,ic) = 0.0d0
      de(3,ic) = 0.0d0
      de(1,id) = 0.0d0
      de(2,id) = 0.0d0
      de(3,id) = 0.0d0
c
c     compute the projected in-plane angle gradient
c
      xad = xia - xid
      yad = yia - yid
      zad = zia - zid
      xbd = xib - xid
      ybd = yib - yid
      zbd = zib - zid
      xcd = xic - xid
      ycd = yic - yid
      zcd = zic - zid
      if (use_polymer) then
         call image (xad,yad,zad)
         call image (xbd,ybd,zbd)
         call image (xcd,ycd,zcd)
      end if
      xt = yad*zcd - zad*ycd
      yt = zad*xcd - xad*zcd
      zt = xad*ycd - yad*xcd
      rt2 = max(xt*xt+yt*yt+zt*zt,eps)
      delta = -(xt*xbd + yt*ybd + zt*zbd) / rt2
      xip = xib + xt*delta
      yip = yib + yt*delta
      zip = zib + zt*delta
      xap = xia - xip
      yap = yia - yip
      zap = zia - zip
      xcp = xic - xip
      ycp = yic - yip
      zcp = zic - zip
      if (use_polymer) then
         call image (xap,yap,zap)
         call image (xcp,ycp,zcp)
      end if
      rap2 = max(xap*xap+yap*yap+zap*zap,eps)
      rcp2 = max(xcp*xcp+ycp*ycp+zcp*zcp,eps)
      xm = ycp*zap - zcp*yap
      ym = zcp*xap - xcp*zap
      zm = xcp*yap - ycp*xap
      rm = sqrt(max(xm*xm+ym*ym+zm*zm,eps))
      dot = xap*xcp + yap*ycp + zap*zcp
      cosine = dot / sqrt(rap2*rcp2)
      cosine = min(1.0d0,max(-1.0d0,cosine))
      angle = radian * acos(cosine)
c
c     get the master chain rule term for derivatives
c
      dt = angle - ideal
      dt2 = dt * dt
      dt3 = dt2 * dt
      dt4 = dt2 * dt2
      deddt = angunit * force * dt * radian
     &           * (2.0d0 + 3.0d0*cang*dt + 4.0d0*qang*dt2
     &                + 5.0d0*pang*dt3 + 6.0d0*sang*dt4)
c
c     chain rule terms for first derivative components
c
      terma = -deddt / (rap2*rm)
      termc = deddt / (rcp2*rm)
      dedxia = terma * (yap*zm-zap*ym)
      dedyia = terma * (zap*xm-xap*zm)
      dedzia = terma * (xap*ym-yap*xm)
      dedxic = termc * (ycp*zm-zcp*ym)
      dedyic = termc * (zcp*xm-xcp*zm)
      dedzic = termc * (xcp*ym-ycp*xm)
      dedxip = -dedxia - dedxic
      dedyip = -dedyia - dedyic
      dedzip = -dedzia - dedzic
c
c     chain rule components for the projection of the central atom
c
      delta2 = 2.0d0 * delta
      ptrt2 = (dedxip*xt + dedyip*yt + dedzip*zt) / rt2
      term = (zcd*ybd-ycd*zbd) + delta2*(yt*zcd-zt*ycd)
      dpdxia = delta*(ycd*dedzip-zcd*dedyip) + term*ptrt2
      term = (xcd*zbd-zcd*xbd) + delta2*(zt*xcd-xt*zcd)
      dpdyia = delta*(zcd*dedxip-xcd*dedzip) + term*ptrt2
      term = (ycd*xbd-xcd*ybd) + delta2*(xt*ycd-yt*xcd)
      dpdzia = delta*(xcd*dedyip-ycd*dedxip) + term*ptrt2
      term = (yad*zbd-zad*ybd) + delta2*(zt*yad-yt*zad)
      dpdxic = delta*(zad*dedyip-yad*dedzip) + term*ptrt2
      term = (zad*xbd-xad*zbd) + delta2*(xt*zad-zt*xad)
      dpdyic = delta*(xad*dedzip-zad*dedxip) + term*ptrt2
      term = (xad*ybd-yad*xbd) + delta2*(yt*xad-xt*yad)
      dpdzic = delta*(yad*dedxip-xad*dedyip) + term*ptrt2
c
c     compute derivative components for this interaction
c
      dedxia = dedxia + dpdxia
      dedyia = dedyia + dpdyia
      dedzia = dedzia + dpdzia
      dedxib = dedxip
      dedyib = dedyip
      dedzib = dedzip
      dedxic = dedxic + dpdxic
      dedyic = dedyic + dpdyic
      dedzic = dedzic + dpdzic
      dedxid = -dedxia - dedxib - dedxic
      dedyid = -dedyia - dedyib - dedyic
      dedzid = -dedzia - dedzib - dedzic
c
c     set the in-plane angle bending first derivatives
c
      de(1,ia) = dedxia
      de(2,ia) = dedyia
      de(3,ia) = dedzia
      de(1,ib) = dedxib
      de(2,ib) = dedyib
      de(3,ib) = dedzib
      de(1,ic) = dedxic
      de(2,ic) = dedyic
      de(3,ic) = dedzic
      de(1,id) = dedxid
      de(2,id) = dedyid
      de(3,id) = dedzid
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eangle3  --  angle bending energy & analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "eangle3" calculates the angle bending potential energy, also
c     partitions the energy among the atoms; projected in-plane
c     angles at trigonal centers, spceial linear or Fourier angle
c     bending terms are optionally used
c
c
      subroutine eangle3
      use action
      use analyz
      use angbnd
      use angpot
      use atomid
      use atoms
      use bound
      use energi
      use group
      use inform
      use iounit
      use math
      use usage
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps
      real*8 ideal,force
      real*8 fold,factor
      real*8 dot,cosine
      real*8 angle,fgrp
      real*8 dt,dt2,dt3,dt4
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 xip,yip,zip
      real*8 xap,yap,zap
      real*8 xcp,ycp,zcp
      real*8 rab2,rcb2
      real*8 rap2,rcp2
      real*8 xt,yt,zt
      real*8 rt2,delta
      logical proceed
      logical header,huge
      character*9 label
c
c
c     zero out the angle bending energy and partitioning terms
c
      nea = 0
      ea = 0.0d0
      do i = 1, n
         aea(i) = 0.0d0
      end do
      if (nangle .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nangle.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Angle Bending Interactions :',
     &           //,' Type',18x,'Atom Names',18x,
     &              'Ideal',4x,'Actual',6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nangle,iang,anat,ak,afld,
!$OMP& use,x,y,z,cang,qang,pang,sang,angtyp,angunit,eps,use_group,
!$OMP& use_polymer,name,verbose,debug,header,iout)
!$OMP& shared(ea,nea,aea)
!$OMP DO reduction(+:ea,nea,aea)
c
c     calculate the bond angle bending energy term
c
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         id = iang(4,i)
         ideal = anat(i)
         force = ak(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (angtyp(i) .eq. 'IN-PLANE') then
            if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
            if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                                 use(ic) .or. use(id))
         else
            if (use_group)  call groups (proceed,fgrp,ia,ib,ic,0,0,0)
            if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic))
         end if
c
c     get the coordinates of the atoms in the 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)
c
c     compute the bond angle bending energy
c
            if (angtyp(i) .ne. 'IN-PLANE') then
               xab = xia - xib
               yab = yia - yib
               zab = zia - zib
               xcb = xic - xib
               ycb = yic - yib
               zcb = zic - zib
               if (use_polymer) then
                  call image (xab,yab,zab)
                  call image (xcb,ycb,zcb)
               end if
               rab2 = max(xab*xab+yab*yab+zab*zab,eps)
               rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
               dot = xab*xcb + yab*ycb + zab*zcb
               cosine = dot / sqrt(rab2*rcb2)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               if (angtyp(i) .eq. 'HARMONIC') then
                  dt = angle - ideal
                  dt2 = dt * dt
                  dt3 = dt2 * dt
                  dt4 = dt2 * dt2
                  e = angunit * force * dt2
     &                   * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4)
               else if (angtyp(i) .eq. 'LINEAR') then
                  factor = 2.0d0 * angunit * radian**2
                  e = factor * force * (1.0d0+cosine)
               else if (angtyp(i) .eq. 'FOURIER') then
                  fold = afld(i)
                  factor = 2.0d0 * angunit * (radian/fold)**2
                  cosine = cos((fold*angle-ideal)/radian)
                  e = factor * force * (1.0d0+cosine)
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the total bond angle bending energy
c
               nea = nea + 1
               ea = ea + e
               aea(ib) = aea(ib) + e
c
c     print a message if the energy of this interaction is large
c
               huge = (e .gt. 5.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual Angle Bending',
     &                          ' Interactions :',
     &                       //,' Type',18x,'Atom Names',18x,
     &                          'Ideal',4x,'Actual',6x,'Energy',/)
                  end if
                  label = 'Angle    '
                  if (angtyp(i) .eq. 'LINEAR') then
                     label = 'Angle-Lin'
                  else if (angtyp(i) .eq. 'FOURIER') then
                     label = 'Angle-Cos'
                     ideal = (ideal+180.0d0) / fold
                     if (angle-ideal .gt. 180.0d0/fold)
     &                  ideal = ideal + 360.0d0/fold
                  end if
                  write (iout,30)  label,ia,name(ia),ib,name(ib),
     &                             ic,name(ic),ideal,angle,e
   30             format (1x,a9,1x,i7,'-',a3,i7,'-',a3,i7,
     &                       '-',a3,2x,2f10.4,f12.4)
               end if
c
c     compute the projected in-plane angle bend energy
c
            else
               xid = x(id)
               yid = y(id)
               zid = z(id)
               xad = xia - xid
               yad = yia - yid
               zad = zia - zid
               xbd = xib - xid
               ybd = yib - yid
               zbd = zib - zid
               xcd = xic - xid
               ycd = yic - yid
               zcd = zic - zid
               if (use_polymer) then
                  call image (xad,yad,zad)
                  call image (xbd,ybd,zbd)
                  call image (xcd,ycd,zcd)
               end if
               xt = yad*zcd - zad*ycd
               yt = zad*xcd - xad*zcd
               zt = xad*ycd - yad*xcd
               rt2 = xt*xt + yt*yt + zt*zt
               delta = -(xt*xbd + yt*ybd + zt*zbd) / rt2
               xip = xib + xt*delta
               yip = yib + yt*delta
               zip = zib + zt*delta
               xap = xia - xip
               yap = yia - yip
               zap = zia - zip
               xcp = xic - xip
               ycp = yic - yip
               zcp = zic - zip
               if (use_polymer) then
                  call image (xap,yap,zap)
                  call image (xcp,ycp,zcp)
               end if
               rap2 = max(xap*xap+yap*yap+zap*zap,eps)
               rcp2 = max(xcp*xcp+ycp*ycp+zcp*zcp,eps)
               dot = xap*xcp + yap*ycp + zap*zcp
               cosine = dot / sqrt(rap2*rcp2)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               dt = angle - ideal
               dt2 = dt * dt
               dt3 = dt2 * dt
               dt4 = dt2 * dt2
               e = angunit * force * dt2
     &                * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4)
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the total bond angle bending energy
c
               nea = nea + 1
               ea = ea + e
               aea(ib) = aea(ib) + e
c
c     print a message if the energy of this interaction is large
c
               huge = (e .gt. 5.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,40)
   40                format (/,' Individual Angle Bending',
     &                          ' Interactions :',
     &                       //,' Type',18x,'Atom Names',18x,
     &                          'Ideal',4x,'Actual',6x,'Energy',/)
                  end if
                  write (iout,50)  ia,name(ia),ib,name(ib),ic,
     &                             name(ic),ideal,angle,e
   50             format (' Angle-IP',2x,i7,'-',a3,i7,'-',a3,i7,
     &                       '-',a3,2x,2f10.4,f12.4)
               end if
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder  ##
c     ##                  All Rights Reserved                 ##
c     ##########################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eangtor  --  angle-torsion cross term energy  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "eangtor" calculates the angle-torsion potential energy
c
c
      subroutine eangtor
      use angtor
      use atoms
      use angbnd
      use bound
      use energi
      use group
      use math
      use torpot
      use tors
      use usage
      implicit none
      integer i,k,iangtor
      integer ia,ib,ic,id
      real*8 e,e1,e2
      real*8 eps,fgrp
      real*8 rba,rcb,rdc
      real*8 rt2,ru2,rtru
      real*8 dot,dt
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 sine3,cosine3
      real*8 phi1,phi2,phi3
      real*8 angle,cosang
      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
      real*8 xdc,ydc,zdc
      logical proceed
c
c
c     zero out the energy due to extra potential terms
c
      eat = 0.0d0
      if (nangtor .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nangtor,iat,itors,kant,anat,
!$OMP& tors1,tors2,tors3,use,x,y,z,atorunit,eps,use_group,use_polymer)
!$OMP& shared(eat)
!$OMP DO reduction(+:eat)
c
c     calculate the angle-torsion interaction energy term
c
      do iangtor = 1, nangtor
         i = iat(1,iangtor)
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rba = sqrt(max(xba*xba+yba*yba+zba*zba,eps))
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            rdc = sqrt(max(xdc*xdc+ydc*ydc+zdc*zdc,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2*ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     compute multiple angle trigonometry and phase terms
c
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            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)
c
c     get the angle-torsion values for the first angle
c
            v1 = kant(1,iangtor)
            v2 = kant(2,iangtor)
            v3 = kant(3,iangtor)
            k = iat(2,iangtor)
            dot = xba*xcb + yba*ycb + zba*zcb
            cosang = -dot / (rba*rcb)
            angle = radian * acos(cosang)
            dt = angle - anat(k)
            e1 = atorunit * dt * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     get the angle-torsion values for the second angle
c
            v1 = kant(4,iangtor)
            v2 = kant(5,iangtor)
            v3 = kant(6,iangtor)
            k = iat(3,iangtor)
            dot = xcb*xdc + ycb*ydc + zcb*zdc
            cosang = -dot / (rcb*rdc)
            angle = radian * acos(cosang)
            dt = angle - anat(k)
            e2 = atorunit * dt * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e1 = e1 * fgrp
               e2 = e2 * fgrp
            end if
c
c     increment the total angle-torsion energy
c
            e = e1 + e2
            eat = eat + e
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder  ##
c     ##                  All Rights Reserved                 ##
c     ##########################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine eangtor1  --  angle-torsion energy & derivs  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "eangtor1" calculates the angle-torsion energy and first
c     derivatives with respect to Cartesian coordinates
c
c
      subroutine eangtor1
      use angbnd
      use angtor
      use atoms
      use bound
      use deriv
      use energi
      use group
      use math
      use torpot
      use tors
      use usage
      use virial
      implicit none
      integer i,k,iangtor
      integer ia,ib,ic,id
      real*8 e,e1,e2
      real*8 eps,fgrp
      real*8 ddt,dedphi
      real*8 rba,rcb,rdc
      real*8 rba2,rcb2,rdc2
      real*8 rt,ru,rtru
      real*8 rt2,ru2
      real*8 dot,dt
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 sine3,cosine3
      real*8 phi1,phi2,phi3
      real*8 dphi1,dphi2,dphi3
      real*8 angle,cosang
      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
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 terma,termb
      real*8 termc,termd
      real*8 dedxt,dedyt,dedzt
      real*8 dedxu,dedyu,dedzu
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out the angle-torsion energy and first derivatives
c
      eat = 0.0d0
      do i = 1, n
         deat(1,i) = 0.0d0
         deat(2,i) = 0.0d0
         deat(3,i) = 0.0d0
      end do
      if (nangtor .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nangtor,iat,itors,kant,anat,
!$OMP& tors1,tors2,tors3,use,x,y,z,atorunit,eps,use_group,use_polymer)
!$OMP& shared(eat,deat,vir)
!$OMP DO reduction(+:eat,deat,vir)
c
c     calculate the angle-torsion energy and first derviatives
c
      do iangtor = 1, nangtor
         i = iat(1,iangtor)
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rba2 = max(xba*xba+yba*yba+zba*zba,eps)
            rba = sqrt(rba2)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
            rcb = sqrt(rcb2)
            rdc2 = max(xdc*xdc+ydc*ydc+zdc*zdc,eps)
            rdc = sqrt(rdc2)
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            rt = sqrt(rt2)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            ru = sqrt(ru2)
            rtru = rt * ru
            xca = xic - xia
            yca = yic - yia
            zca = zic - zia
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            if (use_polymer) then
               call image (xca,yca,zca)
               call image (xdb,ydb,zdb)
            end if
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     compute multiple angle trigonometry and phase terms
c
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            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     set the angle-torsion parameters for the first angle
c
            v1 = kant(1,iangtor)
            v2 = kant(2,iangtor)
            v3 = kant(3,iangtor)
            k = iat(2,iangtor)
            dot = xba*xcb + yba*ycb + zba*zcb
            cosang = -dot / (rba*rcb)
            angle = radian * acos(cosang)
            dt = angle - anat(k)
            e1 = atorunit * dt * (v1*phi1 + v2*phi2 + v3*phi3)
            dedphi = atorunit * dt * (v1*dphi1 + v2*dphi2 + v3*dphi3)
            ddt = atorunit * radian * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e1 = e1 * fgrp
               dedphi = dedphi * fgrp
               ddt = ddt * fgrp
            end if
c
c     compute derivative components for this interaction
c
            dedxt = dedphi * (zcb*yt-ycb*zt) / (rt2*rcb)
            dedyt = dedphi * (xcb*zt-zcb*xt) / (rt2*rcb)
            dedzt = dedphi * (ycb*xt-xcb*yt) / (rt2*rcb)
            dedxu = dedphi * (ycb*zu-zcb*yu) / (ru2*rcb)
            dedyu = dedphi * (zcb*xu-xcb*zu) / (ru2*rcb)
            dedzu = dedphi * (xcb*yu-ycb*xu) / (ru2*rcb)
c
c     increment chain rule components for the first angle
c
            terma = -ddt / (rba2*rt)
            termc = ddt / (rcb2*rt)
            dedxia = terma*(zba*yt-yba*zt) + zcb*dedyt - ycb*dedzt
            dedyia = terma*(xba*zt-zba*xt) + xcb*dedzt - zcb*dedxt
            dedzia = terma*(yba*xt-xba*yt) + ycb*dedxt - xcb*dedyt
            dedxib = terma*(yba*zt-zba*yt) + termc*(zcb*yt-ycb*zt)
     &                  + yca*dedzt - zca*dedyt + zdc*dedyu - ydc*dedzu
            dedyib = terma*(zba*xt-xba*zt) + termc*(xcb*zt-zcb*xt)
     &                  + zca*dedxt - xca*dedzt + xdc*dedzu - zdc*dedxu
            dedzib = terma*(xba*yt-yba*xt) + termc*(ycb*xt-xcb*yt)
     &                  + xca*dedyt - yca*dedxt + ydc*dedxu - xdc*dedyu
            dedxic = termc*(ycb*zt-zcb*yt) + zba*dedyt
     &                  - yba*dedzt + ydb*dedzu - zdb*dedyu
            dedyic = termc*(zcb*xt-xcb*zt) + xba*dedzt
     &                  - zba*dedxt + zdb*dedxu - xdb*dedzu
            dedzic = termc*(xcb*yt-ycb*xt) + yba*dedxt
     &                  - xba*dedyt + xdb*dedyu - ydb*dedxu
            dedxid = zcb*dedyu - ycb*dedzu
            dedyid = xcb*dedzu - zcb*dedxu
            dedzid = ycb*dedxu - xcb*dedyu
c
c     get the angle-torsion values for the second angle
c
            v1 = kant(4,iangtor)
            v2 = kant(5,iangtor)
            v3 = kant(6,iangtor)
            k = iat(3,iangtor)
            dot = xcb*xdc + ycb*ydc + zcb*zdc
            cosang = -dot / (rcb*rdc)
            angle = radian * acos(cosang)
            dt = angle - anat(k)
            e2 = atorunit * dt * (v1*phi1 + v2*phi2 + v3*phi3)
            dedphi = atorunit * dt * (v1*dphi1 + v2*dphi2 + v3*dphi3)
            ddt = atorunit * radian * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e2 = e2 * fgrp
               dedphi = dedphi * fgrp
               ddt = ddt * fgrp
            end if
c
c     compute derivative components for this interaction
c
            dedxt = dedphi * (zcb*yt-ycb*zt) / (rt2*rcb)
            dedyt = dedphi * (xcb*zt-zcb*xt) / (rt2*rcb)
            dedzt = dedphi * (ycb*xt-xcb*yt) / (rt2*rcb)
            dedxu = dedphi * (ycb*zu-zcb*yu) / (ru2*rcb)
            dedyu = dedphi * (zcb*xu-xcb*zu) / (ru2*rcb)
            dedzu = dedphi * (xcb*yu-ycb*xu) / (ru2*rcb)
c
c     increment chain rule components for the second angle
c
            termb = -ddt / (rcb2*ru)
            termd = ddt / (rdc2*ru)
            dedxia = dedxia + zcb*dedyt - ycb*dedzt
            dedyia = dedyia + xcb*dedzt - zcb*dedxt
            dedzia = dedzia + ycb*dedxt - xcb*dedyt
            dedxib = dedxib + termb*(zcb*yu-ycb*zu) + yca*dedzt
     &                  - zca*dedyt + zdc*dedyu - ydc*dedzu
            dedyib = dedyib + termb*(xcb*zu-zcb*xu) + zca*dedxt
     &                  - xca*dedzt + xdc*dedzu - zdc*dedxu
            dedzib = dedzib + termb*(ycb*xu-xcb*yu) + xca*dedyt
     &                  - yca*dedxt + ydc*dedxu - xdc*dedyu
            dedxic = dedxic + termb*(ycb*zu-zcb*yu)
     &                  + termd*(zdc*yu-ydc*zu) + zba*dedyt
     &                  - yba*dedzt + ydb*dedzu - zdb*dedyu
            dedyic = dedyic + termb*(zcb*xu-xcb*zu)
     &                  + termd*(xdc*zu-zdc*xu) + xba*dedzt
     &                  - zba*dedxt + zdb*dedxu - xdb*dedzu
            dedzic = dedzic + termb*(xcb*yu-ycb*xu)
     &                  + termd*(ydc*xu-xdc*yu) + yba*dedxt
     &                  - xba*dedyt + xdb*dedyu - ydb*dedxu
            dedxid = dedxid + termd*(ydc*zu-zdc*yu)
     &                  + zcb*dedyu - ycb*dedzu
            dedyid = dedyid + termd*(zdc*xu-xdc*zu)
     &                  + xcb*dedzu - zcb*dedxu
            dedzid = dedzid + termd*(xdc*yu-ydc*xu)
     &                  + ycb*dedxu - xcb*dedyu
c
c     increment the angle-torsion energy and gradient
c
            e = e1 + e2
            eat = eat + e
            deat(1,ia) = deat(1,ia) + dedxia
            deat(2,ia) = deat(2,ia) + dedyia
            deat(3,ia) = deat(3,ia) + dedzia
            deat(1,ib) = deat(1,ib) + dedxib
            deat(2,ib) = deat(2,ib) + dedyib
            deat(3,ib) = deat(3,ib) + dedzib
            deat(1,ic) = deat(1,ic) + dedxic
            deat(2,ic) = deat(2,ic) + dedyic
            deat(3,ic) = deat(3,ic) + dedzic
            deat(1,id) = deat(1,id) + dedxid
            deat(2,id) = deat(2,id) + dedyid
            deat(3,id) = deat(3,id) + dedzid
c
c     increment the internal virial tensor components
c
            vxx = xcb*(dedxic+dedxid) - xba*dedxia + xdc*dedxid
            vyx = ycb*(dedxic+dedxid) - yba*dedxia + ydc*dedxid
            vzx = zcb*(dedxic+dedxid) - zba*dedxia + zdc*dedxid
            vyy = ycb*(dedyic+dedyid) - yba*dedyia + ydc*dedyid
            vzy = zcb*(dedyic+dedyid) - zba*dedyia + zdc*dedyid
            vzz = zcb*(dedzic+dedzid) - zba*dedzia + zdc*dedzid
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder  ##
c     ##                  All Rights Reserved                 ##
c     ##########################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eangtor2  --  atomwise angle-torsion Hessian  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "eangtor2" calculates the angle-torsion potential energy
c     second derivatives with respect to Cartesian coordinates
c
c
      subroutine eangtor2 (i)
      use angbnd
      use angtor
      use atoms
      use bound
      use group
      use hessn
      use math
      use torpot
      use tors
      implicit none
      integer i,j,k,iangtor
      integer ia,ib,ic,id
      real*8 eps,fgrp
      real*8 dedphi,d2edphi2
      real*8 rba,rcb,rdc
      real*8 rba2,rcb2,rdc2
      real*8 rt,ru,rtru
      real*8 rt2,ru2
      real*8 dot,dt,d2dt
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 terma,termb
      real*8 termc,termd
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 sine3,cosine3
      real*8 angle,cosang
      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
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 xab,yab,zab
      real*8 xbc,ybc,zbc
      real*8 xrab,yrab,zrab
      real*8 xrcb,yrcb,zrcb
      real*8 xabp,yabp,zabp
      real*8 xcbp,ycbp,zcbp
      real*8 xrbc,yrbc,zrbc
      real*8 xrdc,yrdc,zrdc
      real*8 xbcp,ybcp,zbcp
      real*8 xdcp,ydcp,zdcp
      real*8 phi1,phi2,phi3
      real*8 dphi1,dphi2,dphi3
      real*8 d2phi1,d2phi2,d2phi3
      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 xycb2,xzcb2,yzcb2
      real*8 rcbxt,rcbyt,rcbzt,rcbt2
      real*8 rcbxu,rcbyu,rcbzu,rcbu2
      real*8 dphidxibt,dphidyibt,dphidzibt
      real*8 dphidxibu,dphidyibu,dphidzibu
      real*8 dphidxict,dphidyict,dphidzict
      real*8 dphidxicu,dphidyicu,dphidzicu
      real*8 dxia,dyia,dzia
      real*8 dxib,dyib,dzib
      real*8 dxic,dyic,dzic
      real*8 dxid,dyid,dzid
      real*8 dxiaxia,dyiayia,dziazia
      real*8 dxibxib,dyibyib,dzibzib
      real*8 dxicxic,dyicyic,dziczic
      real*8 dxidxid,dyidyid,dzidzid
      real*8 dxiayia,dxiazia,dyiazia
      real*8 dxibyib,dxibzib,dyibzib
      real*8 dxicyic,dxiczic,dyiczic
      real*8 dxidyid,dxidzid,dyidzid
      real*8 dxiaxib,dxiayib,dxiazib
      real*8 dyiaxib,dyiayib,dyiazib
      real*8 dziaxib,dziayib,dziazib
      real*8 dxiaxic,dxiayic,dxiazic
      real*8 dyiaxic,dyiayic,dyiazic
      real*8 dziaxic,dziayic,dziazic
      real*8 dxiaxid,dxiayid,dxiazid
      real*8 dyiaxid,dyiayid,dyiazid
      real*8 dziaxid,dziayid,dziazid
      real*8 dxibxic,dxibyic,dxibzic
      real*8 dyibxic,dyibyic,dyibzic
      real*8 dzibxic,dzibyic,dzibzic
      real*8 dxibxid,dxibyid,dxibzid
      real*8 dyibxid,dyibyid,dyibzid
      real*8 dzibxid,dzibyid,dzibzid
      real*8 dxicxid,dxicyid,dxiczid
      real*8 dyicxid,dyicyid,dyiczid
      real*8 dzicxid,dzicyid,dziczid
      real*8 domegadxia,domegadyia,domegadzia
      real*8 domegadxib,domegadyib,domegadzib
      real*8 domegadxic,domegadyic,domegadzic
      real*8 domegadxid,domegadyid,domegadzid
      real*8 doxiaxia,doyiayia,doziazia
      real*8 doxibxib,doyibyib,dozibzib
      real*8 doxicxic,doyicyic,doziczic
      real*8 doxidxid,doyidyid,dozidzid
      real*8 doxiayia,doxiazia,doyiazia
      real*8 doxibyib,doxibzib,doyibzib
      real*8 doxicyic,doxiczic,doyiczic
      real*8 doxidyid,doxidzid,doyidzid
      real*8 doxiaxic,doxiayic,doxiazic
      real*8 doyiaxic,doyiayic,doyiazic
      real*8 doziaxic,doziayic,doziazic
      real*8 doxibxic,doxibyic,doxibzic
      real*8 doyibxic,doyibyic,doyibzic
      real*8 dozibxic,dozibyic,dozibzic
      real*8 doxibxid,doxibyid,doxibzid
      real*8 doyibxid,doyibyid,doyibzid
      real*8 dozibxid,dozibyid,dozibzid
      real*8 doxicxid,doxicyid,doxiczid
      real*8 doyicxid,doyicyid,doyiczid
      real*8 dozicxid,dozicyid,doziczid
      real*8 doxibxia,doxibyia,doxibzia
      real*8 doyibxia,doyibyia,doyibzia
      real*8 dozibxia,dozibyia,dozibzia
      real*8 doxicxib,doxicyib,doxiczib
      real*8 doyicxib,doyicyib,doyiczib
      real*8 dozicxib,dozicyib,doziczib
      logical proceed
c
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     calculate the angle-torsion interaction Hessian elements
c
      do iangtor = 1, nangtor
         j = iat(1,iangtor)
         ia = itors(1,j)
         ib = itors(2,j)
         ic = itors(3,j)
         id = itors(4,j)
c
c     decide whether to compute the current interaction
c
         proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic .or. i.eq.id)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,id,0,0)
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
            xab = -xba
            yab = -yba
            zab = -zba
            xbc = -xcb
            ybc = -ycb
            zbc = -zcb
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
               call image (xab,yab,zab)
               call image (xbc,ybc,zbc)
            end if
            rba2 = max(xba*xba+yba*yba+zba*zba,eps)
            rba = sqrt(rba2)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
            rcb = sqrt(rcb2)
            rdc2 = max(xdc*xdc+ydc*ydc+zdc*zdc,eps)
            rdc = sqrt(rdc2)
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            rt = sqrt(rt2)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            ru = sqrt(ru2)
            rtru = rt * ru
            xca = xic - xia
            yca = yic - yia
            zca = zic - zia
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            if (use_polymer) then
               call image (xca,yca,zca)
               call image (xdb,ydb,zdb)
            end if
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     compute multiple angle trigonometry and phase terms
c
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            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)
            d2phi1 = -(cosine*c1 + sine*s1)
            d2phi2 = -4.0d0 * (cosine2*c2 + sine2*s2)
            d2phi3 = -9.0d0 * (cosine3*c3 + sine3*s3)
c
c     set the angle-torsion parameters for the first angle
c
            v1 = kant(1,iangtor)
            v2 = kant(2,iangtor)
            v3 = kant(3,iangtor)
            k = iat(2,iangtor)
            dot = xab*xcb + yab*ycb + zab*zcb
            cosang = dot / (rba*rcb)
            angle = radian * acos(cosang)
            dt = angle - anat(k)
            dedphi = atorunit * (v1*dphi1 + v2*dphi2 + v3*dphi3)
            d2edphi2 = atorunit * dt
     &                    * (v1*d2phi1 + v2* d2phi2 + v3*d2phi3)
            d2dt = atorunit * radian * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               dedphi = dedphi * fgrp
               d2edphi2 = d2edphi2 * fgrp
               d2dt = d2dt * fgrp
            end if
c
c     first and second derivative components for the first angle
c
            terma = -1.0d0 / (rba2*rt)
            termc = 1.0d0 / (rcb2*rt)
            domegadxia = terma * (zba*yt-yba*zt)
            domegadyia = terma * (xba*zt-zba*xt)
            domegadzia = terma * (yba*xt-xba*yt)
            domegadxic = termc * (ycb*zt-zcb*yt)
            domegadyic = termc * (zcb*xt-xcb*zt)
            domegadzic = termc * (xcb*yt-ycb*xt)
            domegadxib = -domegadxia - domegadxic
            domegadyib = -domegadyia - domegadyic
            domegadzib = -domegadzia - domegadzic
c
c     abbreviations used in defining chain rule terms
c
            xrab = 2.0d0 * xab / rba2
            yrab = 2.0d0 * yab / rba2
            zrab = 2.0d0 * zab / rba2
            xrcb = 2.0d0 * xcb / rcb2
            yrcb = 2.0d0 * ycb / rcb2
            zrcb = 2.0d0 * zcb / rcb2
            xabp = (yab*zt-zab*yt) / rt2
            yabp = (zab*xt-xab*zt) / rt2
            zabp = (xab*yt-yab*xt) / rt2
            xcbp = (ycb*zt-zcb*yt) / rt2
            ycbp = (zcb*xt-xcb*zt) / rt2
            zcbp = (xcb*yt-ycb*xt) / rt2
c
c     chain rule terms for second derivative components
c
            doxiaxia = terma*(xab*xcb-dot) + domegadxia*(xcbp-xrab)
            doxiayia = terma*(zt+yab*xcb) + domegadxia*(ycbp-yrab)
            doxiazia = terma*(zab*xcb-yt) + domegadxia*(zcbp-zrab)
            doyiayia = terma*(yab*ycb-dot) + domegadyia*(ycbp-yrab)
            doyiazia = terma*(xt+zab*ycb) + domegadyia*(zcbp-zrab)
            doziazia = terma*(zab*zcb-dot) + domegadzia*(zcbp-zrab)
            doxicxic = termc*(dot-xab*xcb) - domegadxic*(xabp+xrcb)
            doxicyic = termc*(zt-ycb*xab) - domegadxic*(yabp+yrcb)
            doxiczic = -termc*(yt+zcb*xab) - domegadxic*(zabp+zrcb)
            doyicyic = termc*(dot-yab*ycb) - domegadyic*(yabp+yrcb)
            doyiczic = termc*(xt-zcb*yab) - domegadyic*(zabp+zrcb)
            doziczic = termc*(dot-zab*zcb) - domegadzic*(zabp+zrcb)
            doxiaxic = terma*(yab*yab+zab*zab) - domegadxia*xabp
            doxiayic = -terma*xab*yab - domegadxia*yabp
            doxiazic = -terma*xab*zab - domegadxia*zabp
            doyiaxic = -terma*xab*yab - domegadyia*xabp
            doyiayic = terma*(xab*xab+zab*zab) - domegadyia*yabp
            doyiazic = -terma*yab*zab - domegadyia*zabp
            doziaxic = -terma*xab*zab - domegadzia*xabp
            doziayic = -terma*yab*zab - domegadzia*yabp
            doziazic = terma*(xab*xab+yab*yab) - domegadzia*zabp
c
c     get some second derivative chain rule terms by difference
c
            doxibxia = -doxiaxia - doxiaxic
            doxibyia = -doxiayia - doyiaxic
            doxibzia = -doxiazia - doziaxic
            doyibxia = -doxiayia - doxiayic
            doyibyia = -doyiayia - doyiayic
            doyibzia = -doyiazia - doziayic
            dozibxia = -doxiazia - doxiazic
            dozibyia = -doyiazia - doyiazic
            dozibzia = -doziazia - doziazic
            doxibxic = -doxicxic - doxiaxic
            doxibyic = -doxicyic - doxiayic
            doxibzic = -doxiczic - doxiazic
            doyibxic = -doxicyic - doyiaxic
            doyibyic = -doyicyic - doyiayic
            doyibzic = -doyiczic - doyiazic
            dozibxic = -doxiczic - doziaxic
            dozibyic = -doyiczic - doziayic
            dozibzic = -doziczic - doziazic
            doxibxib = -doxibxia - doxibxic
            doxibyib = -doxibyia - doxibyic
            doxibzib = -doxibzia - doxibzic
            doyibyib = -doyibyia - doyibyic
            doyibzib = -doyibzia - doyibzic
            dozibzib = -dozibzia - dozibzic
c
c     scale the first derivatives of the first angle
c
            domegadxia = domegadxia * radian
            domegadyia = domegadyia * radian
            domegadzia = domegadzia * radian
            domegadxic = domegadxic * radian
            domegadyic = domegadyic * radian
            domegadzic = domegadzic * radian
            domegadxib = domegadxib * radian
            domegadyib = domegadyib * radian
            domegadzib = domegadzib * radian
c
c     scale the second derivatives of the first angle
c
            doxiaxia = doxiaxia * d2dt
            doxiayia = doxiayia * d2dt
            doxiazia = doxiazia * d2dt
            doyiayia = doyiayia * d2dt
            doyiazia = doyiazia * d2dt
            doziazia = doziazia * d2dt
            doxicxic = doxicxic * d2dt
            doxicyic = doxicyic * d2dt
            doxiczic = doxiczic * d2dt
            doyicyic = doyicyic * d2dt
            doyiczic = doyiczic * d2dt
            doziczic = doziczic * d2dt
            doxiaxic = doxiaxic * d2dt
            doxiayic = doxiayic * d2dt
            doxiazic = doxiazic * d2dt
            doyiaxic = doyiaxic * d2dt
            doyiayic = doyiayic * d2dt
            doyiazic = doyiazic * d2dt
            doziaxic = doziaxic * d2dt
            doziayic = doziayic * d2dt
            doziazic = doziazic * d2dt
            doxibxia = doxibxia * d2dt
            doxibyia = doxibyia * d2dt
            doxibzia = doxibzia * d2dt
            doyibxia = doyibxia * d2dt
            doyibyia = doyibyia * d2dt
            doyibzia = doyibzia * d2dt
            dozibxia = dozibxia * d2dt
            dozibyia = dozibyia * d2dt
            dozibzia = dozibzia * d2dt
            doxibxic = doxibxic * d2dt
            doxibyic = doxibyic * d2dt
            doxibzic = doxibzic * d2dt
            doyibxic = doyibxic * d2dt
            doyibyic = doyibyic * d2dt
            doyibzic = doyibzic * d2dt
            dozibxic = dozibxic * d2dt
            dozibyic = dozibyic * d2dt
            dozibzic = dozibzic * d2dt
            doxibxib = doxibxib * d2dt
            doxibyib = doxibyib * d2dt
            doxibzib = doxibzib * d2dt
            doyibyib = doyibyib * d2dt
            doyibzib = doyibzib * d2dt
            dozibzib = dozibzib * d2dt
c
c     abbreviations for first derivative chain rule terms
c
            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     abbreviations for second derivative chain rule terms
c
            xycb2 = xcb*xcb + ycb*ycb
            xzcb2 = xcb*xcb + zcb*zcb
            yzcb2 = ycb*ycb + zcb*zcb
            rcbxt = -2.0d0 * rcb * dphidxt
            rcbyt = -2.0d0 * rcb * dphidyt
            rcbzt = -2.0d0 * rcb * dphidzt
            rcbt2 = rcb * rt2
            rcbxu = 2.0d0 * rcb * dphidxu
            rcbyu = 2.0d0 * rcb * dphidyu
            rcbzu = 2.0d0 * rcb * dphidzu
            rcbu2 = rcb * ru2
            dphidxibt = yca*dphidzt - zca*dphidyt
            dphidxibu = zdc*dphidyu - ydc*dphidzu
            dphidyibt = zca*dphidxt - xca*dphidzt
            dphidyibu = xdc*dphidzu - zdc*dphidxu
            dphidzibt = xca*dphidyt - yca*dphidxt
            dphidzibu = ydc*dphidxu - xdc*dphidyu
            dphidxict = zba*dphidyt - yba*dphidzt
            dphidxicu = ydb*dphidzu - zdb*dphidyu
            dphidyict = xba*dphidzt - zba*dphidxt
            dphidyicu = zdb*dphidxu - xdb*dphidzu
            dphidzict = yba*dphidxt - xba*dphidyt
            dphidzicu = xdb*dphidyu - ydb*dphidxu
c
c     intermediate terms for first derivative components
c
            dphidxia = zcb*dphidyt - ycb*dphidzt
            dphidyia = xcb*dphidzt - zcb*dphidxt
            dphidzia = ycb*dphidxt - xcb*dphidyt
            dphidxib = dphidxibt + dphidxibu
            dphidyib = dphidyibt + dphidyibu
            dphidzib = dphidzibt + dphidzibu
            dphidxic = dphidxict + dphidxicu
            dphidyic = dphidyict + dphidyicu
            dphidzic = dphidzict + dphidzicu
            dphidxid = zcb*dphidyu - ycb*dphidzu
            dphidyid = xcb*dphidzu - zcb*dphidxu
            dphidzid = ycb*dphidxu - xcb*dphidyu
c
c     chain rule terms for first derivative components
c
            dxia = dedphi * dphidxia
            dyia = dedphi * dphidyia
            dzia = dedphi * dphidzia
            dxib = dedphi * dphidxib
            dyib = dedphi * dphidyib
            dzib = dedphi * dphidzib
            dxic = dedphi * dphidxic
            dyic = dedphi * dphidyic
            dzic = dedphi * dphidzic
            dxid = dedphi * dphidxid
            dyid = dedphi * dphidyid
            dzid = dedphi * dphidzid
            dedphi = dedphi * dt
c
c     chain rule terms for second derivative components
c
            dxiaxia = rcbxt*dphidxia
            dxiayia = rcbxt*dphidyia - zcb*rcb/rt2
            dxiazia = rcbxt*dphidzia + ycb*rcb/rt2
            dxiaxic = rcbxt*dphidxict + xcb*xt/rcbt2
            dxiayic = rcbxt*dphidyict - dphidzt
     &                   - (xba*zcb*xcb+zba*yzcb2)/rcbt2
            dxiazic = rcbxt*dphidzict + dphidyt
     &                   + (xba*ycb*xcb+yba*yzcb2)/rcbt2
            dxiaxid = 0.0d0
            dxiayid = 0.0d0
            dxiazid = 0.0d0
            dyiayia = rcbyt*dphidyia
            dyiazia = rcbyt*dphidzia - xcb*rcb/rt2
            dyiaxib = rcbyt*dphidxibt - dphidzt
     &                   - (yca*zcb*ycb+zca*xzcb2)/rcbt2
            dyiaxic = rcbyt*dphidxict + dphidzt
     &                   + (yba*zcb*ycb+zba*xzcb2)/rcbt2
            dyiayic = rcbyt*dphidyict + ycb*yt/rcbt2
            dyiazic = rcbyt*dphidzict - dphidxt
     &                   - (yba*xcb*ycb+xba*xzcb2)/rcbt2
            dyiaxid = 0.0d0
            dyiayid = 0.0d0
            dyiazid = 0.0d0
            dziazia = rcbzt*dphidzia
            dziaxib = rcbzt*dphidxibt + dphidyt
     &                   + (zca*ycb*zcb+yca*xycb2)/rcbt2
            dziayib = rcbzt*dphidyibt - dphidxt
     &                   - (zca*xcb*zcb+xca*xycb2)/rcbt2
            dziaxic = rcbzt*dphidxict - dphidyt
     &                   - (zba*ycb*zcb+yba*xycb2)/rcbt2
            dziayic = rcbzt*dphidyict + dphidxt
     &                   + (zba*xcb*zcb+xba*xycb2)/rcbt2
            dziazic = rcbzt*dphidzict + zcb*zt/rcbt2
            dziaxid = 0.0d0
            dziayid = 0.0d0
            dziazid = 0.0d0
            dxibxic = -xcb*dphidxib/(rcb*rcb)
     &          - (yca*(zba*xcb+yt)-zca*(yba*xcb-zt))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidxibt/rt2
     &          - (zdc*(ydb*xcb+zu)-ydc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidxibu/ru2
            dxibyic = -ycb*dphidxib/(rcb*rcb) + dphidzt + dphidzu
     &          - (yca*(zba*ycb-xt)+zca*(xba*xcb+zcb*zba))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidxibt/rt2
     &          + (zdc*(xdb*xcb+zcb*zdb)+ydc*(zdb*ycb+xu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidxibu/ru2
            dxibxid = rcbxu*dphidxibu + xcb*xu/rcbu2
            dxibyid = rcbyu*dphidxibu - dphidzu
     &                   - (ydc*zcb*ycb+zdc*xzcb2)/rcbu2
            dxibzid = rcbzu*dphidxibu + dphidyu
     &                   + (zdc*ycb*zcb+ydc*xycb2)/rcbu2
            dyibzib = ycb*dphidzib/(rcb*rcb)
     &          - (xca*(xca*xcb+zcb*zca)+yca*(ycb*xca+zt))/rcbt2
     &          - 2.0d0*(xt*zca-xca*zt)*dphidzibt/rt2
     &          + (ydc*(xdc*ycb-zu)+xdc*(xdc*xcb+zcb*zdc))/rcbu2
     &          + 2.0d0*(xu*zdc-xdc*zu)*dphidzibu/ru2
            dyibxic = -xcb*dphidyib/(rcb*rcb) - dphidzt - dphidzu
     &          + (xca*(zba*xcb+yt)+zca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidyibt/rt2
     &          - (zdc*(zdb*zcb+ycb*ydb)+xdc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidyibu/ru2
            dyibyic = -ycb*dphidyib/(rcb*rcb)
     &          - (zca*(xba*ycb+zt)-xca*(zba*ycb-xt))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidyibt/rt2
     &          - (xdc*(zdb*ycb+xu)-zdc*(xdb*ycb-zu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidyibu/ru2
            dyibxid = rcbxu*dphidyibu + dphidzu
     &                   + (xdc*zcb*xcb+zdc*yzcb2)/rcbu2
            dyibyid = rcbyu*dphidyibu + ycb*yu/rcbu2
            dyibzid = rcbzu*dphidyibu - dphidxu
     &                   - (zdc*xcb*zcb+xdc*xycb2)/rcbu2
            dzibxic = -xcb*dphidzib/(rcb*rcb) + dphidyt + dphidyu
     &          - (xca*(yba*xcb-zt)+yca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidzibt/rt2
     &          + (ydc*(zdb*zcb+ycb*ydb)+xdc*(ydb*xcb+zu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidzibu/ru2
            dzibzic = -zcb*dphidzib/(rcb*rcb)
     &          - (xca*(yba*zcb+xt)-yca*(xba*zcb-yt))/rcbt2
     &          - 2.0d0*(xt*yba-xba*yt)*dphidzibt/rt2
     &          - (ydc*(xdb*zcb+yu)-xdc*(ydb*zcb-xu))/rcbu2
     &          + 2.0d0*(xu*ydb-xdb*yu)*dphidzibu/ru2
            dzibxid = rcbxu*dphidzibu - dphidyu
     &                   - (xdc*ycb*xcb+ydc*yzcb2)/rcbu2
            dzibyid = rcbyu*dphidzibu + dphidxu
     &                   + (ydc*xcb*ycb+xdc*xzcb2)/rcbu2
            dzibzid = rcbzu*dphidzibu + zcb*zu/rcbu2
            dxicxid = rcbxu*dphidxicu - xcb*(zdb*ycb-ydb*zcb)/rcbu2
            dxicyid = rcbyu*dphidxicu + dphidzu
     &                   + (ydb*zcb*ycb+zdb*xzcb2)/rcbu2
            dxiczid = rcbzu*dphidxicu - dphidyu
     &                   - (zdb*ycb*zcb+ydb*xycb2)/rcbu2
            dyicxid = rcbxu*dphidyicu - dphidzu
     &                   - (xdb*zcb*xcb+zdb*yzcb2)/rcbu2
            dyicyid = rcbyu*dphidyicu - ycb*(xdb*zcb-zdb*xcb)/rcbu2
            dyiczid = rcbzu*dphidyicu + dphidxu
     &                   + (zdb*xcb*zcb+xdb*xycb2)/rcbu2
            dzicxid = rcbxu*dphidzicu + dphidyu
     &                   + (xdb*ycb*xcb+ydb*yzcb2)/rcbu2
            dzicyid = rcbyu*dphidzicu - dphidxu
     &                   - (ydb*xcb*ycb+xdb*xzcb2)/rcbu2
            dziczid = rcbzu*dphidzicu - zcb*(ydb*xcb-xdb*ycb)/rcbu2
            dxidxid = rcbxu*dphidxid
            dxidyid = rcbxu*dphidyid + zcb*rcb/ru2
            dxidzid = rcbxu*dphidzid - ycb*rcb/ru2
            dyidyid = rcbyu*dphidyid
            dyidzid = rcbyu*dphidzid + xcb*rcb/ru2
            dzidzid = rcbzu*dphidzid
c
c     get some second derivative chain rule terms by difference
c
            dxiaxib = -dxiaxia - dxiaxic - dxiaxid
            dxiayib = -dxiayia - dxiayic - dxiayid
            dxiazib = -dxiazia - dxiazic - dxiazid
            dyiayib = -dyiayia - dyiayic - dyiayid
            dyiazib = -dyiazia - dyiazic - dyiazid
            dziazib = -dziazia - dziazic - dziazid
            dxibxib = -dxiaxib - dxibxic - dxibxid
            dxibyib = -dyiaxib - dxibyic - dxibyid
            dxibzib = -dxiazib - dzibxic - dzibxid
            dxibzic = -dziaxib - dxibzib - dxibzid
            dyibyib = -dyiayib - dyibyic - dyibyid
            dyibzic = -dziayib - dyibzib - dyibzid
            dzibzib = -dziazib - dzibzic - dzibzid
            dzibyic = -dyiazib - dyibzib - dzibyid
            dxicxic = -dxiaxic - dxibxic - dxicxid
            dxicyic = -dyiaxic - dyibxic - dxicyid
            dxiczic = -dziaxic - dzibxic - dxiczid
            dyicyic = -dyiayic - dyibyic - dyicyid
            dyiczic = -dziayic - dzibyic - dyiczid
            dziczic = -dziazic - dzibzic - dziczid
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (i .eq. ia) then
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia + doxiaxia
     &                          + d2edphi2*dphidxia*dphidxia
     &                          + 2.0d0*domegadxia*dxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia + doxiayia
     &                          + d2edphi2*dphidxia*dphidyia
     &                          + domegadxia*dyia + domegadyia*dxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia + doxiazia
     &                          + d2edphi2*dphidxia*dphidzia
     &                          + domegadxia*dzia + domegadzia*dxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia + doxiayia
     &                          + d2edphi2*dphidxia*dphidyia
     &                          + domegadyia*dxia + domegadxia*dyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia + doyiayia
     &                          + d2edphi2*dphidyia*dphidyia
     &                          + 2.0d0*domegadyia*dyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia + doyiazia
     &                          + d2edphi2*dphidyia*dphidzia
     &                          + domegadyia*dzia + domegadzia*dyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia + doxiazia
     &                          + d2edphi2*dphidxia*dphidzia
     &                          + domegadxia*dzia + domegadzia*dxia
               hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia + doyiazia
     &                          + d2edphi2*dphidyia*dphidzia
     &                          + domegadyia*dzia + domegadzia*dyia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazia + doziazia
     &                          + d2edphi2*dphidzia*dphidzia
     &                          + 2.0d0*domegadzia*dzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib + doxibxia
     &                          + d2edphi2*dphidxia*dphidxib
     &                          + domegadxia*dxib + domegadxib*dxia
               hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib + doxibyia
     &                          + d2edphi2*dphidyia*dphidxib
     &                          + domegadyia*dxib + domegadxib*dyia
               hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib + doxibzia
     &                          + d2edphi2*dphidzia*dphidxib
     &                          + domegadzia*dxib + domegadxib*dzia
               hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib + doyibxia
     &                          + d2edphi2*dphidxia*dphidyib
     &                          + domegadxia*dyib + domegadyib*dxia
               hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib + doyibyia
     &                          + d2edphi2*dphidyia*dphidyib
     &                          + domegadyia*dyib + domegadyib*dyia
               hessz(2,ib) = hessz(2,ib) + dedphi*dziayib + doyibzia
     &                          + d2edphi2*dphidzia*dphidyib
     &                          + domegadzia*dyib + domegadyib*dzia
               hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib + dozibxia
     &                          + d2edphi2*dphidxia*dphidzib
     &                          + domegadxia*dzib + domegadzib*dxia
               hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib + dozibyia
     &                          + d2edphi2*dphidyia*dphidzib
     &                          + domegadyia*dzib + domegadzib*dyia
               hessz(3,ib) = hessz(3,ib) + dedphi*dziazib  + dozibzia
     &                          + d2edphi2*dphidzia*dphidzib
     &                          + domegadzia*dzib + domegadzib*dzia
               hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic + doxiaxic
     &                          + d2edphi2*dphidxia*dphidxic
     &                          + domegadxia*dxic + domegadxic*dxia
               hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic + doyiaxic
     &                          + d2edphi2*dphidyia*dphidxic
     &                          + domegadyia*dxic + domegadxic*dyia
               hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic + doziaxic
     &                          + d2edphi2*dphidzia*dphidxic
     &                          + domegadzia*dxic + domegadxic*dzia
               hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic + doxiayic
     &                          + d2edphi2*dphidxia*dphidyic
     &                          + domegadxia*dyic + domegadyic*dxia
               hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic + doyiayic
     &                          + d2edphi2*dphidyia*dphidyic
     &                          + domegadyia*dyic + domegadyic*dyia
               hessz(2,ic) = hessz(2,ic) + dedphi*dziayic + doziayic
     &                          + d2edphi2*dphidzia*dphidyic
     &                          + domegadzia*dyic + domegadyic*dzia
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic + doxiazic
     &                          + d2edphi2*dphidxia*dphidzic
     &                          + domegadxia*dzic + domegadzic*dxia
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic + doyiazic
     &                          + d2edphi2*dphidyia*dphidzic
     &                          + domegadyia*dzic + domegadzic*dyia
               hessz(3,ic) = hessz(3,ic) + dedphi*dziazic + doziazic
     &                          + d2edphi2*dphidzia*dphidzic
     &                          + domegadzia*dzic + domegadzic*dzia
               hessx(1,id) = hessx(1,id) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxia*dphidxid
     &                          + domegadxia*dxid
               hessy(1,id) = hessy(1,id) + dedphi*dyiaxid
     &                          + d2edphi2*dphidyia*dphidxid
     &                          + domegadyia*dxid
               hessz(1,id) = hessz(1,id) + dedphi*dziaxid
     &                          + d2edphi2*dphidzia*dphidxid
     &                          + domegadzia*dxid
               hessx(2,id) = hessx(2,id) + dedphi*dxiayid
     &                          + d2edphi2*dphidxia*dphidyid
     &                          + domegadxia*dyid
               hessy(2,id) = hessy(2,id) + dedphi*dyiayid
     &                          + d2edphi2*dphidyia*dphidyid
     &                          + domegadyia*dyid
               hessz(2,id) = hessz(2,id) + dedphi*dziayid
     &                          + d2edphi2*dphidzia*dphidyid
     &                          + domegadzia*dyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiazid
     &                          + d2edphi2*dphidxia*dphidzid
     &                          + domegadxia*dzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiazid
     &                          + d2edphi2*dphidyia*dphidzid
     &                          + domegadyia*dzid
               hessz(3,id) = hessz(3,id) + dedphi*dziazid
     &                          + d2edphi2*dphidzia*dphidzid
     &                          + domegadzia*dzid
            else if (i .eq. ib) then
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib + doxibxib
     &                          + d2edphi2*dphidxib*dphidxib
     &                          + 2.0d0*domegadxib*dxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib + doxibyib
     &                          + d2edphi2*dphidxib*dphidyib
     &                          + domegadxib*dyib + domegadyib*dxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib + doxibzib
     &                          + d2edphi2*dphidxib*dphidzib
     &                          + domegadxib*dzib + domegadzib*dxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib + doxibyib
     &                          + d2edphi2*dphidxib*dphidyib
     &                          + domegadxib*dyib + domegadyib*dxib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib + doyibyib
     &                          + d2edphi2*dphidyib*dphidyib
     &                          + 2.0d0*domegadyib*dyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib + doyibzib
     &                          + d2edphi2*dphidyib*dphidzib
     &                          + domegadyib*dzib + domegadzib*dyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib + doxibzib
     &                          + d2edphi2*dphidxib*dphidzib
     &                          + domegadxib*dzib + domegadzib*dxib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib + doyibzib
     &                          + d2edphi2*dphidyib*dphidzib
     &                          + domegadyib*dzib + domegadzib*dyib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib + dozibzib
     &                          + d2edphi2*dphidzib*dphidzib
     &                          + 2.0*domegadzib*dzib
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib + doxibxia
     &                          + d2edphi2*dphidxib*dphidxia
     &                          + domegadxia*dxib + domegadxib*dxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib + doyibxia
     &                          + d2edphi2*dphidyib*dphidxia
     &                          + domegadxia*dyib + domegadyib*dxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib + dozibxia
     &                          + d2edphi2*dphidzib*dphidxia
     &                          + domegadxia*dzib + domegadzib*dxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib + doxibyia
     &                          + d2edphi2*dphidxib*dphidyia
     &                          + domegadyia*dxib + domegadxib*dyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib + doyibyia
     &                          + d2edphi2*dphidyib*dphidyia
     &                          + domegadyia*dyib + domegadyib*dyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib + dozibyia
     &                          + d2edphi2*dphidzib*dphidyia
     &                          + domegadyia*dzib + domegadzib*dyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib + doxibzia
     &                          + d2edphi2*dphidxib*dphidzia
     &                          + domegadzia*dxib + domegadxib*dzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayib + doyibzia
     &                          + d2edphi2*dphidyib*dphidzia
     &                          + domegadzia*dyib + domegadyib*dzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazib + dozibzia
     &                          + d2edphi2*dphidzib*dphidzia
     &                          + domegadzia*dzib + domegadzib*dzia
               hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic + doxibxic
     &                          + d2edphi2*dphidxib*dphidxic
     &                          + domegadxib*dxic + domegadxic*dxib
               hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic + doyibxic
     &                          + d2edphi2*dphidyib*dphidxic
     &                          + domegadyib*dxic + domegadxic*dyib
               hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic + dozibxic
     &                          + d2edphi2*dphidzib*dphidxic
     &                          + domegadzib*dxic + domegadxic*dzib
               hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic + doxibyic
     &                          + d2edphi2*dphidxib*dphidyic
     &                          + domegadxib*dyic + domegadyic*dxib
               hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic + doyibyic
     &                          + d2edphi2*dphidyib*dphidyic
     &                          + domegadyib*dyic + domegadyic*dyib
               hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic + dozibyic
     &                          + d2edphi2*dphidzib*dphidyic
     &                          + domegadzib*dyic + domegadyic*dzib
               hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic + doxibzic
     &                          + d2edphi2*dphidxib*dphidzic
     &                          + domegadxib*dzic + domegadzic*dxib
               hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic + doyibzic
     &                          + d2edphi2*dphidyib*dphidzic
     &                          + domegadyib*dzic + domegadzic*dyib
               hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic + dozibzic
     &                          + d2edphi2*dphidzib*dphidzic
     &                          + domegadzib*dzic + domegadzic*dzib
               hessx(1,id) = hessx(1,id) + dedphi*dxibxid
     &                          + d2edphi2*dphidxib*dphidxid
     &                          + domegadxib*dxid
               hessy(1,id) = hessy(1,id) + dedphi*dyibxid
     &                          + d2edphi2*dphidyib*dphidxid
     &                          + domegadyib*dxid
               hessz(1,id) = hessz(1,id) + dedphi*dzibxid
     &                          + d2edphi2*dphidzib*dphidxid
     &                          + domegadzib*dxid
                hessx(2,id) = hessx(2,id) + dedphi*dxibyid
     &                         + d2edphi2*dphidxib*dphidyid
     &                          + domegadxib*dyid
               hessy(2,id) = hessy(2,id) + dedphi*dyibyid
     &                          + d2edphi2*dphidyib*dphidyid
     &                          + domegadyib*dyid
               hessz(2,id) = hessz(2,id) + dedphi*dzibyid
     &                          + d2edphi2*dphidzib*dphidyid
     &                          + domegadzib*dyid
               hessx(3,id) = hessx(3,id) + dedphi*dxibzid
     &                          + d2edphi2*dphidxib*dphidzid
     &                          + domegadxib*dzid
               hessy(3,id) = hessy(3,id) + dedphi*dyibzid
     &                          + d2edphi2*dphidyib*dphidzid
     &                          + domegadyib*dzid
               hessz(3,id) = hessz(3,id) + dedphi*dzibzid
     &                          + d2edphi2*dphidzib*dphidzid
     &                          + domegadzib*dzid
            else if (i .eq. ic) then
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic + doxicxic
     &                          + d2edphi2*dphidxic*dphidxic
     &                          + 2.0d0*domegadxic*dxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic + doxicyic
     &                          + d2edphi2*dphidxic*dphidyic
     &                          + domegadxic*dyic + domegadyic*dxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic + doxiczic
     &                          + d2edphi2*dphidxic*dphidzic
     &                          + domegadxic*dzic + domegadzic*dxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic + doxicyic
     &                          + d2edphi2*dphidxic*dphidyic
     &                          + domegadxic*dyic + domegadyic*dxic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic + doyicyic
     &                          + d2edphi2*dphidyic*dphidyic
     &                          + 2.0d0*domegadyic*dyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic + doyiczic
     &                          + d2edphi2*dphidyic*dphidzic
     &                          + domegadyic*dzic + domegadzic*dyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic + doxiczic
     &                          + d2edphi2*dphidxic*dphidzic
     &                          + domegadxic*dzic + domegadzic*dxic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic + doyiczic
     &                          + d2edphi2*dphidyic*dphidzic
     &                          + domegadyic*dzic + domegadzic*dyic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczic + doziczic
     &                          + d2edphi2*dphidzic*dphidzic
     &                          + 2.0d0*domegadzic*dzic
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic + doxiaxic
     &                          + d2edphi2*dphidxic*dphidxia
     &                          + domegadxia*dxic + domegadxic*dxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic + doxiayic
     &                          + d2edphi2*dphidyic*dphidxia
     &                          + domegadxia*dyic + domegadyic*dxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic + doxiazic
     &                          + d2edphi2*dphidzic*dphidxia
     &                          + domegadxia*dzic + domegadzic*dxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic + doyiaxic
     &                          + d2edphi2*dphidxic*dphidyia
     &                          + domegadyia*dxic + domegadxic*dyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic + doyiayic
     &                          + d2edphi2*dphidyic*dphidyia
     &                          + domegadyia*dyic + domegadyic*dyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic + doyiazic
     &                          + d2edphi2*dphidzic*dphidyia
     &                          + domegadyia*dzic + domegadzic*dyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic + doziaxic
     &                          + d2edphi2*dphidxic*dphidzia
     &                          + domegadzia*dxic + domegadxic*dzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayic + doziayic
     &                          + d2edphi2*dphidyic*dphidzia
     &                          + domegadzia*dyic + domegadyic*dzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazic + doziazic
     &                          + d2edphi2*dphidzic*dphidzia
     &                          + domegadzia*dzic + domegadzic*dzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic + doxibxic
     &                          + d2edphi2*dphidxic*dphidxib
     &                          + domegadxib*dxic + domegadxic*dxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic + doxibyic
     &                          + d2edphi2*dphidyic*dphidxib
     &                          + domegadxib*dyic + domegadyic*dxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic + doxibzic
     &                          + d2edphi2*dphidzic*dphidxib
     &                          + domegadxib*dzic + domegadzic*dxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic + doyibxic
     &                          + d2edphi2*dphidxic*dphidyib
     &                          + domegadyib*dxic + domegadxic*dyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic + doyibyic
     &                          + d2edphi2*dphidyic*dphidyib
     &                          + domegadyib*dyic + domegadyic*dyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic + doyibzic
     &                          + d2edphi2*dphidzic*dphidyib
     &                          + domegadyib*dzic + domegadzic*dyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic + dozibxic
     &                          + d2edphi2*dphidxic*dphidzib
     &                          + domegadzib*dxic + domegadxic*dzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic + dozibyic
     &                          + d2edphi2*dphidyic*dphidzib
     &                          + domegadzib*dyic + domegadyic*dzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic + dozibzic
     &                          + d2edphi2*dphidzic*dphidzib
     &                          + domegadzib*dzic + domegadzic*dzib
               hessx(1,id) = hessx(1,id) + dedphi*dxicxid
     &                          + d2edphi2*dphidxic*dphidxid
     &                          + domegadxic*dxid
               hessy(1,id) = hessy(1,id) + dedphi*dyicxid
     &                          + d2edphi2*dphidyic*dphidxid
     &                          + domegadyic*dxid
               hessz(1,id) = hessz(1,id) + dedphi*dzicxid
     &                          + d2edphi2*dphidzic*dphidxid
     &                          + domegadzic*dxid
               hessx(2,id) = hessx(2,id) + dedphi*dxicyid
     &                          + d2edphi2*dphidxic*dphidyid
     &                          + domegadxic*dyid
               hessy(2,id) = hessy(2,id) + dedphi*dyicyid
     &                          + d2edphi2*dphidyic*dphidyid
     &                          + domegadyic*dyid
               hessz(2,id) = hessz(2,id) + dedphi*dzicyid
     &                          + d2edphi2*dphidzic*dphidyid
     &                          + domegadzic*dyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiczid
     &                          + d2edphi2*dphidxic*dphidzid
     &                          + domegadxic*dzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiczid
     &                          + d2edphi2*dphidyic*dphidzid
     &                          + domegadyic*dzid
               hessz(3,id) = hessz(3,id) + dedphi*dziczid
     &                          + d2edphi2*dphidzic*dphidzid
     &                          + domegadzic*dzid
            else if (i .eq. id) then
               hessx(1,id) = hessx(1,id) + dedphi*dxidxid
     &                          + d2edphi2*dphidxid*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessz(1,id) = hessz(1,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessx(2,id) = hessx(2,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyidyid
     &                          + d2edphi2*dphidyid*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessx(3,id) = hessx(3,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzidzid
     &                          + d2edphi2*dphidzid*dphidzid
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxid*dphidxia
     &                          + domegadxia*dxid
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid
     &                          + d2edphi2*dphidyid*dphidxia
     &                          + domegadxia*dyid
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid
     &                          + d2edphi2*dphidzid*dphidxia
     &                          + domegadxia*dzid
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid
     &                          + d2edphi2*dphidxid*dphidyia
     &                          + domegadyia*dxid
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid
     &                          + d2edphi2*dphidyid*dphidyia
     &                          + domegadyia*dyid
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid
     &                          + d2edphi2*dphidzid*dphidyia
     &                          + domegadyia*dzid
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid
     &                          + d2edphi2*dphidxid*dphidzia
     &                          + domegadzia*dxid
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayid
     &                          + d2edphi2*dphidyid*dphidzia
     &                          + domegadzia*dyid
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazid
     &                          + d2edphi2*dphidzid*dphidzia
     &                          + domegadzia*dzid
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid
     &                          + d2edphi2*dphidxid*dphidxib
     &                          + domegadxib*dxid
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid
     &                          + d2edphi2*dphidyid*dphidxib
     &                          + domegadxib*dyid
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid
     &                          + d2edphi2*dphidzid*dphidxib
     &                          + domegadxib*dzid
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid
     &                          + d2edphi2*dphidxid*dphidyib
     &                          + domegadyib*dxid
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid
     &                          + d2edphi2*dphidyid*dphidyib
     &                          + domegadyib*dyid
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid
     &                          + d2edphi2*dphidzid*dphidyib
     &                          + domegadyib*dzid
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid
     &                          + d2edphi2*dphidxid*dphidzib
     &                          + domegadzib*dxid
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid
     &                          + d2edphi2*dphidyid*dphidzib
     &                          + domegadzib*dyid
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid
     &                          + d2edphi2*dphidzid*dphidzib
     &                          + domegadzib*dzid
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid
     &                          + d2edphi2*dphidxid*dphidxic
     &                          + domegadxic*dxid
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid
     &                          + d2edphi2*dphidyid*dphidxic
     &                          + domegadxic*dyid
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid
     &                          + d2edphi2*dphidzid*dphidxic
     &                          + domegadxic*dzid
               hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid
     &                          + d2edphi2*dphidxid*dphidyic
     &                          + domegadyic*dxid
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid
     &                          + d2edphi2*dphidyid*dphidyic
     &                          + domegadyic*dyid
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid
     &                          + d2edphi2*dphidzid*dphidyic
     &                          + domegadyic*dzid
               hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid
     &                          + d2edphi2*dphidxid*dphidzic
     &                          + domegadzic*dxid
               hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid
     &                          + d2edphi2*dphidyid*dphidzic
     &                          + domegadzic*dyid
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczid
     &                          + d2edphi2*dphidzid*dphidzic
     &                          + domegadzic*dzid
            end if
c
c     get the angle-torsion values for the second angle
c
            v1 = kant(4,iangtor)
            v2 = kant(5,iangtor)
            v3 = kant(6,iangtor)
            k = iat(3,iangtor)
            dot = xbc*xdc + ybc*ydc + zbc*zdc
            cosang = dot / (rcb*rdc)
            angle = radian * acos(cosang)
            dt = angle - anat(k)
            dedphi = atorunit * (v1*dphi1 + v2*dphi2 + v3*dphi3)
            d2edphi2 = atorunit * dt
     &                    * (v1*d2phi1 + v2* d2phi2 + v3*d2phi3)
            d2dt = atorunit * radian * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               dedphi = dedphi * fgrp
               d2edphi2 = d2edphi2 * fgrp
               d2dt = d2dt * fgrp
            end if
c
c     first and second derivative components for the second angle
c
            termb = -1.0d0 / (rcb2*ru)
            termd = 1.0d0 / (rdc2*ru)
            domegadxib = termb * (ybc*zu - zbc*yu)
            domegadyib = termb * (zbc*xu - xbc*zu)
            domegadzib = termb * (xbc*yu - ybc*xu)
            domegadxid = termd * (ydc*zu - zdc*yu)
            domegadyid = termd * (zdc*xu - xdc*zu)
            domegadzid = termd * (xdc*yu - ydc*xu)
            domegadxic = -domegadxib - domegadxid
            domegadyic = -domegadyib - domegadyid
            domegadzic = -domegadzib - domegadzid
c
c     abbreviations used in defining chain rule terms
c
            xrbc = 2.0d0 * xbc / rcb2
            yrbc = 2.0d0 * ybc / rcb2
            zrbc = 2.0d0 * zbc / rcb2
            xrdc = 2.0d0 * xdc / rdc2
            yrdc = 2.0d0 * ydc / rdc2
            zrdc = 2.0d0 * zdc / rdc2
            xbcp = (ybc*zu-zbc*yu) / ru2
            ybcp = (zbc*xu-xbc*zu) / ru2
            zbcp = (xbc*yu-ybc*xu) / ru2
            xdcp = (ydc*zu-zdc*yu) / ru2
            ydcp = (zdc*xu-xdc*zu) / ru2
            zdcp = (xdc*yu-ydc*xu) / ru2
c
c     chain rule terms for second derivative components
c
            doxibxib = termb*(xbc*xdc-dot) + domegadxib*(xdcp-xrbc)
            doxibyib = termb*(zu+ybc*xdc) + domegadxib*(ydcp-yrbc)
            doxibzib = termb*(zbc*xdc-yu) + domegadxib*(zdcp-zrbc)
            doyibyib = termb*(ybc*ydc-dot) + domegadyib*(ydcp-yrbc)
            doyibzib = termb*(xu+zbc*ydc) + domegadyib*(zdcp-zrbc)
            dozibzib = termb*(zbc*zdc-dot) + domegadzib*(zdcp-zrbc)
            doxidxid = termd*(dot-xbc*xdc) - domegadxid*(xbcp+xrdc)
            doxidyid = termd*(zu-ydc*xbc) - domegadxid*(ybcp+yrdc)
            doxidzid = -termd*(yu+zdc*xbc) - domegadxid*(zbcp+zrdc)
            doyidyid = termd*(dot-ybc*ydc) - domegadyid*(ybcp+yrdc)
            doyidzid = termd*(xu-zdc*ybc) - domegadyid*(zbcp+zrdc)
            dozidzid = termd*(dot-zbc*zdc) - domegadzid*(zbcp+zrdc)
            doxibxid = termb*(ybc*ybc+zbc*zbc) - domegadxib*xbcp
            doxibyid = -termb*xbc*ybc - domegadxib*ybcp
            doxibzid = -termb*xbc*zbc - domegadxib*zbcp
            doyibxid = -termb*xbc*ybc - domegadyib*xbcp
            doyibyid = termb*(xbc*xbc+zbc*zbc) - domegadyib*ybcp
            doyibzid = -termb*ybc*zbc - domegadyib*zbcp
            dozibxid = -termb*xbc*zbc - domegadzib*xbcp
            dozibyid = -termb*ybc*zbc - domegadzib*ybcp
            dozibzid = termb*(xbc*xbc+ybc*ybc) - domegadzib*zbcp
c
c     get some second derivative chain rule terms by difference
c
            doxicxib = -doxibxib - doxibxid
            doxicyib = -doxibyib - doyibxid
            doxiczib = -doxibzib - dozibxid
            doyicxib = -doxibyib - doxibyid
            doyicyib = -doyibyib - doyibyid
            doyiczib = -doyibzib - dozibyid
            dozicxib = -doxibzib - doxibzid
            dozicyib = -doyibzib - doyibzid
            doziczib = -dozibzib - dozibzid
            doxicxid = -doxidxid - doxibxid
            doxicyid = -doxidyid - doxibyid
            doxiczid = -doxidzid - doxibzid
            doyicxid = -doxidyid - doyibxid
            doyicyid = -doyidyid - doyibyid
            doyiczid = -doyidzid - doyibzid
            dozicxid = -doxidzid - dozibxid
            dozicyid = -doyidzid - dozibyid
            doziczid = -dozidzid - dozibzid
            doxicxic = -doxicxib - doxicxid
            doxicyic = -doxicyib - doxicyid
            doxiczic = -doxiczib - doxiczid
            doyicyic = -doyicyib - doyicyid
            doyiczic = -doyiczib - doyiczid
            doziczic = -doziczib - doziczid
c
c     scale the first-derivatives of the second angle
c
            domegadxib = domegadxib * radian
            domegadyib = domegadyib * radian
            domegadzib = domegadzib * radian
            domegadxid = domegadxid * radian
            domegadyid = domegadyid * radian
            domegadzid = domegadzid * radian
            domegadxic = domegadxic * radian
            domegadyic = domegadyic * radian
            domegadzic = domegadzic * radian
c
c     scale the second-derivatives of the second angle
c
            doxibxib = doxibxib * d2dt
            doxibyib = doxibyib * d2dt
            doxibzib = doxibzib * d2dt
            doyibyib = doyibyib * d2dt
            doyibzib = doyibzib * d2dt
            dozibzib = dozibzib * d2dt
            doxidxid = doxidxid * d2dt
            doxidyid = doxidyid * d2dt
            doxidzid = doxidzid * d2dt
            doyidyid = doyidyid * d2dt
            doyidzid = doyidzid * d2dt
            dozidzid = dozidzid * d2dt
            doxibxid = doxibxid * d2dt
            doxibyid = doxibyid * d2dt
            doxibzid = doxibzid * d2dt
            doyibxid = doyibxid * d2dt
            doyibyid = doyibyid * d2dt
            doyibzid = doyibzid * d2dt
            dozibxid = dozibxid * d2dt
            dozibyid = dozibyid * d2dt
            dozibzid = dozibzid * d2dt
            doxicxib = doxicxib * d2dt
            doxicyib = doxicyib * d2dt
            doxiczib = doxiczib * d2dt
            doyicxib = doyicxib * d2dt
            doyicyib = doyicyib * d2dt
            doyiczib = doyiczib * d2dt
            dozicxib = dozicxib * d2dt
            dozicyib = dozicyib * d2dt
            doziczib = doziczib * d2dt
            doxicxid = doxicxid * d2dt
            doxicyid = doxicyid * d2dt
            doxiczid = doxiczid * d2dt
            doyicxid = doyicxid * d2dt
            doyicyid = doyicyid * d2dt
            doyiczid = doyiczid * d2dt
            dozicxid = dozicxid * d2dt
            dozicyid = dozicyid * d2dt
            doziczid = doziczid * d2dt
            doxicxic = doxicxic * d2dt
            doxicyic = doxicyic * d2dt
            doxiczic = doxiczic * d2dt
            doyicyic = doyicyic * d2dt
            doyiczic = doyiczic * d2dt
            doziczic = doziczic * d2dt
c
c     chain rule terms for first derivative components
c
            dxia = dedphi * dphidxia
            dyia = dedphi * dphidyia
            dzia = dedphi * dphidzia
            dxib = dedphi * dphidxib
            dyib = dedphi * dphidyib
            dzib = dedphi * dphidzib
            dxic = dedphi * dphidxic
            dyic = dedphi * dphidyic
            dzic = dedphi * dphidzic
            dxid = dedphi * dphidxid
            dyid = dedphi * dphidyid
            dzid = dedphi * dphidzid
            dedphi = dedphi * dt
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (i .eq. ia) then
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia
     &                          + d2edphi2*dphidxia*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia
     &                          + d2edphi2*dphidyia*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazia
     &                          + d2edphi2*dphidzia*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxia*dphidxib
     &                          + domegadxib*dxia
               hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib
     &                          + d2edphi2*dphidyia*dphidxib
     &                          + domegadxib*dyia
               hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib
     &                          + d2edphi2*dphidzia*dphidxib
     &                          + domegadxib*dzia
               hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib
     &                          + d2edphi2*dphidxia*dphidyib
     &                          + domegadyib*dxia
               hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib
     &                          + d2edphi2*dphidyia*dphidyib
     &                          + domegadyib*dyia
               hessz(2,ib) = hessz(2,ib) + dedphi*dziayib
     &                          + d2edphi2*dphidzia*dphidyib
     &                          + domegadyib*dzia
               hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib
     &                          + d2edphi2*dphidxia*dphidzib
     &                          + domegadzib*dxia
               hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib
     &                          + d2edphi2*dphidyia*dphidzib
     &                          + domegadzib*dyia
               hessz(3,ib) = hessz(3,ib) + dedphi*dziazib
     &                          + d2edphi2*dphidzia*dphidzib
     &                          + domegadzib*dzia
               hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxia*dphidxic
     &                          + domegadxic*dxia
               hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic
     &                          + d2edphi2*dphidyia*dphidxic
     &                          + domegadxic*dyia
               hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic
     &                          + d2edphi2*dphidzia*dphidxic
     &                          + domegadxic*dzia
               hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic
     &                          + d2edphi2*dphidxia*dphidyic
     &                          + domegadyic*dxia
               hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic
     &                          + d2edphi2*dphidyia*dphidyic
     &                          + domegadyic*dyia
               hessz(2,ic) = hessz(2,ic) + dedphi*dziayic
     &                          + d2edphi2*dphidzia*dphidyic
     &                          + domegadyic*dzia
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic
     &                          + d2edphi2*dphidxia*dphidzic
     &                          + domegadzic*dxia
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic
     &                          + d2edphi2*dphidyia*dphidzic
     &                          + domegadzic*dyia
               hessz(3,ic) = hessz(3,ic) + dedphi*dziazic
     &                          + d2edphi2*dphidzia*dphidzic
     &                          + domegadzic*dzia
               hessx(1,id) = hessx(1,id) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxia*dphidxid
     &                          + domegadxid*dxia
               hessy(1,id) = hessy(1,id) + dedphi*dyiaxid
     &                          + d2edphi2*dphidyia*dphidxid
     &                          + domegadxid*dyia
               hessz(1,id) = hessz(1,id) + dedphi*dziaxid
     &                          + d2edphi2*dphidzia*dphidxid
     &                          + domegadxid*dzia
               hessx(2,id) = hessx(2,id) + dedphi*dxiayid
     &                          + d2edphi2*dphidxia*dphidyid
     &                          + domegadyid*dxia
               hessy(2,id) = hessy(2,id) + dedphi*dyiayid
     &                          + d2edphi2*dphidyia*dphidyid
     &                          + domegadyid*dyia
               hessz(2,id) = hessz(2,id) + dedphi*dziayid
     &                          + d2edphi2*dphidzia*dphidyid
     &                          + domegadyid*dzia
               hessx(3,id) = hessx(3,id) + dedphi*dxiazid
     &                          + d2edphi2*dphidxia*dphidzid
     &                          + domegadzid*dxia
               hessy(3,id) = hessy(3,id) + dedphi*dyiazid
     &                          + d2edphi2*dphidyia*dphidzid
     &                          + domegadzid*dyia
               hessz(3,id) = hessz(3,id) + dedphi*dziazid
     &                          + d2edphi2*dphidzia*dphidzid
     &                          + domegadzid*dzia
            else if (i .eq. ib) then
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib + doxibxib
     &                          + d2edphi2*dphidxib*dphidxib
     &                          + 2.0d0*domegadxib*dxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib + doxibyib
     &                          + d2edphi2*dphidxib*dphidyib
     &                          + domegadxib*dyib + domegadyib*dxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib + doxibzib
     &                          + d2edphi2*dphidxib*dphidzib
     &                          + domegadxib*dzib + domegadzib*dxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib + doxibyib
     &                          + d2edphi2*dphidxib*dphidyib
     &                          + domegadxib*dyib + domegadyib*dxib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib + doyibyib
     &                          + d2edphi2*dphidyib*dphidyib
     &                          + 2.0d0*domegadyib*dyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib + doyibzib
     &                          + d2edphi2*dphidyib*dphidzib
     &                          + domegadyib*dzib + domegadzib*dyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib + doxibzib
     &                          + d2edphi2*dphidxib*dphidzib
     &                          + domegadxib*dzib + domegadzib*dxib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib + doyibzib
     &                          + d2edphi2*dphidyib*dphidzib
     &                          + domegadyib*dzib + domegadzib*dyib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib + dozibzib
     &                          + d2edphi2*dphidzib*dphidzib
     &                          + 2.0d0*domegadzib*dzib
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxib*dphidxia
     &                          + domegadxib*dxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib
     &                          + d2edphi2*dphidyib*dphidxia
     &                          + domegadyib*dxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib
     &                          + d2edphi2*dphidzib*dphidxia
     &                          + domegadzib*dxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib
     &                          + d2edphi2*dphidxib*dphidyia
     &                          + domegadxib*dyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib
     &                          + d2edphi2*dphidyib*dphidyia
     &                          + domegadyib*dyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib
     &                          + d2edphi2*dphidzib*dphidyia
     &                          + domegadzib*dyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib
     &                          + d2edphi2*dphidxib*dphidzia
     &                          + domegadxib*dzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayib
     &                          + d2edphi2*dphidyib*dphidzia
     &                          + domegadyib*dzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazib
     &                          + d2edphi2*dphidzib*dphidzia
     &                          + domegadzib*dzia
               hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic + doxicxib
     &                          + d2edphi2*dphidxib*dphidxic
     &                          + domegadxib*dxic + domegadxic*dxib
               hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic + doxicyib
     &                          + d2edphi2*dphidyib*dphidxic
     &                          + domegadyib*dxic + domegadxic*dyib
               hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic + doxiczib
     &                          + d2edphi2*dphidzib*dphidxic
     &                          + domegadzib*dxic + domegadxic*dzib
               hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic + doyicxib
     &                          + d2edphi2*dphidxib*dphidyic
     &                          + domegadxib*dyic + domegadyic*dxib
               hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic + doyicyib
     &                          + d2edphi2*dphidyib*dphidyic
     &                          + domegadyib*dyic + domegadyic*dyib
               hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic + doyiczib
     &                          + d2edphi2*dphidzib*dphidyic
     &                          + domegadzib*dyic + domegadyic*dzib
               hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic + dozicxib
     &                          + d2edphi2*dphidxib*dphidzic
     &                          + domegadxib*dzic + domegadzic*dxib
               hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic + dozicyib
     &                          + d2edphi2*dphidyib*dphidzic
     &                          + domegadyib*dzic + domegadzic*dyib
               hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic + doziczib
     &                          + d2edphi2*dphidzib*dphidzic
     &                          + domegadzib*dzic + domegadzic*dzib
               hessx(1,id) = hessx(1,id) + dedphi*dxibxid + doxibxid
     &                          + d2edphi2*dphidxib*dphidxid
     &                          + domegadxib*dxid + domegadxid*dxib
               hessy(1,id) = hessy(1,id) + dedphi*dyibxid + doyibxid
     &                          + d2edphi2*dphidyib*dphidxid
     &                          + domegadyib*dxid + domegadxid*dyib
               hessz(1,id) = hessz(1,id) + dedphi*dzibxid + dozibxid
     &                          + d2edphi2*dphidzib*dphidxid
     &                          + domegadzib*dxid + domegadxid*dzib
               hessx(2,id) = hessx(2,id) + dedphi*dxibyid + doxibyid
     &                          + d2edphi2*dphidxib*dphidyid
     &                          + domegadxib*dyid + domegadyid*dxib
               hessy(2,id) = hessy(2,id) + dedphi*dyibyid + doyibyid
     &                          + d2edphi2*dphidyib*dphidyid
     &                          + domegadyib*dyid + domegadyid*dyib
               hessz(2,id) = hessz(2,id) + dedphi*dzibyid + dozibyid
     &                          + d2edphi2*dphidzib*dphidyid
     &                          + domegadzib*dyid + domegadyid*dzib
               hessx(3,id) = hessx(3,id) + dedphi*dxibzid + doxibzid
     &                          + d2edphi2*dphidxib*dphidzid
     &                          + domegadxib*dzid + domegadzid*dxib
               hessy(3,id) = hessy(3,id) + dedphi*dyibzid + doyibzid
     &                          + d2edphi2*dphidyib*dphidzid
     &                          + domegadyib*dzid + domegadzid*dyib
               hessz(3,id) = hessz(3,id) + dedphi*dzibzid + dozibzid
     &                          + d2edphi2*dphidzib*dphidzid
     &                          + domegadzib*dzid + domegadzid*dzib
            else if (i .eq. ic) then
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic + doxicxic
     &                          + d2edphi2*dphidxic*dphidxic
     &                          + 2.0d0*domegadxic*dxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic + doxicyic
     &                          + d2edphi2*dphidxic*dphidyic
     &                          + domegadxic*dyic + domegadyic*dxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic + doxiczic
     &                          + d2edphi2*dphidxic*dphidzic
     &                          + domegadxic*dzic + domegadzic*dxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic + doxicyic
     &                          + d2edphi2*dphidxic*dphidyic
     &                          + domegadxic*dyic + domegadyic*dxic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic + doyicyic
     &                          + d2edphi2*dphidyic*dphidyic
     &                          + 2.0d0*domegadyic*dyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic + doyiczic
     &                          + d2edphi2*dphidyic*dphidzic
     &                          + domegadyic*dzic + domegadzic*dyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic + doxiczic
     &                          + d2edphi2*dphidxic*dphidzic
     &                          + domegadxic*dzic + domegadzic*dxic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic + doyiczic
     &                          + d2edphi2*dphidyic*dphidzic
     &                          + domegadyic*dzic + domegadzic*dyic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczic + doziczic
     &                          + d2edphi2*dphidzic*dphidzic
     &                          + 2.0d0*domegadzic*dzic
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxic*dphidxia
     &                          + domegadxic*dxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic
     &                          + d2edphi2*dphidyic*dphidxia
     &                          + domegadyic*dxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic
     &                          + d2edphi2*dphidzic*dphidxia
     &                          + domegadzic*dxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic
     &                          + d2edphi2*dphidxic*dphidyia
     &                          + domegadxic*dyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic
     &                          + d2edphi2*dphidyic*dphidyia
     &                          + domegadyic*dyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic
     &                          + d2edphi2*dphidzic*dphidyia
     &                          + domegadzic*dyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic
     &                          + d2edphi2*dphidxic*dphidzia
     &                          + domegadxic*dzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayic
     &                          + d2edphi2*dphidyic*dphidzia
     &                          + domegadyic*dzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazic
     &                          + d2edphi2*dphidzic*dphidzia
     &                          + domegadzic*dzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic + doxicxib
     &                          + d2edphi2*dphidxic*dphidxib
     &                          + domegadxib*dxic + domegadxic*dxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic + doyicxib
     &                          + d2edphi2*dphidyic*dphidxib
     &                          + domegadxib*dyic + domegadyic*dxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic + dozicxib
     &                          + d2edphi2*dphidzic*dphidxib
     &                          + domegadxib*dzic + domegadzic*dxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic + doxicyib
     &                          + d2edphi2*dphidxic*dphidyib
     &                          + domegadyib*dxic + domegadxic*dyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic + doyicyib
     &                          + d2edphi2*dphidyic*dphidyib
     &                          + domegadyib*dyic + domegadyic*dyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic + dozicyib
     &                          + d2edphi2*dphidzic*dphidyib
     &                          + domegadyib*dzic + domegadzic*dyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic + doxiczib
     &                          + d2edphi2*dphidxic*dphidzib
     &                          + domegadzib*dxic + domegadxic*dzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic + doyiczib
     &                          + d2edphi2*dphidyic*dphidzib
     &                          + domegadzib*dyic + domegadyic*dzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic + doziczib
     &                          + d2edphi2*dphidzic*dphidzib
     &                          + domegadzib*dzic + domegadzic*dzib
               hessx(1,id) = hessx(1,id) + dedphi*dxicxid + doxicxid
     &                          + d2edphi2*dphidxic*dphidxid
     &                          + domegadxic*dxid + domegadxid*dxic
               hessy(1,id) = hessy(1,id) + dedphi*dyicxid + doyicxid
     &                          + d2edphi2*dphidyic*dphidxid
     &                          + domegadyic*dxid + domegadxid*dyic
               hessz(1,id) = hessz(1,id) + dedphi*dzicxid + dozicxid
     &                          + d2edphi2*dphidzic*dphidxid
     &                          + domegadzic*dxid + domegadxid*dzic
               hessx(2,id) = hessx(2,id) + dedphi*dxicyid + doxicyid
     &                          + d2edphi2*dphidxic*dphidyid
     &                          + domegadxic*dyid + domegadyid*dxic
               hessy(2,id) = hessy(2,id) + dedphi*dyicyid + doyicyid
     &                          + d2edphi2*dphidyic*dphidyid
     &                          + domegadyic*dyid + domegadyid*dyic
               hessz(2,id) = hessz(2,id) + dedphi*dzicyid + dozicyid
     &                          + d2edphi2*dphidzic*dphidyid
     &                          + domegadzic*dyid + domegadyid*dzic
               hessx(3,id) = hessx(3,id) + dedphi*dxiczid + doxiczid
     &                          + d2edphi2*dphidxic*dphidzid
     &                          + domegadxic*dzid + domegadzid*dxic
               hessy(3,id) = hessy(3,id) + dedphi*dyiczid + doyiczid
     &                          + d2edphi2*dphidyic*dphidzid
     &                          + domegadyic*dzid + domegadzid*dyic
               hessz(3,id) = hessz(3,id) + dedphi*dziczid + doziczid
     &                          + d2edphi2*dphidzic*dphidzid
     &                          + domegadzic*dzid + domegadzid*dzic
            else if (i .eq. id) then
               hessx(1,id) = hessx(1,id) + dedphi*dxidxid + doxidxid
     &                          + d2edphi2*dphidxid*dphidxid
     &                          + 2.0d0*domegadxid*dxid
               hessy(1,id) = hessy(1,id) + dedphi*dxidyid + doxidyid
     &                          + d2edphi2*dphidxid*dphidyid
     &                          + domegadxid*dyid + domegadyid*dxid
               hessz(1,id) = hessz(1,id) + dedphi*dxidzid + doxidzid
     &                          + d2edphi2*dphidxid*dphidzid
     &                          + domegadxid*dzid + domegadzid*dxid
               hessx(2,id) = hessx(2,id) + dedphi*dxidyid + doxidyid
     &                          + d2edphi2*dphidxid*dphidyid
     &                          + domegadxid*dyid + domegadyid*dxid
               hessy(2,id) = hessy(2,id) + dedphi*dyidyid + doyidyid
     &                          + d2edphi2*dphidyid*dphidyid
     &                          + 2.0d0*domegadyid*dyid
               hessz(2,id) = hessz(2,id) + dedphi*dyidzid + doyidzid
     &                          + d2edphi2*dphidyid*dphidzid
     &                          + domegadyid*dzid + domegadzid*dyid
               hessx(3,id) = hessx(3,id) + dedphi*dxidzid + doxidzid
     &                          + d2edphi2*dphidxid*dphidzid
     &                          + domegadxid*dzid + domegadzid*dxid
               hessy(3,id) = hessy(3,id) + dedphi*dyidzid + doyidzid
     &                          + d2edphi2*dphidyid*dphidzid
     &                          + domegadyid*dzid + domegadzid*dyid
               hessz(3,id) = hessz(3,id) + dedphi*dzidzid + dozidzid
     &                          + d2edphi2*dphidzid*dphidzid
     &                          + 2.0d0*domegadzid*dzid
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxid*dphidxia
     &                          + domegadxid*dxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid
     &                          + d2edphi2*dphidyid*dphidxia
     &                          + domegadyid*dxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid
     &                          + d2edphi2*dphidzid*dphidxia
     &                          + domegadzid*dxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid
     &                          + d2edphi2*dphidxid*dphidyia
     &                          + domegadxid*dyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid
     &                          + d2edphi2*dphidyid*dphidyia
     &                          + domegadyid*dyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid
     &                          + d2edphi2*dphidzid*dphidyia
     &                          + domegadzid*dyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid
     &                          + d2edphi2*dphidxid*dphidzia
     &                          + domegadxid*dzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayid
     &                          + d2edphi2*dphidyid*dphidzia
     &                          + domegadyid*dzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazid
     &                          + d2edphi2*dphidzid*dphidzia
     &                          + domegadzid*dzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid + doxibxid
     &                          + d2edphi2*dphidxid*dphidxib
     &                          + domegadxib*dxid + domegadxid*dxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid + doxibyid
     &                          + d2edphi2*dphidyid*dphidxib
     &                          + domegadxib*dyid + domegadyid*dxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid + doxibzid
     &                          + d2edphi2*dphidzid*dphidxib
     &                          + domegadxib*dzid + domegadzid*dxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid + doyibxid
     &                          + d2edphi2*dphidxid*dphidyib
     &                          + domegadyib*dxid + domegadxid*dyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid + doyibyid
     &                          + d2edphi2*dphidyid*dphidyib
     &                          + domegadyib*dyid + domegadyid*dyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid + doyibzid
     &                          + d2edphi2*dphidzid*dphidyib
     &                          + domegadyib*dzid + domegadzid*dyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid + dozibxid
     &                          + d2edphi2*dphidxid*dphidzib
     &                          + domegadzib*dxid + domegadxid*dzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid + dozibyid
     &                          + d2edphi2*dphidyid*dphidzib
     &                          + domegadzib*dyid + domegadyid*dzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid + dozibzid
     &                          + d2edphi2*dphidzid*dphidzib
     &                          + domegadzib*dzid + domegadzid*dzib
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid + doxicxid
     &                          + d2edphi2*dphidxid*dphidxic
     &                          + domegadxic*dxid + domegadxid*dxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid + doxicyid
     &                          + d2edphi2*dphidyid*dphidxic
     &                          + domegadxic*dyid + domegadyid*dxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid + doxiczid
     &                          + d2edphi2*dphidzid*dphidxic
     &                          + domegadxic*dzid + domegadzid*dxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid + doyicxid
     &                          + d2edphi2*dphidxid*dphidyic
     &                          + domegadyic*dxid + domegadxid*dyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid + doyicyid
     &                          + d2edphi2*dphidyid*dphidyic
     &                          + domegadyic*dyid + domegadyid*dyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid + doyiczid
     &                          + d2edphi2*dphidzid*dphidyic
     &                          + domegadyic*dzid + domegadzid*dyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid + dozicxid
     &                          + d2edphi2*dphidxid*dphidzic
     &                          + domegadzic*dxid + domegadxid*dzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid + dozicyid
     &                          + d2edphi2*dphidyid*dphidzic
     &                          + domegadzic*dyid + domegadyid*dzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczid + doziczid
     &                          + d2edphi2*dphidzid*dphidzic
     &                          + domegadzic*dzid + domegadzid*dzic
            end if
         end if
      end do
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder  ##
c     ##                  All Rights Reserved                 ##
c     ##########################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eangtor3  --  angle-torsion energy & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "eangtor3" calculates the angle-torsion potential energy;
c     also partitions the energy terms among the atoms
c
c
      subroutine eangtor3
      use action
      use analyz
      use angbnd
      use angtor
      use atomid
      use atoms
      use bound
      use energi
      use group
      use inform
      use iounit
      use math
      use torpot
      use tors
      use usage
      implicit none
      integer i,k,iangtor
      integer ia,ib,ic,id
      real*8 e,e1,e2
      real*8 eps,fgrp
      real*8 rba,rcb,rdc
      real*8 rt2,ru2,rtru
      real*8 dot,dt,tangle
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 sine3,cosine3
      real*8 phi1,phi2,phi3
      real*8 angle,cosang
      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
      real*8 xdc,ydc,zdc
      logical proceed
      logical header,huge
c
c
c     zero out the energy due to extra potential terms
c
      neat = 0
      eat = 0.0d0
      do i = 1, n
         aeat(i) = 0.0d0
      end do
      if (nangtor .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nangtor.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Angle-Torsion Interactions :',
     &           //,' Type',25x,'Atom Names',21x,'Angle',
     &              6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nangtor,iat,itors,kant,
!$OMP& anat,tors1,tors2,tors3,use,x,y,z,atorunit,eps,use_group,
!$OMP& use_polymer,name,verbose,debug,header,iout)
!$OMP& shared(eat,neat,aeat)
!$OMP DO reduction(+:eat,neat,aeat)
c
c     calculate the angle-torsion interaction energy term
c
      do iangtor = 1, nangtor
         i = iat(1,iangtor)
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rba = sqrt(max(xba*xba+yba*yba+zba*zba,eps))
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            rdc = sqrt(max(xdc*xdc+ydc*ydc+zdc*zdc,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2*ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            tangle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  tangle = -tangle
c
c     compute multiple angle trigonometry and phase terms
c
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            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)
c
c     get the angle-torsion values for the first angle
c
            v1 = kant(1,iangtor)
            v2 = kant(2,iangtor)
            v3 = kant(3,iangtor)
            k = iat(2,iangtor)
            dot = xba*xcb + yba*ycb + zba*zcb
            cosang = -dot / (rba*rcb)
            angle = radian * acos(cosang)
            dt = angle - anat(k)
            e1 = atorunit * dt * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     get the angle-torsion values for the second angle
c
            v1 = kant(4,iangtor)
            v2 = kant(5,iangtor)
            v3 = kant(6,iangtor)
            k = iat(3,iangtor)
            dot = xcb*xdc + ycb*ydc + zcb*zdc
            cosang = -dot / (rcb*rdc)
            angle = radian * acos(cosang)
            dt = angle - anat(k)
            e2 = atorunit * dt * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e1 = e1 * fgrp
               e2 = e2 * fgrp
            end if
c
c     increment the total angle-torsion energy
c
            neat = neat + 1
            e = e1 + e2
            eat = eat + e
            aeat(ia) = aeat(ia) + e1/3.0d0
            aeat(ib) = aeat(ib) + e/3.0d0
            aeat(ic) = aeat(ic) + e/3.0d0
            aeat(id) = aeat(id) + e2/3.0d0
c
c     print a message if the energy of this interaction is large
c
            huge = (e .gt. 3.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Individual Angle-Torsion',
     &                       ' Interactions :',
     &                    //,' Type',25x,'Atom Names',21x,'Angle',
     &                       6x,'Energy',/)
               end if
               write (iout,30)  ia,name(ia),ib,name(ib),ic,
     &                          name(ic),id,name(id),tangle,e
   30          format (' AngTors',3x,4(i7,'-',a3),f11.4,f12.4)
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine ebond  --  bond stretch potential energy  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "ebond" calculates the bond stretching energy
c
c
      subroutine ebond
      use atoms
      use bndpot
      use bndstr
      use bound
      use energi
      use group
      use usage
      implicit none
      integer i,ia,ib
      real*8 e,ideal,force
      real*8 expterm,bde
      real*8 dt,dt2,fgrp
      real*8 xab,yab,zab,rab
      logical proceed
c
c
c     zero out the bond stretching energy
c
      eb = 0.0d0
      if (nbond .eq. 0)  return
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nbond,ibnd,bl,bk,use,
!$OMP& x,y,z,cbnd,qbnd,bndtyp,bndunit,use_group,use_polymer)
!$OMP& shared(eb)
!$OMP DO reduction(+:eb)
c
c     calculate the bond stretching energy term
c
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ideal = bl(i)
         force = bk(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,0,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib))
c
c     compute the value of the bond length deviation
c
         if (proceed) then
            xab = x(ia) - x(ib)
            yab = y(ia) - y(ib)
            zab = z(ia) - z(ib)
            if (use_polymer)  call image (xab,yab,zab)
            rab = sqrt(xab*xab + yab*yab + zab*zab)
            dt = rab - ideal
c
c     harmonic potential uses Taylor expansion of Morse potential
c     through the fourth power of the bond length deviation
c
            if (bndtyp .eq. 'HARMONIC') then
               dt2 = dt * dt
               e = bndunit * force * dt2 * (1.0d0+cbnd*dt+qbnd*dt2)
c
c     Morse potential uses energy = BDE * (1 - e**(-alpha*dt))**2
c     with the approximations alpha = sqrt(ForceConst/BDE) = 2
c     and BDE = Bond Dissociation Energy = ForceConst/alpha**2
c
            else if (bndtyp .eq. 'MORSE') then
               expterm = exp(-2.0d0*dt)
               bde = 0.25d0 * bndunit * force
               e = bde * (1.0d0-expterm)**2
            end if
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total bond stretching energy
c
            eb = eb + e
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ebond1  --  bond stretch energy & derivatives  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ebond1" calculates the bond stretching energy and
c     first derivatives with respect to Cartesian coordinates
c
c
      subroutine ebond1
      use atoms
      use bndpot
      use bndstr
      use bound
      use deriv
      use energi
      use group
      use usage
      use virial
      implicit none
      integer i,ia,ib
      real*8 e,ideal,force
      real*8 expterm,bde,fgrp
      real*8 dt,dt2,deddt
      real*8 de,dedx,dedy,dedz
      real*8 xab,yab,zab,rab
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out the bond energy and first derivatives
c
      eb = 0.0d0
      do i = 1, n
         deb(1,i) = 0.0d0
         deb(2,i) = 0.0d0
         deb(3,i) = 0.0d0
      end do
      if (nbond .eq. 0)  return
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nbond,ibnd,bl,bk,use,
!$OMP& x,y,z,cbnd,qbnd,bndtyp,bndunit,use_group,use_polymer)
!$OMP& shared(eb,deb,vir)
!$OMP DO reduction(+:eb,deb,vir)
c
c     calculate the bond stretch energy and first derivatives
c
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ideal = bl(i)
         force = bk(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,0,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib))
c
c     compute the value of the bond length deviation
c
         if (proceed) then
            xab = x(ia) - x(ib)
            yab = y(ia) - y(ib)
            zab = z(ia) - z(ib)
            if (use_polymer)  call image (xab,yab,zab)
            rab = sqrt(xab*xab + yab*yab + zab*zab)
            dt = rab - ideal
c
c     harmonic potential uses Taylor expansion of Morse potential
c     through the fourth power of the bond length deviation
c
            if (bndtyp .eq. 'HARMONIC') then
               dt2 = dt * dt
               e = bndunit * force * dt2 * (1.0d0+cbnd*dt+qbnd*dt2)
               deddt = 2.0d0 * bndunit * force * dt
     &                    * (1.0d0+1.5d0*cbnd*dt+2.0d0*qbnd*dt2)
c
c     Morse potential uses energy = BDE * (1 - e**(-alpha*dt))**2
c     with the approximations alpha = sqrt(ForceConst/BDE) = 2
c     and BDE = Bond Dissociation Energy = ForceConst/alpha**2
c
            else if (bndtyp .eq. 'MORSE') then
               expterm = exp(-2.0d0*dt)
               bde = 0.25d0 * bndunit * force
               e = bde * (1.0d0-expterm)**2
               deddt = 4.0d0 * bde * (1.0d0-expterm) * expterm
            end if
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e = e * fgrp
               deddt = deddt * fgrp
            end if
c
c     compute chain rule terms needed for derivatives
c
            if (rab .eq. 0.0d0) then
               de = 0.0d0
            else
               de = deddt / rab
            end if
            dedx = de * xab
            dedy = de * yab
            dedz = de * zab
c
c     increment the total bond energy and first derivatives
c
            eb = eb + e
            deb(1,ia) = deb(1,ia) + dedx
            deb(2,ia) = deb(2,ia) + dedy
            deb(3,ia) = deb(3,ia) + dedz
            deb(1,ib) = deb(1,ib) - dedx
            deb(2,ib) = deb(2,ib) - dedy
            deb(3,ib) = deb(3,ib) - dedz
c
c     increment the internal virial tensor components
c
            vxx = xab * dedx
            vyx = yab * dedx
            vzx = zab * dedx
            vyy = yab * dedy
            vzy = zab * dedy
            vzz = zab * dedz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ebond2  --  atom-by-atom bond stretch Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ebond2" calculates second derivatives of the bond
c     stretching energy for a single atom at a time
c
c
      subroutine ebond2 (i)
      use atmlst
      use atoms
      use bndpot
      use bndstr
      use bound
      use couple
      use group
      use hessn
      implicit none
      integer i,j,k,ia,ib
      real*8 ideal,force,fgrp
      real*8 xab,yab,zab
      real*8 rab,rab2
      real*8 expterm,bde
      real*8 dt,dt2,term
      real*8 termx,termy,termz
      real*8 de,deddt,d2eddt2
      real*8 d2e(3,3)
      logical proceed
c
c
c     calculate the bond stretch interaction Hessian elements
c
      ia = i
      do k = 1, n12(ia)
         j = bndlist(k,ia)
         if (ibnd(1,j) .eq. ia) then
            ib = ibnd(2,j)
         else
            ib = ibnd(1,j)
         end if
         ideal = bl(j)
         force = bk(j)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,0,0,0,0)
c
c     compute the value of the bond length deviation
c
         if (proceed) then
            xab = x(ia) - x(ib)
            yab = y(ia) - y(ib)
            zab = z(ia) - z(ib)
            if (use_polymer)  call image (xab,yab,zab)
            rab2 = xab*xab + yab*yab + zab*zab
            rab = sqrt(rab2)
            dt = rab - ideal
c
c     harmonic potential uses Taylor expansion of Morse potential
c     through the fourth power of the bond length deviation
c
            if (bndtyp .eq. 'HARMONIC') then
               dt2 = dt * dt
               deddt = 2.0d0 * bndunit * force * dt
     &                    * (1.0d0+1.5d0*cbnd*dt+2.0d0*qbnd*dt2)
               d2eddt2 = 2.0d0 * bndunit * force
     &                      * (1.0d0+3.0d0*cbnd*dt+6.0d0*qbnd*dt2)
c
c     Morse potential uses energy = BDE * (1 - e**(-alpha*dt))**2
c     with the approximations alpha = sqrt(ForceConst/BDE) = 2
c     and BDE = Bond Dissociation Energy = ForceConst/alpha**2
c
            else if (bndtyp .eq. 'MORSE') then
               expterm = exp(-2.0d0*dt)
               bde = 0.25d0 * bndunit * force
               deddt = 4.0d0 * bde * (1.0d0-expterm) * expterm
               d2eddt2 = -8.0d0 * bde * (1.0d0-2.0d0*expterm) * expterm
            end if
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               deddt = deddt * fgrp
               d2eddt2 = d2eddt2 * fgrp
            end if
c
c     set the chain rule terms for the Hessian elements
c
            if (rab2 .eq. 0.0d0) then
               de = 0.0d0
               term = 0.0d0
            else
               de = deddt / rab
               term = (d2eddt2-de) / rab2
            end if
            termx = term * xab
            termy = term * yab
            termz = term * zab
            d2e(1,1) = termx*xab + de
            d2e(1,2) = termx*yab
            d2e(1,3) = termx*zab
            d2e(2,1) = d2e(1,2)
            d2e(2,2) = termy*yab + de
            d2e(2,3) = termy*zab
            d2e(3,1) = d2e(1,3)
            d2e(3,2) = d2e(2,3)
            d2e(3,3) = termz*zab + de
c
c     increment diagonal and off-diagonal Hessian elements
c
            do j = 1, 3
               hessx(j,ia) = hessx(j,ia) + d2e(1,j)
               hessy(j,ia) = hessy(j,ia) + d2e(2,j)
               hessz(j,ia) = hessz(j,ia) + d2e(3,j)
               hessx(j,ib) = hessx(j,ib) - d2e(1,j)
               hessy(j,ib) = hessy(j,ib) - d2e(2,j)
               hessz(j,ib) = hessz(j,ib) - d2e(3,j)
            end do
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine ebond3  --  bond stretch energy & analysis  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "ebond3" calculates the bond stretching energy; also
c     partitions the energy among the atoms
c
c
      subroutine ebond3
      use action
      use analyz
      use atomid
      use atoms
      use bndpot
      use bndstr
      use bound
      use energi
      use group
      use inform
      use iounit
      use usage
      implicit none
      integer i,ia,ib
      real*8 e,ideal,force
      real*8 expterm,bde
      real*8 dt,dt2,fgrp
      real*8 xab,yab,zab,rab
      logical proceed
      logical header,huge
c
c
c     zero out the bond energy and partitioning terms
c
      neb = 0
      eb = 0.0d0
      do i = 1, n
         aeb(i) = 0.0d0
      end do
      if (nbond .eq. 0)  return
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nbond.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Bond Stretching Interactions :',
     &           //,' Type',14x,'Atom Names',22x,'Ideal',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nbond,ibnd,bl,bk,use,
!$OMP& x,y,z,cbnd,qbnd,bndtyp,bndunit,use_group,use_polymer,
!$OMP& name,verbose,debug,header,iout)
!$OMP& shared(eb,neb,aeb)
!$OMP DO reduction(+:eb,neb,aeb)
c
c     calculate the bond stretching energy term
c
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ideal = bl(i)
         force = bk(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,0,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib))
c
c     compute the value of the bond length deviation
c
         if (proceed) then
            xab = x(ia) - x(ib)
            yab = y(ia) - y(ib)
            zab = z(ia) - z(ib)
            if (use_polymer)  call image (xab,yab,zab)
            rab = sqrt(xab*xab + yab*yab + zab*zab)
            dt = rab - ideal
c
c     harmonic potential uses Taylor expansion of Morse potential
c     through the fourth power of the bond length deviation
c
            if (bndtyp .eq. 'HARMONIC') then
               dt2 = dt * dt
               e = bndunit * force * dt2 * (1.0d0+cbnd*dt+qbnd*dt2)
c
c     Morse potential uses energy = BDE * (1 - e**(-alpha*dt))**2
c     with the approximations alpha = sqrt(ForceConst/BDE) = 2
c     and BDE = Bond Dissociation Energy = ForceConst/alpha**2
c
            else if (bndtyp .eq. 'MORSE') then
               expterm = exp(-2.0d0*dt)
               bde = 0.25d0 * bndunit * force
               e = bde * (1.0d0-expterm)**2
            end if
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total bond energy and partition between atoms
c
            neb = neb + 1
            eb = eb + e
            aeb(ia) = aeb(ia) + 0.5d0*e
            aeb(ib) = aeb(ib) + 0.5d0*e
c
c     print a message if the energy of this interaction is large
c
            huge = (e .gt. 5.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Individual Bond Stretching',
     &                       ' Interactions :',
     &                    //,' Type',14x,'Atom Names',22x,'Ideal',
     &                       4x,'Actual',6x,'Energy',/)
               end if
               write (iout,30)  ia,name(ia),ib,name(ib),ideal,rab,e
   30          format (' Bond',6x,2(i7,'-',a3),13x,2f10.4,f12.4)
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine ebuck  --  Buckingham van der Waals energy  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "ebuck" calculates the Buckingham exp-6 van der Waals energy
c
c
      subroutine ebuck
      use energi
      use iounit
      use limits
      use vdwpot
      use warp
      implicit none
      real*8 elrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_stophat) then
         write (iout,10)
   10    format (/,' EBUCK  --  Stophat Smoothing not Available',
     &              ' for Buckingham vdw Potential')
         call fatal
      else if (use_smooth) then
         call ebuck0d
      else if (use_vlist) then
         call ebuck0c
      else if (use_lights) then
         call ebuck0b
      else
         call ebuck0a
      end if
c
c     apply the long range van der Waals correction if used
c
      if (use_vcorr) then
         mode = 'VDW'
         call evcorr (mode,elrc)
         ev = ev + elrc
      end if
      return
      end
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ebuck0a  --  double loop Buckingham vdw energy  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ebuck0a" calculates the Buckingham exp-6 van der Waals energy
c     using a pairwise double loop
c
c
      subroutine ebuck0a
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use energi
      use group
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     switch from exponential to R^12 at very short range
c
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - cbuck*p6)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     p2 = (rv*rv) / rik2
                     p6 = p2 * p2 * p2
                     if (p2 .le. expcut2) then
                        p = sqrt(p2)
                        expterm = abuck * exp(-bbuck/p)
                        e = eps * (expterm - cbuck*p6)
                     else
                        p12 = p6 * p6
                        e = expmerge * eps * p12
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik = sqrt(rik2)
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component;
c     interaction of an atom with its own image counts half
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ev = ev + e
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ebuck0b  --  Buckingham vdw energy via lights  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ebuck0b" calculates the Buckingham exp-6 van der Waals energy
c     using the method of lights
c
c
      subroutine ebuck0b
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use couple
      use energi
      use group
      use light
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer kgy,kgz
      integer start,stop
      integer, allocatable :: iv14(:)
      real*8 e,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     switch from exponential to R^12 at very short range
c
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rv = radmin4(kt,it)
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - cbuck*p6)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine ebuck0c  --  Buckingham vdw energy via list  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "ebuck0c" calculates the Buckingham exp-6 van der Waals energy
c     using a pairwise neighbor list
c
c
      subroutine ebuck0c
      use atomid
      use atoms
      use bound
      use couple
      use energi
      use group
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     switch from exponential to R^12 at very short range
c
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13,
!$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group,
!$OMP& off2,radmin,epsilon,radmin4,epsilon4,abuck,bbuck,cbuck,
!$OMP& expcut2,expmerge,cut2,c0,c1,c2,c3,c4,c5)
!$OMP& firstprivate(vscale,iv14) shared(ev)
!$OMP DO reduction(+:ev)
c
c     find the van der Waals energy via neighbor list search
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - cbuck*p6)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ebuck0d  --  Buckingham energy for smoothing  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ebuck0d" calculates the Buckingham exp-6 van der Waals energy
c     via a Gaussian approximation for potential energy smoothing
c
c
      subroutine ebuck0d
      use math
      use vdwpot
      implicit none
c
c
c     set coefficients for a two-Gaussian fit to MM2 vdw form
c
      ngauss = 2
      igauss(1,1) = 3423.562d0
      igauss(2,1) = 9.692821d0 * twosix**2
      igauss(1,2) = -6.503760d0
      igauss(2,2) = 1.585344d0 * twosix**2
c
c     compute Gaussian approximation to the Buckingham potential
c
      call egauss
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ebuck1  --  Buckingham vdw energy & derivatives  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ebuck1" calculates the Buckingham exp-6 van der Waals energy
c     and its first derivatives with respect to Cartesian coordinates
c
c
      subroutine ebuck1
      use energi
      use iounit
      use limits
      use vdwpot
      use virial
      use warp
      implicit none
      real*8 elrc,vlrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_stophat) then
         write (iout,10)
   10    format (/,' EBUCK1  --  Stophat Smoothing not Available',
     &              ' for Buckingham vdw Potential')
         call fatal
      else if (use_smooth) then
         call ebuck1d
      else if (use_vlist) then
         call ebuck1c
      else if (use_lights) then
         call ebuck1b
      else
         call ebuck1a
      end if
c
c     apply the long range van der Waals correction if used
c
      if (use_vcorr) then
         mode = 'VDW'
         call evcorr1 (mode,elrc,vlrc)
         ev = ev + elrc
         vir(1,1) = vir(1,1) + vlrc
         vir(2,2) = vir(2,2) + vlrc
         vir(3,3) = vir(3,3) + vlrc
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ebuck1a  --  double loop Buckingham vdw derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ebuck1a" calculates the Buckingham exp-6 van der Waals energy
c     and its first derivatives using a pairwise double loop
c
c
      subroutine ebuck1a
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use deriv
      use energi
      use group
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,de,rv
      real*8 eps,rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rvterm
      real*8 taper,dtaper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     switch from exponential to R^12 at very short range
c
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find van der Waals energy and derivatives via double loop
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  rik = sqrt(rik2)
                  if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     rvterm = -bbuck / rv
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - cbuck*p6)
                     de = eps * (rvterm*expterm+6.0d0*cbuck*p6/rik)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                     de = -12.0d0 * e / rik
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     p2 = (rv*rv) / rik2
                     p6 = p2 * p2 * p2
                     rik = sqrt(rik2)
                     if (p2 .le. expcut2) then
                        p = sqrt(p2)
                        rvterm = -bbuck / rv
                        expterm = abuck * exp(-bbuck/p)
                        e = eps * (expterm - cbuck*p6)
                        de = eps * (rvterm*expterm+6.0d0*cbuck*p6/rik)
                     else
                        p12 = p6 * p6
                        e = expmerge * eps * p12
                        de = -12.0d0 * e / rik
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                              + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                        de = e*dtaper + de*taper
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        e = e * fgrp
                        de = de * fgrp
                     end if
c
c     find the chain rule terms for derivative components
c
                     de = de / rik
                     dedx = de * xr
                     dedy = de * yr
                     dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ev = ev + e
                     if (i .eq. iv) then
                        dev(1,i) = dev(1,i) + dedx
                        dev(2,i) = dev(2,i) + dedy
                        dev(3,i) = dev(3,i) + dedz
                     else
                        dev(1,i) = dev(1,i) + dedx*redi
                        dev(2,i) = dev(2,i) + dedy*redi
                        dev(3,i) = dev(3,i) + dedz*redi
                        dev(1,iv) = dev(1,iv) + dedx*rediv
                        dev(2,iv) = dev(2,iv) + dedy*rediv
                        dev(3,iv) = dev(3,iv) + dedz*rediv
                     end if
                     if (i .ne. k) then
                        if (k .eq. kv) then
                           dev(1,k) = dev(1,k) - dedx
                           dev(2,k) = dev(2,k) - dedy
                           dev(3,k) = dev(3,k) - dedz
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           dev(1,k) = dev(1,k) - dedx*redk
                           dev(2,k) = dev(2,k) - dedy*redk
                           dev(3,k) = dev(3,k) - dedz*redk
                           dev(1,kv) = dev(1,kv) - dedx*redkv
                           dev(2,kv) = dev(2,kv) - dedy*redkv
                           dev(3,kv) = dev(3,kv) - dedz*redkv
                        end if
                     end if
c
c     increment the internal virial tensor components
c
                     vxx = xr * dedx
                     vyx = yr * dedx
                     vzx = zr * dedx
                     vyy = yr * dedy
                     vzy = zr * dedy
                     vzz = zr * dedz
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ebuck1b  --  Buckingham vdw derivs via lights  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ebuck1b" calculates the Buckingham exp-6 van der Waals energy
c     and its first derivatives using the method of lights
c
c
      subroutine ebuck1b
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use couple
      use deriv
      use energi
      use group
      use light
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer kgy,kgz
      integer start,stop
      integer, allocatable :: iv14(:)
      real*8 e,de,rv
      real*8 eps,rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rvterm
      real*8 taper,dtaper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     switch from exponential to R^12 at very short range
c
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rv = radmin4(kt,it)
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  rik = sqrt(rik2)
                  if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     rvterm = -bbuck / rv
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - cbuck*p6)
                     de = eps * (rvterm*expterm+6.0d0*cbuck*p6/rik)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                     de = -12.0d0 * e / rik
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine ebuck1c  --  Buckingham vdw derivs via list  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "ebuck1c" calculates the Buckingham exp-6 van der Waals energy
c     and its first derivatives using a pairwise neighbor list
c
c
      subroutine ebuck1c
      use atomid
      use atoms
      use bound
      use couple
      use deriv
      use energi
      use group
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,de,rv
      real*8 eps,rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rvterm
      real*8 taper,dtaper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     switch from exponential to R^12 at very short range
c
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& kred,xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,
!$OMP& i12,i13,i14,i15,v2scale,v3scale,v4scale,v5scale,
!$OMP& use_group,off2,radmin,epsilon,radmin4,epsilon4,abuck,
!$OMP& bbuck,cbuck,expcut2,expmerge,cut2,c0,c1,c2,c3,c4,c5)
!$OMP& firstprivate(vscale,iv14) shared(ev,dev,vir)
!$OMP DO reduction(+:ev,dev,vir)
c
c     find van der Waals energy and derivatives via neighbor list
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  rik = sqrt(rik2)
                  if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     rvterm = -bbuck / rv
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - cbuck*p6)
                     de = eps * (rvterm*expterm+6.0d0*cbuck*p6/rik)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                     de = -12.0d0 * e / rik
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ebuck1d  --  Buckingham derivs for smoothing  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ebuck1d" calculates the Buckingham exp-6 van der Waals energy
c     and its first derivatives via a Gaussian approximation for
c     potential energy smoothing
c
c
      subroutine ebuck1d
      use math
      use vdwpot
      implicit none
c
c
c     set coefficients for a two-Gaussian fit to MM2 vdw form
c
      ngauss = 2
      igauss(1,1) = 3423.562d0
      igauss(2,1) = 9.692821d0 * twosix**2
      igauss(1,2) = -6.503760d0
      igauss(2,2) = 1.585344d0 * twosix**2
c
c     compute Gaussian approximation to the Buckingham potential
c
      call egauss1
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ebuck2  --  atom-by-atom Buckingham vdw Hessian  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ebuck2" calculates the Buckingham exp-6 van der Waals
c     second derivatives for a single atom at a time
c
c
      subroutine ebuck2 (i)
      use iounit
      use warp
      implicit none
      integer i
c
c
c     choose double loop, method of lights or smoothing version
c
      if (use_stophat) then
         write (iout,10)
   10    format (/,' EBUCK2  --  Stophat Smoothing not Available',
     &              ' for Buckingham vdw Potential')
         call fatal
      else if (use_smooth) then
         call ebuck2b (i)
      else
         call ebuck2a (i)
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ebuck2a  --  double loop Buckingham vdw Hessian  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ebuck2a" calculates the Buckingham exp-6 van der Waals second
c     derivatives using a double loop over relevant atom pairs
c
c
      subroutine ebuck2a (iatom)
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use group
      use hessn
      use shunt
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer iatom,jcell
      integer nlist,list(5)
      integer, allocatable :: iv14(:)
      real*8 e,de,d2e,fgrp
      real*8 p,p2,p6,p12
      real*8 eps,rv,rdn
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 redi2,rediv2,rediiv
      real*8 redik,redivk
      real*8 redikv,redivkv
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 taper,dtaper,d2taper
      real*8 d2edx,d2edy,d2edz
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8 rvterm,rvterm2
      real*8 term(3,3)
      real*8, allocatable :: vscale(:)
      logical proceed
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     switch from exponential to R^12 at very short range
c
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     check to see if the atom of interest is a vdw site
c
      nlist = 0
      do k = 1, nvdw
         if (ivdw(k) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = iatom
            goto 10
         end if
      end do
      return
   10 continue
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     determine the atoms involved via reduction factors
c
      nlist = 1
      list(nlist) = iatom
      do k = 1, n12(iatom)
         i = i12(k,iatom)
         if (ired(i) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = i
         end if
      end do
c
c     find van der Waals Hessian elements for involved atoms
c
      do ii = 1, nlist
         i = list(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         if (i .ne. iv) then
            rediv = 1.0d0 - redi
            redi2 = redi * redi
            rediv2 = rediv * rediv
            rediiv = redi * rediv
         end if
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (k .ne. i)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  rik = sqrt(rik2)
                  if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     rvterm = -bbuck / rv
                     rvterm2 = rvterm * rvterm
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - cbuck*p6)
                     de = eps * (rvterm*expterm+6.0d0*cbuck*p6/rik)
                     d2e = eps * (rvterm2*expterm-42.0d0*cbuck*p6/rik2)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                     de = -12.0d0 * e / rik
                     d2e = 156.0d0 * e / rik2
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2
     &                            + 6.0d0*c3*rik + 2.0d0*c2
                     d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper
                     de = e*dtaper + de*taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     de = de * fgrp
                     d2e = d2e * fgrp
                  end if
c
c     get chain rule terms for van der Waals Hessian elements
c
                  de = de / rik
                  d2e = (d2e-de) / rik2
                  d2edx = d2e * xr
                  d2edy = d2e * yr
                  d2edz = d2e * zr
                  term(1,1) = d2edx*xr + de
                  term(1,2) = d2edx*yr
                  term(1,3) = d2edx*zr
                  term(2,1) = term(1,2)
                  term(2,2) = d2edy*yr + de
                  term(2,3) = d2edy*zr
                  term(3,1) = term(1,3)
                  term(3,2) = term(2,3)
                  term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                  if (i .eq. iatom) then
                     if (i.eq.iv .and. k.eq.kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)
                           hessy(j,i) = hessy(j,i) + term(2,j)
                           hessz(j,i) = hessz(j,i) + term(3,j)
                           hessx(j,k) = hessx(j,k) - term(1,j)
                           hessy(j,k) = hessy(j,k) - term(2,j)
                           hessz(j,k) = hessz(j,k) - term(3,j)
                        end do
                     else if (k .eq. kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                           hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                           hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                           hessx(j,k) = hessx(j,k) - term(1,j)*redi
                           hessy(j,k) = hessy(j,k) - term(2,j)*redi
                           hessz(j,k) = hessz(j,k) - term(3,j)*redi
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                        end do
                     else if (i .eq. iv) then
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)
                           hessy(j,i) = hessy(j,i) + term(2,j)
                           hessz(j,i) = hessz(j,i) + term(3,j)
                           hessx(j,k) = hessx(j,k) - term(1,j)*redk
                           hessy(j,k) = hessy(j,k) - term(2,j)*redk
                           hessz(j,k) = hessz(j,k) - term(3,j)*redk
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv
                        end do
                     else
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        redik = redi * redk
                        redikv = redi * redkv
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                           hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                           hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                           hessx(j,k) = hessx(j,k) - term(1,j)*redik
                           hessy(j,k) = hessy(j,k) - term(2,j)*redik
                           hessz(j,k) = hessz(j,k) - term(3,j)*redik
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv
                        end do
                     end if
                  else if (iv .eq. iatom) then
                     if (k .eq. kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                           hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                           hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                           hessx(j,k) = hessx(j,k) - term(1,j)*rediv
                           hessy(j,k) = hessy(j,k) - term(2,j)*rediv
                           hessz(j,k) = hessz(j,k) - term(3,j)*rediv
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                        end do
                     else
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        redivk = rediv * redk
                        redivkv = rediv * redkv
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                           hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                           hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                           hessx(j,k) = hessx(j,k) - term(1,j)*redivk
                           hessy(j,k) = hessy(j,k) - term(2,j)*redivk
                           hessz(j,k) = hessz(j,k) - term(3,j)*redivk
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv
                        end do
                     end if
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nlist
         i = list(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         if (i .ne. iv) then
            rediv = 1.0d0 - redi
            redi2 = redi * redi
            rediv2 = rediv * rediv
            rediiv = redi * rediv
         end if
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               do jcell = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,jcell)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     p2 = (rv*rv) / rik2
                     p6 = p2 * p2 * p2
                     rik = sqrt(rik2)
                     if (p2 .le. expcut2) then
                        p = sqrt(p2)
                        rvterm = -bbuck / rv
                        rvterm2 = rvterm * rvterm
                        expterm = abuck * exp(-bbuck/p)
                        e = eps * (expterm - cbuck*p6)
                        de = eps * (rvterm*expterm+6.0d0*cbuck*p6/rik)
                        d2e = eps * (rvterm2*expterm
     &                                  -42.0d0*cbuck*p6/rik2)
                     else
                        p12 = p6 * p6
                        e = expmerge * eps * p12
                        de = -12.0d0 * e / rik
                        d2e = 156.0d0 * e / rik2
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                        d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2
     &                             + 6.0d0*c3*rik + 2.0d0*c2
                        d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper
                        de = e*dtaper + de*taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        de = de * fgrp
                        d2e = d2e * fgrp
                     end if
c
c     get chain rule terms for van der Waals Hessian elements
c
                     de = de / rik
                     d2e = (d2e-de) / rik2
                     d2edx = d2e * xr
                     d2edy = d2e * yr
                     d2edz = d2e * zr
                     term(1,1) = d2edx*xr + de
                     term(1,2) = d2edx*yr
                     term(1,3) = d2edx*zr
                     term(2,1) = term(1,2)
                     term(2,2) = d2edy*yr + de
                     term(2,3) = d2edy*zr
                     term(3,1) = term(1,3)
                     term(3,2) = term(2,3)
                     term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                     if (i .eq. iatom) then
                        if (i.eq.iv .and. k.eq.kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)
                              hessy(j,i) = hessy(j,i) + term(2,j)
                              hessz(j,i) = hessz(j,i) + term(3,j)
                              hessx(j,k) = hessx(j,k) - term(1,j)
                              hessy(j,k) = hessy(j,k) - term(2,j)
                              hessz(j,k) = hessz(j,k) - term(3,j)
                           end do
                        else if (k .eq. kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                              hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                              hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                              hessx(j,k) = hessx(j,k) - term(1,j)*redi
                              hessy(j,k) = hessy(j,k) - term(2,j)*redi
                              hessz(j,k) = hessz(j,k) - term(3,j)*redi
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediiv
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediiv
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediiv
                           end do
                        else if (i .eq. iv) then
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)
                              hessy(j,i) = hessy(j,i) + term(2,j)
                              hessz(j,i) = hessz(j,i) + term(3,j)
                              hessx(j,k) = hessx(j,k) - term(1,j)*redk
                              hessy(j,k) = hessy(j,k) - term(2,j)*redk
                              hessz(j,k) = hessz(j,k) - term(3,j)*redk
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redkv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redkv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redkv
                           end do
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           redik = redi * redk
                           redikv = redi * redkv
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                              hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                              hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                              hessx(j,k) = hessx(j,k) - term(1,j)*redik
                              hessy(j,k) = hessy(j,k) - term(2,j)*redik
                              hessz(j,k) = hessz(j,k) - term(3,j)*redik
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediiv
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediiv
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediiv
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redikv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redikv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redikv
                           end do
                        end if
                     else if (iv .eq. iatom) then
                        if (k .eq. kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                              hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                              hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                              hessx(j,k) = hessx(j,k) - term(1,j)*rediv
                              hessy(j,k) = hessy(j,k) - term(2,j)*rediv
                              hessz(j,k) = hessz(j,k) - term(3,j)*rediv
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediv2
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediv2
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediv2
                           end do
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           redivk = rediv * redk
                           redivkv = rediv * redkv
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                              hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                              hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                              hessx(j,k) = hessx(j,k) - term(1,j)*redivk
                              hessy(j,k) = hessy(j,k) - term(2,j)*redivk
                              hessz(j,k) = hessz(j,k) - term(3,j)*redivk
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediv2
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediv2
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediv2
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redivkv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redivkv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redivkv
                           end do
                        end if
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ebuck2b  --  Buckingham Hessian for smoothing  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ebuck2b" calculates the Buckingham exp-6 van der Waals second
c     derivatives via a Gaussian approximation for use with potential
c     energy smoothing
c
c
      subroutine ebuck2b (i)
      use math
      use vdwpot
      implicit none
      integer i
c
c
c     set coefficients for a two-Gaussian fit to MM2 vdw form
c
      ngauss = 2
      igauss(1,1) = 3423.562d0
      igauss(2,1) = 9.692821d0 * twosix**2
      igauss(1,2) = -6.503760d0
      igauss(2,2) = 1.585344d0 * twosix**2
c
c     compute Gaussian approximation to the Buckingham potential
c
      call egauss2 (i)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ebuck3  --  Buckingham vdw energy & analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ebuck3" calculates the Buckingham exp-6 van der Waals energy
c     and partitions the energy among the atoms
c
c
      subroutine ebuck3
      use analyz
      use atoms
      use energi
      use inform
      use iounit
      use limits
      use vdwpot
      use warp
      implicit none
      integer i
      real*8 elrc,aelrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_stophat) then
         write (iout,10)
   10    format (/,' EBUCK3  --  Stophat Smoothing not Available',
     &              ' for Buckingham vdw Potential')
         call fatal
      else if (use_smooth) then
         call ebuck3d
      else if (use_vlist) then
         call ebuck3c
      else if (use_lights) then
         call ebuck3b
      else
         call ebuck3a
      end if
c
c     apply the long range van der Waals correction if used
c
      if (use_vcorr) then
         mode = 'VDW'
         call evcorr (mode,elrc)
         ev = ev + elrc
         aelrc = elrc / dble(n)
         do i = 1, n
            aev(i) = aev(i) + aelrc
         end do
         if (verbose .and. elrc.ne.0.0d0) then
            if (digits .ge. 8) then
               write (iout,20)  elrc
   20          format (/,' Long-Range van der Waals :',6x,f16.8)
            else if (digits .ge. 6) then
               write (iout,30)  elrc
   30          format (/,' Long-Range van der Waals :',6x,f16.6)
            else
               write (iout,40)  elrc
   40          format (/,' Long-Range van der Waals :',6x,f16.4)
            end if
         end if
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ebuck3a  --  double loop Buckingham analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ebuck3a" calculates the Buckingham exp-6 van der Waals
c     energy and partitions the energy among the atoms using
c     a pairwise double loop
c
c
      subroutine ebuck3a
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical header,huge
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     switch from exponential to R^12 at very short range
c
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - cbuck*p6)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   30                format (' VDW-Buck',2x,2(i7,'-',a3),
     &                          13x,2f10.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     p2 = (rv*rv) / rik2
                     p6 = p2 * p2 * p2
                     if (p2 .le. expcut2) then
                        p = sqrt(p2)
                        expterm = abuck * exp(-bbuck/p)
                        e = eps * (expterm - cbuck*p6)
                     else
                        p12 = p6 * p6
                        e = expmerge * eps * p12
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik = sqrt(rik2)
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                                + c2*rik2 + c1*rik + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component
c
                     if (e .ne. 0.0d0) then
                        nev = nev + 1
                        if (i .eq. k) then
                           ev = ev + 0.5d0*e
                           aev(i) = aev(i) + 0.5d0*e
                        else
                           ev = ev + e
                           aev(i) = aev(i) + 0.5d0*e
                           aev(k) = aev(k) + 0.5d0*e
                        end if
                     end if
c
c     increment the total intermolecular energy
c
                     einter = einter + e
c
c     print a message if the energy of this interaction is large
c
                     huge = (e .gt. 10.0d0)
                     if ((debug.and.e.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual van der Waals',
     &                                ' Interactions :',
     &                             //,' Type',14x,'Atom Names',
     &                                20x,'Minimum',4x,'Actual',
     &                                6x,'Energy',/)
                        end if
                        write (iout,50)  i,name(i),k,name(k),
     &                                   rv,sqrt(rik2),e
   50                   format (' VDW-Buck',2x,2(i7,'-',a3),1x,
     &                             '(XTAL)',6x,2f10.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ebuck3b  --  Buckingham vdw analysis via lights  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ebuck3b" calculates the Buckingham exp-6 van der Waals
c     energy and also partitions the energy among the atoms using
c     the method of lights
c
c
      subroutine ebuck3b
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use light
      use molcul
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer kgy,kgz
      integer start,stop
      integer ikmin,ikmax
      integer, allocatable :: iv14(:)
      real*8 e,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      logical header,huge
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     switch from exponential to R^12 at very short range
c
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   20    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 60
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 60
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 60
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 60
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rv = radmin4(kt,it)
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - cbuck*p6)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (.not.prime .or. molcule(i).ne.molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,30)
   30                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     ikmin = min(i,k)
                     ikmax = max(i,k)
                     if (prime) then
                        write (iout,40)  ikmin,name(ikmin),ikmax,
     &                                   name(ikmax),rv,sqrt(rik2),e
   40                   format (' VDW-Buck',2x,2(i7,'-',a3),
     &                             13x,2f10.4,f12.4)
                     else
                        write (iout,50)  ikmin,name(ikmin),ikmax,
     &                                   name(ikmax),rv,sqrt(rik2),e
   50                   format (' VDW-Buck',2x,2(i7,'-',a3),1x,
     &                             '(XTAL)',6x,2f10.4,f12.4)
                     end if
                  end if
               end if
            end if
   60       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 20
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ebuck3c  --  Buckingham vdw analysis via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ebuck3c" calculates the Buckingham exp-6 van der Waals energy
c     and also partitions the energy among the atoms using a pairwise
c     neighbor list
c
c
      subroutine ebuck3c
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical header,huge
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     switch from exponential to R^12 at very short range
c
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13,
!$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group,
!$OMP& off2,radmin,epsilon,radmin4,epsilon4,abuck,bbuck,cbuck,
!$OMP& expcut2,expmerge,cut2,c0,c1,c2,c3,c4,c5,molcule,name,
!$OMP& verbose,debug,header,iout)
!$OMP& firstprivate(vscale,iv14) shared(ev,nev,aev,einter)
!$OMP DO reduction(+:ev,nev,aev,einter)
c
c     find the van der Waals energy via neighbor list search
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - cbuck*p6)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   30                format (' VDW-Buck',2x,2(i7,'-',a3),
     &                          13x,2f10.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ebuck3d  --  Buckingham analysis for smoothing  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ebuck3d" calculates the Buckingham exp-6 van der Waals energy
c     via a Gaussian approximation for potential energy smoothing
c
c
      subroutine ebuck3d
      use math
      use vdwpot
      implicit none
c
c
c     set coefficients for a two-Gaussian fit to MM2 vdw form
c
      ngauss = 2
      igauss(1,1) = 3423.562d0
      igauss(2,1) = 9.692821d0 * twosix**2
      igauss(1,2) = -6.503760d0
      igauss(2,2) = 1.585344d0 * twosix**2
c
c     compute Gaussian approximation to the Buckingham potential
c
      call egauss3
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine echarge  --  charge-charge potential energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "echarge" calculates the charge-charge interaction energy
c
c
      subroutine echarge
      use energi
      use extfld
      use limits
      use warp
      implicit none
      real*8 exf
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_smooth) then
         call echarge0g
      else if (use_ewald) then
         if (use_clist) then
            call echarge0f
         else if (use_lights) then
            call echarge0e
         else
            call echarge0d
         end if
      else if (use_clist) then
         call echarge0c
      else if (use_lights) then
         call echarge0b
      else
         call echarge0a
      end if
c
c     get contribution from external electric field if used
c
      if (use_exfld) then
         mode = 'CHARGE'
         call exfield (mode,exf)
         ec = ec + exf
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine echarge0a  --  charge energy via double loop  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "echarge0a" calculates the charge-charge interaction energy
c     using a pairwise double loop
c
c
      subroutine echarge0a
      use atoms
      use bound
      use cell
      use charge
      use chgpot
      use couple
      use energi
      use group
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,in,ic
      integer kk,kn,kc
      real*8 e,fgrp
      real*8 r,r2,rb
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xc,yc,zc
      real*8 xic,yic,zic
      real*8 shift,taper,trans
      real*8 rc,rc2,rc3,rc4
      real*8 rc5,rc6,rc7
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the charge interaction energy
c
      ec = 0.0d0
      if (nion .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHARGE'
      call switch (mode)
c
c     calculate the charge interaction energy term
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(i)
         ic = kion(i)
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(i)
         usei = (use(i) .or. use(ic))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nion
            k = iion(kk)
            kn = jion(k)
            kc = kion(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xc = xic - x(kc)
               yc = yic - y(kc)
               zc = zic - z(kc)
               if (use_bounds)  call image (xc,yc,zc)
               rc2 = xc*xc + yc*yc + zc*zc
               if (rc2 .le. off2) then
                  xr = xc + xi - x(k) + x(kc)
                  yr = yc + yi - y(k) + y(kc)
                  zr = zc + zi - z(k) + z(kc)
                  r2 = xr*xr + yr*yr + zr*zr
                  r = sqrt(r2)
                  rb = r + ebuffer
                  fik = fi * pchg(k) * cscale(kn)
                  e = fik / rb
c
c     use shifted energy switching if near the cutoff distance
c
                  shift = fik / (0.5d0*(off+cut))
                  e = e - shift
                  if (rc2 .gt. cut2) then
                     rc = sqrt(rc2)
                     rc3 = rc2 * rc
                     rc4 = rc2 * rc2
                     rc5 = rc2 * rc3
                     rc6 = rc3 * rc3
                     rc7 = rc3 * rc4
                     taper = c5*rc5 + c4*rc4 + c3*rc3
     &                          + c2*rc2 + c1*rc + c0
                     trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                               + f3*rc3 + f2*rc2 + f1*rc + f0)
                     e = e*taper + trans
                  end if
c
c     increment the overall charge-charge energy component
c
                  if (use_group)  e = e * fgrp
                  ec = ec + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         ic = kion(i)
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(i)
         usei = (use(i) .or. use(ic))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nion
            k = iion(kk)
            kn = jion(k)
            kc = kion(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xc = xic - x(kc)
                  yc = yic - y(kc)
                  zc = zic - z(kc)
                  call imager (xc,yc,zc,j)
                  rc2 = xc*xc + yc*yc + zc*zc
                  if (rc2 .le. off2) then
                     xr = xc + xi - x(k) + x(kc)
                     yr = yc + yi - y(k) + y(kc)
                     zr = zc + zi - z(k) + z(kc)
                     r2 = xr*xr + yr*yr + zr*zr
                     r = sqrt(r2)
                     rb = r + ebuffer
                     fik = fi * pchg(k)
                     if (use_polymer) then
                        if (r2 .le. polycut2)  fik = fik * cscale(kn)
                     end if
                     e = fik / rb
c
c     use shifted energy switching if near the cutoff distance
c
                     shift = fik / (0.5d0*(off+cut))
                     e = e - shift
                     if (rc2 .gt. cut2) then
                        rc = sqrt(rc2)
                        rc3 = rc2 * rc
                        rc4 = rc2 * rc2
                        rc5 = rc2 * rc3
                        rc6 = rc3 * rc3
                        rc7 = rc3 * rc4
                        taper = c5*rc5 + c4*rc4 + c3*rc3
     &                             + c2*rc2 + c1*rc + c0
                        trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                                  + f3*rc3 + f2*rc2 + f1*rc + f0)
                        e = e*taper + trans
                     end if
c
c     increment the overall charge-charge energy component
c
                     if (i .eq. k)  e = 0.5d0 * e
                     if (use_group)  e = e * fgrp
                     ec = ec + e
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine echarge0b  --  method of lights charge energy  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "echarge0b" calculates the charge-charge interaction energy
c     using the method of lights
c
c
      subroutine echarge0b
      use atoms
      use bound
      use boxes
      use cell
      use charge
      use chgpot
      use couple
      use energi
      use group
      use iounit
      use light
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,in,ic
      integer kk,kn,kc
      integer kgy,kgz,kmap
      integer start,stop
      real*8 e,fgrp
      real*8 r,r2,rb
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xc,yc,zc
      real*8 xic,yic,zic
      real*8 shift,taper,trans
      real*8 rc,rc2,rc3,rc4
      real*8 rc5,rc6,rc7
      real*8, allocatable :: cscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      character*6 mode
c
c
c     zero out the charge interaction energy
c
      ec = 0.0d0
      if (nion .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHARGE'
      call switch (mode)
c
c     transfer the interaction site coordinates to sorting arrays
c
      do ii = 1, nion
         i = iion(ii)
         ic = kion(i)
         xsort(ii) = x(ic)
         ysort(ii) = y(ic)
         zsort(ii) = z(ic)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nion,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         ic = kion(i)
         xic = xsort(rgx(ii))
         yic = ysort(rgy(ii))
         zic = zsort(rgz(ii))
         xi = x(i) - x(ic)
         yi = y(i) - y(ic)
         zi = z(i) - z(ic)
         fi = f * pchg(i)
         usei = (use(i) .or. use(ic))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            kmap = kk - ((kk-1)/nion)*nion
            k = iion(kmap)
            kn = jion(k)
            kc = kion(k)
            prime = (kk .le. nion)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xc = xic - xsort(j)
               yc = yic - ysort(kgy)
               zc = zic - zsort(kgz)
               if (use_bounds) then
                  if (abs(xc) .gt. xcell2)  xc = xc - sign(xcell,xc)
                  if (abs(yc) .gt. ycell2)  yc = yc - sign(ycell,yc)
                  if (abs(zc) .gt. zcell2)  zc = zc - sign(zcell,zc)
                  if (monoclinic) then
                     xc = xc + zc*beta_cos
                     zc = zc * beta_sin
                  else if (triclinic) then
                     xc = xc + yc*gamma_cos + zc*beta_cos
                     yc = yc*gamma_sin + zc*beta_term
                     zc = zc * gamma_term
                  end if
               end if
               rc2 = xc*xc + yc*yc + zc*zc
               if (rc2 .le. off2) then
                  xr = xc + xi - x(k) + x(kc)
                  yr = yc + yi - y(k) + y(kc)
                  zr = zc + zi - z(k) + z(kc)
                  r2 = xr*xr + yr*yr + zr*zr
                  r = sqrt(r2)
                  rb = r + ebuffer
                  fik = fi * pchg(k)
                  if (prime)  fik = fik * cscale(kn)
                  if (use_polymer) then
                     if (r2 .gt. polycut2)  fik = fi * pchg(k)
                  end if
                  e = fik / rb
c
c     use shifted energy switching if near the cutoff distance
c
                  shift = fik / (0.5d0*(off+cut))
                  e = e - shift
                  if (rc2 .gt. cut2) then
                     rc = sqrt(rc2)
                     rc3 = rc2 * rc
                     rc4 = rc2 * rc2
                     rc5 = rc2 * rc3
                     rc6 = rc3 * rc3
                     rc7 = rc3 * rc4
                     taper = c5*rc5 + c4*rc4 + c3*rc3
     &                          + c2*rc2 + c1*rc + c0
                     trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                               + f3*rc3 + f2*rc2 + f1*rc + f0)
                     e = e*taper + trans
                  end if
c
c     increment the overall charge-charge energy component
c
                  if (use_group)  e = e * fgrp
                  ec = ec + e
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine echarge0c  --  charge energy via neighbor list  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "echarge0c" calculates the charge-charge interaction energy
c     using a pairwise neighbor list
c
c
      subroutine echarge0c
      use atoms
      use bound
      use charge
      use chgpot
      use couple
      use energi
      use group
      use neigh
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,in,ic
      integer kk,kn,kc
      real*8 e,fgrp
      real*8 r,r2,rb
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xc,yc,zc
      real*8 xic,yic,zic
      real*8 shift,taper,trans
      real*8 rc,rc2,rc3,rc4
      real*8 rc5,rc6,rc7
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the charge interaction energy
c
      ec = 0.0d0
      if (nion .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHARGE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,jion,kion,use,
!$OMP& x,y,z,f,pchg,nelst,elst,n12,n13,n14,n15,i12,i13,i14,i15,
!$OMP& c1scale,c2scale,c3scale,c4scale,c5scale,use_group,use_bounds,
!$OMP& off,off2,cut,cut2,c0,c1,c2,c3,c4,c5,f0,f1,f2,f3,f4,f5,f6,f7,
!$OMP& ebuffer)
!$OMP& firstprivate(cscale) shared (ec)
!$OMP DO reduction(+:ec)
c
c     calculate the charge interaction energy term
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         ic = kion(i)
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(i)
         usei = (use(i) .or. use(ic))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            kn = jion(k)
            kc = kion(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xc = xic - x(kc)
               yc = yic - y(kc)
               zc = zic - z(kc)
               if (use_bounds)  call image (xc,yc,zc)
               rc2 = xc*xc + yc*yc + zc*zc
               if (rc2 .le. off2) then
                  xr = xc + xi - x(k) + x(kc)
                  yr = yc + yi - y(k) + y(kc)
                  zr = zc + zi - z(k) + z(kc)
                  r2 = xr*xr + yr*yr + zr*zr
                  r = sqrt(r2)
                  rb = r + ebuffer
                  fik = fi * pchg(k) * cscale(kn)
                  e = fik / rb
c
c     use shifted energy switching if near the cutoff distance
c
                  shift = fik / (0.5d0*(off+cut))
                  e = e - shift
                  if (rc2 .gt. cut2) then
                     rc = sqrt(rc2)
                     rc3 = rc2 * rc
                     rc4 = rc2 * rc2
                     rc5 = rc2 * rc3
                     rc6 = rc3 * rc3
                     rc7 = rc3 * rc4
                     taper = c5*rc5 + c4*rc4 + c3*rc3
     &                          + c2*rc2 + c1*rc + c0
                     trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                               + f3*rc3 + f2*rc2 + f1*rc + f0)
                     e = e*taper + trans
                  end if
c
c     increment the overall charge-charge energy component
c
                  if (use_group)  e = e * fgrp
                  ec = ec + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine echarge0d  --  double loop Ewald charge energy  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "echarge0d" calculates the charge-charge interaction energy
c     using a particle mesh Ewald summation
c
c
      subroutine echarge0d
      use atoms
      use bound
      use boxes
      use cell
      use charge
      use chgpot
      use couple
      use energi
      use ewald
      use group
      use math
      use pme
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,in
      integer kk,kn
      real*8 e,fs,fgrp
      real*8 f,fi,fik
      real*8 r,r2,rb,rew
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xd,yd,zd
      real*8 erfc,erfterm
      real*8 sum,scale
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      character*6 mode
      external erfc
c
c
c     zero out the Ewald charge interaction energy
c
      ec = 0.0d0
      if (nion .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     compute the Ewald self-energy term over all the atoms
c
      fs = -f * aewald / rootpi
      do ii = 1, nion
         i = iion(ii)
         e = fs * pchg(i)**2
         ec = ec + e
      end do
c
c     compute the uniform background charge correction term
c
      fs = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, nion
         i = iion(ii)
         sum = sum + pchg(i)
      end do
      e = fs * sum**2
      ec = ec + e
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(i)*x(i)
            yd = yd + pchg(i)*y(i)
            zd = zd + pchg(i)*z(i)
         end do
         e = (2.0d0/3.0d0) * f * (pi/volbox) * (xd*xd+yd*yd+zd*zd)
         ec = ec + e
      end if
c
c     compute the reciprocal space part of the Ewald summation
c
      call ecrecip
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nion
            k = iion(kk)
            kn = jion(k)
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rb = r + ebuffer
                  fik = fi * pchg(k)
                  rew = aewald * r
                  erfterm = erfc (rew)
                  scale = cscale(kn)
                  if (use_group)  scale = scale * fgrp
                  scale = scale - 1.0d0
                  e = (fik/rb) * (erfterm+scale)
c
c     increment the overall charge-charge energy component
c
                  ec = ec + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate real space portion involving other unit cells
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nion
            k = iion(kk)
            kn = jion(k)
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  call imager (xr,yr,zr,j)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     rb = r + ebuffer
                     fik = fi * pchg(k)
                     rew = aewald * r
                     erfterm = erfc (rew)
                     scale = 1.0d0
                     if (use_group)  scale = scale * fgrp
                     if (use_polymer) then
                        if (r2 .le. polycut2) then
                           scale = scale * cscale(kn)
                        end if
                     end if
                     scale = scale - 1.0d0
                     e = (fik/rb) * (erfterm+scale)
c
c     increment the overall charge-charge energy component
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ec = ec + e
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine echarge0e  --  Ewald charge energy via lights  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "echarge0e" calculates the charge-charge interaction energy
c     using a particle mesh Ewald summation and the method of lights
c
c
      subroutine echarge0e
      use atoms
      use bound
      use boxes
      use cell
      use charge
      use chgpot
      use couple
      use energi
      use ewald
      use group
      use light
      use math
      use pme
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,in,ic
      integer kk,kn
      integer kgy,kgz,kmap
      integer start,stop
      real*8 e,fs,fgrp
      real*8 f,fi,fik
      real*8 r,r2,rb,rew
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xd,yd,zd
      real*8 erfc,erfterm
      real*8 sum,scale
      real*8, allocatable :: cscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      character*6 mode
      external erfc
c
c
c     zero out the Ewald charge interaction energy
c
      ec = 0.0d0
      if (nion .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     compute the Ewald self-energy term over all the atoms
c
      fs = -f * aewald / rootpi
      do ii = 1, nion
         i = iion(ii)
         e = fs * pchg(i)**2
         ec = ec + e
      end do
c
c     compute the uniform background charge correction term
c
      fs = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, nion
         i = iion(ii)
         sum = sum + pchg(i)
      end do
      e = fs * sum**2
      ec = ec + e
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(i)*x(i)
            yd = yd + pchg(i)*y(i)
            zd = zd + pchg(i)*z(i)
         end do
         e = (2.0d0/3.0d0) * f * (pi/volbox) * (xd*xd+yd*yd+zd*zd)
         ec = ec + e
      end if
c
c     compute the reciprocal space part of the Ewald summation
c
      call ecrecip
c
c     compute the real space portion of the Ewald summation;
c     transfer the interaction site coordinates to sorting arrays
c
      do ii = 1, nion
         i = iion(ii)
         ic = kion(i)
         xsort(ii) = x(ic)
         ysort(ii) = y(ic)
         zsort(ii) = z(ic)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nion,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         fi = f * pchg(i)
         usei = (use(i))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            kmap = kk - ((kk-1)/nion)*nion
            k = iion(kmap)
            kn = jion(k)
            prime = (kk .le. nion)
c
c     decide whether to compute the current interaction
c
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rb = r + ebuffer
                  rew = aewald * r
                  erfterm = erfc (rew)
                  scale = 1.0d0
                  if (prime)  scale = cscale(kn)
                  if (use_group)  scale = scale * fgrp
                  fik = fi * pchg(k)
                  if (use_polymer) then
                     if (r2 .gt. polycut2)  fik = fi * pchg(k)
                  end if
                  scale = scale - 1.0d0
                  e = (fik/rb) * (erfterm+scale)
c
c     increment the overall charge-charge energy component
c
                  ec = ec + e
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine echarge0f  --  Ewald charge energy via list  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "echarge0f" calculates the charge-charge interaction energy
c     using a particle mesh Ewald summation and a neighbor list
c
c
      subroutine echarge0f
      use atoms
      use bound
      use boxes
      use charge
      use chgpot
      use couple
      use energi
      use ewald
      use group
      use math
      use neigh
      use pme
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,in
      integer kk,kn
      real*8 e,fs,fgrp
      real*8 f,fi,fik
      real*8 r,r2,rb,rew
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xd,yd,zd
      real*8 erfc,erfterm
      real*8 sum,scale
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      character*6 mode
      external erfc
c
c
c     zero out the Ewald charge interaction energy
c
      ec = 0.0d0
      if (nion .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     compute the Ewald self-energy term over all the atoms
c
      fs = -f * aewald / rootpi
      do ii = 1, nion
         i = iion(ii)
         e = fs * pchg(i)**2
         ec = ec + e
      end do
c
c     compute the uniform background charge correction term
c
      fs = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, nion
         i = iion(ii)
         sum = sum + pchg(i)
      end do
      e = fs * sum**2
      ec = ec + e
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(i)*x(i)
            yd = yd + pchg(i)*y(i)
            zd = zd + pchg(i)*z(i)
         end do
         e = (2.0d0/3.0d0) * f * (pi/volbox) * (xd*xd+yd*yd+zd*zd)
         ec = ec + e
      end if
c
c     compute the reciprocal space part of the Ewald summation
c
      call ecrecip
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,jion,use,x,y,z,
!$OMP& f,pchg,nelst,elst,n12,n13,n14,n15,i12,i13,i14,i15,c1scale,
!$OMP& c2scale,c3scale,c4scale,c5scale,use_group,off2,aewald,ebuffer)
!$OMP& firstprivate(cscale) shared (ec)
!$OMP DO reduction(+:ec)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            kn = jion(k)
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rb = r + ebuffer
                  fik = fi * pchg(k)
                  rew = aewald * r
                  erfterm = erfc (rew)
                  scale = cscale(kn)
                  if (use_group)  scale = scale * fgrp
                  scale = scale - 1.0d0
                  e = (fik/rb) * (erfterm+scale)
c
c     increment the overall charge-charge energy component
c
                  ec = ec + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine echarge0g  --  charge energy for smoothing  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "echarge0g" calculates the charge-charge interaction energy
c     for use with potential smoothing methods
c
c
      subroutine echarge0g
      use atoms
      use charge
      use chgpot
      use couple
      use energi
      use group
      use usage
      use warp
      implicit none
      integer i,j,k
      integer ii,in
      integer kk,kn
      real*8 e,fgrp
      real*8 r,r2,rb,rb2
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 erf,wterm,width
      real*8 width2,width3
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      external erf
c
c
c     zero out the charge interaction energy
c
      ec = 0.0d0
      if (nion .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set the energy units conversion factor
c
      f = electric / dielec
c
c     set the extent of smoothing to be performed
c
      width = deform * diffc
      if (use_dem) then
         if (width .gt. 0.0d0)  width = 0.5d0 / sqrt(width)
      else if (use_gda) then
         wterm = sqrt(3.0d0/(2.0d0*diffc))
      end if
      width2 = width * width
      width3 = width * width2
c
c     calculate the charge interaction energy term
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         usei = (use(i))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nion
            k = iion(kk)
            kn = jion(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               r = sqrt(r2)
               rb = r + ebuffer
               fik = fi * pchg(k) * cscale(kn)
               e = fik / rb
c
c     transform the potential function via smoothing
c
               if (use_dem) then
                  if (width .gt. 0.0d0) then
                     e = e * erf(width*rb)
                  end if
               else if (use_gda) then
                  width = m2(i) + m2(k)
                  if (width .gt. 0.0d0) then
                     width = wterm / sqrt(width)
                     e = e * erf(width*rb)
                  end if
               else if (use_tophat) then
                  if (width .gt. rb) then
                     rb2 = rb * rb
                     e = fik * (3.0d0*width2-rb2) / (2.0d0*width3)
                  end if
               else if (use_stophat) then
                  e = fik / (rb+width)
               end if
c
c     increment the overall charge-charge energy component
c
               if (use_group)  e = e * fgrp
               ec = ec + e
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ecrecip  --  PME reciprocal space charge energy  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ecrecip" evaluates the reciprocal space portion of the particle
c     mesh Ewald energy due to partial charges
c
c     literature reference:
c
c     U. Essmann, L. Perera, M. L Berkowitz, T. Darden, H. Lee and
c     L. G. Pedersen, "A Smooth Particle Mesh Ewald Method", Journal
c     of Chemical Physics, 103, 8577-8593 (1995)
c
c     W. Smith and D. Fincham, "The Ewald Sum in Truncated Octahedral
c     and Rhombic Dodecahedral Boundary Conditions", Molecular
c     Simulation, 10, 67-71 (1993)
c
c     modifications for nonperiodic systems suggested by Tom Darden
c     during May 2007
c
c
      subroutine ecrecip
      use bound
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use pme
      implicit none
      integer i,j
      integer k1,k2,k3
      integer m1,m2,m3
      integer nf1,nf2,nf3
      integer nff,ntot
      real*8 e,f,denom
      real*8 term,expterm
      real*8 pterm,volterm
      real*8 hsq,struc2
      real*8 h1,h2,h3
      real*8 r1,r2,r3
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      f = 0.5d0 * electric / dielec
c
c     perform dynamic allocation of some global arrays
c
      ntot = nfft1 * nfft2 * nfft3
      if (allocated(qgrid)) then
         if (size(qgrid) .ne. 2*ntot)  call fftclose
      end if
      if (.not. allocated(qgrid))  call fftsetup
c
c     setup spatial decomposition and B-spline coefficients
c
      call getchunk
      call moduli
      call bspline_fill
      call table_fill
c
c     assign PME grid and perform 3-D FFT forward transform
c
      call grid_pchg
      call fftfront
c
c     use scalar sum to get the reciprocal space energy
c
      pterm = (pi/aewald)**2
      volterm = pi * volbox
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      nff = nfft1 * nfft2
      ntot = nff * nfft3
      do i = 1, ntot-1
         k3 = i/nff + 1
         j = i - (k3-1)*nff
         k2 = j/nfft1 + 1
         k1 = j - (k2-1)*nfft1 + 1
         m1 = k1 - 1
         m2 = k2 - 1
         m3 = k3 - 1
         if (k1 .gt. nf1)  m1 = m1 - nfft1
         if (k2 .gt. nf2)  m2 = m2 - nfft2
         if (k3 .gt. nf3)  m3 = m3 - nfft3
         r1 = dble(m1)
         r2 = dble(m2)
         r3 = dble(m3)
         h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
         h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
         h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
         hsq = h1*h1 + h2*h2 + h3*h3
         term = -pterm * hsq
         expterm = 0.0d0
         if (term .gt. -50.0d0) then
            denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
            expterm = exp(term) / denom
            if (.not. use_bounds) then
               expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
            else if (nonprism) then
               if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
            end if
            struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2
            e = f * expterm * struc2
            ec = ec + e
         end if
      end do
c
c     account for zeroth grid point for nonperiodic system
c
      qgrid(1,1,1,1) = 0.0d0
      qgrid(2,1,1,1) = 0.0d0
      if (.not. use_bounds) then
         expterm = 0.5d0 * pi / xbox
         struc2 = qgrid(1,1,1,1)**2 + qgrid(2,1,1,1)**2
         e = f * expterm * struc2
         ec = ec + e
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine echarge1  --  charge-charge energy & derivs  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "echarge1" calculates the charge-charge interaction energy
c     and first derivatives with respect to Cartesian coordinates
c
c
      subroutine echarge1
      use energi
      use extfld
      use limits
      use warp
      implicit none
      real*8 exf
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_smooth) then
         call echarge1g
      else if (use_ewald) then
         if (use_clist) then
            call echarge1f
         else if (use_lights) then
            call echarge1e
         else
            call echarge1d
         end if
      else if (use_clist) then
         call echarge1c
      else if (use_lights) then
         call echarge1b
      else
         call echarge1a
      end if
c
c     get contribution from external electric field if used
c
      if (use_exfld) then
         mode = 'CHARGE'
         call exfield1 (mode,exf)
         ec = ec + exf
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine echarge1a  --  charge derivs via double loop  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "echarge1a" calculates the charge-charge interaction energy
c     and first derivatives with respect to Cartesian coordinates
c     using a pairwise double loop
c
c
      subroutine echarge1a
      use atoms
      use bound
      use cell
      use charge
      use chgpot
      use couple
      use deriv
      use energi
      use group
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,in,ic
      integer kk,kn,kc
      real*8 e,fgrp,de,dc
      real*8 f,fi,fik
      real*8 r,r2,rb,rb2
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xc,yc,zc
      real*8 xic,yic,zic
      real*8 dedx,dedy,dedz
      real*8 dedxc,dedyc,dedzc
      real*8 shift,taper,trans
      real*8 dtaper,dtrans
      real*8 rc,rc2,rc3,rc4
      real*8 rc5,rc6,rc7
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the charge interaction energy and derivatives
c
      ec = 0.0d0
      do i = 1, n
         dec(1,i) = 0.0d0
         dec(2,i) = 0.0d0
         dec(3,i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHARGE'
      call switch (mode)
c
c     compute the charge interaction energy and first derivatives
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(i)
         ic = kion(i)
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(i)
         usei = (use(i) .or. use(ic))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nion
            k = iion(kk)
            kn = jion(k)
            kc = kion(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xc = xic - x(kc)
               yc = yic - y(kc)
               zc = zic - z(kc)
               if (use_bounds)  call image (xc,yc,zc)
               rc2 = xc*xc + yc*yc + zc*zc
               if (rc2 .le. off2) then
                  xr = xc + xi - x(k) + x(kc)
                  yr = yc + yi - y(k) + y(kc)
                  zr = zc + zi - z(k) + z(kc)
                  r2 = xr*xr + yr*yr + zr*zr
                  r = sqrt(r2)
                  rb = r + ebuffer
                  rb2 = rb * rb
                  fik = fi * pchg(k) * cscale(kn)
                  e = fik / rb
                  de = -fik / rb2
                  dc = 0.0d0
c
c     use shifted energy switching if near the cutoff distance
c
                  shift = fik / (0.5d0*(off+cut))
                  e = e - shift
                  if (rc2 .gt. cut2) then
                     rc = sqrt(rc2)
                     rc3 = rc2 * rc
                     rc4 = rc2 * rc2
                     rc5 = rc2 * rc3
                     rc6 = rc3 * rc3
                     rc7 = rc3 * rc4
                     taper = c5*rc5 + c4*rc4 + c3*rc3
     &                          + c2*rc2 + c1*rc + c0
                     dtaper = 5.0d0*c5*rc4 + 4.0d0*c4*rc3
     &                           + 3.0d0*c3*rc2 + 2.0d0*c2*rc + c1
                     trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                               + f3*rc3 + f2*rc2 + f1*rc + f0)
                     dtrans = fik * (7.0d0*f7*rc6 + 6.0d0*f6*rc5
     &                               + 5.0d0*f5*rc4 + 4.0d0*f4*rc3
     &                             + 3.0d0*f3*rc2 + 2.0d0*f2*rc + f1)
                     dc = (e*dtaper + dtrans) / rc
                     de = de * taper
                     e = e*taper + trans
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                     dc = dc * fgrp
                  end if
c
c     form the chain rule terms for derivative expressions
c
                  de = de / r
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
                  dedxc = dc * xc
                  dedyc = dc * yc
                  dedzc = dc * zc
c
c     increment the overall energy and derivative expressions
c
                  ec = ec + e
                  dec(1,i) = dec(1,i) + dedx
                  dec(2,i) = dec(2,i) + dedy
                  dec(3,i) = dec(3,i) + dedz
                  dec(1,ic) = dec(1,ic) + dedxc
                  dec(2,ic) = dec(2,ic) + dedyc
                  dec(3,ic) = dec(3,ic) + dedzc
                  dec(1,k) = dec(1,k) - dedx
                  dec(2,k) = dec(2,k) - dedy
                  dec(3,k) = dec(3,k) - dedz
                  dec(1,kc) = dec(1,kc) - dedxc
                  dec(2,kc) = dec(2,kc) - dedyc
                  dec(3,kc) = dec(3,kc) - dedzc
c
c     increment the internal virial tensor components
c
                  vxx = xr*dedx + xc*dedxc
                  vyx = yr*dedx + yc*dedxc
                  vzx = zr*dedx + zc*dedxc
                  vyy = yr*dedy + yc*dedyc
                  vzy = zr*dedy + zc*dedyc
                  vzz = zr*dedz + zc*dedzc
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         ic = kion(i)
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(i)
         usei = (use(i) .or. use(ic))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nion
            k = iion(kk)
            kn = jion(kk)
            kc = kion(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xc = xic - x(kc)
                  yc = yic - y(kc)
                  zc = zic - z(kc)
                  call imager (xc,yc,zc,j)
                  rc2 = xc*xc + yc*yc + zc*zc
                  if (rc2 .le. off2) then
                     xr = xc + xi - x(k) + x(kc)
                     yr = yc + yi - y(k) + y(kc)
                     zr = zc + zi - z(k) + z(kc)
                     r2 = xr*xr + yr*yr + zr*zr
                     r = sqrt(r2)
                     rb = r + ebuffer
                     rb2 = rb * rb
                     fik = fi * pchg(k)
                     if (use_polymer) then
                        if (r2 .le. polycut2)  fik = fik * cscale(kn)
                     end if
                     e = fik / rb
                     de = -fik / rb2
                     dc = 0.0d0
c
c     use shifted energy switching if near the cutoff distance
c
                     shift = fik / (0.5d0*(off+cut))
                     e = e - shift
                     if (rc2 .gt. cut2) then
                        rc = sqrt(rc2)
                        rc3 = rc2 * rc
                        rc4 = rc2 * rc2
                        rc5 = rc2 * rc3
                        rc6 = rc3 * rc3
                        rc7 = rc3 * rc4
                        taper = c5*rc5 + c4*rc4 + c3*rc3
     &                             + c2*rc2 + c1*rc + c0
                        dtaper = 5.0d0*c5*rc4 + 4.0d0*c4*rc3
     &                              + 3.0d0*c3*rc2 + 2.0d0*c2*rc + c1
                        trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                                  + f3*rc3 + f2*rc2 + f1*rc + f0)
                        dtrans = fik * (7.0d0*f7*rc6 + 6.0d0*f6*rc5
     &                                  + 5.0d0*f5*rc4 + 4.0d0*f4*rc3
     &                                + 3.0d0*f3*rc2 + 2.0d0*f2*rc + f1)
                        dc = (e*dtaper + dtrans) / rc
                        de = de * taper
                        e = e*taper + trans
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        e = e * fgrp
                        de = de * fgrp
                        dc = dc * fgrp
                     end if
c
c     form the chain rule terms for derivative expressions
c
                     de = de / r
                     dedx = de * xr
                     dedy = de * yr
                     dedz = de * zr
                     dedxc = dc * xc
                     dedyc = dc * yc
                     dedzc = dc * zc
c
c     increment the energy and gradient values
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ec = ec + e
                     dec(1,i) = dec(1,i) + dedx
                     dec(2,i) = dec(2,i) + dedy
                     dec(3,i) = dec(3,i) + dedz
                     dec(1,ic) = dec(1,ic) + dedxc
                     dec(2,ic) = dec(2,ic) + dedyc
                     dec(3,ic) = dec(3,ic) + dedzc
                     if (i .ne. k) then
                        dec(1,k) = dec(1,k) - dedx
                        dec(2,k) = dec(2,k) - dedy
                        dec(3,k) = dec(3,k) - dedz
                        dec(1,kc) = dec(1,kc) - dedxc
                        dec(2,kc) = dec(2,kc) - dedyc
                        dec(3,kc) = dec(3,kc) - dedzc
                     end if
c
c     increment the internal virial tensor components
c
                     vxx = xr*dedx + xc*dedxc
                     vyx = yr*dedx + yc*dedxc
                     vzx = zr*dedx + zc*dedxc
                     vyy = yr*dedy + yc*dedyc
                     vzy = zr*dedy + zc*dedyc
                     vzz = zr*dedz + zc*dedzc
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine echarge1b  --  method of lights charge derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "echarge1b" calculates the charge-charge interaction energy
c     and first derivatives with respect to Cartesian coordinates
c     using the method of lights
c
c
      subroutine echarge1b
      use atoms
      use bound
      use boxes
      use cell
      use charge
      use chgpot
      use couple
      use deriv
      use energi
      use group
      use light
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,in,ic
      integer kk,kn,kc
      integer kgy,kgz,kmap
      integer start,stop
      real*8 e,fgrp,de,dc
      real*8 f,fi,fik
      real*8 r,r2,rb,rb2
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xc,yc,zc
      real*8 xic,yic,zic
      real*8 dedx,dedy,dedz
      real*8 dedxc,dedyc,dedzc
      real*8 shift,taper,trans
      real*8 dtaper,dtrans
      real*8 rc,rc2,rc3,rc4
      real*8 rc5,rc6,rc7
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: cscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      character*6 mode
c
c
c     zero out the charge interaction energy and derivatives
c
      ec = 0.0d0
      do i = 1, n
         dec(1,i) = 0.0d0
         dec(2,i) = 0.0d0
         dec(3,i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHARGE'
      call switch (mode)
c
c     transfer the interaction site coordinates to sorting arrays
c
      do ii = 1, nion
         i = iion(ii)
         ic = kion(i)
         xsort(ii) = x(ic)
         ysort(ii) = y(ic)
         zsort(ii) = z(ic)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nion,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         ic = kion(i)
         xic = xsort(rgx(ii))
         yic = ysort(rgy(ii))
         zic = zsort(rgz(ii))
         xi = x(i) - x(ic)
         yi = y(i) - y(ic)
         zi = z(i) - z(ic)
         fi = f * pchg(i)
         usei = (use(i) .or. use(ic))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            kmap = kk - ((kk-1)/nion)*nion
            k = iion(kmap)
            kn = jion(k)
            kc = kion(k)
            prime = (kk .le. nion)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xc = xic - xsort(j)
               yc = yic - ysort(kgy)
               zc = zic - zsort(kgz)
               if (use_bounds) then
                  if (abs(xc) .gt. xcell2)  xc = xc - sign(xcell,xc)
                  if (abs(yc) .gt. ycell2)  yc = yc - sign(ycell,yc)
                  if (abs(zc) .gt. zcell2)  zc = zc - sign(zcell,zc)
                  if (monoclinic) then
                     xc = xc + zc*beta_cos
                     zc = zc * beta_sin
                  else if (triclinic) then
                     xc = xc + yc*gamma_cos + zc*beta_cos
                     yc = yc*gamma_sin + zc*beta_term
                     zc = zc * gamma_term
                  end if
               end if
               rc2 = xc*xc + yc*yc + zc*zc
               if (rc2 .le. off2) then
                  xr = xc + xi - x(k) + x(kc)
                  yr = yc + yi - y(k) + y(kc)
                  zr = zc + zi - z(k) + z(kc)
                  r2 = xr*xr + yr*yr + zr*zr
                  r = sqrt(r2)
                  rb = r + ebuffer
                  rb2 = rb * rb
                  fik = fi * pchg(k)
                  if (prime)  fik = fik * cscale(kn)
                  if (use_polymer) then
                     if (r2 .gt. polycut2)  fik = fi * pchg(k)
                  end if
                  e = fik / rb
                  de = -fik / rb2
                  dc = 0.0d0
c
c     use shifted energy switching if near the cutoff distance
c
                  shift = fik / (0.5d0*(off+cut))
                  e = e - shift
                  if (rc2 .gt. cut2) then
                     rc = sqrt(rc2)
                     rc3 = rc2 * rc
                     rc4 = rc2 * rc2
                     rc5 = rc2 * rc3
                     rc6 = rc3 * rc3
                     rc7 = rc3 * rc4
                     taper = c5*rc5 + c4*rc4 + c3*rc3
     &                          + c2*rc2 + c1*rc + c0
                     dtaper = 5.0d0*c5*rc4 + 4.0d0*c4*rc3
     &                           + 3.0d0*c3*rc2 + 2.0d0*c2*rc + c1
                     trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                               + f3*rc3 + f2*rc2 + f1*rc + f0)
                     dtrans = fik * (7.0d0*f7*rc6 + 6.0d0*f6*rc5
     &                               + 5.0d0*f5*rc4 + 4.0d0*f4*rc3
     &                             + 3.0d0*f3*rc2 + 2.0d0*f2*rc + f1)
                     dc = (e*dtaper + dtrans) / rc
                     de = de * taper
                     e = e*taper + trans
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                     dc = dc * fgrp
                  end if
c
c     form the chain rule terms for derivative expressions
c
                  de = de / r
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
                  dedxc = dc * xc
                  dedyc = dc * yc
                  dedzc = dc * zc
c
c     increment the overall energy and derivative expressions
c
                  ec = ec + e
                  dec(1,i) = dec(1,i) + dedx
                  dec(2,i) = dec(2,i) + dedy
                  dec(3,i) = dec(3,i) + dedz
                  dec(1,ic) = dec(1,ic) + dedxc
                  dec(2,ic) = dec(2,ic) + dedyc
                  dec(3,ic) = dec(3,ic) + dedzc
                  dec(1,k) = dec(1,k) - dedx
                  dec(2,k) = dec(2,k) - dedy
                  dec(3,k) = dec(3,k) - dedz
                  dec(1,kc) = dec(1,kc) - dedxc
                  dec(2,kc) = dec(2,kc) - dedyc
                  dec(3,kc) = dec(3,kc) - dedzc
c
c     increment the internal virial tensor components
c
                  vxx = xr*dedx + xc*dedxc
                  vyx = yr*dedx + yc*dedxc
                  vzx = zr*dedx + zc*dedxc
                  vyy = yr*dedy + yc*dedyc
                  vzy = zr*dedy + zc*dedyc
                  vzz = zr*dedz + zc*dedzc
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine echarge1c  --  charge derivs via neighbor list  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "echarge1c" calculates the charge-charge interaction energy
c     and first derivatives with respect to Cartesian coordinates
c     using a pairwise neighbor list
c
c
      subroutine echarge1c
      use atoms
      use bound
      use charge
      use chgpot
      use couple
      use deriv
      use energi
      use group
      use neigh
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,in,ic
      integer kk,kn,kc
      real*8 e,fgrp,de,dc
      real*8 f,fi,fik
      real*8 r,r2,rb,rb2
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xc,yc,zc
      real*8 xic,yic,zic
      real*8 dedx,dedy,dedz
      real*8 dedxc,dedyc,dedzc
      real*8 shift,taper,trans
      real*8 dtaper,dtrans
      real*8 rc,rc2,rc3,rc4
      real*8 rc5,rc6,rc7
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the charge interaction energy and derivatives
c
      ec = 0.0d0
      do i = 1, n
         dec(1,i) = 0.0d0
         dec(2,i) = 0.0d0
         dec(3,i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHARGE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,jion,kion,use,
!$OMP& x,y,z,f,pchg,nelst,elst,n12,n13,n14,n15,i12,i13,i14,i15,
!$OMP& c1scale,c2scale,c3scale,c4scale,c5scale,use_group,use_bounds,
!$OMP& off,off2,cut,cut2,c0,c1,c2,c3,c4,c5,f0,f1,f2,f3,f4,f5,
!$OMP& f6,f7,ebuffer)
!$OMP& firstprivate(cscale) shared (ec,dec,vir)
!$OMP DO reduction(+:ec,dec,vir)
c
c     compute the charge interaction energy and first derivatives
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         ic = kion(i)
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(i)
         usei = (use(i) .or. use(ic))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            kn = jion(k)
            kc = kion(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xc = xic - x(kc)
               yc = yic - y(kc)
               zc = zic - z(kc)
               if (use_bounds)  call image (xc,yc,zc)
               rc2 = xc*xc + yc*yc + zc*zc
               if (rc2 .le. off2) then
                  xr = xc + xi - x(k) + x(kc)
                  yr = yc + yi - y(k) + y(kc)
                  zr = zc + zi - z(k) + z(kc)
                  r2 = xr*xr + yr*yr + zr*zr
                  r = sqrt(r2)
                  rb = r + ebuffer
                  rb2 = rb * rb
                  fik = fi * pchg(k) * cscale(kn)
                  e = fik / rb
                  de = -fik / rb2
                  dc = 0.0d0
c
c     use shifted energy switching if near the cutoff distance
c
                  shift = fik / (0.5d0*(off+cut))
                  e = e - shift
                  if (rc2 .gt. cut2) then
                     rc = sqrt(rc2)
                     rc3 = rc2 * rc
                     rc4 = rc2 * rc2
                     rc5 = rc2 * rc3
                     rc6 = rc3 * rc3
                     rc7 = rc3 * rc4
                     taper = c5*rc5 + c4*rc4 + c3*rc3
     &                          + c2*rc2 + c1*rc + c0
                     dtaper = 5.0d0*c5*rc4 + 4.0d0*c4*rc3
     &                           + 3.0d0*c3*rc2 + 2.0d0*c2*rc + c1
                     trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                               + f3*rc3 + f2*rc2 + f1*rc + f0)
                     dtrans = fik * (7.0d0*f7*rc6 + 6.0d0*f6*rc5
     &                               + 5.0d0*f5*rc4 + 4.0d0*f4*rc3
     &                             + 3.0d0*f3*rc2 + 2.0d0*f2*rc + f1)
                     dc = (e*dtaper + dtrans) / rc
                     de = de * taper
                     e = e*taper + trans
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                     dc = dc * fgrp
                  end if
c
c     form the chain rule terms for derivative expressions
c
                  de = de / r
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
                  dedxc = dc * xc
                  dedyc = dc * yc
                  dedzc = dc * zc
c
c     increment the overall energy and derivative expressions
c
                  ec = ec + e
                  dec(1,i) = dec(1,i) + dedx
                  dec(2,i) = dec(2,i) + dedy
                  dec(3,i) = dec(3,i) + dedz
                  dec(1,ic) = dec(1,ic) + dedxc
                  dec(2,ic) = dec(2,ic) + dedyc
                  dec(3,ic) = dec(3,ic) + dedzc
                  dec(1,k) = dec(1,k) - dedx
                  dec(2,k) = dec(2,k) - dedy
                  dec(3,k) = dec(3,k) - dedz
                  dec(1,kc) = dec(1,kc) - dedxc
                  dec(2,kc) = dec(2,kc) - dedyc
                  dec(3,kc) = dec(3,kc) - dedzc
c
c     increment the internal virial tensor components
c
                  vxx = xr*dedx + xc*dedxc
                  vyx = yr*dedx + yc*dedxc
                  vzx = zr*dedx + zc*dedxc
                  vyy = yr*dedy + yc*dedyc
                  vzy = zr*dedy + zc*dedyc
                  vzz = zr*dedz + zc*dedzc
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine echarge1d  --  double loop Ewald charge derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "echarge1d" calculates the charge-charge interaction energy
c     and first derivatives with respect to Cartesian coordinates
c     using a particle mesh Ewald summation
c
c
      subroutine echarge1d
      use atoms
      use bound
      use boxes
      use cell
      use charge
      use chgpot
      use couple
      use deriv
      use energi
      use ewald
      use group
      use math
      use pme
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,in
      integer kk,kn
      real*8 e,de,f
      real*8 fi,fik,fs
      real*8 r,r2,rew
      real*8 rb,rb2
      real*8 fgrp,term
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xd,yd,zd
      real*8 erfc,erfterm
      real*8 sum,scale
      real*8 dedx,dedy,dedz
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      character*6 mode
      external erfc
c
c
c     zero out the Ewald summation energy and derivatives
c
      ec = 0.0d0
      do i = 1, n
         dec(1,i) = 0.0d0
         dec(2,i) = 0.0d0
         dec(3,i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     compute the Ewald self-energy term over all the atoms
c
      fs = -f * aewald / rootpi
      do ii = 1, nion
         i = iion(ii)
         e = fs * pchg(i)**2
         ec = ec + e
      end do
c
c     compute the uniform background charge correction term
c
      fs = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, nion
         i = iion(ii)
         sum = sum + pchg(i)
      end do
      e = fs * sum**2
      ec = ec + e
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(i)*x(i)
            yd = yd + pchg(i)*y(i)
            zd = zd + pchg(i)*z(i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         e = term * (xd*xd+yd*yd+zd*zd)
         ec = ec + e
         do ii = 1, nion
            i = iion(ii)
            de = 2.0d0 * term * pchg(i)
            dedx = de * xd
            dedy = de * yd
            dedz = de * zd
            dec(1,i) = dec(1,i) + dedx
            dec(2,i) = dec(2,i) + dedy
            dec(3,i) = dec(3,i) + dedz
         end do
      end if
c
c     compute reciprocal space Ewald energy and first derivatives
c
      call ecrecip1
c
c     compute the real space Ewald energy and first derivatives
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nion
            k = iion(kk)
            kn = jion(k)
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rb = r + ebuffer
                  rb2 = rb * rb
                  fik = fi * pchg(k)
                  rew = aewald * r
                  erfterm = erfc (rew)
                  scale = cscale(kn)
                  if (use_group)  scale = scale * fgrp
                  scale = scale - 1.0d0
                  e = (fik/rb) * (erfterm+scale)
                  de = -fik * ((erfterm+scale)/rb2
     &                    + (2.0d0*aewald/rootpi)*exp(-rew**2)/rb)
c
c     form the chain rule terms for derivative expressions
c
                  de = de / r
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the overall energy and derivative expressions
c
                  ec = ec + e
                  dec(1,i) = dec(1,i) + dedx
                  dec(2,i) = dec(2,i) + dedy
                  dec(3,i) = dec(3,i) + dedz
                  dec(1,k) = dec(1,k) - dedx
                  dec(2,k) = dec(2,k) - dedy
                  dec(3,k) = dec(3,k) - dedz
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate real space portion involving other unit cells
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nion
            k = iion(kk)
            kn = jion(k)
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
c
c     find appropriate image and check the real space cutoff
c
                  call imager (xr,yr,zr,j)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     rb = r + ebuffer
                     rb2 = rb * rb
                     fik = fi * pchg(k)
                     rew = aewald * r
                     erfterm = erfc (rew)
                     scale = 1.0d0
                     if (use_group)  scale = scale * fgrp
                     if (use_polymer) then
                        if (r2 .le. polycut2) then
                           scale = scale * cscale(kn)
                        end if
                     end if
                     scale = scale - 1.0d0
                     e = (fik/rb) * (erfterm+scale)
                     de = -fik * ((erfterm+scale)/rb2
     &                       + (2.0d0*aewald/rootpi)*exp(-rew**2)/rb)
c
c     form the chain rule terms for derivative expressions
c
                     de = de / r
                     dedx = de * xr
                     dedy = de * yr
                     dedz = de * zr
c
c     increment the energy and gradient values
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ec = ec + e
                     dec(1,i) = dec(1,i) + dedx
                     dec(2,i) = dec(2,i) + dedy
                     dec(3,i) = dec(3,i) + dedz
                     if (i .ne. k) then
                        dec(1,k) = dec(1,k) - dedx
                        dec(2,k) = dec(2,k) - dedy
                        dec(3,k) = dec(3,k) - dedz
                     end if
c
c     increment the internal virial tensor components
c
                     vxx = xr * dedx
                     vyx = yr * dedx
                     vzx = zr * dedx
                     vyy = yr * dedy
                     vzy = zr * dedy
                     vzz = zr * dedz
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine echarge1e  --  Ewald charge derivs via lights  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "echarge1e" calculates the charge-charge interaction energy
c     and first derivatives with respect to Cartesian coordinates
c     using a particle mesh Ewald summation and the method of lights
c
c
      subroutine echarge1e
      use atoms
      use bound
      use boxes
      use cell
      use charge
      use chgpot
      use couple
      use deriv
      use energi
      use ewald
      use group
      use light
      use math
      use pme
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,in,ic
      integer kk,kn
      integer kgy,kgz,kmap
      integer start,stop
      real*8 e,de,f
      real*8 fi,fik,fs
      real*8 r,r2,rew
      real*8 rb,rb2
      real*8 fgrp,term
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xd,yd,zd
      real*8 erfc,erfterm
      real*8 sum,scale
      real*8 dedx,dedy,dedz
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: cscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      character*6 mode
      external erfc
c
c
c     zero out the Ewald summation energy and derivatives
c
      ec = 0.0d0
      do i = 1, n
         dec(1,i) = 0.0d0
         dec(2,i) = 0.0d0
         dec(3,i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     compute the Ewald self-energy term over all the atoms
c
      fs = -f * aewald / rootpi
      do ii = 1, nion
         i = iion(ii)
         e = fs * pchg(i)**2
         ec = ec + e
      end do
c
c     compute the uniform background charge correction term
c
      fs = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, nion
         i = iion(ii)
         sum = sum + pchg(i)
      end do
      e = fs * sum**2
      ec = ec + e
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(i)*x(i)
            yd = yd + pchg(i)*y(i)
            zd = zd + pchg(i)*z(i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         e = term * (xd*xd+yd*yd+zd*zd)
         ec = ec + e
         do ii = 1, nion
            i = iion(ii)
            de = 2.0d0 * term * pchg(i)
            dedx = de * xd
            dedy = de * yd
            dedz = de * zd
            dec(1,i) = dec(1,i) + dedx
            dec(2,i) = dec(2,i) + dedy
            dec(3,i) = dec(3,i) + dedz
         end do
      end if
c
c     compute reciprocal space Ewald energy and first derivatives
c
      call ecrecip1
c
c     compute the real space portion of the Ewald summation;
c     transfer the interaction site coordinates to sorting arrays
c
      do ii = 1, nion
         i = iion(ii)
         ic = kion(i)
         xsort(ii) = x(ic)
         ysort(ii) = y(ic)
         zsort(ii) = z(ic)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nion,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         fi = f * pchg(i)
         usei = (use(i))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            kmap = kk - ((kk-1)/nion)*nion
            k = iion(kmap)
            kn = jion(k)
            prime = (kk .le. nion)
c
c     decide whether to compute the current interaction
c
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rb = r + ebuffer
                  rb2 = rb * rb
                  rew = aewald * r
                  erfterm = erfc (rew)
                  scale = 1.0d0
                  if (prime)  scale = cscale(kn)
                  if (use_group)  scale = scale * fgrp
                  fik = fi * pchg(k)
                  if (use_polymer) then
                     if (r2 .gt. polycut2)  fik = fi * pchg(k)
                  end if
                  scale = scale - 1.0d0
                  e = (fik/rb) * (erfterm+scale)
                  de = -fik * ((erfterm+scale)/rb2
     &                    + (2.0d0*aewald/rootpi)*exp(-rew**2)/rb)
c
c     form the chain rule terms for derivative expressions
c
                  de = de / r
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the overall energy and derivative expressions
c
                  ec = ec + e
                  dec(1,i) = dec(1,i) + dedx
                  dec(2,i) = dec(2,i) + dedy
                  dec(3,i) = dec(3,i) + dedz
                  dec(1,k) = dec(1,k) - dedx
                  dec(2,k) = dec(2,k) - dedy
                  dec(3,k) = dec(3,k) - dedz
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine echarge1f  --  Ewald charge derivs via list  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "echarge1f" calculates the charge-charge interaction energy
c     and first derivatives with respect to Cartesian coordinates
c     using a particle mesh Ewald summation and a neighbor list
c
c
      subroutine echarge1f
      use atoms
      use bound
      use boxes
      use charge
      use chgpot
      use couple
      use deriv
      use energi
      use ewald
      use group
      use math
      use neigh
      use pme
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,in
      integer kk,kn
      real*8 e,de,f
      real*8 fi,fik,fs
      real*8 r,r2,rew
      real*8 rb,rb2
      real*8 fgrp,term
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xd,yd,zd
      real*8 erfc,erfterm
      real*8 sum,scale
      real*8 dedx,dedy,dedz
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      character*6 mode
      external erfc
c
c
c     zero out the Ewald summation energy and derivatives
c
      ec = 0.0d0
      do i = 1, n
         dec(1,i) = 0.0d0
         dec(2,i) = 0.0d0
         dec(3,i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     compute the Ewald self-energy term over all the atoms
c
      fs = -f * aewald / rootpi
      do ii = 1, nion
         i = iion(ii)
         e = fs * pchg(i)**2
         ec = ec + e
      end do
c
c     compute the uniform background charge correction term
c
      fs = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, nion
         i = iion(ii)
         sum = sum + pchg(i)
      end do
      e = fs * sum**2
      ec = ec + e
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(i)*x(i)
            yd = yd + pchg(i)*y(i)
            zd = zd + pchg(i)*z(i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         e = term * (xd*xd+yd*yd+zd*zd)
         ec = ec + e
         do ii = 1, nion
            i = iion(ii)
            de = 2.0d0 * term * pchg(i)
            dedx = de * xd
            dedy = de * yd
            dedz = de * zd
            dec(1,i) = dec(1,i) + dedx
            dec(2,i) = dec(2,i) + dedy
            dec(3,i) = dec(3,i) + dedz
         end do
      end if
c
c     compute reciprocal space Ewald energy and first derivatives
c
      call ecrecip1
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,jion,use,x,y,z,
!$OMP& f,pchg,nelst,elst,n12,n13,n14,n15,i12,i13,i14,i15,c1scale,
!$OMP& c2scale,c3scale,c4scale,c5scale,use_group,off2,aewald,ebuffer)
!$OMP& firstprivate(cscale) shared (ec,dec,vir)
!$OMP DO reduction(+:ec,dec,vir)
c
c     compute the real space Ewald energy and first derivatives
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            kn = jion(k)
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
c
c     find energy for interactions within real space cutoff
c
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rb = r + ebuffer
                  rb2 = rb * rb
                  fik = fi * pchg(k)
                  rew = aewald * r
                  erfterm = erfc (rew)
                  scale = cscale(kn)
                  if (use_group)  scale = scale * fgrp
                  scale = scale - 1.0d0
                  e = (fik/rb) * (erfterm+scale)
                  de = -fik * ((erfterm+scale)/rb2
     &                    + (2.0d0*aewald/rootpi)*exp(-rew**2)/rb)
c
c     form the chain rule terms for derivative expressions
c
                  de = de / r
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the overall energy and derivative expressions
c
                  ec = ec + e
                  dec(1,i) = dec(1,i) + dedx
                  dec(2,i) = dec(2,i) + dedy
                  dec(3,i) = dec(3,i) + dedz
                  dec(1,k) = dec(1,k) - dedx
                  dec(2,k) = dec(2,k) - dedy
                  dec(3,k) = dec(3,k) - dedz
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine echarge1g  --  charge derivatives for smoothing  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "echarge1g" calculates the charge-charge interaction energy
c     and first derivatives with respect to Cartesian coordinates
c     for use with potential smoothing methods
c
c
      subroutine echarge1g
      use atoms
      use charge
      use chgpot
      use couple
      use deriv
      use energi
      use group
      use math
      use usage
      use warp
      implicit none
      integer i,j,k
      integer ii,in
      integer kk,kn
      real*8 e,de,fgrp
      real*8 r,r2,rb,rb2
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 dedx,dedy,dedz
      real*8 erf,erfterm
      real*8 expcut,expterm
      real*8 wterm,width
      real*8 width2,width3
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      external erf
c
c
c     zero out the charge interaction energy and derivatives
c
      ec = 0.0d0
      do i = 1, n
         dec(1,i) = 0.0d0
         dec(2,i) = 0.0d0
         dec(3,i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set the energy units conversion factor
c
      f = electric / dielec
      expcut = -50.0d0
c
c     set the extent of smoothing to be performed
c
      width = deform * diffc
      if (use_dem) then
         if (width .gt. 0.0d0)  width = 0.5d0 / sqrt(width)
      else if (use_gda) then
         wterm = sqrt(3.0d0/(2.0d0*diffc))
      end if
      width2 = width * width
      width3 = width * width2
c
c     compute the charge interaction energy and first derivatives
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         usei = (use(i))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nion
            k = iion(kk)
            kn = jion(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               r = sqrt(r2)
               rb = r + ebuffer
               rb2 = rb * rb
               fik = fi * pchg(k) * cscale(kn)
               e = fik / rb
               de = -fik / rb2
c
c     transform the potential function via smoothing
c
               if (use_dem) then
                  if (width .gt. 0.0d0) then
                     erfterm = erf(width*rb)
                     expterm = -rb2 * width2
                     if (expterm .gt. expcut) then
                        expterm = 2.0d0*fik*width*exp(expterm)
     &                               / (rootpi*rb)
                     else
                        expterm = 0.0d0
                     end if
                     e = e * erfterm
                     de = de*erfterm + expterm
                  end if
               else if (use_gda) then
                  width = m2(i) + m2(k)
                  if (width .gt. 0.0d0) then
                     width = wterm / sqrt(width)
                     erfterm = erf(width*rb)
                     expterm = -rb2 * width * width
                     if (expterm .gt. expcut) then
                        expterm = 2.0d0*fik*width*exp(expterm)
     &                               / (rootpi*rb)
                     else
                        expterm = 0.0d0
                     end if
                     e = e * erfterm
                     de = de*erfterm + expterm
                  end if
               else if (use_tophat) then
                  if (width .gt. rb) then
                     e = fik * (3.0d0*width2-rb2) / (2.0d0*width3)
                     de = -fik * rb / width3
                  end if
               else if (use_stophat) then
                  wterm = rb + width
                  e = fik / wterm
                  de = -fik / (wterm*wterm)
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  e = e * fgrp
                  de = de * fgrp
               end if
c
c     form the chain rule terms for derivative expressions
c
               de = de / r
               dedx = de * xr
               dedy = de * yr
               dedz = de * zr
c
c     increment the overall energy and derivative expressions
c
               ec = ec + e
               dec(1,i) = dec(1,i) + dedx
               dec(2,i) = dec(2,i) + dedy
               dec(3,i) = dec(3,i) + dedz
               dec(1,k) = dec(1,k) - dedx
               dec(2,k) = dec(2,k) - dedy
               dec(3,k) = dec(3,k) - dedz
c
c     increment the total intermolecular energy
c
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ecrecip1  --  PME recip charge energy & derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ecrecip1" evaluates the reciprocal space portion of the particle
c     mesh Ewald summation energy and gradient due to partial charges
c
c     literature reference:
c
c     U. Essmann, L. Perera, M. L Berkowitz, T. Darden, H. Lee and
c     L. G. Pedersen, "A Smooth Particle Mesh Ewald Method", Journal
c     of Chemical Physics, 103, 8577-8593 (1995)
c
c     W. Smith and D. Fincham, "The Ewald Sum in Truncated Octahedral
c     and Rhombic Dodecahedral Boundary Conditions", Molecular
c     Simulation, 10, 67-71 (1993)
c
c     modifications for nonperiodic systems suggested by Tom Darden
c     during May 2007
c
c
      subroutine ecrecip1
      use atoms
      use bound
      use boxes
      use charge
      use chgpot
      use deriv
      use energi
      use ewald
      use math
      use pme
      use virial
      implicit none
      integer i,j,ii
      integer k1,k2,k3
      integer m1,m2,m3
      integer nf1,nf2,nf3
      integer nff,ntot
      real*8 e,term,eterm
      real*8 expterm
      real*8 vterm,pterm
      real*8 volterm
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 f,fi,denom
      real*8 hsq,struc2
      real*8 h1,h2,h3
      real*8 r1,r2,r3
      real*8 f1,f2,f3
      real*8, allocatable :: fphi(:,:)
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      f = electric / dielec
c
c     perform dynamic allocation of some global arrays
c
      ntot = nfft1 * nfft2 * nfft3
      if (allocated(qgrid)) then
         if (size(qgrid) .ne. 2*ntot)  call fftclose
      end if
      if (.not. allocated(qgrid))  call fftsetup
c
c     setup spatial decomposition and B-spline coefficients
c
      call getchunk
      call moduli
      call bspline_fill
      call table_fill
c
c     assign PME grid and perform 3-D FFT forward transform
c
      call grid_pchg
      call fftfront
c
c     zero out the temporary virial accumulation variables
c
      vxx = 0.0d0
      vxy = 0.0d0
      vxz = 0.0d0
      vyy = 0.0d0
      vyz = 0.0d0
      vzz = 0.0d0
c
c     use scalar sum to get reciprocal space energy and virial
c
      pterm = (pi/aewald)**2
      volterm = pi * volbox
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      nff = nfft1 * nfft2
      ntot = nff * nfft3
      do i = 1, ntot-1
         k3 = i/nff + 1
         j = i - (k3-1)*nff
         k2 = j/nfft1 + 1
         k1 = j - (k2-1)*nfft1 + 1
         m1 = k1 - 1
         m2 = k2 - 1
         m3 = k3 - 1
         if (k1 .gt. nf1)  m1 = m1 - nfft1
         if (k2 .gt. nf2)  m2 = m2 - nfft2
         if (k3 .gt. nf3)  m3 = m3 - nfft3
         r1 = dble(m1)
         r2 = dble(m2)
         r3 = dble(m3)
         h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
         h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
         h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
         hsq = h1*h1 + h2*h2 + h3*h3
         term = -pterm * hsq
         expterm = 0.0d0
         if (term .gt. -50.0d0) then
            denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
            expterm = exp(term) / denom
            if (.not. use_bounds) then
               expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
            else if (nonprism) then
               if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
            end if
            struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2
            eterm = 0.5d0 * f * expterm * struc2
            vterm = (2.0d0/hsq) * (1.0d0-term) * eterm
            vxx = vxx + h1*h1*vterm - eterm
            vxy = vxy + h1*h2*vterm
            vxz = vxz + h1*h3*vterm
            vyy = vyy + h2*h2*vterm - eterm
            vyz = vyz + h2*h3*vterm
            vzz = vzz + h3*h3*vterm - eterm
         end if
         qgrid(1,k1,k2,k3) = expterm * qgrid(1,k1,k2,k3)
         qgrid(2,k1,k2,k3) = expterm * qgrid(2,k1,k2,k3)
      end do
c
c     increment the total internal virial tensor components
c
      vir(1,1) = vir(1,1) + vxx
      vir(2,1) = vir(2,1) + vxy
      vir(3,1) = vir(3,1) + vxz
      vir(1,2) = vir(1,2) + vxy
      vir(2,2) = vir(2,2) + vyy
      vir(3,2) = vir(3,2) + vyz
      vir(1,3) = vir(1,3) + vxz
      vir(2,3) = vir(2,3) + vyz
      vir(3,3) = vir(3,3) + vzz
c
c     account for zeroth grid point for nonperiodic system
c
      qgrid(1,1,1,1) = 0.0d0
      qgrid(2,1,1,1) = 0.0d0
      if (.not. use_bounds) then
         expterm = 0.5d0 * pi / xbox
         qgrid(1,1,1,1) = expterm * qgrid(1,1,1,1)
         qgrid(2,1,1,1) = expterm * qgrid(2,1,1,1)
      end if
c
c     perform the 3-D FFT backward transformation
c
      call fftback
c
c     perform dynamic allocation of some local arrays
c
      allocate (fphi(4,n))
c
c     extract the partial charge electrostatic potential
c
      call fphi_pchg (fphi)
c
c     increment partial charge energy and gradient components
c
      e = 0.0d0
      do ii = 1, nion
         i = iion(ii)
         fi = f * pchg(i)
         e = e + fi*fphi(1,i)
         f1 = fi * dble(nfft1) * fphi(2,i)
         f2 = fi * dble(nfft2) * fphi(3,i)
         f3 = fi * dble(nfft3) * fphi(4,i)
         h1 = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3
         h2 = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3
         h3 = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3
         dec(1,i) = dec(1,i) + h1
         dec(2,i) = dec(2,i) + h2
         dec(3,i) = dec(3,i) + h3
      end do
      e = 0.5d0 * e
      ec = ec + e
c
c     perform deallocation of some local arrays
c
      deallocate (fphi)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine echarge2  --  atomwise charge-charge Hessian  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "echarge2" calculates second derivatives of the
c     charge-charge interaction energy for a single atom
c
c
      subroutine echarge2 (i)
      use limits
      use warp
      implicit none
      integer i
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_smooth) then
         call echarge2f (i)
      else if (use_ewald) then
         call echarge2c (i)
         if (use_clist) then
            call echarge2e (i)
         else
            call echarge2d (i)
         end if
      else if (use_clist) then
         call echarge2b (i)
      else
         call echarge2a (i)
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine echarge2a  --  charge Hessian via pairwise loop  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "echarge2a" calculates second derivatives of the charge-charge
c     interaction energy for a single atom using a pairwise loop
c
c
      subroutine echarge2a (i)
      use atoms
      use bound
      use cell
      use charge
      use chgpot
      use couple
      use group
      use hessn
      use shunt
      implicit none
      integer i,j,k,kk
      integer in,ic,kn,kc
      integer jcell
      real*8 e,de,d2e
      real*8 fi,fik,fgrp
      real*8 r,r2,rb,rb2
      real*8 d2edx,d2edy,d2edz
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xc,yc,zc
      real*8 xic,yic,zic
      real*8 shift,taper,trans
      real*8 dtaper,dtrans
      real*8 d2taper,d2trans
      real*8 rc,rc2,rc3,rc4
      real*8 rc5,rc6,rc7
      real*8 term(3,3)
      real*8, allocatable :: cscale(:)
      logical proceed
      character*6 mode
c
c
c     first see if the atom of interest carries a charge
c
      do kk = 1, nion
         k = iion(kk)
         if (k .eq. i) then
            fi = electric * pchg(k) / dielec
            in = jion(k)
            ic = kion(k)
            goto 10
         end if
      end do
      return
   10 continue
c
c     store the coordinates of the atom of interest
c
      xic = x(ic)
      yic = y(ic)
      zic = z(ic)
      xi = x(i) - xic
      yi = y(i) - yic
      zi = z(i) - zic
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do j = 1, nion
         cscale(iion(j)) = 1.0d0
      end do
      cscale(in) = c1scale
      do j = 1, n12(in)
         cscale(i12(j,in)) = c2scale
      end do
      do j = 1, n13(in)
         cscale(i13(j,in)) = c3scale
      end do
      do j = 1, n14(in)
         cscale(i14(j,in)) = c4scale
      end do
      do j = 1, n15(in)
         cscale(i15(j,in)) = c5scale
      end do
c
c     set cutoff distances and switching function coefficients
c
      mode = 'CHARGE'
      call switch (mode)
c
c     calculate the charge interaction energy Hessian elements
c
      do kk = 1, nion
         k = iion(kk)
         kn = jion(k)
         kc = kion(k)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
         if (proceed)  proceed = (kn .ne. i)
c
c     compute the energy contribution for this interaction
c
         if (proceed) then
            xc = xic - x(kc)
            yc = yic - y(kc)
            zc = zic - z(kc)
            if (use_bounds)  call image (xc,yc,zc)
            rc2 = xc*xc + yc*yc + zc*zc
            if (rc2 .le. off2) then
               xr = xc + xi - x(k) + x(kc)
               yr = yc + yi - y(k) + y(kc)
               zr = zc + zi - z(k) + z(kc)
               r2 = xr*xr + yr*yr + zr*zr
               r = sqrt(r2)
               rb = r + ebuffer
               rb2 = rb * rb
               fik = fi * pchg(k) * cscale(kn)
c
c     compute chain rule terms for Hessian matrix elements
c
               de = -fik / rb2
               d2e = -2.0d0 * de/rb
c
c     use shifted energy switching if near the cutoff distance
c
               if (rc2 .gt. cut2) then
                  e = fik / rb
                  shift = fik / (0.5d0*(off+cut))
                  e = e - shift
                  rc = sqrt(rc2)
                  rc3 = rc2 * rc
                  rc4 = rc2 * rc2
                  rc5 = rc2 * rc3
                  rc6 = rc3 * rc3
                  rc7 = rc3 * rc4
                  taper = c5*rc5 + c4*rc4 + c3*rc3
     &                       + c2*rc2 + c1*rc + c0
                  dtaper = 5.0d0*c5*rc4 + 4.0d0*c4*rc3
     &                        + 3.0d0*c3*rc2 + 2.0d0*c2*rc + c1
                  d2taper = 20.0d0*c5*rc3 + 12.0d0*c4*rc2
     &                         + 6.0d0*c3*rc + 2.0d0*c2
                  trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                            + f3*rc3 + f2*rc2 + f1*rc + f0)
                  dtrans = fik * (7.0d0*f7*rc6 + 6.0d0*f6*rc5
     &                            + 5.0d0*f5*rc4 + 4.0d0*f4*rc3
     &                            + 3.0d0*f3*rc2 + 2.0d0*f2*rc + f1)
                  d2trans = fik * (42.0d0*f7*rc5 + 30.0d0*f6*rc4
     &                             + 20.0d0*f5*rc3 + 12.0d0*f4*rc2
     &                             + 6.0d0*f3*rc + 2.0d0*f2)
                  d2e = e*d2taper + 2.0d0*de*dtaper
     &                     + d2e*taper + d2trans
                  de = e*dtaper + de*taper + dtrans
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  de = de * fgrp
                  d2e = d2e * fgrp
               end if
c
c     form the individual Hessian element components
c
               de = de / r
               d2e = (d2e-de) / r2
               d2edx = d2e * xr
               d2edy = d2e * yr
               d2edz = d2e * zr
               term(1,1) = d2edx*xr + de
               term(1,2) = d2edx*yr
               term(1,3) = d2edx*zr
               term(2,1) = term(1,2)
               term(2,2) = d2edy*yr + de
               term(2,3) = d2edy*zr
               term(3,1) = term(1,3)
               term(3,2) = term(2,3)
               term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
               do j = 1, 3
                  hessx(j,i) = hessx(j,i) + term(1,j)
                  hessy(j,i) = hessy(j,i) + term(2,j)
                  hessz(j,i) = hessz(j,i) + term(3,j)
                  hessx(j,k) = hessx(j,k) - term(1,j)
                  hessy(j,k) = hessy(j,k) - term(2,j)
                  hessz(j,k) = hessz(j,k) - term(3,j)
               end do
            end if
         end if
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do kk = 1, nion
         k = iion(kk)
         kn = jion(k)
         kc = kion(k)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
c
c     compute the energy contribution for this interaction
c
         if (proceed) then
            do jcell = 2, ncell
               xc = xic - x(kc)
               yc = yic - y(kc)
               zc = zic - z(kc)
               call imager (xc,yc,zc,jcell)
               rc2 = xc*xc + yc*yc + zc*zc
               if (rc2 .le. off2) then
                  xr = xc + xi - x(k) + x(kc)
                  yr = yc + yi - y(k) + y(kc)
                  zr = zc + zi - z(k) + z(kc)
                  r2 = xr*xr + yr*yr + zr*zr
                  r = sqrt(r2)
                  rb = r + ebuffer
                  rb2 = rb * rb
                  fik = fi * pchg(k)
                  if (use_polymer) then
                     if (rc2 .le. polycut2)  fik = fik * cscale(kn)
                  end if
c
c     compute chain rule terms for Hessian matrix elements
c
                  de = -fik / rb2
                  d2e = -2.0d0 * de/rb
c
c     use shifted energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     e = fik / rb
                     shift = fik / (0.5d0*(off+cut))
                     e = e - shift
                     rc = sqrt(rc2)
                     rc3 = rc2 * rc
                     rc4 = rc2 * rc2
                     rc5 = rc2 * rc3
                     rc6 = rc3 * rc3
                     rc7 = rc3 * rc4
                     taper = c5*rc5 + c4*rc4 + c3*rc3
     &                          + c2*rc2 + c1*rc + c0
                     dtaper = 5.0d0*c5*rc4 + 4.0d0*c4*rc3
     &                           + 3.0d0*c3*rc2 + 2.0d0*c2*rc + c1
                     d2taper = 20.0d0*c5*rc3 + 12.0d0*c4*rc2
     &                            + 6.0d0*c3*rc + 2.0d0*c2
                     trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                               + f3*rc3 + f2*rc2 + f1*rc + f0)
                     dtrans = fik * (7.0d0*f7*rc6 + 6.0d0*f6*rc5
     &                               + 5.0d0*f5*rc4 + 4.0d0*f4*rc3
     &                               + 3.0d0*f3*rc2 + 2.0d0*f2*rc + f1)
                     d2trans = fik * (42.0d0*f7*rc5 + 30.0d0*f6*rc4
     &                                + 20.0d0*f5*rc3 + 12.0d0*f4*rc2
     &                                + 6.0d0*f3*rc + 2.0d0*f2)
                     d2e = e*d2taper + 2.0d0*de*dtaper
     &                        + d2e*taper + d2trans
                     de = e*dtaper + de*taper + dtrans
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     de = de * fgrp
                     d2e = d2e * fgrp
                  end if
c
c     form the individual Hessian element components
c
                  de = de / r
                  d2e = (d2e-de) / r2
                  d2edx = d2e * xr
                  d2edy = d2e * yr
                  d2edz = d2e * zr
                  term(1,1) = d2edx*xr + de
                  term(1,2) = d2edx*yr
                  term(1,3) = d2edx*zr
                  term(2,1) = term(1,2)
                  term(2,2) = d2edy*yr + de
                  term(2,3) = d2edy*zr
                  term(3,1) = term(1,3)
                  term(3,2) = term(2,3)
                  term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                  do j = 1, 3
                     hessx(j,i) = hessx(j,i) + term(1,j)
                     hessy(j,i) = hessy(j,i) + term(2,j)
                     hessz(j,i) = hessz(j,i) + term(3,j)
                     hessx(j,k) = hessx(j,k) - term(1,j)
                     hessy(j,k) = hessy(j,k) - term(2,j)
                     hessz(j,k) = hessz(j,k) - term(3,j)
                  end do
               end if
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine echarge2b  --  charge Hessian via neighbor list  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "echarge2b" calculates second derivatives of the charge-charge
c     interaction energy for a single atom using a neighbor list
c
c
      subroutine echarge2b (i)
      use atoms
      use bound
      use cell
      use charge
      use chgpot
      use couple
      use group
      use hessn
      use neigh
      use shunt
      implicit none
      integer i,j,k,kk
      integer in,ic,kn,kc
      real*8 e,de,d2e
      real*8 fi,fik,fgrp
      real*8 r,r2,rb,rb2
      real*8 d2edx,d2edy,d2edz
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xc,yc,zc
      real*8 xic,yic,zic
      real*8 shift,taper,trans
      real*8 dtaper,dtrans
      real*8 d2taper,d2trans
      real*8 rc,rc2,rc3,rc4
      real*8 rc5,rc6,rc7
      real*8 term(3,3)
      real*8, allocatable :: cscale(:)
      logical proceed
      character*6 mode
c
c
c     first see if the atom of interest carries a charge
c
      do kk = 1, nion
         k = iion(kk)
         if (k .eq. i) then
            fi = electric * pchg(k) / dielec
            in = jion(k)
            ic = kion(k)
            goto 10
         end if
      end do
      return
   10 continue
c
c     store the coordinates of the atom of interest
c
      xic = x(ic)
      yic = y(ic)
      zic = z(ic)
      xi = x(i) - xic
      yi = y(i) - yic
      zi = z(i) - zic
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do j = 1, nion
         cscale(iion(j)) = 1.0d0
      end do
      cscale(in) = c1scale
      do j = 1, n12(in)
         cscale(i12(j,in)) = c2scale
      end do
      do j = 1, n13(in)
         cscale(i13(j,in)) = c3scale
      end do
      do j = 1, n14(in)
         cscale(i14(j,in)) = c4scale
      end do
      do j = 1, n15(in)
         cscale(i15(j,in)) = c5scale
      end do
c
c     set cutoff distances and switching function coefficients
c
      mode = 'CHARGE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(i,iion,jion,kion,x,y,z,
!$OMP& xi,yi,zi,xic,yic,zic,fi,pchg,nelst,elst,use_group,use_bounds,
!$OMP& off,off2,cut,cut2,c0,c1,c2,c3,c4,c5,f0,f1,f2,f3,f4,f5,f6,f7,
!$OMP& ebuffer,cscale)
!$OMP& shared (hessx,hessy,hessz)
!$OMP DO reduction(+:hessx,hessy,hessz)
c
c     calculate the charge interaction energy Hessian elements
c
      do kk = 1, nelst(i)
         k = elst(kk,i)
         kn = jion(k)
         kc = kion(k)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
         if (proceed)  proceed = (kn .ne. i)
c
c     compute the energy contribution for this interaction
c
         if (proceed) then
            xc = xic - x(kc)
            yc = yic - y(kc)
            zc = zic - z(kc)
            if (use_bounds)  call image (xc,yc,zc)
            rc2 = xc*xc + yc*yc + zc*zc
            if (rc2 .le. off2) then
               xr = xc + xi - x(k) + x(kc)
               yr = yc + yi - y(k) + y(kc)
               zr = zc + zi - z(k) + z(kc)
               r2 = xr*xr + yr*yr + zr*zr
               r = sqrt(r2)
               rb = r + ebuffer
               rb2 = rb * rb
               fik = fi * pchg(k) * cscale(kn)
c
c     compute chain rule terms for Hessian matrix elements
c
               de = -fik / rb2
               d2e = -2.0d0 * de/rb
c
c     use shifted energy switching if near the cutoff distance
c
               if (r2 .gt. cut2) then
                  e = fik / rb
                  shift = fik / (0.5d0*(off+cut))
                  e = e - shift
                  rc = sqrt(rc2)
                  rc3 = rc2 * rc
                  rc4 = rc2 * rc2
                  rc5 = rc2 * rc3
                  rc6 = rc3 * rc3
                  rc7 = rc3 * rc4
                  taper = c5*rc5 + c4*rc4 + c3*rc3
     &                       + c2*rc2 + c1*rc + c0
                  dtaper = 5.0d0*c5*rc4 + 4.0d0*c4*rc3
     &                        + 3.0d0*c3*rc2 + 2.0d0*c2*rc + c1
                  d2taper = 20.0d0*c5*rc3 + 12.0d0*c4*rc2
     &                         + 6.0d0*c3*rc + 2.0d0*c2
                  trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                            + f3*rc3 + f2*rc2 + f1*rc + f0)
                  dtrans = fik * (7.0d0*f7*rc6 + 6.0d0*f6*rc5
     &                            + 5.0d0*f5*rc4 + 4.0d0*f4*rc3
     &                            + 3.0d0*f3*rc2 + 2.0d0*f2*rc + f1)
                  d2trans = fik * (42.0d0*f7*rc5 + 30.0d0*f6*rc4
     &                             + 20.0d0*f5*rc3 + 12.0d0*f4*rc2
     &                             + 6.0d0*f3*rc + 2.0d0*f2)
                  d2e = e*d2taper + 2.0d0*de*dtaper
     &                     + d2e*taper + d2trans
                  de = e*dtaper + de*taper + dtrans
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  de = de * fgrp
                  d2e = d2e * fgrp
               end if
c
c     form the individual Hessian element components
c
               de = de / r
               d2e = (d2e-de) / r2
               d2edx = d2e * xr
               d2edy = d2e * yr
               d2edz = d2e * zr
               term(1,1) = d2edx*xr + de
               term(1,2) = d2edx*yr
               term(1,3) = d2edx*zr
               term(2,1) = term(1,2)
               term(2,2) = d2edy*yr + de
               term(2,3) = d2edy*zr
               term(3,1) = term(1,3)
               term(3,2) = term(2,3)
               term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
               do j = 1, 3
                  hessx(j,i) = hessx(j,i) + term(1,j)
                  hessy(j,i) = hessy(j,i) + term(2,j)
                  hessz(j,i) = hessz(j,i) + term(3,j)
                  hessx(j,k) = hessx(j,k) - term(1,j)
                  hessy(j,k) = hessy(j,k) - term(2,j)
                  hessz(j,k) = hessz(j,k) - term(3,j)
               end do
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine echarge2c  --  reciprocal Ewald charge Hessian  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "echarge2c" calculates second derivatives of the reciprocal
c     space charge-charge interaction energy for a single atom using
c     a particle mesh Ewald summation via numerical differentiation
c
c
      subroutine echarge2c (i)
      use atoms
      use deriv
      use hessn
      implicit none
      integer i,j,k
      real*8 eps,old
      real*8, allocatable :: d0(:,:)
      logical prior
      logical twosided
c
c
c     set the default stepsize and accuracy control flags
c
      eps = 1.0d-5
      twosided = .false.
      if (n .le. 300)  twosided = .true.
      if (n .gt. 600)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (d0(3,n))
c
c     perform dynamic allocation of some global arrays
c
      prior = .false.
      if (allocated(dec)) then
         prior = .true.
         if (size(dec) .lt. 3*n)  deallocate (dec)
      end if
      if (.not. allocated(dec))  allocate (dec(3,n))
c
c     get charge first derivatives for the base structure
c
      if (.not. twosided) then
         call echarge2r
         do k = 1, n
            do j = 1, 3
               d0(j,k) = dec(j,k)
            end do
         end do
      end if
c
c     find numerical x-components via perturbed structures
c
      old = x(i)
      if (twosided) then
         x(i) = x(i) - 0.5d0*eps
         call echarge2r
         do k = 1, n
            do j = 1, 3
               d0(j,k) = dec(j,k)
            end do
         end do
      end if
      x(i) = x(i) + eps
      call echarge2r
      x(i) = old
      do k = 1, n
         do j = 1, 3
            hessx(j,k) = hessx(j,k) + (dec(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical y-components via perturbed structures
c
      old = y(i)
      if (twosided) then
         y(i) = y(i) - 0.5d0*eps
         call echarge2r
         do k = 1, n
            do j = 1, 3
               d0(j,k) = dec(j,k)
            end do
         end do
      end if
      y(i) = y(i) + eps
      call echarge2r
      y(i) = old
      do k = 1, n
         do j = 1, 3
            hessy(j,k) = hessy(j,k) + (dec(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical z-components via perturbed structures
c
      old = z(i)
      if (twosided) then
         z(i) = z(i) - 0.5d0*eps
         call echarge2r
         do k = 1, n
            do j = 1, 3
               d0(j,k) = dec(j,k)
            end do
         end do
      end if
      z(i) = z(i) + eps
      call echarge2r
      z(i) = old
      do k = 1, n
         do j = 1, 3
            hessz(j,k) = hessz(j,k) + (dec(j,k)-d0(j,k))/eps
         end do
      end do
c
c     perform deallocation of some global arrays
c
      if (.not. prior)  deallocate (dec)
c
c     perform deallocation of some local arrays
c
      deallocate (d0)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine echarge2r  --  recip charge derivs utility  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "echarge2r" computes reciprocal space charge-charge first
c     derivatives; used to get finite difference second derivatives
c
c
      subroutine echarge2r
      use atoms
      use boxes
      use charge
      use chgpot
      use deriv
      use ewald
      use math
      use pme
      implicit none
      integer i,ii
      real*8 de,f,term
      real*8 xd,yd,zd
      real*8 dedx,dedy,dedz
c
c
c     zero out the Ewald summation derivative values
c
      do i = 1, n
         dec(1,i) = 0.0d0
         dec(2,i) = 0.0d0
         dec(3,i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
      f = electric / dielec
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(i)*x(i)
            yd = yd + pchg(i)*y(i)
            zd = zd + pchg(i)*z(i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         do ii = 1, nion
            i = iion(ii)
            de = 2.0d0 * term * pchg(i)
            dedx = de * xd
            dedy = de * yd
            dedz = de * zd
            dec(1,i) = dec(1,i) + dedx
            dec(2,i) = dec(2,i) + dedy
            dec(3,i) = dec(3,i) + dedz
         end do
      end if
c
c     compute reciprocal space Ewald first derivative values
c
      call ecrecip1
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine echarge2d  --  real Ewald charge Hessian; loop  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "echarge2d" calculates second derivatives of the real space
c     charge-charge interaction energy for a single atom using a
c     pairwise loop
c
c
      subroutine echarge2d (i)
      use atoms
      use bound
      use cell
      use charge
      use chgpot
      use couple
      use ewald
      use group
      use hessn
      use limits
      use math
      use shunt
      implicit none
      integer i,j,k,kk
      integer in,kn,jcell
      real*8 fi,fik,fgrp
      real*8 r,r2,rb,rb2
      real*8 de,d2e
      real*8 d2edx,d2edy,d2edz
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rew,erfc
      real*8 erfterm,expterm
      real*8 scale
      real*8 term(3,3)
      real*8, allocatable :: cscale(:)
      logical proceed
      character*6 mode
      external erfc
c
c
c     first see if the atom of interest carries a charge
c
      do kk = 1, nion
         k = iion(kk)
         if (k .eq. i) then
            fi = electric * pchg(k) / dielec
            in = jion(k)
            goto 10
         end if
      end do
      return
   10 continue
c
c     store the coordinates of the atom of interest
c
      xi = x(i)
      yi = y(i)
      zi = z(i)
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     set cutoff distances and switching function coefficients
c
      mode = 'EWALD'
      call switch (mode)
c
c     initialize connected atom exclusion coefficients
c
      do j = 1, nion
         cscale(iion(j)) = 1.0d0
      end do
      cscale(in) = c1scale
      do j = 1, n12(in)
         cscale(i12(j,in)) = c2scale
      end do
      do j = 1, n13(in)
         cscale(i13(j,in)) = c3scale
      end do
      do j = 1, n14(in)
         cscale(i14(j,in)) = c4scale
      end do
      do j = 1, n15(in)
         cscale(i15(j,in)) = c5scale
      end do
c
c     calculate the real space Ewald interaction Hessian elements
c
      do kk = 1, nion
         k = iion(kk)
         kn = jion(k)
         if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
         proceed = .true.
         if (proceed)  proceed = (kn .ne. i)
c
c     compute the energy contribution for this interaction
c
         if (proceed) then
            xr = xi - x(k)
            yr = yi - y(k)
            zr = zi - z(k)
            call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               rb = r + ebuffer
               rb2 = rb * rb
               fik = fi * pchg(k) * cscale(kn)
               rew = aewald * r
               erfterm = erfc (rew)
               expterm = exp(-rew**2)
               scale = cscale(kn)
               if (use_group)  scale = scale * fgrp
               scale = scale - 1.0d0
c
c     compute chain rule terms for Hessian matrix elements
c
               de = -fik * ((erfterm+scale)/rb2
     &                        + (2.0d0*aewald/rootpi)*expterm/r)
               d2e = -2.0d0*de/rb + 2.0d0*(fik/(rb*rb2))*scale
     &                  + (4.0d0*fik*aewald**3/rootpi)*expterm
     &                  + 2.0d0*(fik/(rb*rb2))*scale
c
c     form the individual Hessian element components
c
               de = de / r
               d2e = (d2e-de) / r2
               d2edx = d2e * xr
               d2edy = d2e * yr
               d2edz = d2e * zr
               term(1,1) = d2edx*xr + de
               term(1,2) = d2edx*yr
               term(1,3) = d2edx*zr
               term(2,1) = term(1,2)
               term(2,2) = d2edy*yr + de
               term(2,3) = d2edy*zr
               term(3,1) = term(1,3)
               term(3,2) = term(2,3)
               term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
               do j = 1, 3
                  hessx(j,i) = hessx(j,i) + term(1,j)
                  hessy(j,i) = hessy(j,i) + term(2,j)
                  hessz(j,i) = hessz(j,i) + term(3,j)
                  hessx(j,k) = hessx(j,k) - term(1,j)
                  hessy(j,k) = hessy(j,k) - term(2,j)
                  hessz(j,k) = hessz(j,k) - term(3,j)
               end do
            end if
         end if
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do kk = 1, nion
         k = iion(kk)
         kn = jion(k)
         if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
         proceed = .true.
c
c     compute the energy contribution for this interaction
c
         if (proceed) then
            do jcell = 2, ncell
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call imager (xr,yr,zr,jcell)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rb = r + ebuffer
                  rb2 = rb * rb
                  fik = fi * pchg(k)
                  rew = aewald * r
                  erfterm = erfc (rew)
                  expterm = exp(-rew**2)
                  scale = 1.0d0
                  if (use_group)  scale = scale * fgrp
                  if (use_polymer) then
                     if (r2 .le. polycut2) then
                        scale = scale * cscale(kn)
                     end if
                  end if
                  scale = scale - 1.0d0
c
c     compute chain rule terms for Hessian matrix elements
c
                  de = -fik * ((erfterm+scale)/rb2
     &                    + (2.0d0*aewald/rootpi)*exp(-rew**2)/r)
                  d2e = -2.0d0*de/rb + 2.0d0*(fik/(rb*rb2))*scale
     &                     + (4.0d0*fik*aewald**3/rootpi)*expterm
     &                     + 2.0d0*(fik/(rb*rb2))*scale
c
c     form the individual Hessian element components
c
                  de = de / r
                  d2e = (d2e-de) / r2
                  d2edx = d2e * xr
                  d2edy = d2e * yr
                  d2edz = d2e * zr
                  term(1,1) = d2edx*xr + de
                  term(1,2) = d2edx*yr
                  term(1,3) = d2edx*zr
                  term(2,1) = term(1,2)
                  term(2,2) = d2edy*yr + de
                  term(2,3) = d2edy*zr
                  term(3,1) = term(1,3)
                  term(3,2) = term(2,3)
                  term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                  do j = 1, 3
                     hessx(j,i) = hessx(j,i) + term(1,j)
                     hessy(j,i) = hessy(j,i) + term(2,j)
                     hessz(j,i) = hessz(j,i) + term(3,j)
                     hessx(j,k) = hessx(j,k) - term(1,j)
                     hessy(j,k) = hessy(j,k) - term(2,j)
                     hessz(j,k) = hessz(j,k) - term(3,j)
                  end do
               end if
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine echarge2e  --  real Ewald charge Hessian; list  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "echarge2e" calculates second derivatives of the real space
c     charge-charge interaction energy for a single atom using a
c     pairwise neighbor list
c
c
      subroutine echarge2e (i)
      use atoms
      use bound
      use charge
      use chgpot
      use couple
      use ewald
      use group
      use hessn
      use limits
      use math
      use neigh
      use shunt
      implicit none
      integer i,j,k
      integer in,kn,kk
      real*8 fi,fik,fgrp
      real*8 r,r2,rb,rb2
      real*8 de,d2e
      real*8 d2edx,d2edy,d2edz
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rew,erfc
      real*8 erfterm,expterm
      real*8 scale
      real*8 term(3,3)
      real*8, allocatable :: cscale(:)
      logical proceed
      character*6 mode
      external erfc
c
c
c     first see if the atom of interest carries a charge
c
      do kk = 1, nion
         k = iion(kk)
         if (k .eq. i) then
            fi = electric * pchg(k) / dielec
            in = jion(k)
            goto 10
         end if
      end do
      return
   10 continue
c
c     store the coordinates of the atom of interest
c
      xi = x(i)
      yi = y(i)
      zi = z(i)
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     set cutoff distances and switching function coefficients
c
      mode = 'EWALD'
      call switch (mode)
c
c     initialize connected atom exclusion coefficients
c
      do j = 1, nion
         cscale(iion(j)) = 1.0d0
      end do
      cscale(in) = c1scale
      do j = 1, n12(in)
         cscale(i12(j,in)) = c2scale
      end do
      do j = 1, n13(in)
         cscale(i13(j,in)) = c3scale
      end do
      do j = 1, n14(in)
         cscale(i14(j,in)) = c4scale
      end do
      do j = 1, n15(in)
         cscale(i15(j,in)) = c5scale
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(i,iion,jion,x,y,z,fi,
!$OMP& pchg,nelst,elst,cscale,use_group,off2,aewald,ebuffer)
!$OMP& shared (hessx,hessy,hessz)
!$OMP DO reduction(+:hessx,hessy,hessz)
c
c     calculate the real space Ewald interaction Hessian elements
c
      do kk = 1, nelst(i)
         k = elst(kk,i)
         kn = jion(k)
         if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
         proceed = .true.
         if (proceed)  proceed = (kn .ne. i)
c
c     compute the energy contribution for this interaction
c
         if (proceed) then
            xr = xi - x(k)
            yr = yi - y(k)
            zr = zi - z(k)
            call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               rb = r + ebuffer
               rb2 = rb * rb
               fik = fi * pchg(k) * cscale(kn)
               rew = aewald * r
               erfterm = erfc (rew)
               expterm = exp(-rew**2)
               scale = cscale(kn)
               if (use_group)  scale = scale * fgrp
               scale = scale - 1.0d0
c
c     compute chain rule terms for Hessian matrix elements
c
               de = -fik * ((erfterm+scale)/rb2
     &                        + (2.0d0*aewald/rootpi)*expterm/r)
               d2e = -2.0d0*de/rb + 2.0d0*(fik/(rb*rb2))*scale
     &                  + (4.0d0*fik*aewald**3/rootpi)*expterm
     &                  + 2.0d0*(fik/(rb*rb2))*scale
c
c     form the individual Hessian element components
c
               de = de / r
               d2e = (d2e-de) / r2
               d2edx = d2e * xr
               d2edy = d2e * yr
               d2edz = d2e * zr
               term(1,1) = d2edx*xr + de
               term(1,2) = d2edx*yr
               term(1,3) = d2edx*zr
               term(2,1) = term(1,2)
               term(2,2) = d2edy*yr + de
               term(2,3) = d2edy*zr
               term(3,1) = term(1,3)
               term(3,2) = term(2,3)
               term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
               do j = 1, 3
                  hessx(j,i) = hessx(j,i) + term(1,j)
                  hessy(j,i) = hessy(j,i) + term(2,j)
                  hessz(j,i) = hessz(j,i) + term(3,j)
                  hessx(j,k) = hessx(j,k) - term(1,j)
                  hessy(j,k) = hessy(j,k) - term(2,j)
                  hessz(j,k) = hessz(j,k) - term(3,j)
               end do
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine echarge2f  --  charge Hessian for smoothing  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "echarge2f" calculates second derivatives of the charge-charge
c     interaction energy for a single atom for use with potential
c     smoothing methods
c
c
      subroutine echarge2f (i)
      use atoms
      use charge
      use chgpot
      use couple
      use group
      use hessn
      use math
      use warp
      implicit none
      integer i,j,k
      integer in,kn,kk
      real*8 fi,fik,fgrp
      real*8 r,r2,rb,rb2
      real*8 de,d2e
      real*8 d2edx,d2edy,d2edz
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 erf,erfterm
      real*8 expcut,expterm
      real*8 wterm,width
      real*8 width2,width3
      real*8 term(3,3)
      real*8, allocatable :: cscale(:)
      logical proceed
      external erf
c
c
c     first see if the atom of interest carries a charge
c
      do kk = 1, nion
         k = iion(kk)
         if (k .eq. i) then
            fi = electric * pchg(k) / dielec
            in = jion(k)
            goto 10
         end if
      end do
      return
   10 continue
c
c     store the coordinates of the atom of interest
c
      xi = x(i)
      yi = y(i)
      zi = z(i)
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do j = 1, nion
         cscale(iion(j)) = 1.0d0
      end do
      cscale(in) = c1scale
      do j = 1, n12(in)
         cscale(i12(j,in)) = c2scale
      end do
      do j = 1, n13(in)
         cscale(i13(j,in)) = c3scale
      end do
      do j = 1, n14(in)
         cscale(i14(j,in)) = c4scale
      end do
      do j = 1, n15(in)
         cscale(i15(j,in)) = c5scale
      end do
c
c     set the smallest exponential terms to be calculated
c
      expcut = -50.0d0
c
c     set the extent of smoothing to be performed
c
      width = deform * diffc
      if (use_dem) then
         if (width .gt. 0.0d0)  width = 0.5d0 / sqrt(width)
      else if (use_gda) then
         wterm = sqrt(3.0d0/(2.0d0*diffc))
      end if
      width2 = width * width
      width3 = width * width2
c
c     calculate the charge interaction energy Hessian elements
c
      do kk = 1, nion
         k = iion(kk)
         kn = jion(k)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
         if (proceed)  proceed = (kn .ne. i)
c
c     compute the energy contribution for this interaction
c
         if (proceed) then
            xr = xi - x(k)
            yr = yi - y(k)
            zr = zi - z(k)
            r2 = xr*xr + yr*yr + zr*zr
            r = sqrt(r2)
            rb = r + ebuffer
            rb2 = rb * rb
            fik = fi * pchg(k) * cscale(kn)
c
c     compute chain rule terms for Hessian matrix elements
c
            de = -fik / rb2
            d2e = -2.0d0 * de/rb
c
c     transform the potential function via smoothing
c
            if (use_dem) then
               if (width .gt. 0.0d0) then
                  erfterm = erf(width*rb)
                  expterm = -rb2 * width2
                  if (expterm .gt. expcut) then
                     expterm = 2.0d0*fik*width*exp(expterm)
     &                            / (rootpi*rb)
                  else
                     expterm = 0.0d0
                  end if
                  de = de*erfterm + expterm
                  d2e = -2.0d0 * (de/rb + expterm*rb*width2)
               end if
            else if (use_gda) then
               width = m2(i) + m2(k)
               if (width .gt. 0.0d0) then
                  width = wterm / sqrt(width)
                  width2 = width * width
                  erfterm = erf(width*rb)
                  expterm = -rb2 * width2
                  if (expterm .gt. expcut) then
                     expterm = 2.0d0*fik*width*exp(expterm)
     &                            / (rootpi*rb)
                  else
                     expterm = 0.0d0
                  end if
                  de = de*erfterm + expterm
                  d2e = -2.0d0 * (de/rb + expterm*r*width2)
               end if
            else if (use_tophat) then
               if (width .gt. rb) then
                  d2e = -fik / width3
                  de = d2e * rb
               end if
            else if (use_stophat) then
               wterm = rb + width
               de = -fik / (wterm*wterm)
               d2e = -2.0d0 * de / wterm
            end if
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               de = de * fgrp
               d2e = d2e * fgrp
            end if
c
c     form the individual Hessian element components
c
            de = de / r
            d2e = (d2e-de) / r2
            d2edx = d2e * xr
            d2edy = d2e * yr
            d2edz = d2e * zr
            term(1,1) = d2edx*xr + de
            term(1,2) = d2edx*yr
            term(1,3) = d2edx*zr
            term(2,1) = term(1,2)
            term(2,2) = d2edy*yr + de
            term(2,3) = d2edy*zr
            term(3,1) = term(1,3)
            term(3,2) = term(2,3)
            term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
            do j = 1, 3
               hessx(j,i) = hessx(j,i) + term(1,j)
               hessy(j,i) = hessy(j,i) + term(2,j)
               hessz(j,i) = hessz(j,i) + term(3,j)
               hessx(j,k) = hessx(j,k) - term(1,j)
               hessy(j,k) = hessy(j,k) - term(2,j)
               hessz(j,k) = hessz(j,k) - term(3,j)
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine echarge3  --  charge-charge energy & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "echarge3" calculates the charge-charge interaction energy
c     and partitions the energy among the atoms
c
c
      subroutine echarge3
      use energi
      use extfld
      use inform
      use iounit
      use limits
      use warp
      implicit none
      real*8 exf
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_smooth) then
         call echarge3g
      else if (use_ewald) then
         if (use_clist) then
            call echarge3f
         else if (use_lights) then
            call echarge3e
         else
            call echarge3d
         end if
      else if (use_clist) then
         call echarge3c
      else if (use_lights) then
         call echarge3b
      else
         call echarge3a
      end if
c
c     get contribution from external electric field if used
c
      if (use_exfld) then
         mode = 'CHARGE'
         call exfield3 (mode,exf)
         ec = ec + exf
         if (verbose .and. exf.ne.0.0d0) then
            if (digits .ge. 8) then
               write (iout,10)  exf
   10          format (/,' External Electric Field :',7x,f16.8)
            else if (digits .ge. 6) then
               write (iout,20)  exf
   20          format (/,' External Electric Field :',7x,f16.6)
            else
               write (iout,30)  exf
   30          format (/,' External Electric Field :',7x,f16.4)
            end if
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine echarge3a  --  charge analysis via double loop  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "echarge3a" calculates the charge-charge interaction energy
c     and partitions the energy among the atoms using a pairwise
c     double loop
c
c
      subroutine echarge3a
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use cell
      use charge
      use chgpot
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,in,ic,im
      integer kk,kn,kc,km
      real*8 e,fgrp
      real*8 r,r2,rb
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xc,yc,zc
      real*8 xic,yic,zic
      real*8 shift,taper,trans
      real*8 rc,rc2,rc3,rc4
      real*8 rc5,rc6,rc7
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      logical header,huge
      character*6 mode
c
c
c     zero out the charge interaction energy and partitioning
c
      nec = 0
      ec = 0.0d0
      do i = 1, n
         aec(i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHARGE'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nion.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Charge-Charge Interactions :',
     &           //,' Type',14x,'Atom Names',17x,'Charges',
     &              5x,'Distance',6x,'Energy',/)
      end if
c
c     compute and partition the charge interaction energy
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(i)
         ic = kion(i)
         im = molcule(i)
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(i)
         usei = (use(i) .or. use(ic))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nion
            k = iion(kk)
            kn = jion(k)
            kc = kion(k)
            km = molcule(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kc))
            if (proceed)  proceed = (cscale(kn) .ne. 0.0d0)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xc = xic - x(kc)
               yc = yic - y(kc)
               zc = zic - z(kc)
               if (use_bounds)  call image (xc,yc,zc)
               rc2 = xc*xc + yc*yc + zc*zc
               if (rc2 .le. off2) then
                  xr = xc + xi - x(k) + x(kc)
                  yr = yc + yi - y(k) + y(kc)
                  zr = zc + zi - z(k) + z(kc)
                  r2 = xr*xr + yr*yr + zr*zr
                  r = sqrt(r2)
                  rb = r + ebuffer
                  fik = fi * pchg(k) * cscale(kn)
                  e = fik / rb
c
c     use shifted energy switching if near the cutoff distance
c
                  shift = fik / (0.5d0*(off+cut))
                  e = e - shift
                  if (rc2 .gt. cut2) then
                     rc = sqrt(rc2)
                     rc3 = rc2 * rc
                     rc4 = rc2 * rc2
                     rc5 = rc2 * rc3
                     rc6 = rc3 * rc3
                     rc7 = rc3 * rc4
                     taper = c5*rc5 + c4*rc4 + c3*rc3
     &                          + c2*rc2 + c1*rc + c0
                     trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                               + f3*rc3 + f2*rc2 + f1*rc + f0)
                     e = e*taper + trans
                  end if
c
c     increment the overall charge-charge energy components
c
                  if (e .ne. 0.0d0) then
                     if (use_group)  e = e * fgrp
                     nec = nec + 1
                     ec = ec + e
                     aec(i) = aec(i) + 0.5d0*e
                     aec(k) = aec(k) + 0.5d0*e
                     if (im .ne. km)  einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(e) .gt. 100.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Charge-Charge',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             17x,'Charges',5x,'Distance',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                pchg(i),pchg(k),r,e
   30                format (' Charge',4x,2(i7,'-',a3),8x,
     &                          2f7.2,f11.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         ic = kion(i)
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(i)
         usei = (use(i) .or. use(ic))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nion
            k = iion(kk)
            kn = jion(k)
            kc = kion(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xc = xic - x(kc)
                  yc = yic - y(kc)
                  zc = zic - z(kc)
                  call imager (xc,yc,zc,j)
                  rc2 = xc*xc + yc*yc + zc*zc
                  if (rc2 .le. off2) then
                     xr = xc + xi - x(k) + x(kc)
                     yr = yc + yi - y(k) + y(kc)
                     zr = zc + zi - z(k) + z(kc)
                     r2 = xr*xr + yr*yr + zr*zr
                     r = sqrt(r2)
                     rb = r + ebuffer
                     fik = fi * pchg(k)
                     if (use_polymer) then
                        if (r2 .le. polycut2)  fik = fik * cscale(kn)
                     end if
                     e = fik / rb
c
c     use shifted energy switching if near the cutoff distance
c
                     shift = fik / (0.5d0*(off+cut))
                     e = e - shift
                     if (rc2 .gt. cut2) then
                        rc = sqrt(rc2)
                        rc3 = rc2 * rc
                        rc4 = rc2 * rc2
                        rc5 = rc2 * rc3
                        rc6 = rc3 * rc3
                        rc7 = rc3 * rc4
                        taper = c5*rc5 + c4*rc4 + c3*rc3
     &                             + c2*rc2 + c1*rc + c0
                        trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                                  + f3*rc3 + f2*rc2 + f1*rc + f0)
                        e = e*taper + trans
                     end if
c
c     increment the overall charge-charge energy components
c
                     if (e .ne. 0.0d0) then
                        if (use_group)  e = e * fgrp
                        if (i .eq. k)  e = 0.5d0 * e
                        nec = nec + 1
                        ec = ec + e
                        aec(i) = aec(i) + 0.5d0*e
                        aec(k) = aec(k) + 0.5d0*e
                        einter = einter + e
                     end if
c
c     print a message if the energy of this interaction is large
c
                     huge = (abs(e) .gt. 100.0d0)
                     if ((debug.and.e.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual Charge-Charge',
     &                                ' Interactions :',
     &                             //,' Type',14x,'Atom Names',
     &                                17x,'Charges',5x,'Distance',
     &                                6x,'Energy',/)
                        end if
                        write (iout,50)  i,name(i),k,name(k),
     &                                   pchg(i),pchg(k),r,e
   50                   format (' Charge',4x,2(i7,'-',a3),1x,
     &                             '(XTAL)',1x,2f7.2,f11.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine echarge3b  --  method of lights charge analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "echarge3b" calculates the charge-charge interaction energy
c     and partitions the energy among the atoms using the method
c     of lights
c
c
      subroutine echarge3b
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use charge
      use chgpot
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use light
      use molcul
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,in,ic,im
      integer kk,kn,kc,km
      integer kgy,kgz,kmap
      integer start,stop
      integer ikmin,ikmax
      real*8 e,fgrp
      real*8 r,r2,rb
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xc,yc,zc
      real*8 xic,yic,zic
      real*8 shift,taper,trans
      real*8 rc,rc2,rc3,rc4
      real*8 rc5,rc6,rc7
      real*8, allocatable :: cscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      logical header,huge
      character*6 mode
c
c
c     zero out the charge interaction energy and partitioning
c
      nec = 0
      ec = 0.0d0
      do i = 1, n
         aec(i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHARGE'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nion.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Charge-Charge Interactions :',
     &           //,' Type',14x,'Atom Names',17x,'Charges',
     &              5x,'Distance',6x,'Energy',/)
      end if
c
c     transfer the interaction site coordinates to sorting arrays
c
      do ii = 1, nion
         i = iion(ii)
         ic = kion(i)
         xsort(ii) = x(ic)
         ysort(ii) = y(ic)
         zsort(ii) = z(ic)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nion,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         ic = kion(i)
         im = molcule(i)
         xic = xsort(rgx(ii))
         yic = ysort(rgy(ii))
         zic = zsort(rgz(ii))
         xi = x(i) - x(ic)
         yi = y(i) - y(ic)
         zi = z(i) - z(ic)
         fi = f * pchg(i)
         usei = (use(i) .or. use(ic))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   20    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 60
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 60
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 60
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 60
            end if
            kmap = kk - ((kk-1)/nion)*nion
            k = iion(kmap)
            kn = jion(k)
            kc = kion(k)
            km = molcule(k)
            prime = (kk .le. nion)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xc = xic - xsort(j)
               yc = yic - ysort(kgy)
               zc = zic - zsort(kgz)
               if (use_bounds) then
                  if (abs(xc) .gt. xcell2)  xc = xc - sign(xcell,xc)
                  if (abs(yc) .gt. ycell2)  yc = yc - sign(ycell,yc)
                  if (abs(zc) .gt. zcell2)  zc = zc - sign(zcell,zc)
                  if (monoclinic) then
                     xc = xc + zc*beta_cos
                     zc = zc * beta_sin
                  else if (triclinic) then
                     xc = xc + yc*gamma_cos + zc*beta_cos
                     yc = yc*gamma_sin + zc*beta_term
                     zc = zc * gamma_term
                  end if
               end if
               rc2 = xc*xc + yc*yc + zc*zc
               if (rc2 .le. off2) then
                  xr = xc + xi - x(k) + x(kc)
                  yr = yc + yi - y(k) + y(kc)
                  zr = zc + zi - z(k) + z(kc)
                  r2 = xr*xr + yr*yr + zr*zr
                  r = sqrt(r2)
                  rb = r + ebuffer
                  fik = fi * pchg(k)
                  if (prime)  fik = fik * cscale(kn)
                  if (use_polymer) then
                     if (r2 .gt. polycut2)  fik = fi * pchg(k)
                  end if
                  e = fik / rb
c
c     use shifted energy switching if near the cutoff distance
c
                  shift = fik / (0.5d0*(off+cut))
                  e = e - shift
                  if (rc2 .gt. cut2) then
                     rc = sqrt(rc2)
                     rc3 = rc2 * rc
                     rc4 = rc2 * rc2
                     rc5 = rc2 * rc3
                     rc6 = rc3 * rc3
                     rc7 = rc3 * rc4
                     taper = c5*rc5 + c4*rc4 + c3*rc3
     &                          + c2*rc2 + c1*rc + c0
                     trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                               + f3*rc3 + f2*rc2 + f1*rc + f0)
                     e = e*taper + trans
                  end if
c
c     increment the overall charge-charge energy components
c
                  if (e .ne. 0.0d0) then
                     if (use_group)  e = e * fgrp
                     nec = nec + 1
                     ec = ec + e
                     aec(i) = aec(i) + 0.5d0*e
                     aec(k) = aec(k) + 0.5d0*e
                     if (.not.prime .or. im.ne.km)  einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(e) .gt. 100.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,30)
   30                   format (/,' Individual Charge-Charge',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             17x,'Charges',5x,'Distance',
     &                             6x,'Energy',/)
                     end if
                     ikmin = min(i,k)
                     ikmax = max(i,k)
                     if (prime) then
                        write (iout,40)  ikmin,name(ikmin),ikmax,
     &                                   name(ikmax),pchg(i),
     &                                   pchg(k),r,e
   40                   format (' Charge',4x,2(i7,'-',a3),8x,
     &                             2f7.2,f11.4,f12.4)
                     else
                        write (iout,50)  ikmin,name(ikmin),ikmax,
     &                                   name(ikmax),pchg(i),
     &                                   pchg(k),r,e
   50                   format (' Charge',4x,2(i7,'-',a3),1x,
     &                             '(XTAL)',1x,2f7.2,f11.4,f12.4)
                     end if
                  end if
               end if
            end if
   60       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 20
         end if
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine echarge3c  --  neighbor list charge analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "echarge3c" calculates the charge-charge interaction energy
c     and partitions the energy among the atoms using a pairwise
c     neighbor list
c
c
      subroutine echarge3c
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use charge
      use chgpot
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use neigh
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,in,ic,im
      integer kk,kn,kc,km
      real*8 e,fgrp
      real*8 r,r2,rb
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xc,yc,zc
      real*8 xic,yic,zic
      real*8 shift,taper,trans
      real*8 rc,rc2,rc3,rc4
      real*8 rc5,rc6,rc7
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      logical header,huge
      character*6 mode
c
c
c     zero out the charge interaction energy and partitioning
c
      nec = 0
      ec = 0.0d0
      do i = 1, n
         aec(i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHARGE'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nion.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Charge-Charge Interactions :',
     &           //,' Type',14x,'Atom Names',17x,'Charges',
     &              5x,'Distance',6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,jion,kion,use,
!$OMP& x,y,z,f,pchg,nelst,elst,n12,n13,n14,n15,i12,i13,i14,i15,
!$OMP& c1scale,c2scale,c3scale,c4scale,c5scale,use_group,use_bounds,
!$OMP& off,off2,cut,cut2,c0,c1,c2,c3,c4,c5,f0,f1,f2,f3,f4,f5,f6,f7,
!$OMP% molcule,ebuffer,name,verbose,debug,header,iout)
!$OMP& firstprivate(cscale) shared (ec,nec,aec,einter)
!$OMP DO reduction(+:ec,nec,aec,einter)
c
c     compute and partition the charge interaction energy
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(i)
         ic = kion(i)
         im = molcule(i)
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(i)
         usei = (use(i) .or. use(ic))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            kn = jion(k)
            kc = kion(k)
            km = molcule(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kc))
            if (proceed)  proceed = (cscale(kn) .ne. 0.0d0)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xc = xic - x(kc)
               yc = yic - y(kc)
               zc = zic - z(kc)
               if (use_bounds)  call image (xc,yc,zc)
               rc2 = xc*xc + yc*yc + zc*zc
               if (rc2 .le. off2) then
                  xr = xc + xi - x(k) + x(kc)
                  yr = yc + yi - y(k) + y(kc)
                  zr = zc + zi - z(k) + z(kc)
                  r2 = xr*xr + yr*yr + zr*zr
                  r = sqrt(r2)
                  rb = r + ebuffer
                  fik = fi * pchg(k) * cscale(kn)
                  e = fik / rb
c
c     use shifted energy switching if near the cutoff distance
c
                  shift = fik / (0.5d0*(off+cut))
                  e = e - shift
                  if (rc2 .gt. cut2) then
                     rc = sqrt(rc2)
                     rc3 = rc2 * rc
                     rc4 = rc2 * rc2
                     rc5 = rc2 * rc3
                     rc6 = rc3 * rc3
                     rc7 = rc3 * rc4
                     taper = c5*rc5 + c4*rc4 + c3*rc3
     &                          + c2*rc2 + c1*rc + c0
                     trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4
     &                               + f3*rc3 + f2*rc2 + f1*rc + f0)
                     e = e*taper + trans
                  end if
c
c     increment the overall charge-charge energy components
c
                  if (e .ne. 0.0d0) then
                     if (use_group)  e = e * fgrp
                     nec = nec + 1
                     ec = ec + e
                     aec(i) = aec(i) + 0.5d0*e
                     aec(k) = aec(k) + 0.5d0*e
                     if (im .ne. km)  einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(e) .gt. 100.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Charge-Charge',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             17x,'Charges',5x,'Distance',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                pchg(i),pchg(k),r,e
   30                format (' Charge',4x,2(i7,'-',a3),8x,
     &                          2f7.2,f11.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine echarge3d  --  Ewald charge analysis via loop  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "echarge3d" calculates the charge-charge interaction energy
c     and partitions the energy among the atoms using a particle
c     mesh Ewald summation
c
c
      subroutine echarge3d
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use charge
      use chgpot
      use couple
      use energi
      use ewald
      use group
      use inform
      use inter
      use iounit
      use math
      use molcul
      use pme
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,in,im
      integer kk,kn,km
      real*8 e,efull
      real*8 f,fi,fik
      real*8 fs,fgrp
      real*8 r,r2,rb,rew
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xd,yd,zd
      real*8 erfc,erfterm
      real*8 sum,scale
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      logical header,huge
      character*6 mode
      external erfc
c
c
c     zero out the Ewald summation energy and partitioning
c
      nec = 0
      ec = 0.0d0
      do i = 1, n
         aec(i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nion.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Charge-Charge Interactions :',
     &           //,' Type',14x,'Atom Names',17x,'Charges',
     &              5x,'Distance',6x,'Energy',/)
      end if
c
c     compute the Ewald self-energy term over all the atoms
c
      fs = -f * aewald / rootpi
      do ii = 1, nion
         i = iion(ii)
         e = fs * pchg(i)**2
         ec = ec + e
         nec = nec + 1
         aec(i) = aec(i) + e
      end do
c
c     compute the uniform background charge correction term
c
      fs = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, nion
         i = iion(ii)
         sum = sum + pchg(i)
      end do
      if (sum .ne. 0.0d0) then
         e = fs * sum**2
         ec = ec + e
         nec = nec + 1
         do ii = 1, nion
            i = iion(ii)
            aec(i) = aec(i) + e/dble(nion)
         end do
      end if
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(i)*x(i)
            yd = yd + pchg(i)*y(i)
            zd = zd + pchg(i)*z(i)
         end do
         e = (2.0d0/3.0d0) * f * (pi/volbox) * (xd*xd+yd*yd+zd*zd)
         ec = ec + e
         nec = nec + 1
         do ii = 1, nion
            i = iion(ii)
            aec(i) = aec(i) + e/dble(nion)
         end do
      end if
c
c     compute the reciprocal space part of the Ewald summation
c
      call ecrecip3
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(i)
         im = molcule(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nion
            k = iion(kk)
            kn = jion(k)
            km = molcule(k)
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rb = r + ebuffer
                  fik = fi * pchg(k)
                  rew = aewald * r
                  erfterm = erfc (rew)
                  scale = cscale(kn)
                  if (use_group)  scale = scale * fgrp
                  e = (fik/rb) * (erfterm+scale-1.0d0)
c
c     increment the overall charge-charge energy components
c
                  ec = ec + e
                  efull = (fik/rb) * scale
                  if (efull .ne. 0.0d0) then
                     nec = nec + 1
                     aec(i) = aec(i) + 0.5d0*efull
                     aec(k) = aec(k) + 0.5d0*efull
                     if (im .ne. km)  einter = einter + efull
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(efull) .gt. 100.0d0)
                  if ((debug.and.efull.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Real Space Ewald',
     &                             ' Charge-Charge Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             17x,'Charges',5x,'Distance',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                pchg(i),pchg(k),r,efull
   30                format (' Charge',4x,2(i7,'-',a3),8x,
     &                          2f7.2,f11.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate real space portion involving other unit cells
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nion
            k = iion(kk)
            kn = jion(k)
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  call imager (xr,yr,zr,j)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     rb = r + ebuffer
                     fik = fi * pchg(k)
                     rew = aewald * r
                     erfterm = erfc (rew)
                     scale = 1.0d0
                     if (use_group)  scale = scale * fgrp
                     if (use_polymer) then
                        if (r2 .le. polycut2) then
                           scale = scale * cscale(kn)
                        end if
                     end if
                     e = (fik/rb) * (erfterm+scale-1.0d0)
                     if (i .eq. k)  e = 0.5d0 * e
c
c     increment the overall charge-charge energy components
c
                     ec = ec + e
                     aec(i) = aec(i) + 0.5d0*e
                     aec(k) = aec(k) + 0.5d0*e
                     efull = (fik/rb) * scale
                     if (i .eq. k)  efull = 0.5d0 * efull
                     if (efull .ne. 0.0d0) then
                        nec = nec + 1
                        einter = einter + efull
                     end if
c
c     print a message if the energy of this interaction is large
c
                     huge = (abs(efull) .gt. 100.0d0)
                     if ((debug.and.efull.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual Real Space Ewald',
     &                                ' Charge-Charge Interactions :',
     &                             //,' Type',14x,'Atom Names',
     &                                17x,'Charges',5x,'Distance',
     &                                6x,'Energy',/)
                        end if
                        write (iout,50)  i,name(i),k,name(k),
     &                                   pchg(i),pchg(k),r,efull
   50                   format (' Charge',4x,2(i7,'-',a3),1x,
     &                             '(XTAL)',1x,2f7.2,f11.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine echarge3e  --  Ewald charge analysis via lights  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "echarge3e" calculates the charge-charge interaction energy
c     and partitions the energy among the atoms using a particle
c     mesh Ewald summation and the method of lights
c
c
      subroutine echarge3e
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use charge
      use chgpot
      use couple
      use energi
      use ewald
      use group
      use inform
      use inter
      use iounit
      use light
      use math
      use molcul
      use pme
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,in,ic,im
      integer kk,kn,km
      integer kgy,kgz,kmap
      integer start,stop
      real*8 e,efull
      real*8 f,fi,fik
      real*8 fs,fgrp
      real*8 r,r2,rb,rew
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xd,yd,zd
      real*8 erfc,erfterm
      real*8 sum,scale
      real*8, allocatable :: cscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      logical header,huge
      character*6 mode
      external erfc
c
c
c     zero out the Ewald summation energy and partitioning
c
      nec = 0
      ec = 0.0d0
      do i = 1, n
         aec(i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nion.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Charge-Charge Interactions :',
     &           //,' Type',14x,'Atom Names',17x,'Charges',
     &              5x,'Distance',6x,'Energy',/)
      end if
c
c     compute the Ewald self-energy term over all the atoms
c
      fs = -f * aewald / rootpi
      do ii = 1, nion
         i = iion(ii)
         e = fs * pchg(i)**2
         ec = ec + e
         nec = nec + 1
         aec(i) = aec(i) + e
      end do
c
c     compute the uniform background charge correction term
c
      fs = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, nion
         i = iion(ii)
         sum = sum + pchg(i)
      end do
      if (sum .ne. 0.0d0) then
         e = fs * sum**2
         ec = ec + e
         nec = nec + 1
         do ii = 1, nion
            i = iion(ii)
            aec(i) = aec(i) + e/dble(nion)
         end do
      end if
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(i)*x(i)
            yd = yd + pchg(i)*y(i)
            zd = zd + pchg(i)*z(i)
         end do
         e = (2.0d0/3.0d0) * f * (pi/volbox) * (xd*xd+yd*yd+zd*zd)
         ec = ec + e
         nec = nec + 1
         do ii = 1, nion
            i = iion(ii)
            aec(i) = aec(i) + e/dble(nion)
         end do
      end if
c
c     compute the reciprocal space part of the Ewald summation
c
      call ecrecip3
c
c     compute the real space portion of the Ewald summation;
c     transfer the interaction site coordinates to sorting arrays
c
      do ii = 1, nion
         i = iion(ii)
         ic = kion(i)
         xsort(ii) = x(ic)
         ysort(ii) = y(ic)
         zsort(ii) = z(ic)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nion,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         im = molcule(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         fi = f * pchg(i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   20    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 60
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 60
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 60
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 60
            end if
            kmap = kk - ((kk-1)/nion)*nion
            k = iion(kmap)
            kn = jion(k)
            km = molcule(k)
            prime = (kk .le. nion)
c
c     decide whether to compute the current interaction
c
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
c
c     find energy for interactions within real space cutoff
c
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rb = r + ebuffer
                  rew = aewald * r
                  erfterm = erfc (rew)
                  scale = 1.0d0
                  if (prime)  scale = cscale(kn)
                  if (use_group)  scale = scale * fgrp
                  fik = fi * pchg(k)
                  if (use_polymer) then
                     if (r2 .gt. polycut2)  fik = fi * pchg(k)
                  end if
                  e = (fik/rb) * (erfterm+scale-1.0d0)
c
c     increment the overall charge-charge energy components
c
                  ec = ec + e
                  aec(i) = aec(i) + 0.5d0*e
                  aec(k) = aec(k) + 0.5d0*e
                  efull = (fik/rb) * scale
                  if (efull .ne. 0.0d0) then
                     nec = nec + 1
                     if (.not.prime .or. im.ne.km)
     &                  einter = einter + efull
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(efull) .gt. 100.0d0)
                  if ((debug.and.efull.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,30)
   30                   format (/,' Individual Real Space Ewald',
     &                             ' Charge-Charge Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             17x,'Charges',5x,'Distance',
     &                             6x,'Energy',/)
                     end if
                     if (prime) then
                        write (iout,40)  i,name(i),k,name(k),pchg(i),
     &                                   pchg(k),r,efull
   40                   format (' Charge',4x,2(i7,'-',a3),8x,
     &                             2f7.2,f11.4,f12.4)
                     else
                        write (iout,50)  i,name(i),k,name(k),pchg(i),
     &                                   pchg(k),r,efull
   50                   format (' Charge',4x,2(i7,'-',a3),1x,
     &                             '(XTAL)',1x,2f7.2,f11.4,f12.4)
                     end if
                  end if
               end if
            end if
   60       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 20
         end if
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine echarge3f  --  Ewald charge analysis via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "echarge3f" calculates the charge-charge interaction energy
c     and partitions the energy among the atoms using a particle
c     mesh Ewald summation and a pairwise neighbor list
c
c
      subroutine echarge3f
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use charge
      use chgpot
      use couple
      use energi
      use ewald
      use group
      use inform
      use inter
      use iounit
      use math
      use molcul
      use neigh
      use pme
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,in,im
      integer kk,kn,km
      real*8 e,efull
      real*8 f,fi,fik
      real*8 fs,fgrp
      real*8 r,r2,rb,rew
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xd,yd,zd
      real*8 erfc,erfterm
      real*8 sum,scale
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      logical header,huge
      character*6 mode
      external erfc
c
c
c     zero out the Ewald summation energy and partitioning
c
      nec = 0
      ec = 0.0d0
      do i = 1, n
         aec(i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nion.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Charge-Charge Interactions :',
     &           //,' Type',14x,'Atom Names',17x,'Charges',
     &              5x,'Distance',6x,'Energy',/)
      end if
c
c     compute the Ewald self-energy term over all the atoms
c
      fs = -f * aewald / rootpi
      do ii = 1, nion
         i = iion(ii)
         e = fs * pchg(i)**2
         ec = ec + e
         nec = nec + 1
         aec(i) = aec(i) + e
      end do
c
c     compute the uniform background charge correction term
c
      fs = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, nion
         i = iion(ii)
         sum = sum + pchg(i)
      end do
      if (sum .ne. 0.0d0) then
         e = fs * sum**2
         ec = ec + e
         nec = nec + 1
         do ii = 1, nion
            i = iion(ii)
            aec(i) = aec(i) + e/dble(nion)
         end do
      end if
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(i)*x(i)
            yd = yd + pchg(i)*y(i)
            zd = zd + pchg(i)*z(i)
         end do
         e = (2.0d0/3.0d0) * f * (pi/volbox) * (xd*xd+yd*yd+zd*zd)
         ec = ec + e
         nec = nec + 1
         do ii = 1, nion
            i = iion(ii)
            aec(i) = aec(i) + e/dble(nion)
         end do
      end if
c
c     compute the reciprocal space part of the Ewald summation
c
      call ecrecip3
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,jion,use,
!$OMP& x,y,z,f,pchg,nelst,elst,n12,n13,n14,n15,i12,i13,i14,i15,
!$OMP& c1scale,c2scale,c3scale,c4scale,c5scale,use_group,off2,
!$OMP& aewald,molcule,ebuffer,name,verbose,debug,header,iout)
!$OMP& firstprivate(cscale) shared (ec,nec,aec,einter)
!$OMP DO reduction(+:ec,nec,aec,einter)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(i)
         im = molcule(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            kn = jion(k)
            km = molcule(k)
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
c
c     find energy for interactions within real space cutoff
c
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rb = r + ebuffer
                  fik = fi * pchg(k)
                  rew = aewald * r
                  erfterm = erfc (rew)
                  scale = cscale(kn)
                  if (use_group)  scale = scale * fgrp
                  e = (fik/rb) * (erfterm+scale-1.0d0)
c
c     increment the overall charge-charge energy components
c
                  ec = ec + e
                  aec(i) = aec(i) + 0.5d0*e
                  aec(k) = aec(k) + 0.5d0*e
                  efull = (fik/rb) * scale
                  if (efull .ne. 0.0d0) then
                     nec = nec + 1
                     if (im .ne. km)  einter = einter + efull
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(efull) .gt. 100.0d0)
                  if ((debug.and.efull.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Real Space Ewald',
     &                             ' Charge-Charge Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             17x,'Charges',5x,'Distance',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                pchg(i),pchg(k),r,efull
   30                format (' Charge',4x,2(i7,'-',a3),8x,
     &                          2f7.2,f11.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine echarge3g  --  charge analysis for smoothing  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "echarge3g" calculates the charge-charge interaction energy
c     and partitions the energy among the atoms for use with
c     potential smoothing methods
c
c
      subroutine echarge3g
      use action
      use analyz
      use atomid
      use atoms
      use charge
      use chgpot
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use usage
      use warp
      implicit none
      integer i,j,k
      integer ii,in,im
      integer kk,kn,km
      real*8 e,fgrp
      real*8 r,r2,rb,rb2
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 erf,wterm,width
      real*8 width2,width3
      real*8, allocatable :: cscale(:)
      logical proceed,usei
      logical header,huge
      external erf
c
c
c     zero out the charge interaction energy and partitioning
c
      nec = 0
      ec = 0.0d0
      do i = 1, n
         aec(i) = 0.0d0
      end do
      if (nion .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         cscale(i) = 1.0d0
      end do
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nion.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Charge-Charge Interactions :',
     &           //,' Type',14x,'Atom Names',17x,'Charges',
     &              5x,'Distance',6x,'Energy',/)
      end if
c
c     set the energy units conversion factor
c
      f = electric / dielec
c
c     set the extent of smoothing to be performed
c
      width = deform * diffc
      if (use_dem) then
         if (width .gt. 0.0d0)  width = 0.5d0 / sqrt(width)
      else if (use_gda) then
         wterm = sqrt(3.0d0/(2.0d0*diffc))
      end if
      width2 = width * width
      width3 = width * width2
c
c     compute and partition the charge interaction energy
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(i)
         im = molcule(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         usei = (use(i))
c
c     set exclusion coefficients for connected atoms
c
         cscale(in) = c1scale
         do j = 1, n12(in)
            cscale(i12(j,in)) = c2scale
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = c3scale
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = c4scale
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = c5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nion
            k = iion(kk)
            kn = jion(k)
            km = molcule(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed)  proceed = (cscale(kn) .ne. 0.0d0)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               r = sqrt(r2)
               rb = r + ebuffer
               fik = fi * pchg(k) * cscale(kn)
               e = fik / rb
c
c     transform the potential function via smoothing
c
               if (use_dem) then
                  if (width .gt. 0.0d0) then
                     e = e * erf(width*rb)
                  end if
               else if (use_gda) then
                  width = m2(i) + m2(k)
                  if (width .gt. 0.0d0) then
                     width = wterm / sqrt(width)
                     e = e * erf(width*rb)
                  end if
               else if (use_tophat) then
                  if (width .gt. rb) then
                     rb2 = rb * rb
                     e = fik * (3.0d0*width2-rb2) / (2.0d0*width3)
                  end if
               else if (use_stophat) then
                  e = fik / (rb+width)
               end if
c
c     increment the overall charge-charge energy components
c
               if (e .ne. 0.0d0) then
                  if (use_group)  e = e * fgrp
                  nec = nec + 1
                  ec = ec + e
                  aec(i) = aec(i) + 0.5d0*e
                  aec(k) = aec(k) + 0.5d0*e
                  if (im .ne. km)  einter = einter + e
               end if
c
c     print a message if the energy of this interaction is large
c
               huge = (abs(e) .gt. 100.0d0)
               if ((debug.and.e.ne.0.0d0)
     &               .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual Charge-Charge',
     &                          ' Interactions :',
     &                       //,' Type',14x,'Atom Names',
     &                          17x,'Charges',5x,'Distance',
     &                          6x,'Energy',/)
                  end if
                  write (iout,30)  i,name(i),k,name(k),pchg(i),
     &                             pchg(k),r,e
   30             format (' Charge',4x,2(i7,'-',a3),8x,
     &                       2f7.2,f11.4,f12.4)
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         cscale(in) = 1.0d0
         do j = 1, n12(in)
            cscale(i12(j,in)) = 1.0d0
         end do
         do j = 1, n13(in)
            cscale(i13(j,in)) = 1.0d0
         end do
         do j = 1, n14(in)
            cscale(i14(j,in)) = 1.0d0
         end do
         do j = 1, n15(in)
            cscale(i15(j,in)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ecrecip3  --  PME reciprocal charge analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ecrecip3" evaluates the reciprocal space portion of the
c     particle mesh Ewald energy due to partial charges, and
c     partitions the energy among the atoms
c
c     literature reference:
c
c     U. Essmann, L. Perera, M. L Berkowitz, T. Darden, H. Lee and
c     L. G. Pedersen, "A Smooth Particle Mesh Ewald Method", Journal
c     of Chemical Physics, 103, 8577-8593 (1995)
c
c     W. Smith and D. Fincham, "The Ewald Sum in Truncated Octahedral
c     and Rhombic Dodecahedral Boundary Conditions", Molecular
c     Simulation, 10, 67-71 (1993)
c
c     modifications for nonperiodic systems suggested by Tom Darden
c     during May 2007
c
c
      subroutine ecrecip3
      use analyz
      use atoms
      use bound
      use boxes
      use charge
      use chgpot
      use energi
      use ewald
      use math
      use pme
      implicit none
      integer i,j,ii
      integer k1,k2,k3
      integer m1,m2,m3
      integer nf1,nf2,nf3
      integer nff,ntot
      real*8 e,f,hsq,denom
      real*8 term,expterm
      real*8 pterm,volterm
      real*8 h1,h2,h3
      real*8 r1,r2,r3
      real*8, allocatable :: fphi(:,:)
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      f = 0.5d0 * electric / dielec
c
c     perform dynamic allocation of some global arrays
c
      ntot = nfft1 * nfft2 * nfft3
      if (allocated(qgrid)) then
         if (size(qgrid) .ne. 2*ntot)  call fftclose
      end if
      if (.not. allocated(qgrid))  call fftsetup
c
c     setup spatial decomposition and B-spline coefficients
c
      call getchunk
      call moduli
      call bspline_fill
      call table_fill
c
c     assign PME grid and perform 3-D FFT forward transform
c
      call grid_pchg
      call fftfront
c
c     use scalar sum to get the reciprocal space energy
c
      pterm = (pi/aewald)**2
      volterm = pi * volbox
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      nff = nfft1 * nfft2
      ntot = nff * nfft3
      do i = 1, ntot-1
         k3 = i/nff + 1
         j = i - (k3-1)*nff
         k2 = j/nfft1 + 1
         k1 = j - (k2-1)*nfft1 + 1
         m1 = k1 - 1
         m2 = k2 - 1
         m3 = k3 - 1
         if (k1 .gt. nf1)  m1 = m1 - nfft1
         if (k2 .gt. nf2)  m2 = m2 - nfft2
         if (k3 .gt. nf3)  m3 = m3 - nfft3
         r1 = dble(m1)
         r2 = dble(m2)
         r3 = dble(m3)
         h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
         h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
         h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
         hsq = h1*h1 + h2*h2 + h3*h3
         term = -pterm * hsq
         expterm = 0.0d0
         if (term .gt. -50.0d0) then
            denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
            expterm = exp(term) / denom
            if (.not. use_bounds) then
               expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
            else if (nonprism) then
               if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
            end if
         end if
         qgrid(1,k1,k2,k3) = expterm * qgrid(1,k1,k2,k3)
         qgrid(2,k1,k2,k3) = expterm * qgrid(2,k1,k2,k3)
      end do
c
c     account for zeroth grid point for nonperiodic system
c
      qgrid(1,1,1,1) = 0.0d0
      qgrid(2,1,1,1) = 0.0d0
      if (.not. use_bounds) then
         expterm = 0.5d0 * pi / xbox
         qgrid(1,1,1,1) = expterm * qgrid(1,1,1,1)
         qgrid(2,1,1,1) = expterm * qgrid(2,1,1,1)
      end if
c
c     perform the 3-D FFT backward transformation
c
      call fftback
c
c     perform dynamic allocation of some local arrays
c
      allocate (fphi(4,n))
c
c     extract the partial charge electrostatic potential
c
      call fphi_pchg (fphi)
c
c     sum over charges and increment total charge energy
c
      e = 0.0d0
      do ii = 1, nion
         i = iion(ii)
         term = f * pchg(i) * fphi(1,i)
         e = e + term
         aec(i) = aec(i) + term
      end do
      ec = ec + e
c
c     perform deallocation of some local arrays
c
      deallocate (fphi)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine echgdpl  --  charge-dipole potential energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "echgdpl" calculates the charge-dipole interaction energy
c
c
      subroutine echgdpl
      use atoms
      use bound
      use cell
      use charge
      use chgpot
      use couple
      use dipole
      use energi
      use group
      use shunt
      use units
      use usage
      implicit none
      integer i,j,k
      integer ii,k1,k2
      integer, allocatable :: skip(:)
      real*8 e,rk2,rkr3,dotk
      real*8 taper,fgrp
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xk,yk,zk
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4,r5
      logical proceed
      character*6 mode
c
c
c     zero out the overall charge-dipole interaction energy
c
      ecd = 0.0d0
      if (nion.eq.0 .or. ndipole.eq.0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (skip(n))
c
c     zero out the list of atoms to be skipped
c
      do i = 1, n
         skip(i) = 0
      end do
c
c     set conversion factor and switching function coefficients
c
      f = electric / (debye * dielec)
      mode = 'CHGDPL'
      call switch (mode)
c
c     get the total energy by looping over each charge-dipole pair
c
      do ii = 1, nion
         i = iion(ii)
         skip(i) = i
         do k = 1, n12(i)
            skip(i12(k,i)) = i
         end do
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
c
c     decide whether to compute the current interaction
c
         do k = 1, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k1,k2,0,0,0)
            if (proceed)  proceed = (use(i) .or. use(k1) .or. use(k2))
            if (proceed)  proceed = (skip(k1).ne.i .and.
     &                                 skip(k2).ne.i)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xk = x(k2) - x(k1)
               yk = y(k2) - y(k1)
               zk = z(k2) - z(k1)
               xr = x(k1) + xk*sdpl(k) - xi
               yr = y(k1) + yk*sdpl(k) - yi
               zr = z(k1) + zk*sdpl(k) - zi
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  fik = fi * bdpl(k)
                  rk2 = xk*xk + yk*yk + zk*zk
                  rkr3 = sqrt(rk2*r2) * r2
                  dotk = xk*xr + yk*yr + zk*zr
                  e = fik * dotk / rkr3
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall charge-dipole energy component
c
                  ecd = ecd + e
               end if
            end if
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nion
         i = iion(ii)
         skip(i) = i
         do k = 1, n12(i)
            skip(i12(k,i)) = i
         end do
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
c
c     decide whether to compute the current interaction
c
         do k = 1, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k1,k2,0,0,0)
            if (proceed)  proceed = (use(i) .or. use(k1) .or. use(k2))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xk = x(k2) - x(k1)
                  yk = y(k2) - y(k1)
                  zk = z(k2) - z(k1)
                  xr = x(k1) + xk*sdpl(k) - xi
                  yr = y(k1) + yk*sdpl(k) - yi
                  zr = z(k1) + zk*sdpl(k) - zi
                  call imager (xr,yr,zr,j)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     fik = fi * bdpl(k)
                     if (use_polymer) then
                        if (r2 .lt. polycut2) then
                           if (skip(k1).eq.i .or. skip(k2).ne.i)
     &                        fik = 0.0d0
                        end if
                     end if
                     rk2 = xk*xk + yk*yk + zk*zk
                     rkr3 = sqrt(rk2*r2) * r2
                     dotk = xk*xr + yk*yr + zk*zr
                     e = fik * dotk / rkr3
c
c     use energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        r = sqrt(r2)
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall charge-dipole energy component
c
                     ecd = ecd + e
                  end if
               end do
            end if
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (skip)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine echgdpl1  --  charge-dipole energy & derivs  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "echgdpl1" calculates the charge-dipole interaction energy
c     and first derivatives with respect to Cartesian coordinates
c
c
      subroutine echgdpl1
      use atoms
      use bound
      use cell
      use charge
      use chgpot
      use couple
      use deriv
      use dipole
      use energi
      use group
      use shunt
      use units
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,k1,k2
      integer, allocatable :: skip(:)
      real*8 e,r2,rk2,rkr3,dotk
      real*8 f,fi,fik,fgrp
      real*8 sk1,sk2
      real*8 xi,yi,zi
      real*8 xk,yk,zk
      real*8 xr,yr,zr
      real*8 xr1,yr1,zr1
      real*8 xr2,yr2,zr2
      real*8 term,term2,term3
      real*8 termx,termy,termz
      real*8 termxk,termyk,termzk
      real*8 dedxi1,dedyi1,dedzi1
      real*8 dedxk1,dedyk1,dedzk1
      real*8 dedxk2,dedyk2,dedzk2
      real*8 r,r3,r4,r5,taper,dtaper
      real*8 dtaperx,dtapery,dtaperz
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
      character*6 mode
c
c
c     zero out the overall charge-dipole interaction energy
c     and set up the constants for the calculation
c
      ecd = 0.0d0
      do i = 1, n
         decd(1,i) = 0.0d0
         decd(2,i) = 0.0d0
         decd(3,i) = 0.0d0
      end do
      if (nion.eq.0 .or. ndipole.eq.0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (skip(n))
c
c     zero out the list of atoms to be skipped
c
      do i = 1, n
         skip(i) = 0
      end do
c
c     set conversion factor and switching function coefficients
c
      f = electric / (debye * dielec)
      mode = 'CHGDPL'
      call switch (mode)
c
c     get energy and derivs by looping over each charge-dipole pair
c
      do ii = 1, nion
         i = iion(ii)
         skip(i) = i
         do k = 1, n12(i)
            skip(i12(k,i)) = i
         end do
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
c
c     decide whether to compute the current interaction
c
         do k = 1, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k1,k2,0,0,0)
            if (proceed)  proceed = (use(i) .or. use(k1) .or. use(k2))
            if (proceed)  proceed = (skip(k1).ne.i .and.
     &                                 skip(k2).ne.i)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               sk1 = 1.0d0 - sdpl(k)
               sk2 = sdpl(k)
               xk = x(k2) - x(k1)
               yk = y(k2) - y(k1)
               zk = z(k2) - z(k1)
               xr = x(k1) + xk*sk2 - xi
               yr = y(k1) + yk*sk2 - yi
               zr = z(k1) + zk*sk2 - zi
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  fik = fi * bdpl(k)
                  rk2 = xk*xk + yk*yk + zk*zk
                  rkr3 = sqrt(rk2*r2) * r2
                  dotk = xk*xr + yk*yr + zk*zr
c
c     form the energy and master chain rule term for derivatives
c
                  e = fik * dotk / rkr3
                  term = -fik / rkr3
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     term = term * fgrp
                  end if
c
c     secondary chain rule terms for derivative expressions
c
                  term2 = -3.0d0 * dotk / r2
                  term3 = -dotk / rk2
                  termx = term * (xk+xr*term2)
                  termy = term * (yk+yr*term2)
                  termz = term * (zk+zr*term2)
                  termxk = -term * (xr+xk*term3)
                  termyk = -term * (yr+yk*term3)
                  termzk = -term * (zr+zk*term3)
                  dedxi1 = termx
                  dedyi1 = termy
                  dedzi1 = termz
                  dedxk1 = -sk1*termx - termxk
                  dedyk1 = -sk1*termy - termyk
                  dedzk1 = -sk1*termz - termzk
                  dedxk2 = -sk2*termx + termxk
                  dedyk2 = -sk2*termy + termyk
                  dedzk2 = -sk2*termz + termzk
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     dtaper = dtaper * e/r
                     dtaperx = xr * dtaper
                     dtapery = yr * dtaper
                     dtaperz = zr * dtaper
                     e = e * taper
                     dedxi1 = dedxi1*taper - dtaperx
                     dedyi1 = dedyi1*taper - dtapery
                     dedzi1 = dedzi1*taper - dtaperz
                     dedxk1 = dedxk1*taper + sk1*dtaperx
                     dedyk1 = dedyk1*taper + sk1*dtapery
                     dedzk1 = dedzk1*taper + sk1*dtaperz
                     dedxk2 = dedxk2*taper + sk2*dtaperx
                     dedyk2 = dedyk2*taper + sk2*dtapery
                     dedzk2 = dedzk2*taper + sk2*dtaperz
                  end if
c
c     increment the overall energy and derivative expressions
c
                  ecd = ecd + e
                  decd(1,i) = decd(1,i) + dedxi1
                  decd(2,i) = decd(2,i) + dedyi1
                  decd(3,i) = decd(3,i) + dedzi1
                  decd(1,k1) = decd(1,k1) + dedxk1
                  decd(2,k1) = decd(2,k1) + dedyk1
                  decd(3,k1) = decd(3,k1) + dedzk1
                  decd(1,k2) = decd(1,k2) + dedxk2
                  decd(2,k2) = decd(2,k2) + dedyk2
                  decd(3,k2) = decd(3,k2) + dedzk2
c
c     increment the internal virial tensor components
c
                  xr1 = x(k1) - xi
                  yr1 = y(k1) - yi
                  zr1 = z(k1) - zi
                  xr2 = x(k2) - xi
                  yr2 = y(k2) - yi
                  zr2 = z(k2) - zi
                  vxx = xr1*dedxk1 + xr2*dedxk2
                  vyx = yr1*dedxk1 + yr2*dedxk2
                  vzx = zr1*dedxk1 + zr2*dedxk2
                  vyy = yr1*dedyk1 + yr2*dedyk2
                  vzy = zr1*dedyk1 + zr2*dedyk2
                  vzz = zr1*dedzk1 + zr2*dedzk2
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nion
         i = iion(ii)
         skip(i) = i
         do k = 1, n12(i)
            skip(i12(k,i)) = i
         end do
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
c
c     decide whether to compute the current interaction
c
         do k = 1, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k1,k2,0,0,0)
            if (proceed)  proceed = (use(i) .or. use(k1) .or. use(k2))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               sk1 = 1.0d0 - sdpl(k)
               sk2 = sdpl(k)
               do j = 2, ncell
                  xk = x(k2) - x(k1)
                  yk = y(k2) - y(k1)
                  zk = z(k2) - z(k1)
                  xr = x(k1) + xk*sk2 - xi
                  yr = y(k1) + yk*sk2 - yi
                  zr = z(k1) + zk*sk2 - zi
                  call imager (xr,yr,zr,j)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     fik = fi * bdpl(k)
                     if (use_polymer) then
                        if (r2 .lt. polycut2) then
                           if (skip(k1).eq.i .or. skip(k2).ne.i)
     &                        fik = 0.0d0
                        end if
                     end if
                     rk2 = xk*xk + yk*yk + zk*zk
                     rkr3 = sqrt(rk2*r2) * r2
                     dotk = xk*xr + yk*yr + zk*zr
c
c     form the energy and master chain rule term for derivatives
c
                     e = fik * dotk / rkr3
                     term = -fik / rkr3
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        e = e * fgrp
                        term = term * fgrp
                     end if
c
c     secondary chain rule terms for derivative expressions
c
                     term2 = -3.0d0 * dotk / r2
                     term3 = -dotk / rk2
                     termx = term * (xk+xr*term2)
                     termy = term * (yk+yr*term2)
                     termz = term * (zk+zr*term2)
                     termxk = -term * (xr+xk*term3)
                     termyk = -term * (yr+yk*term3)
                     termzk = -term * (zr+zk*term3)
                     dedxi1 = termx
                     dedyi1 = termy
                     dedzi1 = termz
                     dedxk1 = -sk1*termx - termxk
                     dedyk1 = -sk1*termy - termyk
                     dedzk1 = -sk1*termz - termzk
                     dedxk2 = -sk2*termx + termxk
                     dedyk2 = -sk2*termy + termyk
                     dedzk2 = -sk2*termz + termzk
c
c     use energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        r = sqrt(r2)
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                              + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                        dtaper = dtaper * e/r
                        dtaperx = xr * dtaper
                        dtapery = yr * dtaper
                        dtaperz = zr * dtaper
                        e = e * taper
                        dedxi1 = dedxi1*taper - dtaperx
                        dedyi1 = dedyi1*taper - dtapery
                        dedzi1 = dedzi1*taper - dtaperz
                        dedxk1 = dedxk1*taper + sk1*dtaperx
                        dedyk1 = dedyk1*taper + sk1*dtapery
                        dedzk1 = dedzk1*taper + sk1*dtaperz
                        dedxk2 = dedxk2*taper + sk2*dtaperx
                        dedyk2 = dedyk2*taper + sk2*dtapery
                        dedzk2 = dedzk2*taper + sk2*dtaperz
                     end if
c
c     increment the overall energy and derivative expressions
c
                     ecd = ecd + e
                     decd(1,i) = decd(1,i) + dedxi1
                     decd(2,i) = decd(2,i) + dedyi1
                     decd(3,i) = decd(3,i) + dedzi1
                     decd(1,k1) = decd(1,k1) + dedxk1
                     decd(2,k1) = decd(2,k1) + dedyk1
                     decd(3,k1) = decd(3,k1) + dedzk1
                     decd(1,k2) = decd(1,k2) + dedxk2
                     decd(2,k2) = decd(2,k2) + dedyk2
                     decd(3,k2) = decd(3,k2) + dedzk2
                  end if
c
c     increment the internal virial tensor components
c
                  xr1 = x(k1) - xi
                  yr1 = y(k1) - yi
                  zr1 = z(k1) - zi
                  xr2 = x(k2) - xi
                  yr2 = y(k2) - yi
                  zr2 = z(k2) - zi
                  vxx = xr1*dedxk1 + xr2*dedxk2
                  vyx = yr1*dedxk1 + yr2*dedxk2
                  vzx = zr1*dedxk1 + zr2*dedxk2
                  vyy = yr1*dedyk1 + yr2*dedyk2
                  vzy = zr1*dedyk1 + zr2*dedyk2
                  vzz = zr1*dedzk1 + zr2*dedzk2
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end do
            end if
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (skip)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine echgdpl2  --  atomwise charge-dipole Hessian  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "echgdpl2" calculates second derivatives of the
c     charge-dipole interaction energy for a single atom
c
c
      subroutine echgdpl2 (i)
      use atoms
      use bound
      use cell
      use charge
      use chgpot
      use couple
      use dipole
      use group
      use hessn
      use shunt
      use units
      implicit none
      integer i,k,jcell
      integer ii,i1,k1,k2
      integer, allocatable :: skip(:)
      integer, allocatable :: omit(:)
      real*8 f,fi,fk,fik
      real*8 fgrp,sk1,sk2
      real*8 xi,yi,zi,xk,yk,zk
      real*8 xr,yr,zr,xq,yq,zq
      real*8 e,r2,rk2,rkr3,dotk
      real*8 term,term2,part,part2
      real*8 termx,termy,termz
      real*8 termxk,termyk,termzk
      real*8 xrr2,yrr2,zrr2
      real*8 xkrk2,ykrk2,zkrk2
      real*8 dotk2,dotkr2,dotkrk2
      real*8 factor,factork
      real*8 dedxi1,dedyi1,dedzi1
      real*8 dedxk1,dedyk1,dedzk1
      real*8 dedxk2,dedyk2,dedzk2
      real*8 dtdxi1,dtdyi1,dtdzi1
      real*8 dtdxk1,dtdyk1,dtdzk1
      real*8 dtdxk2,dtdyk2,dtdzk2
      real*8 dtxdxi1,dtxkdxi1,dtxdxk1
      real*8 dtxkdxk1,dtxdxk2,dtxkdxk2
      real*8 dtydxi1,dtykdxi1,dtydxk1
      real*8 dtykdxk1,dtydxk2,dtykdxk2
      real*8 dtzdxi1,dtzkdxi1,dtzdxk1
      real*8 dtzkdxk1,dtzdxk2,dtzkdxk2
      real*8 dtxdyi1,dtxkdyi1,dtxdyk1
      real*8 dtxkdyk1,dtxdyk2,dtxkdyk2
      real*8 dtydyi1,dtykdyi1,dtydyk1
      real*8 dtykdyk1,dtydyk2,dtykdyk2
      real*8 dtzdyi1,dtzkdyi1,dtzdyk1
      real*8 dtzkdyk1,dtzdyk2,dtzkdyk2
      real*8 dtxdzi1,dtxkdzi1,dtxdzk1
      real*8 dtxkdzk1,dtxdzk2,dtxkdzk2
      real*8 dtydzi1,dtykdzi1,dtydzk1
      real*8 dtykdzk1,dtydzk2,dtykdzk2
      real*8 dtzdzi1,dtzkdzi1,dtzdzk1
      real*8 dtzkdzk1,dtzdzk2,dtzkdzk2
      real*8 r,r3,r4,r5
      real*8 taper,dtaper,d2taper
      real*8 dtaperx,dtapery,dtaperz
      real*8 d2taperxx,d2taperyy
      real*8 d2taperzz,d2taperxy
      real*8 d2taperxz,d2taperyz
      logical proceed
      character*6 mode
c
c
c     check for the presence of both charges and dipoles
c
      if (ndipole.eq.0 .or. nion.eq.0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (skip(n))
      allocate (omit(n))
c
c     zero out the lists of atoms to be skipped
c
      do k = 1, n
         skip(k) = 0
         omit(k) = 0
      end do
c
c     set conversion factor and switching function coefficients
c
      f = -electric / (debye * dielec)
      mode = 'CHGDPL'
      call switch (mode)
c
c     first see if the atom of interest carries a charge
c
      do ii = 1, nion
         i1 = iion(ii)
         if (i1 .ne. i)  goto 10
         skip(i1) = i1
         do k = 1, n12(i1)
            skip(i12(k,i1)) = i1
         end do
         xi = x(i1)
         yi = y(i1)
         zi = z(i1)
         fi = f * pchg(i1)
c
c     decide whether to compute the current interaction
c
         do k = 1, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i1,k1,k2,0,0,0)
            if (proceed)  proceed = (skip(k1).ne.i1 .and.
     &                                 skip(k2).ne.i1)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               sk1 = 1.0d0 - sdpl(k)
               sk2 = sdpl(k)
               xk = x(k1) - x(k2)
               yk = y(k1) - y(k2)
               zk = z(k1) - z(k2)
               xr = xi - x(k1) + xk*sk2
               yr = yi - y(k1) + yk*sk2
               zr = zi - z(k1) + zk*sk2
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  rk2 = xk*xk + yk*yk + zk*zk
                  rkr3 = sqrt(rk2*r2) * r2
                  dotk = xk*xr + yk*yr + zk*zr
                  fik = -fi * bdpl(k)
c
c     scale the interaction based on its group membership
c
                  if (use_group)  fik = fik * fgrp
c
c     some abbreviations used in various chain rule terms
c
                  xrr2 = xr / r2
                  yrr2 = yr / r2
                  zrr2 = zr / r2
                  xkrk2 = xk / rk2
                  ykrk2 = yk / rk2
                  zkrk2 = zk / rk2
                  dotk2 = 2.0d0 * dotk
                  dotkr2 = dotk / r2
c
c     form the chain rule terms for first derivatives
c
                  term = fik / rkr3
                  term2 = -3.0d0 * dotk
                  termx = term * (xk+xrr2*term2)
                  termy = term * (yk+yrr2*term2)
                  termz = term * (zk+zrr2*term2)
                  termxk = term * (xr-dotk*xkrk2)
                  termyk = term * (yr-dotk*ykrk2)
                  termzk = term * (zr-dotk*zkrk2)
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     e = fik * dotk / rkr3
                     dedxi1 = termx
                     dedyi1 = termy
                     dedzi1 = termz
                     dedxk1 = -sk1*termx + termxk
                     dedyk1 = -sk1*termy + termyk
                     dedzk1 = -sk1*termz + termzk
                     dedxk2 = -sk2*termx - termxk
                     dedyk2 = -sk2*termy - termyk
                     dedzk2 = -sk2*termz - termzk
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2
     &                            + 6.0d0*c3*r + 2.0d0*c2
                     dtaper = dtaper / r
                     dtaperx = xr * dtaper
                     dtapery = yr * dtaper
                     dtaperz = zr * dtaper
                     d2taper = e * (d2taper-dtaper)
                     dtaper = e * dtaper
                     d2taperxx = xr*xrr2*d2taper + dtaper
                     d2taperxy = xr*yrr2*d2taper
                     d2taperxz = xr*zrr2*d2taper
                     d2taperyy = yr*yrr2*d2taper + dtaper
                     d2taperyz = yr*zrr2*d2taper
                     d2taperzz = zr*zrr2*d2taper + dtaper
                     term = term * taper
                     termx = termx * taper
                     termy = termy * taper
                     termz = termz * taper
                     termxk = termxk * taper
                     termyk = termyk * taper
                     termzk = termzk * taper
                  end if
c
c     chain rule terms for second derivative components
c
                  dtdxi1 = -3.0d0 * xrr2
                  part = xk - dotk2*xrr2
                  factor = -3.0d0 * (dotkr2 + xrr2*part)
                  factork = 1.0d0 - xk*xkrk2
                  dtxdxi1 = dtdxi1*termx + term*factor
                  dtxkdxi1 = dtdxi1*termxk + term*factork
                  factor = -3.0d0 * yrr2 * part
                  factork = -yk * xkrk2
                  dtydxi1 = dtdxi1*termy + term*factor
                  dtykdxi1 = dtdxi1*termyk + term*factork
                  factor = -3.0d0 * zrr2 * part
                  factork = -zk * xkrk2
                  dtzdxi1 = dtdxi1*termz + term*factor
                  dtzkdxi1 = dtdxi1*termzk + term*factork
                  dtdyi1 = -3.0d0 * yrr2
                  part = yk - dotk2*yrr2
                  factor = -3.0d0 * xrr2 * part
                  factork = -xk * ykrk2
                  dtxdyi1 = dtdyi1*termx + term*factor
                  dtxkdyi1 = dtdyi1*termxk + term*factork
                  factor = -3.0d0 * (dotkr2 + yrr2*part)
                  factork = 1.0d0 - yk*ykrk2
                  dtydyi1 = dtdyi1*termy + term*factor
                  dtykdyi1 = dtdyi1*termyk + term*factork
                  factor = -3.0d0 * zrr2 * part
                  factork = -zk * ykrk2
                  dtzdyi1 = dtdyi1*termz + term*factor
                  dtzkdyi1 = dtdyi1*termzk + term*factork
                  dtdzi1 = -3.0d0 * zrr2
                  part = zk - dotk2*zrr2
                  factor = -3.0d0 * xrr2 * part
                  factork = -xk * zkrk2
                  dtxdzi1 = dtdzi1*termx + term*factor
                  dtxkdzi1 = dtdzi1*termxk + term*factork
                  factor = -3.0d0 * yrr2 * part
                  factork = -yk * zkrk2
                  dtydzi1 = dtdzi1*termy + term*factor
                  dtykdzi1 = dtdzi1*termyk + term*factork
                  factor = -3.0d0 * (dotkr2 + zrr2*part)
                  factork = 1.0d0 - zk*zkrk2
                  dtzdzi1 = dtdzi1*termz + term*factor
                  dtzkdzi1 = dtdzi1*termzk + term*factork
c
c     increment diagonal and off-diagonal Hessian elements
c
                  hessx(1,i1) = hessx(1,i1) + dtxdxi1
                  hessx(2,i1) = hessx(2,i1) + dtydxi1
                  hessx(3,i1) = hessx(3,i1) + dtzdxi1
                  hessx(1,k1) = hessx(1,k1) - sk1*dtxdxi1 + dtxkdxi1
                  hessx(2,k1) = hessx(2,k1) - sk1*dtydxi1 + dtykdxi1
                  hessx(3,k1) = hessx(3,k1) - sk1*dtzdxi1 + dtzkdxi1
                  hessx(1,k2) = hessx(1,k2) - sk2*dtxdxi1 - dtxkdxi1
                  hessx(2,k2) = hessx(2,k2) - sk2*dtydxi1 - dtykdxi1
                  hessx(3,k2) = hessx(3,k2) - sk2*dtzdxi1 - dtzkdxi1
                  hessy(1,i1) = hessy(1,i1) + dtxdyi1
                  hessy(2,i1) = hessy(2,i1) + dtydyi1
                  hessy(3,i1) = hessy(3,i1) + dtzdyi1
                  hessy(1,k1) = hessy(1,k1) - sk1*dtxdyi1 + dtxkdyi1
                  hessy(2,k1) = hessy(2,k1) - sk1*dtydyi1 + dtykdyi1
                  hessy(3,k1) = hessy(3,k1) - sk1*dtzdyi1 + dtzkdyi1
                  hessy(1,k2) = hessy(1,k2) - sk2*dtxdyi1 - dtxkdyi1
                  hessy(2,k2) = hessy(2,k2) - sk2*dtydyi1 - dtykdyi1
                  hessy(3,k2) = hessy(3,k2) - sk2*dtzdyi1 - dtzkdyi1
                  hessz(1,i1) = hessz(1,i1) + dtxdzi1
                  hessz(2,i1) = hessz(2,i1) + dtydzi1
                  hessz(3,i1) = hessz(3,i1) + dtzdzi1
                  hessz(1,k1) = hessz(1,k1) - sk1*dtxdzi1 + dtxkdzi1
                  hessz(2,k1) = hessz(2,k1) - sk1*dtydzi1 + dtykdzi1
                  hessz(3,k1) = hessz(3,k1) - sk1*dtzdzi1 + dtzkdzi1
                  hessz(1,k2) = hessz(1,k2) - sk2*dtxdzi1 - dtxkdzi1
                  hessz(2,k2) = hessz(2,k2) - sk2*dtydzi1 - dtykdzi1
                  hessz(3,k2) = hessz(3,k2) - sk2*dtzdzi1 - dtzkdzi1
c
c     more energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     hessx(1,i1) = hessx(1,i1) + dtaperx*dedxi1
     &                             + dtaperx*dedxi1 + d2taperxx
                     hessx(2,i1) = hessx(2,i1) + dtaperx*dedyi1
     &                             + dtapery*dedxi1 + d2taperxy
                     hessx(3,i1) = hessx(3,i1) + dtaperx*dedzi1
     &                             + dtaperz*dedxi1 + d2taperxz
                     hessx(1,k1) = hessx(1,k1) + dtaperx*dedxk1
     &                             - sk1*(dtaperx*dedxi1+d2taperxx)
                     hessx(2,k1) = hessx(2,k1) + dtaperx*dedyk1
     &                             - sk1*(dtapery*dedxi1+d2taperxy)
                     hessx(3,k1) = hessx(3,k1) + dtaperx*dedzk1
     &                             - sk1*(dtaperz*dedxi1+d2taperxz)
                     hessx(1,k2) = hessx(1,k2) + dtaperx*dedxk2
     &                             - sk2*(dtaperx*dedxi1+d2taperxx)
                     hessx(2,k2) = hessx(2,k2) + dtaperx*dedyk2
     &                             - sk2*(dtapery*dedxi1+d2taperxy)
                     hessx(3,k2) = hessx(3,k2) + dtaperx*dedzk2
     &                             - sk2*(dtaperz*dedxi1+d2taperxz)
                     hessy(1,i1) = hessy(1,i1) + dtapery*dedxi1
     &                             + dtaperx*dedyi1 + d2taperxy
                     hessy(2,i1) = hessy(2,i1) + dtapery*dedyi1
     &                             + dtapery*dedyi1 + d2taperyy
                     hessy(3,i1) = hessy(3,i1) + dtapery*dedzi1
     &                             + dtaperz*dedyi1 + d2taperyz
                     hessy(1,k1) = hessy(1,k1) + dtapery*dedxk1
     &                             - sk1*(dtaperx*dedyi1+d2taperxy)
                     hessy(2,k1) = hessy(2,k1) + dtapery*dedyk1
     &                             - sk1*(dtapery*dedyi1+d2taperyy)
                     hessy(3,k1) = hessy(3,k1) + dtapery*dedzk1
     &                             - sk1*(dtaperz*dedyi1+d2taperyz)
                     hessy(1,k2) = hessy(1,k2) + dtapery*dedxk2
     &                             - sk2*(dtaperx*dedyi1+d2taperxy)
                     hessy(2,k2) = hessy(2,k2) + dtapery*dedyk2
     &                             - sk2*(dtapery*dedyi1+d2taperyy)
                     hessy(3,k2) = hessy(3,k2) + dtapery*dedzk2
     &                             - sk2*(dtaperz*dedyi1+d2taperyz)
                     hessz(1,i1) = hessz(1,i1) + dtaperz*dedxi1
     &                             + dtaperx*dedzi1 + d2taperxz
                     hessz(2,i1) = hessz(2,i1) + dtaperz*dedyi1
     &                             + dtapery*dedzi1 + d2taperyz
                     hessz(3,i1) = hessz(3,i1) + dtaperz*dedzi1
     &                             + dtaperz*dedzi1 + d2taperzz
                     hessz(1,k1) = hessz(1,k1) + dtaperz*dedxk1
     &                             - sk1*(dtaperx*dedzi1+d2taperxz)
                     hessz(2,k1) = hessz(2,k1) + dtaperz*dedyk1
     &                             - sk1*(dtapery*dedzi1+d2taperyz)
                     hessz(3,k1) = hessz(3,k1) + dtaperz*dedzk1
     &                             - sk1*(dtaperz*dedzi1+d2taperzz)
                     hessz(1,k2) = hessz(1,k2) + dtaperz*dedxk2
     &                             - sk2*(dtaperx*dedzi1+d2taperxz)
                     hessz(2,k2) = hessz(2,k2) + dtaperz*dedyk2
     &                             - sk2*(dtapery*dedzi1+d2taperyz)
                     hessz(3,k2) = hessz(3,k2) + dtaperz*dedzk2
     &                             - sk2*(dtaperz*dedzi1+d2taperzz)
                  end if
               end if
            end if
         end do
   10    continue
      end do
c
c     see if the atom of interest is part of a dipole
c
      do k = 1, ndipole
         k1 = idpl(1,k)
         k2 = idpl(2,k)
         if (k1.ne.i .and. k2.ne.i)  goto 20
         do ii = 1, n12(k1)
            omit(i12(ii,k1)) = k
         end do
         do ii = 1, n12(k2)
            omit(i12(ii,k2)) = k
         end do
         sk1 = 1.0d0 - sdpl(k)
         sk2 = sdpl(k)
         xk = x(k1) - x(k2)
         yk = y(k1) - y(k2)
         zk = z(k1) - z(k2)
         rk2 = xk*xk + yk*yk + zk*zk
         xq = x(k1) - xk*sk2
         yq = y(k1) - yk*sk2
         zq = z(k1) - zk*sk2
         fk = -f * bdpl(k)
c
c     decide whether to compute the current interaction
c
         do ii = 1, nion
            i1 = iion(ii)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i1,k1,k2,0,0,0)
            if (proceed)  proceed = (omit(i1) .ne. k)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = x(i1) - xq
               yr = y(i1) - yq
               zr = z(i1) - zq
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  rkr3 = sqrt(rk2*r2) * r2
                  dotk = xk*xr + yk*yr + zk*zr
                  fik = fk * pchg(i1)
c
c     scale the interaction based on its group membership
c
                  if (use_group)  fik = fik * fgrp
c
c     some abbreviations used in various chain rule terms
c
                  xrr2 = xr / r2
                  yrr2 = yr / r2
                  zrr2 = zr / r2
                  xkrk2 = xk / rk2
                  ykrk2 = yk / rk2
                  zkrk2 = zk / rk2
                  dotk2 = 2.0d0 * dotk
                  dotkr2 = dotk / r2
                  dotkrk2 = dotk / rk2
c
c     form the chain rule terms for first derivatives
c
                  term = fik / rkr3
                  term2 = -3.0d0 * dotk
                  termx = term * (xk+xrr2*term2)
                  termy = term * (yk+yrr2*term2)
                  termz = term * (zk+zrr2*term2)
                  termxk = term * (xr-dotk*xkrk2)
                  termyk = term * (yr-dotk*ykrk2)
                  termzk = term * (zr-dotk*zkrk2)
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     e = fik * dotk / rkr3
                     dedxi1 = termx
                     dedyi1 = termy
                     dedzi1 = termz
                     dedxk1 = -sk1*termx + termxk
                     dedyk1 = -sk1*termy + termyk
                     dedzk1 = -sk1*termz + termzk
                     dedxk2 = -sk2*termx - termxk
                     dedyk2 = -sk2*termy - termyk
                     dedzk2 = -sk2*termz - termzk
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2
     &                            + 6.0d0*c3*r + 2.0d0*c2
                     dtaper = dtaper / r
                     dtaperx = xr * dtaper
                     dtapery = yr * dtaper
                     dtaperz = zr * dtaper
                     d2taper = e * (d2taper-dtaper)
                     dtaper = e * dtaper
                     d2taperxx = xr*xrr2*d2taper + dtaper
                     d2taperxy = xr*yrr2*d2taper
                     d2taperxz = xr*zrr2*d2taper
                     d2taperyy = yr*yrr2*d2taper + dtaper
                     d2taperyz = yr*zrr2*d2taper
                     d2taperzz = zr*zrr2*d2taper + dtaper
                     term = term * taper
                     termx = termx * taper
                     termy = termy * taper
                     termz = termz * taper
                     termxk = termxk * taper
                     termyk = termyk * taper
                     termzk = termzk * taper
                  end if
c
c     chain rule terms for second derivative components
c
                  if (k1 .eq. i) then
                     dtdxk1 = 3.0d0*sk1*xrr2 - xkrk2
                     part = sk1*xk - xr
                     part2 = sk1*dotk2*xrr2 - part
                     factor = 1.0d0 - 3.0d0*xrr2*part2
     &                           + 3.0d0*sk1*dotkr2
                     factork = -sk1 + dotk2*xkrk2*xkrk2
     &                            + xkrk2*part - dotkrk2
                     dtxdxk1 = dtdxk1*termx + term*factor
                     dtxkdxk1 = dtdxk1*termxk + term*factork
                     factor = -3.0d0 * yrr2 * part2
                     factork = dotk2*ykrk2*xkrk2 + ykrk2*part
                     dtydxk1 = dtdxk1*termy + term*factor
                     dtykdxk1 = dtdxk1*termyk + term*factork
                     factor = -3.0d0 * zrr2 * part2
                     factork = dotk2*zkrk2*xkrk2 + zkrk2*part
                     dtzdxk1 = dtdxk1*termz + term*factor
                     dtzkdxk1 = dtdxk1*termzk + term*factork
                     dtdyk1 = 3.0d0*sk1*yrr2 - ykrk2
                     part = sk1*yk - yr
                     part2 = sk1*dotk2*yrr2 - part
                     factor = -3.0d0 * xrr2 * part2
                     factork = dotk2*xkrk2*ykrk2 + xkrk2*part
                     dtxdyk1 = dtdyk1*termx + term*factor
                     dtxkdyk1 = dtdyk1*termxk + term*factork
                     factor = 1.0d0 - 3.0d0*yrr2*part2
     &                           + 3.0d0*sk1*dotkr2
                     factork = -sk1 + dotk2*ykrk2*ykrk2
     &                            + ykrk2*part - dotkrk2
                     dtydyk1 = dtdyk1*termy + term*factor
                     dtykdyk1 = dtdyk1*termyk + term*factork
                     factor = -3.0d0 * zrr2 * part2
                     factork = dotk2*zkrk2*ykrk2 + zkrk2*part
                     dtzdyk1 = dtdyk1*termz + term*factor
                     dtzkdyk1 = dtdyk1*termzk + term*factork
                     dtdzk1 = 3.0d0*sk1*zrr2 - zkrk2
                     part = sk1*zk - zr
                     part2 = sk1*dotk2*zrr2 - part
                     factor = -3.0d0 * xrr2 * part2
                     factork = dotk2*xkrk2*zkrk2 + xkrk2*part
                     dtxdzk1 = dtdzk1*termx + term*factor
                     dtxkdzk1 = dtdzk1*termxk + term*factork
                     factor = -3.0d0 * yrr2 * part2
                     factork = dotk2*ykrk2*zkrk2 + ykrk2*part
                     dtydzk1 = dtdzk1*termy + term*factor
                     dtykdzk1 = dtdzk1*termyk + term*factork
                     factor = 1.0d0 - 3.0d0*zrr2*part2
     &                           + 3.0d0*sk1*dotkr2
                     factork = -sk1 + dotk2*zkrk2*zkrk2
     &                            + zkrk2*part - dotkrk2
                     dtzdzk1 = dtdzk1*termz + term*factor
                     dtzkdzk1 = dtdzk1*termzk + term*factork
                  else if (k2 .eq. i) then
                     dtdxk2 = 3.0d0*sk2*xrr2 + xkrk2
                     part = sk2*xk + xr
                     part2 = sk2*dotk2*xrr2 - part
                     factor = -1.0d0 - 3.0d0*xrr2*part2
     &                           + 3.0d0*sk2*dotkr2
                     factork = -sk2 - dotk2*xkrk2*xkrk2
     &                            + xkrk2*part + dotkrk2
                     dtxdxk2 = dtdxk2*termx + term*factor
                     dtxkdxk2 = dtdxk2*termxk + term*factork
                     factor = -3.0d0 * yrr2 * part2
                     factork = -dotk2*ykrk2*xkrk2 + ykrk2*part
                     dtydxk2 = dtdxk2*termy + term*factor
                     dtykdxk2 = dtdxk2*termyk + term*factork
                     factor = -3.0d0 * zrr2 * part2
                     factork = -dotk2*zkrk2*xkrk2 + zkrk2*part
                     dtzdxk2 = dtdxk2*termz + term*factor
                     dtzkdxk2 = dtdxk2*termzk + term*factork
                     dtdyk2 = 3.0d0*sk2*yrr2 + ykrk2
                     part = sk2*yk + yr
                     part2 = sk2*dotk2*yrr2 - part
                     factor = -3.0d0 * xrr2 * part2
                     factork = -dotk2*xkrk2*ykrk2 + xkrk2*part
                     dtxdyk2 = dtdyk2*termx + term*factor
                     dtxkdyk2 = dtdyk2*termxk + term*factork
                     factor = -1.0d0 - 3.0d0*yrr2*part2
     &                           + 3.0d0*sk2*dotkr2
                     factork = -sk2 - dotk2*ykrk2*ykrk2
     &                            + ykrk2*part + dotkrk2
                     dtydyk2 = dtdyk2*termy + term*factor
                     dtykdyk2 = dtdyk2*termyk + term*factork
                     factor = -3.0d0 * zrr2 * part2
                     factork = -dotk2*zkrk2*ykrk2 + zkrk2*part
                     dtzdyk2 = dtdyk2*termz + term*factor
                     dtzkdyk2 = dtdyk2*termzk + term*factork
                     dtdzk2 = 3.0d0*sk2*zrr2 + zkrk2
                     part = sk2*zk + zr
                     part2 = sk2*dotk2*zrr2 - part
                     factor = -3.0d0 * xrr2 * part2
                     factork = -dotk2*xkrk2*zkrk2 + xkrk2*part
                     dtxdzk2 = dtdzk2*termx + term*factor
                     dtxkdzk2 = dtdzk2*termxk + term*factork
                     factor = -3.0d0 * yrr2 * part2
                     factork = -dotk2*ykrk2*zkrk2 + ykrk2*part
                     dtydzk2 = dtdzk2*termy + term*factor
                     dtykdzk2 = dtdzk2*termyk + term*factork
                     factor = -1.0d0 - 3.0d0*zrr2*part2
     &                           + 3.0d0*sk2*dotkr2
                     factork = -sk2 - dotk2*zkrk2*zkrk2
     &                            + zkrk2*part + dotkrk2
                     dtzdzk2 = dtdzk2*termz + term*factor
                     dtzkdzk2 = dtdzk2*termzk + term*factork
                  end if
c
c     increment diagonal and off-diagonal Hessian elements
c
                  if (i .eq. k1) then
                     hessx(1,i1) = hessx(1,i1) + dtxdxk1
                     hessx(2,i1) = hessx(2,i1) + dtydxk1
                     hessx(3,i1) = hessx(3,i1) + dtzdxk1
                     hessx(1,k1) = hessx(1,k1) - sk1*dtxdxk1 + dtxkdxk1
                     hessx(2,k1) = hessx(2,k1) - sk1*dtydxk1 + dtykdxk1
                     hessx(3,k1) = hessx(3,k1) - sk1*dtzdxk1 + dtzkdxk1
                     hessx(1,k2) = hessx(1,k2) - sk2*dtxdxk1 - dtxkdxk1
                     hessx(2,k2) = hessx(2,k2) - sk2*dtydxk1 - dtykdxk1
                     hessx(3,k2) = hessx(3,k2) - sk2*dtzdxk1 - dtzkdxk1
                     hessy(1,i1) = hessy(1,i1) + dtxdyk1
                     hessy(2,i1) = hessy(2,i1) + dtydyk1
                     hessy(3,i1) = hessy(3,i1) + dtzdyk1
                     hessy(1,k1) = hessy(1,k1) - sk1*dtxdyk1 + dtxkdyk1
                     hessy(2,k1) = hessy(2,k1) - sk1*dtydyk1 + dtykdyk1
                     hessy(3,k1) = hessy(3,k1) - sk1*dtzdyk1 + dtzkdyk1
                     hessy(1,k2) = hessy(1,k2) - sk2*dtxdyk1 - dtxkdyk1
                     hessy(2,k2) = hessy(2,k2) - sk2*dtydyk1 - dtykdyk1
                     hessy(3,k2) = hessy(3,k2) - sk2*dtzdyk1 - dtzkdyk1
                     hessz(1,i1) = hessz(1,i1) + dtxdzk1
                     hessz(2,i1) = hessz(2,i1) + dtydzk1
                     hessz(3,i1) = hessz(3,i1) + dtzdzk1
                     hessz(1,k1) = hessz(1,k1) - sk1*dtxdzk1 + dtxkdzk1
                     hessz(2,k1) = hessz(2,k1) - sk1*dtydzk1 + dtykdzk1
                     hessz(3,k1) = hessz(3,k1) - sk1*dtzdzk1 + dtzkdzk1
                     hessz(1,k2) = hessz(1,k2) - sk2*dtxdzk1 - dtxkdzk1
                     hessz(2,k2) = hessz(2,k2) - sk2*dtydzk1 - dtykdzk1
                     hessz(3,k2) = hessz(3,k2) - sk2*dtzdzk1 - dtzkdzk1
                  else if (i .eq. k2) then
                     hessx(1,i1) = hessx(1,i1) + dtxdxk2
                     hessx(2,i1) = hessx(2,i1) + dtydxk2
                     hessx(3,i1) = hessx(3,i1) + dtzdxk2
                     hessx(1,k1) = hessx(1,k1) - sk1*dtxdxk2 + dtxkdxk2
                     hessx(2,k1) = hessx(2,k1) - sk1*dtydxk2 + dtykdxk2
                     hessx(3,k1) = hessx(3,k1) - sk1*dtzdxk2 + dtzkdxk2
                     hessx(1,k2) = hessx(1,k2) - sk2*dtxdxk2 - dtxkdxk2
                     hessx(2,k2) = hessx(2,k2) - sk2*dtydxk2 - dtykdxk2
                     hessx(3,k2) = hessx(3,k2) - sk2*dtzdxk2 - dtzkdxk2
                     hessy(1,i1) = hessy(1,i1) + dtxdyk2
                     hessy(2,i1) = hessy(2,i1) + dtydyk2
                     hessy(3,i1) = hessy(3,i1) + dtzdyk2
                     hessy(1,k1) = hessy(1,k1) - sk1*dtxdyk2 + dtxkdyk2
                     hessy(2,k1) = hessy(2,k1) - sk1*dtydyk2 + dtykdyk2
                     hessy(3,k1) = hessy(3,k1) - sk1*dtzdyk2 + dtzkdyk2
                     hessy(1,k2) = hessy(1,k2) - sk2*dtxdyk2 - dtxkdyk2
                     hessy(2,k2) = hessy(2,k2) - sk2*dtydyk2 - dtykdyk2
                     hessy(3,k2) = hessy(3,k2) - sk2*dtzdyk2 - dtzkdyk2
                     hessz(1,i1) = hessz(1,i1) + dtxdzk2
                     hessz(2,i1) = hessz(2,i1) + dtydzk2
                     hessz(3,i1) = hessz(3,i1) + dtzdzk2
                     hessz(1,k1) = hessz(1,k1) - sk1*dtxdzk2 + dtxkdzk2
                     hessz(2,k1) = hessz(2,k1) - sk1*dtydzk2 + dtykdzk2
                     hessz(3,k1) = hessz(3,k1) - sk1*dtzdzk2 + dtzkdzk2
                     hessz(1,k2) = hessz(1,k2) - sk2*dtxdzk2 - dtxkdzk2
                     hessz(2,k2) = hessz(2,k2) - sk2*dtydzk2 - dtykdzk2
                     hessz(3,k2) = hessz(3,k2) - sk2*dtzdzk2 - dtzkdzk2
                  end if
c
c     more energy switching if near the cutoff distance
c
                  if (r2.gt.cut2 .and. i.eq.k1) then
                     hessx(1,i1) = hessx(1,i1) - sk1*dtaperx*dedxi1
     &                      + dtaperx*dedxk1 - sk1*d2taperxx
                     hessx(2,i1) = hessx(2,i1) - sk1*dtaperx*dedyi1
     &                      + dtapery*dedxk1 - sk1*d2taperxy
                     hessx(3,i1) = hessx(3,i1) - sk1*dtaperx*dedzi1
     &                      + dtaperz*dedxk1 - sk1*d2taperxz
                     hessx(1,k1) = hessx(1,k1) - sk1*dtaperx*dedxk1
     &                      - sk1*dtaperx*dedxk1 + sk1*sk1*d2taperxx
                     hessx(2,k1) = hessx(2,k1) - sk1*dtaperx*dedyk1
     &                      - sk1*dtapery*dedxk1 + sk1*sk1*d2taperxy
                     hessx(3,k1) = hessx(3,k1) - sk1*dtaperx*dedzk1
     &                      - sk1*dtaperz*dedxk1 + sk1*sk1*d2taperxz
                     hessx(1,k2) = hessx(1,k2) - sk1*dtaperx*dedxk2
     &                      - sk2*dtaperx*dedxk1 + sk1*sk2*d2taperxx
                     hessx(2,k2) = hessx(2,k2) - sk1*dtaperx*dedyk2
     &                      - sk2*dtapery*dedxk1 + sk1*sk2*d2taperxy
                     hessx(3,k2) = hessx(3,k2) - sk1*dtaperx*dedzk2
     &                      - sk2*dtaperz*dedxk1 + sk1*sk2*d2taperxz
                     hessy(1,i1) = hessy(1,i1) - sk1*dtapery*dedxi1
     &                      + dtaperx*dedyk1 - sk1*d2taperxy
                     hessy(2,i1) = hessy(2,i1) - sk1*dtapery*dedyi1
     &                      + dtapery*dedyk1 - sk1*d2taperyy
                     hessy(3,i1) = hessy(3,i1) - sk1*dtapery*dedzi1
     &                      + dtaperz*dedyk1 - sk1*d2taperyz
                     hessy(1,k1) = hessy(1,k1) - sk1*dtapery*dedxk1
     &                      - sk1*dtaperx*dedyk1 + sk1*sk1*d2taperxy
                     hessy(2,k1) = hessy(2,k1) - sk1*dtapery*dedyk1
     &                      - sk1*dtapery*dedyk1 + sk1*sk1*d2taperyy
                     hessy(3,k1) = hessy(3,k1) - sk1*dtapery*dedzk1
     &                      - sk1*dtaperz*dedyk1 + sk1*sk1*d2taperyz
                     hessy(1,k2) = hessy(1,k2) - sk1*dtapery*dedxk2
     &                      - sk2*dtaperx*dedyk1 + sk1*sk2*d2taperxy
                     hessy(2,k2) = hessy(2,k2) - sk1*dtapery*dedyk2
     &                      - sk2*dtapery*dedyk1 + sk1*sk2*d2taperyy
                     hessy(3,k2) = hessy(3,k2) - sk1*dtapery*dedzk2
     &                      - sk2*dtaperz*dedyk1 + sk1*sk2*d2taperyz
                     hessz(1,i1) = hessz(1,i1) - sk1*dtaperz*dedxi1
     &                      + dtaperx*dedzk1 - sk1*d2taperxz
                     hessz(2,i1) = hessz(2,i1) - sk1*dtaperz*dedyi1
     &                      + dtapery*dedzk1 - sk1*d2taperyz
                     hessz(3,i1) = hessz(3,i1) - sk1*dtaperz*dedzi1
     &                      + dtaperz*dedzk1 - sk1*d2taperzz
                     hessz(1,k1) = hessz(1,k1) - sk1*dtaperz*dedxk1
     &                      - sk1*dtaperx*dedzk1 + sk1*sk1*d2taperxz
                     hessz(2,k1) = hessz(2,k1) - sk1*dtaperz*dedyk1
     &                      - sk1*dtapery*dedzk1 + sk1*sk1*d2taperyz
                     hessz(3,k1) = hessz(3,k1) - sk1*dtaperz*dedzk1
     &                      - sk1*dtaperz*dedzk1 + sk1*sk1*d2taperzz
                     hessz(1,k2) = hessz(1,k2) - sk1*dtaperz*dedxk2
     &                      - sk2*dtaperx*dedzk1 + sk1*sk2*d2taperxz
                     hessz(2,k2) = hessz(2,k2) - sk1*dtaperz*dedyk2
     &                      - sk2*dtapery*dedzk1 + sk1*sk2*d2taperyz
                     hessz(3,k2) = hessz(3,k2) - sk1*dtaperz*dedzk2
     &                      - sk2*dtaperz*dedzk1 + sk1*sk2*d2taperzz
                  else if (r2.gt.cut2 .and. i.eq.k2) then
                     hessx(1,i1) = hessx(1,i1) - sk2*dtaperx*dedxi1
     &                      + dtaperx*dedxk2 - sk2*d2taperxx
                     hessx(2,i1) = hessx(2,i1) - sk2*dtaperx*dedyi1
     &                      + dtapery*dedxk2 - sk2*d2taperxy
                     hessx(3,i1) = hessx(3,i1) - sk2*dtaperx*dedzi1
     &                      + dtaperz*dedxk2 - sk2*d2taperxz
                     hessx(1,k1) = hessx(1,k1) - sk2*dtaperx*dedxk1
     &                      - sk1*dtaperx*dedxk2 + sk1*sk2*d2taperxx
                     hessx(2,k1) = hessx(2,k1) - sk2*dtaperx*dedyk1
     &                      - sk1*dtapery*dedxk2 + sk1*sk2*d2taperxy
                     hessx(3,k1) = hessx(3,k1) - sk2*dtaperx*dedzk1
     &                      - sk1*dtaperz*dedxk2 + sk1*sk2*d2taperxz
                     hessx(1,k2) = hessx(1,k2) - sk2*dtaperx*dedxk2
     &                      - sk2*dtaperx*dedxk2 + sk2*sk2*d2taperxx
                     hessx(2,k2) = hessx(2,k2) - sk2*dtaperx*dedyk2
     &                      - sk2*dtapery*dedxk2 + sk2*sk2*d2taperxy
                     hessx(3,k2) = hessx(3,k2) - sk2*dtaperx*dedzk2
     &                      - sk2*dtaperz*dedxk2 + sk2*sk2*d2taperxz
                     hessy(1,i1) = hessy(1,i1) - sk2*dtapery*dedxi1
     &                      + dtaperx*dedyk2 - sk2*d2taperxy
                     hessy(2,i1) = hessy(2,i1) - sk2*dtapery*dedyi1
     &                      + dtapery*dedyk2 - sk2*d2taperyy
                     hessy(3,i1) = hessy(3,i1) - sk2*dtapery*dedzi1
     &                      + dtaperz*dedyk2 - sk2*d2taperyz
                     hessy(1,k1) = hessy(1,k1) - sk2*dtapery*dedxk1
     &                      - sk1*dtaperx*dedyk2 + sk1*sk2*d2taperxy
                     hessy(2,k1) = hessy(2,k1) - sk2*dtapery*dedyk1
     &                      - sk1*dtapery*dedyk2 + sk1*sk2*d2taperyy
                     hessy(3,k1) = hessy(3,k1) - sk2*dtapery*dedzk1
     &                      - sk1*dtaperz*dedyk2 + sk1*sk2*d2taperyz
                     hessy(1,k2) = hessy(1,k2) - sk2*dtapery*dedxk2
     &                      - sk2*dtaperx*dedyk2 + sk2*sk2*d2taperxy
                     hessy(2,k2) = hessy(2,k2) - sk2*dtapery*dedyk2
     &                      - sk2*dtapery*dedyk2 + sk2*sk2*d2taperyy
                     hessy(3,k2) = hessy(3,k2) - sk2*dtapery*dedzk2
     &                      - sk2*dtaperz*dedyk2 + sk2*sk2*d2taperyz
                     hessz(1,i1) = hessz(1,i1) - sk2*dtaperz*dedxi1
     &                      + dtaperx*dedzk2 - sk2*d2taperxz
                     hessz(2,i1) = hessz(2,i1) - sk2*dtaperz*dedyi1
     &                      + dtapery*dedzk2 - sk2*d2taperyz
                     hessz(3,i1) = hessz(3,i1) - sk2*dtaperz*dedzi1
     &                      + dtaperz*dedzk2 - sk2*d2taperzz
                     hessz(1,k1) = hessz(1,k1) - sk2*dtaperz*dedxk1
     &                      - sk1*dtaperx*dedzk2 + sk1*sk2*d2taperxz
                     hessz(2,k1) = hessz(2,k1) - sk2*dtaperz*dedyk1
     &                      - sk1*dtapery*dedzk2 + sk1*sk2*d2taperyz
                     hessz(3,k1) = hessz(3,k1) - sk2*dtaperz*dedzk1
     &                      - sk1*dtaperz*dedzk2 + sk1*sk2*d2taperzz
                     hessz(1,k2) = hessz(1,k2) - sk2*dtaperz*dedxk2
     &                      - sk2*dtaperx*dedzk2 + sk2*sk2*d2taperxz
                     hessz(2,k2) = hessz(2,k2) - sk2*dtaperz*dedyk2
     &                      - sk2*dtapery*dedzk2 + sk2*sk2*d2taperyz
                     hessz(3,k2) = hessz(3,k2) - sk2*dtaperz*dedzk2
     &                      - sk2*dtaperz*dedzk2 + sk2*sk2*d2taperzz
                  end if
               end if
            end if
         end do
   20    continue
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nion
         i1 = iion(ii)
         if (i1 .ne. i)  goto 30
         skip(i1) = i1
         do k = 1, n12(i1)
            skip(i12(k,i1)) = i1
         end do
         xi = x(i1)
         yi = y(i1)
         zi = z(i1)
         fi = f * pchg(i1)
c
c     decide whether to compute the current interaction
c
         do k = 1, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i1,k1,k2,0,0,0)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               sk1 = 1.0d0 - sdpl(k)
               sk2 = sdpl(k)
               do jcell = 2, ncell
                  xk = x(k1) - x(k2)
                  yk = y(k1) - y(k2)
                  zk = z(k1) - z(k2)
                  xr = xi - x(k1) + xk*sk2
                  yr = yi - y(k1) + yk*sk2
                  zr = zi - z(k1) + zk*sk2
                  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     rk2 = xk*xk + yk*yk + zk*zk
                     rkr3 = sqrt(rk2*r2) * r2
                     dotk = xk*xr + yk*yr + zk*zr
                     fik = -fi * bdpl(k)
                     if (use_polymer) then
                        if (r2 .lt. polycut2) then
                           if (skip(k1).eq.i1 .or. skip(k2).ne.i1)
     &                        fik = 0.0d0
                        end if
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  fik = fik * fgrp
c
c     some abbreviations used in various chain rule terms
c
                     xrr2 = xr / r2
                     yrr2 = yr / r2
                     zrr2 = zr / r2
                     xkrk2 = xk / rk2
                     ykrk2 = yk / rk2
                     zkrk2 = zk / rk2
                     dotk2 = 2.0d0 * dotk
                     dotkr2 = dotk / r2
c
c     form the chain rule terms for first derivatives
c
                     term = fik / rkr3
                     term2 = -3.0d0 * dotk
                     termx = term * (xk+xrr2*term2)
                     termy = term * (yk+yrr2*term2)
                     termz = term * (zk+zrr2*term2)
                     termxk = term * (xr-dotk*xkrk2)
                     termyk = term * (yr-dotk*ykrk2)
                     termzk = term * (zr-dotk*zkrk2)
c
c     use energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        e = fik * dotk / rkr3
                        dedxi1 = termx
                        dedyi1 = termy
                        dedzi1 = termz
                        dedxk1 = -sk1*termx + termxk
                        dedyk1 = -sk1*termy + termyk
                        dedzk1 = -sk1*termz + termzk
                        dedxk2 = -sk2*termx - termxk
                        dedyk2 = -sk2*termy - termyk
                        dedzk2 = -sk2*termz - termzk
                        r = sqrt(r2)
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                              + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                        d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2
     &                               + 6.0d0*c3*r + 2.0d0*c2
                        dtaper = dtaper / r
                        dtaperx = xr * dtaper
                        dtapery = yr * dtaper
                        dtaperz = zr * dtaper
                        d2taper = e * (d2taper-dtaper)
                        dtaper = e * dtaper
                        d2taperxx = xr*xrr2*d2taper + dtaper
                        d2taperxy = xr*yrr2*d2taper
                        d2taperxz = xr*zrr2*d2taper
                        d2taperyy = yr*yrr2*d2taper + dtaper
                        d2taperyz = yr*zrr2*d2taper
                        d2taperzz = zr*zrr2*d2taper + dtaper
                        term = term * taper
                        termx = termx * taper
                        termy = termy * taper
                        termz = termz * taper
                        termxk = termxk * taper
                        termyk = termyk * taper
                        termzk = termzk * taper
                     end if
c
c     chain rule terms for second derivative components
c
                     dtdxi1 = -3.0d0 * xrr2
                     part = xk - dotk2*xrr2
                     factor = -3.0d0 * (dotkr2 + xrr2*part)
                     factork = 1.0d0 - xk*xkrk2
                     dtxdxi1 = dtdxi1*termx + term*factor
                     dtxkdxi1 = dtdxi1*termxk + term*factork
                     factor = -3.0d0 * yrr2 * part
                     factork = -yk * xkrk2
                     dtydxi1 = dtdxi1*termy + term*factor
                     dtykdxi1 = dtdxi1*termyk + term*factork
                     factor = -3.0d0 * zrr2 * part
                     factork = -zk * xkrk2
                     dtzdxi1 = dtdxi1*termz + term*factor
                     dtzkdxi1 = dtdxi1*termzk + term*factork
                     dtdyi1 = -3.0d0 * yrr2
                     part = yk - dotk2*yrr2
                     factor = -3.0d0 * xrr2 * part
                     factork = -xk * ykrk2
                     dtxdyi1 = dtdyi1*termx + term*factor
                     dtxkdyi1 = dtdyi1*termxk + term*factork
                     factor = -3.0d0 * (dotkr2 + yrr2*part)
                     factork = 1.0d0 - yk*ykrk2
                     dtydyi1 = dtdyi1*termy + term*factor
                     dtykdyi1 = dtdyi1*termyk + term*factork
                     factor = -3.0d0 * zrr2 * part
                     factork = -zk * ykrk2
                     dtzdyi1 = dtdyi1*termz + term*factor
                     dtzkdyi1 = dtdyi1*termzk + term*factork
                     dtdzi1 = -3.0d0 * zrr2
                     part = zk - dotk2*zrr2
                     factor = -3.0d0 * xrr2 * part
                     factork = -xk * zkrk2
                     dtxdzi1 = dtdzi1*termx + term*factor
                     dtxkdzi1 = dtdzi1*termxk + term*factork
                     factor = -3.0d0 * yrr2 * part
                     factork = -yk * zkrk2
                     dtydzi1 = dtdzi1*termy + term*factor
                     dtykdzi1 = dtdzi1*termyk + term*factork
                     factor = -3.0d0 * (dotkr2 + zrr2*part)
                     factork = 1.0d0 - zk*zkrk2
                     dtzdzi1 = dtdzi1*termz + term*factor
                     dtzkdzi1 = dtdzi1*termzk + term*factork
c
c     increment diagonal and off-diagonal Hessian elements
c
                     hessx(1,i1) = hessx(1,i1) + dtxdxi1
                     hessx(2,i1) = hessx(2,i1) + dtydxi1
                     hessx(3,i1) = hessx(3,i1) + dtzdxi1
                     hessx(1,k1) = hessx(1,k1) - sk1*dtxdxi1 + dtxkdxi1
                     hessx(2,k1) = hessx(2,k1) - sk1*dtydxi1 + dtykdxi1
                     hessx(3,k1) = hessx(3,k1) - sk1*dtzdxi1 + dtzkdxi1
                     hessx(1,k2) = hessx(1,k2) - sk2*dtxdxi1 - dtxkdxi1
                     hessx(2,k2) = hessx(2,k2) - sk2*dtydxi1 - dtykdxi1
                     hessx(3,k2) = hessx(3,k2) - sk2*dtzdxi1 - dtzkdxi1
                     hessy(1,i1) = hessy(1,i1) + dtxdyi1
                     hessy(2,i1) = hessy(2,i1) + dtydyi1
                     hessy(3,i1) = hessy(3,i1) + dtzdyi1
                     hessy(1,k1) = hessy(1,k1) - sk1*dtxdyi1 + dtxkdyi1
                     hessy(2,k1) = hessy(2,k1) - sk1*dtydyi1 + dtykdyi1
                     hessy(3,k1) = hessy(3,k1) - sk1*dtzdyi1 + dtzkdyi1
                     hessy(1,k2) = hessy(1,k2) - sk2*dtxdyi1 - dtxkdyi1
                     hessy(2,k2) = hessy(2,k2) - sk2*dtydyi1 - dtykdyi1
                     hessy(3,k2) = hessy(3,k2) - sk2*dtzdyi1 - dtzkdyi1
                     hessz(1,i1) = hessz(1,i1) + dtxdzi1
                     hessz(2,i1) = hessz(2,i1) + dtydzi1
                     hessz(3,i1) = hessz(3,i1) + dtzdzi1
                     hessz(1,k1) = hessz(1,k1) - sk1*dtxdzi1 + dtxkdzi1
                     hessz(2,k1) = hessz(2,k1) - sk1*dtydzi1 + dtykdzi1
                     hessz(3,k1) = hessz(3,k1) - sk1*dtzdzi1 + dtzkdzi1
                     hessz(1,k2) = hessz(1,k2) - sk2*dtxdzi1 - dtxkdzi1
                     hessz(2,k2) = hessz(2,k2) - sk2*dtydzi1 - dtykdzi1
                     hessz(3,k2) = hessz(3,k2) - sk2*dtzdzi1 - dtzkdzi1
c
c     more energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        hessx(1,i1) = hessx(1,i1) + dtaperx*dedxi1
     &                                + dtaperx*dedxi1 + d2taperxx
                        hessx(2,i1) = hessx(2,i1) + dtaperx*dedyi1
     &                                + dtapery*dedxi1 + d2taperxy
                        hessx(3,i1) = hessx(3,i1) + dtaperx*dedzi1
     &                                + dtaperz*dedxi1 + d2taperxz
                        hessx(1,k1) = hessx(1,k1) + dtaperx*dedxk1
     &                                - sk1*(dtaperx*dedxi1+d2taperxx)
                        hessx(2,k1) = hessx(2,k1) + dtaperx*dedyk1
     &                                - sk1*(dtapery*dedxi1+d2taperxy)
                        hessx(3,k1) = hessx(3,k1) + dtaperx*dedzk1
     &                                - sk1*(dtaperz*dedxi1+d2taperxz)
                        hessx(1,k2) = hessx(1,k2) + dtaperx*dedxk2
     &                                - sk2*(dtaperx*dedxi1+d2taperxx)
                        hessx(2,k2) = hessx(2,k2) + dtaperx*dedyk2
     &                                - sk2*(dtapery*dedxi1+d2taperxy)
                        hessx(3,k2) = hessx(3,k2) + dtaperx*dedzk2
     &                                - sk2*(dtaperz*dedxi1+d2taperxz)
                        hessy(1,i1) = hessy(1,i1) + dtapery*dedxi1
     &                                + dtaperx*dedyi1 + d2taperxy
                        hessy(2,i1) = hessy(2,i1) + dtapery*dedyi1
     &                                + dtapery*dedyi1 + d2taperyy
                        hessy(3,i1) = hessy(3,i1) + dtapery*dedzi1
     &                                + dtaperz*dedyi1 + d2taperyz
                        hessy(1,k1) = hessy(1,k1) + dtapery*dedxk1
     &                                - sk1*(dtaperx*dedyi1+d2taperxy)
                        hessy(2,k1) = hessy(2,k1) + dtapery*dedyk1
     &                                - sk1*(dtapery*dedyi1+d2taperyy)
                        hessy(3,k1) = hessy(3,k1) + dtapery*dedzk1
     &                                - sk1*(dtaperz*dedyi1+d2taperyz)
                        hessy(1,k2) = hessy(1,k2) + dtapery*dedxk2
     &                                - sk2*(dtaperx*dedyi1+d2taperxy)
                        hessy(2,k2) = hessy(2,k2) + dtapery*dedyk2
     &                                - sk2*(dtapery*dedyi1+d2taperyy)
                        hessy(3,k2) = hessy(3,k2) + dtapery*dedzk2
     &                                - sk2*(dtaperz*dedyi1+d2taperyz)
                        hessz(1,i1) = hessz(1,i1) + dtaperz*dedxi1
     &                                + dtaperx*dedzi1 + d2taperxz
                        hessz(2,i1) = hessz(2,i1) + dtaperz*dedyi1
     &                                + dtapery*dedzi1 + d2taperyz
                        hessz(3,i1) = hessz(3,i1) + dtaperz*dedzi1
     &                                + dtaperz*dedzi1 + d2taperzz
                        hessz(1,k1) = hessz(1,k1) + dtaperz*dedxk1
     &                                - sk1*(dtaperx*dedzi1+d2taperxz)
                        hessz(2,k1) = hessz(2,k1) + dtaperz*dedyk1
     &                                - sk1*(dtapery*dedzi1+d2taperyz)
                        hessz(3,k1) = hessz(3,k1) + dtaperz*dedzk1
     &                                - sk1*(dtaperz*dedzi1+d2taperzz)
                        hessz(1,k2) = hessz(1,k2) + dtaperz*dedxk2
     &                                - sk2*(dtaperx*dedzi1+d2taperxz)
                        hessz(2,k2) = hessz(2,k2) + dtaperz*dedyk2
     &                                - sk2*(dtapery*dedzi1+d2taperyz)
                        hessz(3,k2) = hessz(3,k2) + dtaperz*dedzk2
     &                                - sk2*(dtaperz*dedzi1+d2taperzz)
                     end if
                  end if
               end do
            end if
         end do
   30    continue
      end do
c
c     see if the atom of interest is part of a dipole
c
      do k = 1, ndipole
         k1 = idpl(1,k)
         k2 = idpl(2,k)
         if (k1.ne.i .and. k2.ne.i)  goto 40
         do ii = 1, n12(k1)
            omit(i12(ii,k1)) = k
         end do
         do ii = 1, n12(k2)
            omit(i12(ii,k2)) = k
         end do
         sk1 = 1.0d0 - sdpl(k)
         sk2 = sdpl(k)
         xk = x(k1) - x(k2)
         yk = y(k1) - y(k2)
         zk = z(k1) - z(k2)
         rk2 = xk*xk + yk*yk + zk*zk
         xq = x(k1) - xk*sk2
         yq = y(k1) - yk*sk2
         zq = z(k1) - zk*sk2
         fk = -f * bdpl(k)
c
c     decide whether to compute the current interaction
c
         do ii = 1, nion
            i1 = iion(ii)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i1,k1,k2,0,0,0)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do jcell = 2, ncell
                  xr = x(i1) - xq
                  yr = y(i1) - yq
                  zr = z(i1) - zq
                  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     rkr3 = sqrt(rk2*r2) * r2
                     dotk = xk*xr + yk*yr + zk*zr
                     fik = fk * pchg(i1)
                     if (use_polymer) then
                        if (r2 .lt. polycut2) then
                           if (omit(i1) .ne. k)  fik = 0.0d0
                        end if
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  fik = fik * fgrp
c
c     some abbreviations used in various chain rule terms
c
                     xrr2 = xr / r2
                     yrr2 = yr / r2
                     zrr2 = zr / r2
                     xkrk2 = xk / rk2
                     ykrk2 = yk / rk2
                     zkrk2 = zk / rk2
                     dotk2 = 2.0d0 * dotk
                     dotkr2 = dotk / r2
                     dotkrk2 = dotk / rk2
c
c     form the chain rule terms for first derivatives
c
                     term = fik / rkr3
                     term2 = -3.0d0 * dotk
                     termx = term * (xk+xrr2*term2)
                     termy = term * (yk+yrr2*term2)
                     termz = term * (zk+zrr2*term2)
                     termxk = term * (xr-dotk*xkrk2)
                     termyk = term * (yr-dotk*ykrk2)
                     termzk = term * (zr-dotk*zkrk2)
c
c     use energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        e = fik * dotk / rkr3
                        dedxi1 = termx
                        dedyi1 = termy
                        dedzi1 = termz
                        dedxk1 = -sk1*termx + termxk
                        dedyk1 = -sk1*termy + termyk
                        dedzk1 = -sk1*termz + termzk
                        dedxk2 = -sk2*termx - termxk
                        dedyk2 = -sk2*termy - termyk
                        dedzk2 = -sk2*termz - termzk
                        r = sqrt(r2)
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                              + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                        d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2
     &                               + 6.0d0*c3*r + 2.0d0*c2
                        dtaper = dtaper / r
                        dtaperx = xr * dtaper
                        dtapery = yr * dtaper
                        dtaperz = zr * dtaper
                        d2taper = e * (d2taper-dtaper)
                        dtaper = e * dtaper
                        d2taperxx = xr*xrr2*d2taper + dtaper
                        d2taperxy = xr*yrr2*d2taper
                        d2taperxz = xr*zrr2*d2taper
                        d2taperyy = yr*yrr2*d2taper + dtaper
                        d2taperyz = yr*zrr2*d2taper
                        d2taperzz = zr*zrr2*d2taper + dtaper
                        term = term * taper
                        termx = termx * taper
                        termy = termy * taper
                        termz = termz * taper
                        termxk = termxk * taper
                        termyk = termyk * taper
                        termzk = termzk * taper
                     end if
c
c     chain rule terms for second derivative components
c
                     if (k1 .eq. i) then
                        dtdxk1 = 3.0d0*sk1*xrr2 - xkrk2
                        part = sk1*xk - xr
                        part2 = sk1*dotk2*xrr2 - part
                        factor = 1.0d0 - 3.0d0*xrr2*part2
     &                              + 3.0d0*sk1*dotkr2
                        factork = -sk1 + dotk2*xkrk2*xkrk2
     &                               + xkrk2*part - dotkrk2
                        dtxdxk1 = dtdxk1*termx + term*factor
                        dtxkdxk1 = dtdxk1*termxk + term*factork
                        factor = -3.0d0 * yrr2 * part2
                        factork = dotk2*ykrk2*xkrk2 + ykrk2*part
                        dtydxk1 = dtdxk1*termy + term*factor
                        dtykdxk1 = dtdxk1*termyk + term*factork
                        factor = -3.0d0 * zrr2 * part2
                        factork = dotk2*zkrk2*xkrk2 + zkrk2*part
                        dtzdxk1 = dtdxk1*termz + term*factor
                        dtzkdxk1 = dtdxk1*termzk + term*factork
                        dtdyk1 = 3.0d0*sk1*yrr2 - ykrk2
                        part = sk1*yk - yr
                        part2 = sk1*dotk2*yrr2 - part
                        factor = -3.0d0 * xrr2 * part2
                        factork = dotk2*xkrk2*ykrk2 + xkrk2*part
                        dtxdyk1 = dtdyk1*termx + term*factor
                        dtxkdyk1 = dtdyk1*termxk + term*factork
                        factor = 1.0d0 - 3.0d0*yrr2*part2
     &                              + 3.0d0*sk1*dotkr2
                        factork = -sk1 + dotk2*ykrk2*ykrk2
     &                               + ykrk2*part - dotkrk2
                        dtydyk1 = dtdyk1*termy + term*factor
                        dtykdyk1 = dtdyk1*termyk + term*factork
                        factor = -3.0d0 * zrr2 * part2
                        factork = dotk2*zkrk2*ykrk2 + zkrk2*part
                        dtzdyk1 = dtdyk1*termz + term*factor
                        dtzkdyk1 = dtdyk1*termzk + term*factork
                        dtdzk1 = 3.0d0*sk1*zrr2 - zkrk2
                        part = sk1*zk - zr
                        part2 = sk1*dotk2*zrr2 - part
                        factor = -3.0d0 * xrr2 * part2
                        factork = dotk2*xkrk2*zkrk2 + xkrk2*part
                        dtxdzk1 = dtdzk1*termx + term*factor
                        dtxkdzk1 = dtdzk1*termxk + term*factork
                        factor = -3.0d0 * yrr2 * part2
                        factork = dotk2*ykrk2*zkrk2 + ykrk2*part
                        dtydzk1 = dtdzk1*termy + term*factor
                        dtykdzk1 = dtdzk1*termyk + term*factork
                        factor = 1.0d0 - 3.0d0*zrr2*part2
     &                              + 3.0d0*sk1*dotkr2
                        factork = -sk1 + dotk2*zkrk2*zkrk2
     &                               + zkrk2*part - dotkrk2
                        dtzdzk1 = dtdzk1*termz + term*factor
                        dtzkdzk1 = dtdzk1*termzk + term*factork
                     else if (k2 .eq. i) then
                        dtdxk2 = 3.0d0*sk2*xrr2 + xkrk2
                        part = sk2*xk + xr
                        part2 = sk2*dotk2*xrr2 - part
                        factor = -1.0d0 - 3.0d0*xrr2*part2
     &                              + 3.0d0*sk2*dotkr2
                        factork = -sk2 - dotk2*xkrk2*xkrk2
     &                               + xkrk2*part + dotkrk2
                        dtxdxk2 = dtdxk2*termx + term*factor
                        dtxkdxk2 = dtdxk2*termxk + term*factork
                        factor = -3.0d0 * yrr2 * part2
                        factork = -dotk2*ykrk2*xkrk2 + ykrk2*part
                        dtydxk2 = dtdxk2*termy + term*factor
                        dtykdxk2 = dtdxk2*termyk + term*factork
                        factor = -3.0d0 * zrr2 * part2
                        factork = -dotk2*zkrk2*xkrk2 + zkrk2*part
                        dtzdxk2 = dtdxk2*termz + term*factor
                        dtzkdxk2 = dtdxk2*termzk + term*factork
                        dtdyk2 = 3.0d0*sk2*yrr2 + ykrk2
                        part = sk2*yk + yr
                        part2 = sk2*dotk2*yrr2 - part
                        factor = -3.0d0 * xrr2 * part2
                        factork = -dotk2*xkrk2*ykrk2 + xkrk2*part
                        dtxdyk2 = dtdyk2*termx + term*factor
                        dtxkdyk2 = dtdyk2*termxk + term*factork
                        factor = -1.0d0 - 3.0d0*yrr2*part2
     &                              + 3.0d0*sk2*dotkr2
                        factork = -sk2 - dotk2*ykrk2*ykrk2
     &                               + ykrk2*part + dotkrk2
                        dtydyk2 = dtdyk2*termy + term*factor
                        dtykdyk2 = dtdyk2*termyk + term*factork
                        factor = -3.0d0 * zrr2 * part2
                        factork = -dotk2*zkrk2*ykrk2 + zkrk2*part
                        dtzdyk2 = dtdyk2*termz + term*factor
                        dtzkdyk2 = dtdyk2*termzk + term*factork
                        dtdzk2 = 3.0d0*sk2*zrr2 + zkrk2
                        part = sk2*zk + zr
                        part2 = sk2*dotk2*zrr2 - part
                        factor = -3.0d0 * xrr2 * part2
                        factork = -dotk2*xkrk2*zkrk2 + xkrk2*part
                        dtxdzk2 = dtdzk2*termx + term*factor
                        dtxkdzk2 = dtdzk2*termxk + term*factork
                        factor = -3.0d0 * yrr2 * part2
                        factork = -dotk2*ykrk2*zkrk2 + ykrk2*part
                        dtydzk2 = dtdzk2*termy + term*factor
                        dtykdzk2 = dtdzk2*termyk + term*factork
                        factor = -1.0d0 - 3.0d0*zrr2*part2
     &                              + 3.0d0*sk2*dotkr2
                        factork = -sk2 - dotk2*zkrk2*zkrk2
     &                               + zkrk2*part + dotkrk2
                        dtzdzk2 = dtdzk2*termz + term*factor
                        dtzkdzk2 = dtdzk2*termzk + term*factork
                     end if
c
c     increment diagonal and off-diagonal Hessian elements
c
                     if (i .eq. k1) then
                        hessx(1,i1) = hessx(1,i1) + dtxdxk1
                        hessx(2,i1) = hessx(2,i1) + dtydxk1
                        hessx(3,i1) = hessx(3,i1) + dtzdxk1
                        hessx(1,k1) = hessx(1,k1) - sk1*dtxdxk1
     &                                   + dtxkdxk1
                        hessx(2,k1) = hessx(2,k1) - sk1*dtydxk1
     &                                   + dtykdxk1
                        hessx(3,k1) = hessx(3,k1) - sk1*dtzdxk1
     &                                   + dtzkdxk1
                        hessx(1,k2) = hessx(1,k2) - sk2*dtxdxk1
     &                                   - dtxkdxk1
                        hessx(2,k2) = hessx(2,k2) - sk2*dtydxk1
     &                                   - dtykdxk1
                        hessx(3,k2) = hessx(3,k2) - sk2*dtzdxk1
     &                                   - dtzkdxk1
                        hessy(1,i1) = hessy(1,i1) + dtxdyk1
                        hessy(2,i1) = hessy(2,i1) + dtydyk1
                        hessy(3,i1) = hessy(3,i1) + dtzdyk1
                        hessy(1,k1) = hessy(1,k1) - sk1*dtxdyk1
     &                                   + dtxkdyk1
                        hessy(2,k1) = hessy(2,k1) - sk1*dtydyk1
     &                                   + dtykdyk1
                        hessy(3,k1) = hessy(3,k1) - sk1*dtzdyk1
     &                                   + dtzkdyk1
                        hessy(1,k2) = hessy(1,k2) - sk2*dtxdyk1
     &                                   - dtxkdyk1
                        hessy(2,k2) = hessy(2,k2) - sk2*dtydyk1
     &                                   - dtykdyk1
                        hessy(3,k2) = hessy(3,k2) - sk2*dtzdyk1
     &                                   - dtzkdyk1
                        hessz(1,i1) = hessz(1,i1) + dtxdzk1
                        hessz(2,i1) = hessz(2,i1) + dtydzk1
                        hessz(3,i1) = hessz(3,i1) + dtzdzk1
                        hessz(1,k1) = hessz(1,k1) - sk1*dtxdzk1
     &                                   + dtxkdzk1
                        hessz(2,k1) = hessz(2,k1) - sk1*dtydzk1
     &                                   + dtykdzk1
                        hessz(3,k1) = hessz(3,k1) - sk1*dtzdzk1
     &                                   + dtzkdzk1
                        hessz(1,k2) = hessz(1,k2) - sk2*dtxdzk1
     &                                   - dtxkdzk1
                        hessz(2,k2) = hessz(2,k2) - sk2*dtydzk1
     &                                   - dtykdzk1
                        hessz(3,k2) = hessz(3,k2) - sk2*dtzdzk1
     &                                   - dtzkdzk1
                     else if (i .eq. k2) then
                        hessx(1,i1) = hessx(1,i1) + dtxdxk2
                        hessx(2,i1) = hessx(2,i1) + dtydxk2
                        hessx(3,i1) = hessx(3,i1) + dtzdxk2
                        hessx(1,k1) = hessx(1,k1) - sk1*dtxdxk2
     &                                   + dtxkdxk2
                        hessx(2,k1) = hessx(2,k1) - sk1*dtydxk2
     &                                   + dtykdxk2
                        hessx(3,k1) = hessx(3,k1) - sk1*dtzdxk2
     &                                   + dtzkdxk2
                        hessx(1,k2) = hessx(1,k2) - sk2*dtxdxk2
     &                                   - dtxkdxk2
                        hessx(2,k2) = hessx(2,k2) - sk2*dtydxk2
     &                                   - dtykdxk2
                        hessx(3,k2) = hessx(3,k2) - sk2*dtzdxk2
     &                                   - dtzkdxk2
                        hessy(1,i1) = hessy(1,i1) + dtxdyk2
                        hessy(2,i1) = hessy(2,i1) + dtydyk2
                        hessy(3,i1) = hessy(3,i1) + dtzdyk2
                        hessy(1,k1) = hessy(1,k1) - sk1*dtxdyk2
     &                                   + dtxkdyk2
                        hessy(2,k1) = hessy(2,k1) - sk1*dtydyk2
     &                                   + dtykdyk2
                        hessy(3,k1) = hessy(3,k1) - sk1*dtzdyk2
     &                                   + dtzkdyk2
                        hessy(1,k2) = hessy(1,k2) - sk2*dtxdyk2
     &                                   - dtxkdyk2
                        hessy(2,k2) = hessy(2,k2) - sk2*dtydyk2
     &                                   - dtykdyk2
                        hessy(3,k2) = hessy(3,k2) - sk2*dtzdyk2
     &                                   - dtzkdyk2
                        hessz(1,i1) = hessz(1,i1) + dtxdzk2
                        hessz(2,i1) = hessz(2,i1) + dtydzk2
                        hessz(3,i1) = hessz(3,i1) + dtzdzk2
                        hessz(1,k1) = hessz(1,k1) - sk1*dtxdzk2
     &                                   + dtxkdzk2
                        hessz(2,k1) = hessz(2,k1) - sk1*dtydzk2
     &                                   + dtykdzk2
                        hessz(3,k1) = hessz(3,k1) - sk1*dtzdzk2
     &                                   + dtzkdzk2
                        hessz(1,k2) = hessz(1,k2) - sk2*dtxdzk2
     &                                   - dtxkdzk2
                        hessz(2,k2) = hessz(2,k2) - sk2*dtydzk2
     &                                   - dtykdzk2
                        hessz(3,k2) = hessz(3,k2) - sk2*dtzdzk2
     &                                   - dtzkdzk2
                     end if
c
c     more energy switching if near the cutoff distance
c
                     if (r2.gt.cut2 .and. i.eq.k1) then
                        hessx(1,i1) = hessx(1,i1) - sk1*dtaperx*dedxi1
     &                         + dtaperx*dedxk1 - sk1*d2taperxx
                        hessx(2,i1) = hessx(2,i1) - sk1*dtaperx*dedyi1
     &                         + dtapery*dedxk1 - sk1*d2taperxy
                        hessx(3,i1) = hessx(3,i1) - sk1*dtaperx*dedzi1
     &                         + dtaperz*dedxk1 - sk1*d2taperxz
                        hessx(1,k1) = hessx(1,k1) - sk1*dtaperx*dedxk1
     &                         - sk1*dtaperx*dedxk1 + sk1*sk1*d2taperxx
                        hessx(2,k1) = hessx(2,k1) - sk1*dtaperx*dedyk1
     &                         - sk1*dtapery*dedxk1 + sk1*sk1*d2taperxy
                        hessx(3,k1) = hessx(3,k1) - sk1*dtaperx*dedzk1
     &                         - sk1*dtaperz*dedxk1 + sk1*sk1*d2taperxz
                        hessx(1,k2) = hessx(1,k2) - sk1*dtaperx*dedxk2
     &                         - sk2*dtaperx*dedxk1 + sk1*sk2*d2taperxx
                        hessx(2,k2) = hessx(2,k2) - sk1*dtaperx*dedyk2
     &                         - sk2*dtapery*dedxk1 + sk1*sk2*d2taperxy
                        hessx(3,k2) = hessx(3,k2) - sk1*dtaperx*dedzk2
     &                         - sk2*dtaperz*dedxk1 + sk1*sk2*d2taperxz
                        hessy(1,i1) = hessy(1,i1) - sk1*dtapery*dedxi1
     &                         + dtaperx*dedyk1 - sk1*d2taperxy
                        hessy(2,i1) = hessy(2,i1) - sk1*dtapery*dedyi1
     &                         + dtapery*dedyk1 - sk1*d2taperyy
                        hessy(3,i1) = hessy(3,i1) - sk1*dtapery*dedzi1
     &                         + dtaperz*dedyk1 - sk1*d2taperyz
                        hessy(1,k1) = hessy(1,k1) - sk1*dtapery*dedxk1
     &                         - sk1*dtaperx*dedyk1 + sk1*sk1*d2taperxy
                        hessy(2,k1) = hessy(2,k1) - sk1*dtapery*dedyk1
     &                         - sk1*dtapery*dedyk1 + sk1*sk1*d2taperyy
                        hessy(3,k1) = hessy(3,k1) - sk1*dtapery*dedzk1
     &                         - sk1*dtaperz*dedyk1 + sk1*sk1*d2taperyz
                        hessy(1,k2) = hessy(1,k2) - sk1*dtapery*dedxk2
     &                         - sk2*dtaperx*dedyk1 + sk1*sk2*d2taperxy
                        hessy(2,k2) = hessy(2,k2) - sk1*dtapery*dedyk2
     &                         - sk2*dtapery*dedyk1 + sk1*sk2*d2taperyy
                        hessy(3,k2) = hessy(3,k2) - sk1*dtapery*dedzk2
     &                         - sk2*dtaperz*dedyk1 + sk1*sk2*d2taperyz
                        hessz(1,i1) = hessz(1,i1) - sk1*dtaperz*dedxi1
     &                         + dtaperx*dedzk1 - sk1*d2taperxz
                        hessz(2,i1) = hessz(2,i1) - sk1*dtaperz*dedyi1
     &                         + dtapery*dedzk1 - sk1*d2taperyz
                        hessz(3,i1) = hessz(3,i1) - sk1*dtaperz*dedzi1
     &                         + dtaperz*dedzk1 - sk1*d2taperzz
                        hessz(1,k1) = hessz(1,k1) - sk1*dtaperz*dedxk1
     &                         - sk1*dtaperx*dedzk1 + sk1*sk1*d2taperxz
                        hessz(2,k1) = hessz(2,k1) - sk1*dtaperz*dedyk1
     &                         - sk1*dtapery*dedzk1 + sk1*sk1*d2taperyz
                        hessz(3,k1) = hessz(3,k1) - sk1*dtaperz*dedzk1
     &                         - sk1*dtaperz*dedzk1 + sk1*sk1*d2taperzz
                        hessz(1,k2) = hessz(1,k2) - sk1*dtaperz*dedxk2
     &                         - sk2*dtaperx*dedzk1 + sk1*sk2*d2taperxz
                        hessz(2,k2) = hessz(2,k2) - sk1*dtaperz*dedyk2
     &                         - sk2*dtapery*dedzk1 + sk1*sk2*d2taperyz
                        hessz(3,k2) = hessz(3,k2) - sk1*dtaperz*dedzk2
     &                         - sk2*dtaperz*dedzk1 + sk1*sk2*d2taperzz
                     else if (r2.gt.cut2 .and. i.eq.k2) then
                        hessx(1,i1) = hessx(1,i1) - sk2*dtaperx*dedxi1
     &                         + dtaperx*dedxk2 - sk2*d2taperxx
                        hessx(2,i1) = hessx(2,i1) - sk2*dtaperx*dedyi1
     &                         + dtapery*dedxk2 - sk2*d2taperxy
                        hessx(3,i1) = hessx(3,i1) - sk2*dtaperx*dedzi1
     &                         + dtaperz*dedxk2 - sk2*d2taperxz
                        hessx(1,k1) = hessx(1,k1) - sk2*dtaperx*dedxk1
     &                         - sk1*dtaperx*dedxk2 + sk1*sk2*d2taperxx
                        hessx(2,k1) = hessx(2,k1) - sk2*dtaperx*dedyk1
     &                         - sk1*dtapery*dedxk2 + sk1*sk2*d2taperxy
                        hessx(3,k1) = hessx(3,k1) - sk2*dtaperx*dedzk1
     &                         - sk1*dtaperz*dedxk2 + sk1*sk2*d2taperxz
                        hessx(1,k2) = hessx(1,k2) - sk2*dtaperx*dedxk2
     &                         - sk2*dtaperx*dedxk2 + sk2*sk2*d2taperxx
                        hessx(2,k2) = hessx(2,k2) - sk2*dtaperx*dedyk2
     &                         - sk2*dtapery*dedxk2 + sk2*sk2*d2taperxy
                        hessx(3,k2) = hessx(3,k2) - sk2*dtaperx*dedzk2
     &                         - sk2*dtaperz*dedxk2 + sk2*sk2*d2taperxz
                        hessy(1,i1) = hessy(1,i1) - sk2*dtapery*dedxi1
     &                         + dtaperx*dedyk2 - sk2*d2taperxy
                        hessy(2,i1) = hessy(2,i1) - sk2*dtapery*dedyi1
     &                         + dtapery*dedyk2 - sk2*d2taperyy
                        hessy(3,i1) = hessy(3,i1) - sk2*dtapery*dedzi1
     &                         + dtaperz*dedyk2 - sk2*d2taperyz
                        hessy(1,k1) = hessy(1,k1) - sk2*dtapery*dedxk1
     &                         - sk1*dtaperx*dedyk2 + sk1*sk2*d2taperxy
                        hessy(2,k1) = hessy(2,k1) - sk2*dtapery*dedyk1
     &                         - sk1*dtapery*dedyk2 + sk1*sk2*d2taperyy
                        hessy(3,k1) = hessy(3,k1) - sk2*dtapery*dedzk1
     &                         - sk1*dtaperz*dedyk2 + sk1*sk2*d2taperyz
                        hessy(1,k2) = hessy(1,k2) - sk2*dtapery*dedxk2
     &                         - sk2*dtaperx*dedyk2 + sk2*sk2*d2taperxy
                        hessy(2,k2) = hessy(2,k2) - sk2*dtapery*dedyk2
     &                         - sk2*dtapery*dedyk2 + sk2*sk2*d2taperyy
                        hessy(3,k2) = hessy(3,k2) - sk2*dtapery*dedzk2
     &                         - sk2*dtaperz*dedyk2 + sk2*sk2*d2taperyz
                        hessz(1,i1) = hessz(1,i1) - sk2*dtaperz*dedxi1
     &                         + dtaperx*dedzk2 - sk2*d2taperxz
                        hessz(2,i1) = hessz(2,i1) - sk2*dtaperz*dedyi1
     &                         + dtapery*dedzk2 - sk2*d2taperyz
                        hessz(3,i1) = hessz(3,i1) - sk2*dtaperz*dedzi1
     &                         + dtaperz*dedzk2 - sk2*d2taperzz
                        hessz(1,k1) = hessz(1,k1) - sk2*dtaperz*dedxk1
     &                         - sk1*dtaperx*dedzk2 + sk1*sk2*d2taperxz
                        hessz(2,k1) = hessz(2,k1) - sk2*dtaperz*dedyk1
     &                         - sk1*dtapery*dedzk2 + sk1*sk2*d2taperyz
                        hessz(3,k1) = hessz(3,k1) - sk2*dtaperz*dedzk1
     &                         - sk1*dtaperz*dedzk2 + sk1*sk2*d2taperzz
                        hessz(1,k2) = hessz(1,k2) - sk2*dtaperz*dedxk2
     &                         - sk2*dtaperx*dedzk2 + sk2*sk2*d2taperxz
                        hessz(2,k2) = hessz(2,k2) - sk2*dtaperz*dedyk2
     &                         - sk2*dtapery*dedzk2 + sk2*sk2*d2taperyz
                        hessz(3,k2) = hessz(3,k2) - sk2*dtaperz*dedzk2
     &                         - sk2*dtaperz*dedzk2 + sk2*sk2*d2taperzz
                     end if
                  end if
               end do
            end if
         end do
   40    continue
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (skip)
      deallocate (omit)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine echgdpl3  --  charge-dipole energy & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "echgdpl3" calculates the charge-dipole interaction energy;
c     also partitions the energy among the atoms
c
c
      subroutine echgdpl3
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use cell
      use charge
      use chgpot
      use couple
      use dipole
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use shunt
      use units
      use usage
      implicit none
      integer i,j,k
      integer ii,k1,k2
      integer, allocatable :: skip(:)
      real*8 e,rk2,rkr3,dotk
      real*8 taper,fgrp
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xk,yk,zk
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4,r5
      logical proceed
      logical header,huge
      character*6 mode
c
c
c     zero out the overall charge-dipole interaction energy
c     and partitioning; set up constants for the calculation
c
      necd = 0
      ecd = 0.0d0
      do i = 1, n
         aecd(i) = 0.0d0
      end do
      if (nion.eq.0 .or. ndipole.eq.0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (skip(n))
c
c     zero out the list of atoms to be skipped
c
      do i = 1, n
         skip(i) = 0
      end do
c
c     set conversion factor and switching function coefficients
c
      f = electric / (debye * dielec)
      mode = 'CHGDPL'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nion.ne.0 .and. ndipole.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Charge-Dipole Interactions :',
     &           //,' Type',11x,'Charge',10x,'Dipole',
     &              20x,'Distance',6x,'Energy',/)
      end if
c
c     get the total energy by looping over each charge-dipole pair
c
      do ii = 1, nion
         i = iion(ii)
         skip(i) = i
         do k = 1, n12(i)
            skip(i12(k,i)) = i
         end do
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
c
c     decide whether to compute the current interaction
c
         do k = 1, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k1,k2,0,0,0)
            if (proceed)  proceed = (use(i) .or. use(k1) .or. use(k2))
            if (proceed)  proceed = (skip(k1).ne.i .and.
     &                                 skip(k2).ne.i)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xk = x(k2) - x(k1)
               yk = y(k2) - y(k1)
               zk = z(k2) - z(k1)
               xr = x(k1) + xk*sdpl(k) - xi
               yr = y(k1) + yk*sdpl(k) - yi
               zr = z(k1) + zk*sdpl(k) - zi
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  fik = fi * bdpl(k)
                  rk2 = xk*xk + yk*yk + zk*zk
                  rkr3 = sqrt(rk2*r2) * r2
                  dotk = xk*xr + yk*yr + zk*zr
                  e = fik * dotk / rkr3
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall charge-dipole energy component
c
                  necd = necd + 1
                  ecd = ecd + e
                  aecd(i) = aecd(i) + 0.5d0*e
                  aecd(k1) = aecd(k1) + 0.25d0*e
                  aecd(k2) = aecd(k2) + 0.25d0*e
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k1)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(e) .gt. 25.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Charge-Dipole',
     &                             ' Interactions :',
     &                          //,' Type',11x,'Charge',10x,'Dipole',
     &                             20x,'Distance',6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k1,name(k1),
     &                                k2,name(k2),sqrt(r2),e
   30                format (' Chg-Dpl',3x,3(i7,'-',a3),
     &                          11x,f11.4,f12.4)
                  end if
               end if
            end if
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nion
         i = iion(ii)
         skip(i) = i
         do k = 1, n12(i)
            skip(i12(k,i)) = i
         end do
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
c
c     decide whether to compute the current interaction
c
         do k = 1, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k1,k2,0,0,0)
            if (proceed)  proceed = (use(i) .or. use(k1) .or. use(k2))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xk = x(k2) - x(k1)
                  yk = y(k2) - y(k1)
                  zk = z(k2) - z(k1)
                  xr = x(k1) + xk*sdpl(k) - xi
                  yr = y(k1) + yk*sdpl(k) - yi
                  zr = z(k1) + zk*sdpl(k) - zi
                  call imager (xr,yr,zr,j)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     fik = fi * bdpl(k)
                     if (use_polymer) then
                        if (r2 .lt. polycut2) then
                           if (skip(k1).eq.i .or. skip(k2).ne.i)
     &                        fik = 0.0d0
                        end if
                     end if
                     rk2 = xk*xk + yk*yk + zk*zk
                     rkr3 = sqrt(rk2*r2) * r2
                     dotk = xk*xr + yk*yr + zk*zr
                     e = fik * dotk / rkr3
c
c     use energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        r = sqrt(r2)
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall charge-dipole energy component
c
                     if (e .ne. 0.0d0)  necd = necd + 1
                     ecd = ecd + e
                     aecd(i) = aecd(i) + 0.5d0*e
                     aecd(k1) = aecd(k1) + 0.25d0*e
                     aecd(k2) = aecd(k2) + 0.25d0*e
c
c     increment the total intermolecular energy
c
                     einter = einter + e
c
c     print a message if the energy of this interaction is large
c
                     huge = (abs(e) .gt. 25.0d0)
                     if ((debug.and.e.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual Charge-Dipole',
     &                                ' Interactions :',
     &                             //,' Type',11x,'Charge',10x,'Dipole',
     &                                20x,'Distance',6x,'Energy',/)
                        end if
                        write (iout,50)  i,name(i),k1,name(k1),
     &                                   k2,name(k2),sqrt(r2),e
   50                   format (' Chg-Dpl',3x,3(i7,'-',a3),
     &                             2x,'(XTAL)',3x,f11.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (skip)
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine echgtrn  --  charge transfer potential energy  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "echgtrn" calculates the charge transfer potential energy
c
c
      subroutine echgtrn
      use limits
      implicit none
c
c
c     choose method for summing over charge transfer interactions
c
      if (use_mlist) then
         call echgtrn0c
      else if (use_lights) then
         call echgtrn0b
      else
         call echgtrn0a
      end if
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine echgtrn0a  --  double loop charge transfer  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "echgtrn0a" calculates the charge transfer interaction energy
c     using a double loop
c
c
      subroutine echgtrn0a
      use atoms
      use bound
      use chgpot
      use chgtrn
      use ctrpot
      use cell
      use couple
      use energi
      use group
      use mplpot
      use mpole
      use mutant
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 e,f,fgrp
      real*8 r,r2,r3
      real*8 r4,r5
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 chgi,chgk
      real*8 chgik
      real*8 alphai,alphak
      real*8 expi,expk
      real*8 expik
      real*8 taper
      real*8, allocatable :: mscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     zero out the charge transfer energy
c
      ect = 0.0d0
      if (nct .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHGTRN'
      call switch (mode)
c
c     calculate the charge transfer energy term
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         chgi = chgct(i)
         alphai = dmpct(i)
         if (alphai .eq. 0.0d0)  alphai = 1000.0d0
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  chgk = chgct(k)
                  alphak = dmpct(k)
                  if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                  if (ctrntyp .eq. 'SEPARATE') then
                     expi = exp(-alphai*r)
                     expk = exp(-alphak*r)
                     e = -chgi*expk - chgk*expi
                  else
                     chgik = sqrt(abs(chgi*chgk))
                     expik = exp(-0.5d0*(alphai+alphak)*r)
                     e = -chgik * expik
                  end if
                  e = f * e * mscale(k)
c
c     apply lambda scaling for interaction annihilation 
c
                  if (muti .or. mutk) then
                     e = e * elambda
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall charge transfer energy component
c
                  ect = ect + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction energy with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            chgi = chgct(i)
            alphai = dmpct(i)
            if (alphai .eq. 0.0d0)  alphai = 1000.0d0
            usei = use(i)
            muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = m2scale
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = m3scale
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = m4scale
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = m5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               mutk = mut(k)
               proceed = .true.
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               if (.not. use_intra)  proceed = .true.
               if (proceed)  proceed = (usei .or. use(k))
               if (proceed) then
                  do jcell = 2, ncell
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     call imager (xr,yr,zr,jcell)
                     r2 = xr*xr + yr* yr + zr*zr
                     if (r2 .le. off2) then
                        r = sqrt(r2)
                        chgk = chgct(k)
                        alphak = dmpct(k)
                        if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                        if (ctrntyp .eq. 'SEPARATE') then
                           expi = exp(-alphai*r)
                           expk = exp(-alphak*r)
                           e = -chgi*expk - chgk*expi
                        else
                           chgik = sqrt(abs(chgi*chgk))
                           expik = exp(-0.5d0*(alphai+alphak)*r)
                           e = -chgik * expik
                        end if
                        e = f * e * mscale(k)
c
c     apply lambda scaling for interaction annihilation 
c
                        if (muti .or. mutk) then
                           e = e * elambda
                        end if
c
c     use energy switching if near the cutoff distance
c
                        if (r2 .gt. cut2) then
                           r3 = r2 * r
                           r4 = r2 * r2
                           r5 = r2 * r3
                           taper = c5*r5 + c4*r4 + c3*r3
     &                                + c2*r2 + c1*r + c0
                           e = e * taper
                        end if
c
c     scale the interaction based on its group membership
c
                        if (use_group)  e = e * fgrp
c
c     increment the overall charge transfer energy component
c
                        if (i .eq. k)  e = 0.5d0 * e
                        ect = ect + e
                     end if
                  end do
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine echgtrn0b  --  method of lights charge transfer  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "echgtrn0b" calculates the charge transfer interaction energy
c     using the method of lights
c
c
      subroutine echgtrn0b
      use atoms
      use bound
      use boxes
      use chgpot
      use chgtrn
      use cell
      use couple
      use ctrpot
      use energi
      use group
      use light
      use mplpot
      use mpole
      use mutant
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer kgy,kgz
      integer start,stop
      real*8 e,f,fgrp
      real*8 r,r2,r3
      real*8 r4,r5
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 chgi,chgk
      real*8 chgik
      real*8 alphai,alphak
      real*8 expi,expk
      real*8 expik
      real*8 taper
      real*8, allocatable :: mscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei
      logical unique,repeat
      logical muti,mutk
      character*6 mode
c
c
c     zero out the charge transfer energy
c
      ect = 0.0d0
      if (nct .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHGTRN'
      call switch (mode)
c
c     transfer the interaction site coordinates to sorting arrays
c
      do ii = 1, npole
         i = ipole(ii)
         xsort(ii) = x(i)
         ysort(ii) = y(i)
         zsort(ii) = z(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nct,xsort,ysort,zsort,unique)
c
c     calculate the charge transfer energy term
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         chgi = chgct(i)
         alphai = dmpct(i)
         if (alphai .eq. 0.0d0)  alphai = 1000.0d0
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            k = ipole(kk-((kk-1)/npole)*npole)
            mutk = mut(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  chgk = chgct(k)
                  alphak = dmpct(k)
                  if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                  if (ctrntyp .eq. 'SEPARATE') then
                     expi = exp(-alphai*r)
                     expk = exp(-alphak*r)
                     e = -chgi*expk - chgk*expi
                  else
                     chgik = sqrt(abs(chgi*chgk))
                     expik = exp(-0.5d0*(alphai+alphak)*r)
                     e = -chgik * expik
                  end if
                  e = f * e * mscale(k)
c
c     apply lambda scaling for interaction annihilation 
c
                  if (muti .or. mutk) then
                     e = e * elambda
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall charge transfer energy component
c
                  ect = ect + e
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine echgtrn0c  --  neighbor list charge transfer  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "echgtrn0c" calculates the charge transfer interaction energy
c     using a neighbor list
c
c
      subroutine echgtrn0c
      use atoms
      use bound
      use chgpot
      use chgtrn
      use couple
      use ctrpot
      use energi
      use group
      use mplpot
      use mpole
      use mutant
      use neigh
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      real*8 e,f,fgrp
      real*8 r,r2,r3
      real*8 r4,r5
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 chgi,chgk
      real*8 chgik
      real*8 alphai,alphak
      real*8 expi,expk
      real*8 expik
      real*8 taper
      real*8, allocatable :: mscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c     zero out the charge transfer energy
c
      ect = 0.0d0
      if (nct .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHGTRN'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,x,y,z,chgct,dmpct,n12,i12,n13,i13,
!$OMP& n14,i14,n15,i15,m2scale,m3scale,m4scale,m5scale,nelst,
!$OMP& elst,use,use_group,use_intra,use_bounds,ctrntyp,f,cut2,
!$OMP& off2,elambda,mut,c0,c1,c2,c3,c4,c5)
!$OMP& firstprivate(mscale) shared(ect)
!$OMP DO reduction(+:ect)
c
c     compute the charge transfer energy
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         chgi = chgct(i)
         alphai = dmpct(i)
         if (alphai .eq. 0.0d0)  alphai = 1000.0d0
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  chgk = chgct(k)
                  alphak = dmpct(k)
                  if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                  if (ctrntyp .eq. 'SEPARATE') then
                     expi = exp(-alphai*r)
                     expk = exp(-alphak*r)
                     e = -chgi*expk - chgk*expi
                  else
                     chgik = sqrt(abs(chgi*chgk))
                     expik = exp(-0.5d0*(alphai+alphak)*r)
                     e = -chgik * expik
                  end if
                  e = f * e * mscale(k)
c
c     apply lambda scaling for interaction annihilation 
c
                  if (muti .or. mutk) then
                     e = e * elambda
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall charge transfer energy component
c
                  ect = ect + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine echgtrn1  --  charge transfer energy & derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "echgtrn1" calculates the charge transfer energy and first
c     derivatives with respect to Cartesian coordinates
c
c
      subroutine echgtrn1
      use limits
      implicit none
c
c
c     choose method for summing over charge transfer interactions
c
      if (use_mlist) then
         call echgtrn1b
      else
         call echgtrn1a
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine echgtrn1a  --  charge transfer derivs via loop  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "echgtrn1a" calculates the charge transfer interaction energy
c     and first derivatives using a double loop
c
c
      subroutine echgtrn1a
      use atoms
      use bound
      use chgpot
      use chgtrn
      use cell
      use couple
      use ctrpot
      use deriv
      use energi
      use group
      use mplpot
      use mpole
      use mutant
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 e,de,f,fgrp
      real*8 rr1,r,r2
      real*8 r3,r4,r5
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 chgi,chgk
      real*8 chgik
      real*8 alphai,alphak
      real*8 alphaik
      real*8 expi,expk
      real*8 expik
      real*8 frcx,frcy,frcz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 taper,dtaper
      real*8, allocatable :: mscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     zero out the charge transfer energy and first derivatives
c
      ect = 0.0d0
      do i = 1, n
         dect(1,i) = 0.0d0
         dect(2,i) = 0.0d0
         dect(3,i) = 0.0d0
      end do
      if (nct .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHGTRN'
      call switch (mode)
c
c     calculate the charge transfer energy and derivatives
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         chgi = chgct(i)
         alphai = dmpct(i)
         if (alphai .eq. 0.0d0)  alphai = 1000.0d0
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rr1 = 1.0d0 / r
                  chgk = chgct(k)
                  alphak = dmpct(k)
                  if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                  if (ctrntyp .eq. 'SEPARATE') then
                     expi = exp(-alphai*r)
                     expk = exp(-alphak*r)
                     e = -chgi*expk - chgk*expi
                     de = chgi*expk*alphak + chgk*expi*alphai
                  else
                     chgik = sqrt(abs(chgi*chgk))
                     alphaik = 0.5d0 * (alphai+alphak)
                     expik = exp(-alphaik*r)
                     e = -chgik * expik
                     de = -e * alphaik
                  end if
                  e = f * e * mscale(k)
                  de = f * de * mscale(k)
c
c     apply lambda scaling for interaction annihilation 
c
                  if (muti .or. mutk) then
                     e = e * elambda
                     de = de * elambda
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     compute the force components for this interaction
c
                  frcx = de * xr * rr1
                  frcy = de * yr * rr1
                  frcz = de * zr * rr1
c     
c     increment the total charge transfer energy and derivatives
c
                  ect = ect + e
                  dect(1,i) = dect(1,i) - frcx
                  dect(2,i) = dect(2,i) - frcy
                  dect(3,i) = dect(3,i) - frcz
                  dect(1,k) = dect(1,k) + frcx
                  dect(2,k) = dect(2,k) + frcy
                  dect(3,k) = dect(3,k) + frcz
c
c     increment the internal virial tensor components
c
                  vxx = xr * frcx
                  vxy = yr * frcx
                  vxz = zr * frcx
                  vyy = yr * frcy
                  vyz = zr * frcy
                  vzz = zr * frcz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vxy
                  vir(3,1) = vir(3,1) + vxz
                  vir(1,2) = vir(1,2) + vxy
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vyz
                  vir(1,3) = vir(1,3) + vxz
                  vir(2,3) = vir(2,3) + vyz
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction components with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            chgi = chgct(i)
            alphai = dmpct(i)
            if (alphai .eq. 0.0d0)  alphai = 1000.0d0
            usei = use(i)
            muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = m2scale
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = m3scale
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = m4scale
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = m5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               mutk = mut(k)
               proceed = .true.
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               if (.not. use_intra)  proceed = .true.
               if (proceed)  proceed = (usei .or. use(k))
               if (proceed) then
                  do jcell = 2, ncell
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     call imager (xr,yr,zr,jcell)
                     r2 = xr*xr + yr* yr + zr*zr
                     if (r2 .le. off2) then
                        r = sqrt(r2)
                        rr1 = 1.0d0 / r
                        chgk = chgct(k)
                        alphak = dmpct(k)
                        if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                        if (ctrntyp .eq. 'SEPARATE') then
                           expi = exp(-alphai*r)
                           expk = exp(-alphak*r)
                           e = -chgi*expk - chgk*expi
                           de = chgi*expk*alphak + chgk*expi*alphai
                        else
                           chgik = sqrt(abs(chgi*chgk))
                           alphaik = 0.5d0 * (alphai+alphak)
                           expik = exp(-alphaik*r)
                           e = -chgik * expik
                           de = -e * alphaik
                        end if
                        if (use_group) then
                           e = e * fgrp
                           de = de * fgrp
                        end if
                        e = f * e * mscale(k)
                        de = f * de * mscale(k)
                        if (i .eq. k) then
                           e = 0.5d0 * e
                           de = 0.5d0 * de
                        end if
c
c     apply lambda scaling for interaction annihilation 
c
                        if (muti .or. mutk) then
                           e = e * elambda
                           de = de * elambda
                        end if
c
c     use energy switching if near the cutoff distance
c
                        if (r2 .gt. cut2) then
                           r3 = r2 * r
                           r4 = r2 * r2
                           r5 = r2 * r3
                           taper = c5*r5 + c4*r4 + c3*r3
     &                                + c2*r2 + c1*r + c0
                           dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                                 + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                           de = e*dtaper + de*taper
                           e = e * taper
                        end if
c
c     scale the interaction based on its group membership
c
                        if (use_group) then
                           e = e * fgrp
                           de = de * fgrp
                        end if
c
c     compute the force components for this interaction
c
                        frcx = de * xr * rr1
                        frcy = de * yr * rr1
                        frcz = de * zr * rr1
c     
c     increment the total charge transfer energy and derivatives
c
                        ect = ect + e
                        dect(1,i) = dect(1,i) - frcx
                        dect(2,i) = dect(2,i) - frcy
                        dect(3,i) = dect(3,i) - frcz
                        dect(1,k) = dect(1,k) + frcx
                        dect(2,k) = dect(2,k) + frcy
                        dect(3,k) = dect(3,k) + frcz
c
c     increment the internal virial tensor components
c
                        vxx = xr * frcx
                        vxy = yr * frcx
                        vxz = zr * frcx
                        vyy = yr * frcy
                        vyz = zr * frcy
                        vzz = zr * frcz
                        vir(1,1) = vir(1,1) + vxx
                        vir(2,1) = vir(2,1) + vxy
                        vir(3,1) = vir(3,1) + vxz
                        vir(1,2) = vir(1,2) + vxy
                        vir(2,2) = vir(2,2) + vyy
                        vir(3,2) = vir(3,2) + vyz
                        vir(1,3) = vir(1,3) + vxz
                        vir(2,3) = vir(2,3) + vyz
                        vir(3,3) = vir(3,3) + vzz
                     end if
                  end do
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine echgtrn1b  --  charge transfer derivs via list  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "echgtrn1b" calculates the charge transfer energy and first
c     derivatives using a pairwise neighbor list
c
c
      subroutine echgtrn1b
      use atoms
      use bound
      use chgpot
      use chgtrn
      use cell
      use couple
      use ctrpot
      use deriv
      use energi
      use group
      use mplpot
      use mpole
      use mutant
      use neigh
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      real*8 e,de,f,fgrp
      real*8 rr1,r,r2
      real*8 r3,r4,r5
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 chgi,chgk
      real*8 chgik
      real*8 alphai,alphak
      real*8 alphaik
      real*8 expi,expk
      real*8 expik
      real*8 frcx,frcy,frcz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 taper,dtaper
      real*8, allocatable :: mscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     zero out the charge transfer energy and first derivatives
c
      ect = 0.0d0
      do i = 1, n
         dect(1,i) = 0.0d0
         dect(2,i) = 0.0d0
         dect(3,i) = 0.0d0
      end do
      if (nct .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHGTRN'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,x,y,z,chgct,dmpct,n12,i12,n13,i13,
!$OMP& n14,i14,n15,i15,m2scale,m3scale,m4scale,m5scale,nelst,
!$OMP& elst,use,use_group,use_intra,use_bounds,ctrntyp,f,off2,
!$OMP& elambda,mut,cut2,c0,c1,c2,c3,c4,c5)
!$OMP& firstprivate(mscale) shared(ect,dect,vir)
!$OMP DO reduction(+:ect,dect,vir)
c
c     compute the charge transfer energy and derivatives
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         chgi = chgct(i)
         alphai = dmpct(i)
         if (alphai .eq. 0.0d0)  alphai = 1000.0d0
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rr1 = 1.0d0 / r
                  chgk = chgct(k)
                  alphak = dmpct(k)
                  if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                  if (ctrntyp .eq. 'SEPARATE') then
                     expi = exp(-alphai*r)
                     expk = exp(-alphak*r)
                     e = -chgi*expk - chgk*expi
                     de = chgi*expk*alphak + chgk*expi*alphai
                  else
                     chgik = sqrt(abs(chgi*chgk))
                     alphaik = 0.5d0 * (alphai+alphak)
                     expik = exp(-alphaik*r)
                     e = -chgik * expik
                     de = -e * alphaik
                  end if
                  e = f * e * mscale(k)
                  de = f * de * mscale(k)
c
c     apply lambda scaling for interaction annihilation 
c
                  if (muti .or. mutk) then
                     e = e * elambda
                     de = de * elambda
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     compute the force components for this interaction
c
                  frcx = de * xr * rr1
                  frcy = de * yr * rr1
                  frcz = de * zr * rr1
c     
c     increment the total charge transfer energy and derivatives
c
                  ect = ect + e
                  dect(1,i) = dect(1,i) - frcx
                  dect(2,i) = dect(2,i) - frcy
                  dect(3,i) = dect(3,i) - frcz
                  dect(1,k) = dect(1,k) + frcx
                  dect(2,k) = dect(2,k) + frcy
                  dect(3,k) = dect(3,k) + frcz
c
c     increment the internal virial tensor components
c
                  vxx = xr * frcx
                  vxy = yr * frcx
                  vxz = zr * frcx
                  vyy = yr * frcy
                  vyz = zr * frcy
                  vzz = zr * frcz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vxy
                  vir(3,1) = vir(3,1) + vxz
                  vir(1,2) = vir(1,2) + vxy
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vyz
                  vir(1,3) = vir(1,3) + vxz
                  vir(2,3) = vir(2,3) + vyz
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine echgtrn2  --  atomwise charge transfer Hessian  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "echgtrn2" calculates the second derivatives of the charge
c     transfer energy using a double loop over relevant atom pairs
c
c
      subroutine echgtrn2 (iatom)
      use atoms
      use bound
      use cell
      use chgpot
      use chgtrn
      use couple
      use ctrpot
      use group
      use hessn
      use mplpot
      use mpole
      use mutant
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk,iii
      integer iatom,jcell
      integer nlist,list(5)
      real*8 e,dedr,d2edr2
      real*8 term,f,fgrp
      real*8 termx,termy,termz
      real*8 rr1,r,r2
      real*8 r3,r4,r5
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 chgi,chgk
      real*8 chgik
      real*8 alphai,alphak
      real*8 alphaik
      real*8 alphai2,alphak2
      real*8 expi,expk
      real*8 expik
      real*8 taper,dtaper
      real*8 d2taper
      real*8 d2e(3,3)
      real*8, allocatable :: mscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHGTRN'
      call switch (mode)
c
c     check to see if the atom of interest is a site
c
      nlist = 0
      do ii = 1, npole
         if (ipole(ii) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = ii
            goto 10
         end if
      end do
      return
   10 continue
c
c     calculate the charge transfer energy term
c
      do iii = 1, nlist
         ii = list(iii)
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         chgi = chgct(i)
         alphai = dmpct(i)
         if (alphai .eq. 0.0d0)  alphai = 1000.0d0
         alphai2 = alphai * alphai
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, npole
            k = ipole(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rr1 = 1.0d0 / r
                  chgk = chgct(k)
                  alphak = dmpct(k)
                  if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                  if (ctrntyp .eq. 'SEPARATE') then
                     alphak2 = alphak * alphak
                     expi = exp(-alphai*r)
                     expk = exp(-alphak*r)
                     e = -chgi*expk - chgk*expi
                     dedr = chgi*expk*alphak + chgk*expi*alphai
                     d2edr2 = -chgi*expk*alphak2 - chgk*expi*alphai2
                  else
                     chgik = sqrt(abs(chgi*chgk))
                     alphaik = 0.5d0 * (alphai+alphak)
                     expik = exp(-alphaik*r)
                     e = -chgik * expik
                     dedr = -e * alphaik
                     d2edr2 = -dedr * alphaik
                  end if
                  e = f * e * mscale(k)
                  dedr = f * dedr * mscale(k)
                  d2edr2 = f * d2edr2 * mscale(k)
c
c     apply lambda scaling for interaction annihilation 
c
                  if (muti .or. mutk) then
                     dedr = dedr * elambda
                     d2edr2 = d2edr2 * elambda
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r3 * r2
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2
     &                            + 6.0d0*c3*r + 2.0d0*c2
                     d2e = e*d2taper + 2.0d0*dedr*dtaper + d2edr2*taper
                     dedr = e*dtaper + dedr*taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     dedr = dedr * fgrp
                     d2edr2 = d2edr2 * fgrp
                  end if
c
c     set the chain rule terms for the Hessian elements
c
                  if (r2 .eq. 0.0d0) then
                     dedr = 0.0d0
                     term = 0.0d0
                  else
                     dedr = dedr / r
                     term = (d2edr2-dedr) / r2
                  end if
                  termx = term * xr
                  termy = term * yr
                  termz = term * zr
                  d2e(1,1) = termx*xr + dedr
                  d2e(1,2) = termx*yr
                  d2e(1,3) = termx*zr
                  d2e(2,1) = d2e(1,2)
                  d2e(2,2) = termy*yr + dedr
                  d2e(2,3) = termy*zr
                  d2e(3,1) = d2e(1,3)
                  d2e(3,2) = d2e(2,3)
                  d2e(3,3) = termz*zr + dedr
c
c     increment diagonal and off-diagonal Hessian elements
c
                  do j = 1, 3
                     hessx(j,i) = hessx(j,i) + d2e(1,j)
                     hessy(j,i) = hessy(j,i) + d2e(2,j)
                     hessz(j,i) = hessz(j,i) + d2e(3,j)
                     hessx(j,k) = hessx(j,k) - d2e(1,j)
                     hessy(j,k) = hessy(j,k) - d2e(2,j)
                     hessz(j,k) = hessz(j,k) - d2e(3,j)
                  end do
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction energy with other unit cells
c
         do iii = 1, nlist
            ii = list(iii)
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            chgi = chgct(i)
            alphai = dmpct(i)
            if (alphai .eq. 0.0d0)  alphai = 1000.0d0
            alphai2 = alphai * alphai
            usei = use(i)
            muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = m2scale
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = m3scale
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = m4scale
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = m5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = 1, npole
               k = ipole(kk)
               mutk = mut(k)
               proceed = .true.
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               if (.not. use_intra)  proceed = .true.
               if (proceed)  proceed = (usei .or. use(k))
               if (proceed) then
                  do jcell = 2, ncell
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     call imager (xr,yr,zr,jcell)
                     r2 = xr*xr + yr* yr + zr*zr
                     if (r2 .le. off2) then
                        r = sqrt(r2)
                        rr1 = 1.0d0 / r
                        chgk = chgct(k)
                        alphak = dmpct(k)
                        if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                        if (ctrntyp .eq. 'SEPARATE') then
                           alphak2 = alphak * alphak
                           expi = exp(-alphai*r)
                           expk = exp(-alphak*r)
                           e = -chgi*expk - chgk*expi
                           dedr = chgi*expk*alphak + chgk*expi*alphai
                           d2edr2 = -chgi*expk*alphak2
     &                                 - chgk*expi*alphai2
                        else
                           chgik = sqrt(abs(chgi*chgk))
                           alphaik = 0.5d0 * (alphai+alphak)
                           expik = exp(-alphaik*r)
                           e = -chgik * expik
                           dedr = -e * alphaik
                           d2edr2 = -dedr * alphaik
                        end if
                        e = f * e * mscale(k)
                        dedr = f * dedr * mscale(k)
                        d2edr2 = f * d2edr2 * mscale(k)
c
c     apply lambda scaling for interaction annihilation 
c
                        if (muti .or. mutk) then
                           dedr = dedr * elambda
                           d2edr2 = d2edr2 * elambda
                        end if
c
c     use energy switching if near the cutoff distance
c
                        if (r2 .gt. cut2) then
                           r3 = r2 * r
                           r4 = r2 * r2
                           r5 = r3 * r2
                           taper = c5*r5 + c4*r4 + c3*r3
     &                                + c2*r2 + c1*r + c0
                           dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                                 + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                           d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2
     &                                  + 6.0d0*c3*r + 2.0d0*c2
                           d2e = e*d2taper + 2.0d0*dedr*dtaper
     &                              + d2edr2*taper
                           dedr = e*dtaper + dedr*taper
                        end if
c
c     scale the interaction based on its group membership
c
                        if (use_group) then
                           dedr = dedr * fgrp
                           d2edr2 = d2edr2 * fgrp
                        end if
c
c     set the chain rule terms for the Hessian elements
c
                        if (r2 .eq. 0.0d0) then
                           dedr = 0.0d0
                           term = 0.0d0
                        else
                           dedr = dedr / r
                           term = (d2edr2-dedr) / r2
                        end if
                        termx = term * xr
                        termy = term * yr
                        termz = term * zr
                        d2e(1,1) = termx*xr + dedr
                        d2e(1,2) = termx*yr
                        d2e(1,3) = termx*zr
                        d2e(2,1) = d2e(1,2)
                        d2e(2,2) = termy*yr + dedr
                        d2e(2,3) = termy*zr
                        d2e(3,1) = d2e(1,3)
                        d2e(3,2) = d2e(2,3)
                        d2e(3,3) = termz*zr + dedr
c
c     increment diagonal and off-diagonal Hessian elements
c
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + d2e(1,j)
                           hessy(j,i) = hessy(j,i) + d2e(2,j)
                           hessz(j,i) = hessz(j,i) + d2e(3,j)
                           hessx(j,k) = hessx(j,k) - d2e(1,j)
                           hessy(j,k) = hessy(j,k) - d2e(2,j)
                           hessz(j,k) = hessz(j,k) - d2e(3,j)
                        end do
                     end if
                  end do
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine echgtrn3  --  charge transfer energy & analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "echgtrn3" calculates the charge transfer energy; also partitions
c     the energy among the atoms
c
c
      subroutine echgtrn3
      use limits
      implicit none
c
c
c     choose method for summing over charge transfer interactions
c
      if (use_mlist) then
         call echgtrn3c
      else if (use_lights) then
         call echgtrn3b
      else
         call echgtrn3a
      end if
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine echgtrn3a  --  double loop chgtrn analysis  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "echgtrn3a" calculates the charge transfer interaction energy
c     and also partitions the energy among the atoms using a pairwise
c     double loop
c
c
      subroutine echgtrn3a
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use chgpot
      use chgtrn
      use cell
      use couple
      use ctrpot
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mplpot
      use mpole
      use mutant
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 e,f,fgrp
      real*8 r,r2,r3
      real*8 r4,r5
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 chgi,chgk
      real*8 chgik
      real*8 alphai,alphak
      real*8 expi,expk
      real*8 expik
      real*8 taper
      real*8, allocatable :: mscale(:)
      logical proceed,usei
      logical muti,mutk
      logical header,huge
      character*6 mode
c
c
c     zero out the charge transfer energy and partitioning terms
c
      nect = 0
      ect = 0.0d0
      do i = 1, n
         aect(i) = 0.0d0
      end do
      if (nct .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHGTRN'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nct.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Charge Transfer Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     calculate the charge transfer energy term
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         chgi = chgct(i)
         alphai = dmpct(i)
         if (alphai .eq. 0.0d0)  alphai = 1000.0d0
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  chgk = chgct(k)
                  alphak = dmpct(k)
                  if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                  if (ctrntyp .eq. 'SEPARATE') then
                     expi = exp(-alphai*r)
                     expk = exp(-alphak*r)
                     e = -chgi*expk - chgk*expi
                  else
                     chgik = sqrt(abs(chgi*chgk))
                     expik = exp(-0.5d0*(alphai+alphak)*r)
                     e = -chgik * expik
                  end if
                  e = f * e * mscale(k)
c
c     apply lambda scaling for interaction annihilation 
c
                  if (muti .or. mutk) then
                     e = e * elambda
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c     
c     increment the overall charge transfer energy components
c
                  if (e .ne. 0.0d0) then
                     nect = nect + 1
                     ect = ect + e
                     aect(i) = aect(i) + 0.5d0*e
                     aect(k) = aect(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Charge Transfer',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             15x,'Distance',8x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),r,e
   30                format (' ChgTrn',4x,2(i7,'-',a3),
     &                          9x,f10.4,2x,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction energy with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            chgi = chgct(i)
            alphai = dmpct(i)
            if (alphai .eq. 0.0d0)  alphai = 1000.0d0
            usei = use(i)
            muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = m2scale
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = m3scale
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = m4scale
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = m5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = i, npole
               k = ipole(kk)
               mutk = mut(k)
               proceed = .true.
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               if (.not. use_intra)  proceed = .true.
               if (proceed)  proceed = (usei .or. use(k))
               if (proceed) then
                  do jcell = 2, ncell
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     call imager (xr,yr,zr,jcell)
                     r2 = xr*xr + yr* yr + zr*zr
                     if (r2 .le. off2) then
                        r = sqrt(r2)
                        chgk = chgct(k)
                        alphak = dmpct(k)
                        if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                        if (ctrntyp .eq. 'SEPARATE') then
                           expi = exp(-alphai*r)
                           expk = exp(-alphak*r)
                           e = -chgi*expk - chgk*expi
                        else
                           chgik = sqrt(abs(chgi*chgk))
                           expik = exp(-0.5d0*(alphai+alphak)*r)
                           e = -chgik * expik
                        end if
                        e = f * e * mscale(k)
c
c     apply lambda scaling for interaction annihilation 
c
                        if (muti .or. mutk) then
                           e = e * elambda
                        end if
c
c     use energy switching if near the cutoff distance
c
                        if (r2 .gt. cut2) then
                           r3 = r2 * r
                           r4 = r2 * r2
                           r5 = r2 * r3
                           taper = c5*r5 + c4*r4 + c3*r3
     &                                + c2*r2 + c1*r + c0
                           e = e * taper
                        end if
c
c     scale the interaction based on its group membership
c
                        if (use_group)  e = e * fgrp
c     
c     increment the overall charge transfer energy components
c
                        if (e .ne. 0.0d0) then
                           nect = nect + 1
                           if (i .eq. k) then
                              ect = ect + 0.5d0*e
                              aect(i) = aect(i) + 0.5d0*e
                           else
                              ect = ect + e
                              aect(i) = aect(i) + 0.5d0*e
                              aect(k) = aect(k) + 0.5d0*e
                           end if
                        end if
c
c     increment the total intermolecular energy
c
                        if (molcule(i) .ne. molcule(k)) then
                           einter = einter + e
                        end if
c
c     print a message if the energy of this interaction is large
c
                        huge = (e .gt. 10.0d0)
                        if ((debug.and.e.ne.0.0d0)
     &                        .or. (verbose.and.huge)) then
                           if (header) then
                              header = .false.
                              write (iout,40)
   40                         format (/,' Individual Charge Transfer',
     &                                   ' Interactions :',
     &                                //,' Type',14x,'Atom Names',
     &                                   15x,'Distance',8x,'Energy',/)
                           end if
                           write (iout,50)  i,name(i),k,name(k),r,e
   50                      format (' ChgTrn',4x,2(i7,'-',a3),2x,
     &                                '(XTAL)',1x,f10.4,2x,f12.4)
                        end if
                     end if
                  end do
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine echgtrn3b  --  method lights chgtrn analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "echgtrn3b" calculates the charge transfer interaction energy
c     and also partitions the energy among the atoms using the method
c     of lights
c
c
      subroutine echgtrn3b
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use chgpot
      use chgtrn
      use cell
      use couple
      use ctrpot
      use energi
      use group
      use inform
      use inter
      use iounit
      use light
      use molcul
      use mplpot
      use mpole
      use mutant
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer kgy,kgz
      integer start,stop
      real*8 e,f,fgrp
      real*8 r,r2,r3
      real*8 r4,r5
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 chgi,chgk
      real*8 chgik
      real*8 alphai,alphak
      real*8 expi,expk
      real*8 expik
      real*8 taper
      real*8, allocatable :: mscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei
      logical unique,repeat
      logical muti,mutk
      logical header,huge
      character*6 mode
c
c
c     zero out the charge transfer energy
c
      nect = 0
      ect = 0.0d0
      do i = 1, n
         aect(i) = 0.0d0
      end do
      if (nct .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHGTRN'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nct.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Charge Transfer Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     transfer the interaction site coordinates to sorting arrays
c
      do ii = 1, npole
         i = ipole(ii)
         xsort(ii) = x(i)
         ysort(ii) = y(i)
         zsort(ii) = z(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nct,xsort,ysort,zsort,unique)
c
c     calculate the charge transfer energy term
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         chgi = chgct(i)
         alphai = dmpct(i)
         if (alphai .eq. 0.0d0)  alphai = 1000.0d0
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   20    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 50
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 50
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 50
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 50
            end if
            k = ipole(kk-((kk-1)/npole)*npole)
            mutk = mut(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  chgk = chgct(k)
                  alphak = dmpct(k)
                  if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                  if (ctrntyp .eq. 'SEPARATE') then
                     expi = exp(-alphai*r)
                     expk = exp(-alphak*r)
                     e = -chgi*expk - chgk*expi
                  else
                     chgik = sqrt(abs(chgi*chgk))
                     expik = exp(-0.5d0*(alphai+alphak)*r)
                     e = -chgik * expik
                  end if
                  e = f * e * mscale(k)
c
c     apply lambda scaling for interaction annihilation 
c
                  if (muti .or. mutk) then
                     e = e * elambda
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c     
c     increment the overall charge transfer energy components
c
                  if (e .ne. 0.0d0) then
                     nect = nect + 1
                     ect = ect + e
                     aect(i) = aect(i) + 0.5d0*e
                     aect(k) = aect(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,30)
   30                   format (/,' Individual Charge Transfer',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             15x,'Distance',8x,'Energy',/)
                     end if
                     write (iout,40)  i,name(i),k,name(k),r,e
   40                format (' ChgTrn',4x,2(i7,'-',a3),
     &                          9x,f10.4,2x,f12.4)
                  end if
               end if
            end if
   50       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 20
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine echgtrn3c  --  neighbor list chgtrn analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "echgtrn3c" calculates the charge transfer interaction energy
c     and also partitions the energy among the atoms using a pairwise
c     neighbor list
c
c
      subroutine echgtrn3c
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use chgpot
      use chgtrn
      use cell
      use couple
      use ctrpot
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mplpot
      use mpole
      use mutant
      use neigh
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      real*8 e,f,fgrp
      real*8 r,r2,r3
      real*8 r4,r5
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 chgi,chgk
      real*8 chgik
      real*8 alphai,alphak
      real*8 expi,expk
      real*8 expik
      real*8 taper
      real*8, allocatable :: mscale(:)
      logical proceed,usei
      logical muti,mutk
      logical header,huge
      character*6 mode
c
c     zero out the charge transfer energy and partitioning terms
c
      nect = 0
      ect = 0.0d0
      do i = 1, n
         aect(i) = 0.0d0
      end do
      if (nct .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'CHGTRN'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nct.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Charge Transfer Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,x,y,z,chgct,dmpct,n12,i12,n13,i13,
!$OMP& n14,i14,n15,i15,m2scale,m3scale,m4scale,m5scale,nelst,
!$OMP& elst,use,use_group,use_intra,use_bounds,ctrntyp,f,off2,
!$OMP& elambda,mut,cut2,molcule,c0,c1,c2,c3,c4,c5,name,verbose,
!$OMP& debug,header,iout)
!$OMP& firstprivate(mscale) shared(ect,nect,aect,einter)
!$OMP DO reduction(+:ect,nect,aect,einter)
c
c     compute the charge transfer energy
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         chgi = chgct(i)
         alphai = dmpct(i)
         if (alphai .eq. 0.0d0)  alphai = 1000.0d0
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  chgk = chgct(k)
                  alphak = dmpct(k)
                  if (alphak .eq. 0.0d0)  alphak = 1000.0d0
                  if (ctrntyp .eq. 'SEPARATE') then
                     expi = exp(-alphai*r)
                     expk = exp(-alphak*r)
                     e = -chgi*expk - chgk*expi
                  else
                     chgik = sqrt(abs(chgi*chgk))
                     expik = exp(-0.5d0*(alphai+alphak)*r)
                     e = -chgik * expik
                  end if
                  e = f * e * mscale(k)
c
c     apply lambda scaling for interaction annihilation 
c
                  if (muti .or. mutk) then
                     e = e * elambda
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c     
c     increment the overall charge transfer energy components
c
                  if (e .ne. 0.0d0) then
                     nect = nect + 1
                     ect = ect + e
                     aect(i) = aect(i) + 0.5d0*e
                     aect(k) = aect(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Charge Transfer',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             15x,'Distance',8x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),r,e
   30                format (' ChgTrn',4x,2(i7,'-',a3),
     &                          9x,f10.4,2x,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine edipole  --  dipole-dipole potential energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "edipole" calculates the dipole-dipole interaction energy
c
c
      subroutine edipole
      use atoms
      use bound
      use cell
      use chgpot
      use dipole
      use energi
      use group
      use shunt
      use units
      use usage
      implicit none
      integer i,j,k
      integer i1,i2,k1,k2
      real*8 xi,yi,zi
      real*8 xk,yk,zk
      real*8 xq,yq,zq
      real*8 xr,yr,zr
      real*8 f,fi,fik
      real*8 taper,fgrp
      real*8 e,ri2,rk2,rirkr3
      real*8 doti,dotk,dotp
      real*8 r,r2,r3,r4,r5
      logical proceed
      character*6 mode
c
c
c     zero out the overall dipole interaction energy
c     and set up the constants for the calculation
c
      ed = 0.0d0
      if (ndipole .eq. 0)  return
c
c     set conversion factor and switching function coefficients
c
      f = electric / (debye**2 * dielec)
      mode = 'DIPOLE'
      call switch (mode)
c
c     calculate the pairwise dipole interaction energy term
c
      do i = 1, ndipole-1
         i1 = idpl(1,i)
         i2 = idpl(2,i)
         xi = x(i2) - x(i1)
         yi = y(i2) - y(i1)
         zi = z(i2) - z(i1)
         if (use_polymer)  call imager (xi,yi,zi,-1)
         ri2 = xi*xi + yi*yi + zi*zi
         xq = x(i1) + xi*sdpl(i)
         yq = y(i1) + yi*sdpl(i)
         zq = z(i1) + zi*sdpl(i)
         fi = f * bdpl(i)
c
c     decide whether to compute the current interaction
c
         do k = i+1, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i1,i2,k1,k2,0,0)
            if (proceed)  proceed = (use(i1) .or. use(i2) .or.
     &                                 use(k1) .or. use(k2))
            if (proceed)  proceed = (k1.ne.i1 .and. k1.ne.i2 .and.
     &                                 k2.ne.i1 .and. k2.ne.i2)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xk = x(k2) - x(k1)
               yk = y(k2) - y(k1)
               zk = z(k2) - z(k1)
               if (use_polymer)  call imager (xk,yk,zk,-1)
               xr = xq - x(k1) - xk*sdpl(k)
               yr = yq - y(k1) - yk*sdpl(k)
               zr = zq - z(k1) - zk*sdpl(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  rk2 = xk*xk + yk*yk + zk*zk
                  rirkr3 = sqrt(ri2*rk2*r2) * r2
                  dotp = xi*xk + yi*yk + zi*zk
                  doti = xi*xr + yi*yr + zi*zr
                  dotk = xk*xr + yk*yr + zk*zr
                  fik = fi * bdpl(k)
                  e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall dipole-dipole energy component
c
                  ed = ed + e
               end if
            end if
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do i = 1, ndipole
         i1 = idpl(1,i)
         i2 = idpl(2,i)
         xi = x(i2) - x(i1)
         yi = y(i2) - y(i1)
         zi = z(i2) - z(i1)
         if (use_polymer)  call imager (xi,yi,zi,-1)
         ri2 = xi*xi + yi*yi + zi*zi
         xq = x(i1) + xi*sdpl(i)
         yq = y(i1) + yi*sdpl(i)
         zq = z(i1) + zi*sdpl(i)
         fi = f * bdpl(i)
c
c     decide whether to compute the current interaction
c
         do k = i, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i1,i2,k1,k2,0,0)
            if (proceed)  proceed = (use(i1) .or. use(i2) .or.
     &                                 use(k1) .or. use(k2))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xk = x(k2) - x(k1)
                  yk = y(k2) - y(k1)
                  zk = z(k2) - z(k1)
                  if (use_polymer)  call imager (xk,yk,zk,-1)
                  xr = xq - x(k1) - xk*sdpl(k)
                  yr = yq - y(k1) - yk*sdpl(k)
                  zr = zq - z(k1) - zk*sdpl(k)
                  call imager (xr,yr,zr,j)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     rk2 = xk*xk + yk*yk + zk*zk
                     rirkr3 = sqrt(ri2*rk2*r2) * r2
                     dotp = xi*xk + yi*yk + zi*zk
                     doti = xi*xr + yi*yr + zi*zr
                     dotk = xk*xr + yk*yr + zk*zr
                     fik = fi * bdpl(k)
                     if (use_polymer) then
                        if (r2 .lt. polycut2) then
                           if (k1.eq.i1 .or. k1.eq.i2 .or.
     &                         k2.eq.i1 .or. k2.eq.i2)  fik = 0.0d0
                        end if
                     end if
                     e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3
c
c     use energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        r = sqrt(r2)
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall dipole-dipole energy component
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ed = ed + e
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine edipole1  --  dipole-dipole energy & derivs  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "edipole1" calculates the dipole-dipole interaction energy
c     and first derivatives with respect to Cartesian coordinates
c
c
      subroutine edipole1
      use atoms
      use bound
      use cell
      use chgpot
      use deriv
      use dipole
      use energi
      use group
      use shunt
      use units
      use usage
      use virial
      implicit none
      integer i,j,k
      integer i1,i2,k1,k2
      real*8 xi,yi,zi
      real*8 xk,yk,zk
      real*8 xq,yq,zq
      real*8 xr,yr,zr
      real*8 xq1,yq1,zq1
      real*8 xq2,yq2,zq2
      real*8 f,fi,fik,fgrp
      real*8 e,r2,ri2,rk2,rirkr3
      real*8 doti,dotk,dotp
      real*8 si1,si2,sk1,sk2
      real*8 de,dedr,dedrirk
      real*8 deddoti,deddotk,deddotp
      real*8 termx,termy,termz
      real*8 dedrirkri2,dedrirkrk2
      real*8 termxi,termyi,termzi
      real*8 termxk,termyk,termzk
      real*8 dedxi1,dedyi1,dedzi1
      real*8 dedxi2,dedyi2,dedzi2
      real*8 dedxk1,dedyk1,dedzk1
      real*8 dedxk2,dedyk2,dedzk2
      real*8 r,r3,r4,r5,taper,dtaper
      real*8 dtaperx,dtapery,dtaperz
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
      character*6 mode
c
c
c     zero out the overall dipole interaction energy and derivs,
c     then set up the constants for the calculation
c
      ed = 0.0d0
      do i = 1, n
         ded(1,i) = 0.0d0
         ded(2,i) = 0.0d0
         ded(3,i) = 0.0d0
      end do
      if (ndipole .eq. 0)  return
c
c     set conversion factor and switching function coefficients
c
      f = electric / (debye**2 * dielec)
      mode = 'DIPOLE'
      call switch (mode)
c
c     compute the dipole interaction energy and first derivatives
c
      do i = 1, ndipole-1
         i1 = idpl(1,i)
         i2 = idpl(2,i)
         si1 = 1.0d0 - sdpl(i)
         si2 = sdpl(i)
         xi = x(i2) - x(i1)
         yi = y(i2) - y(i1)
         zi = z(i2) - z(i1)
         if (use_polymer)  call imager (xi,yi,zi,-1)
         ri2 = xi*xi + yi*yi + zi*zi
         xq = x(i1) + xi*si2
         yq = y(i1) + yi*si2
         zq = z(i1) + zi*si2
         fi = f * bdpl(i)
c
c     decide whether to compute the current interaction
c
         do k = i+1, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i1,i2,k1,k2,0,0)
            if (proceed)  proceed = (use(i1) .or. use(i2) .or.
     &                                 use(k1) .or. use(k2))
            if (proceed)  proceed = (k1.ne.i1 .and. k1.ne.i2 .and.
     &                                 k2.ne.i1 .and. k2.ne.i2)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               sk1 = 1.0d0 - sdpl(k)
               sk2 = sdpl(k)
               xk = x(k2) - x(k1)
               yk = y(k2) - y(k1)
               zk = z(k2) - z(k1)
               if (use_polymer)  call imager (xk,yk,zk,-1)
               xr = xq - x(k1) - xk*sk2
               yr = yq - y(k1) - yk*sk2
               zr = zq - z(k1) - zk*sk2
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  rk2 = xk*xk + yk*yk + zk*zk
                  rirkr3 = sqrt(ri2*rk2*r2) * r2
                  dotp = xi*xk + yi*yk + zi*zk
                  doti = xi*xr + yi*yr + zi*zr
                  dotk = xk*xr + yk*yr + zk*zr
                  fik = fi * bdpl(k)
c
c     form the energy and master chain rule term for derivatives
c
                  e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3
                  de = -fik / (rirkr3*r2)
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     secondary chain rule terms for derivative expressions
c
                  deddotp = -de * r2
                  deddoti = de * 3.0d0*dotk
                  deddotk = de * 3.0d0*doti
                  dedr = de * (3.0d0*dotp-15.0d0*doti*dotk/r2)
                  dedrirk = -e
                  dedrirkri2 = dedrirk / ri2
                  dedrirkrk2 = dedrirk / rk2
c
c     more chain rule terms for derivative expressions
c
                  termx = dedr*xr + deddoti*xi + deddotk*xk
                  termy = dedr*yr + deddoti*yi + deddotk*yk
                  termz = dedr*zr + deddoti*zi + deddotk*zk
                  termxi = dedrirkri2*xi + deddotp*xk + deddoti*xr
                  termyi = dedrirkri2*yi + deddotp*yk + deddoti*yr
                  termzi = dedrirkri2*zi + deddotp*zk + deddoti*zr
                  termxk = dedrirkrk2*xk + deddotp*xi + deddotk*xr
                  termyk = dedrirkrk2*yk + deddotp*yi + deddotk*yr
                  termzk = dedrirkrk2*zk + deddotp*zi + deddotk*zr
c
c     finally, the individual first derivative components
c
                  dedxi1 = si1*termx - termxi
                  dedyi1 = si1*termy - termyi
                  dedzi1 = si1*termz - termzi
                  dedxi2 = si2*termx + termxi
                  dedyi2 = si2*termy + termyi
                  dedzi2 = si2*termz + termzi
                  dedxk1 = -sk1*termx - termxk
                  dedyk1 = -sk1*termy - termyk
                  dedzk1 = -sk1*termz - termzk
                  dedxk2 = -sk2*termx + termxk
                  dedyk2 = -sk2*termy + termyk
                  dedzk2 = -sk2*termz + termzk
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     dtaper = dtaper * e/r
                     dtaperx = xr * dtaper
                     dtapery = yr * dtaper
                     dtaperz = zr * dtaper
                     e = e * taper
                     dedxi1 = dedxi1*taper + si1*dtaperx
                     dedyi1 = dedyi1*taper + si1*dtapery
                     dedzi1 = dedzi1*taper + si1*dtaperz
                     dedxi2 = dedxi2*taper + si2*dtaperx
                     dedyi2 = dedyi2*taper + si2*dtapery
                     dedzi2 = dedzi2*taper + si2*dtaperz
                     dedxk1 = dedxk1*taper - sk1*dtaperx
                     dedyk1 = dedyk1*taper - sk1*dtapery
                     dedzk1 = dedzk1*taper - sk1*dtaperz
                     dedxk2 = dedxk2*taper - sk2*dtaperx
                     dedyk2 = dedyk2*taper - sk2*dtapery
                     dedzk2 = dedzk2*taper - sk2*dtaperz
                  end if
c
c     increment the overall energy and derivative expressions
c
                  ed = ed + e
                  ded(1,i1) = ded(1,i1) + dedxi1
                  ded(2,i1) = ded(2,i1) + dedyi1
                  ded(3,i1) = ded(3,i1) + dedzi1
                  ded(1,i2) = ded(1,i2) + dedxi2
                  ded(2,i2) = ded(2,i2) + dedyi2
                  ded(3,i2) = ded(3,i2) + dedzi2
                  ded(1,k1) = ded(1,k1) + dedxk1
                  ded(2,k1) = ded(2,k1) + dedyk1
                  ded(3,k1) = ded(3,k1) + dedzk1
                  ded(1,k2) = ded(1,k2) + dedxk2
                  ded(2,k2) = ded(2,k2) + dedyk2
                  ded(3,k2) = ded(3,k2) + dedzk2
c
c     increment the internal virial tensor components
c
                  xq1 = x(k1) - xq
                  yq1 = y(k1) - yq
                  zq1 = z(k1) - zq
                  xq2 = x(k2) - xq
                  yq2 = y(k2) - yq
                  zq2 = z(k2) - zq
                  vxx = xq1*dedxk1 + xq2*dedxk2
                  vyx = 0.5d0 * (yq1*dedxk1 + yq2*dedxk2
     &                              + xq1*dedyk1 + xq2*dedyk2)
                  vzx = 0.5d0 * (zq1*dedxk1 + zq2*dedxk2
     &                              + xq1*dedzk1 + xq2*dedzk2)
                  vyy = yq1*dedyk1 + yq2*dedyk2
                  vzy = 0.5d0 * (zq1*dedyk1 + zq2*dedyk2
     &                              + yq1*dedzk1 + yq2*dedzk2)
                  vzz = zq1*dedzk1 + zq2*dedzk2
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do i = 1, ndipole
         i1 = idpl(1,i)
         i2 = idpl(2,i)
         si1 = 1.0d0 - sdpl(i)
         si2 = sdpl(i)
         xi = x(i2) - x(i1)
         yi = y(i2) - y(i1)
         zi = z(i2) - z(i1)
         if (use_polymer)  call imager (xi,yi,zi,-1)
         ri2 = xi*xi + yi*yi + zi*zi
         xq = x(i1) + xi*si2
         yq = y(i1) + yi*si2
         zq = z(i1) + zi*si2
         fi = f * bdpl(i)
c
c     decide whether to compute the current interaction
c
         do k = i, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i1,i2,k1,k2,0,0)
            if (proceed)  proceed = (use(i1) .or. use(i2) .or.
     &                                 use(k1) .or. use(k2))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               sk1 = 1.0d0 - sdpl(k)
               sk2 = sdpl(k)
               do j = 2, ncell
                  xk = x(k2) - x(k1)
                  yk = y(k2) - y(k1)
                  zk = z(k2) - z(k1)
                  if (use_polymer)  call imager (xk,yk,zk,-1)
                  xr = xq - x(k1) - xk*sk2
                  yr = yq - y(k1) - yk*sk2
                  zr = zq - z(k1) - zk*sk2
                  call imager (xr,yr,zr,j)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     rk2 = xk*xk + yk*yk + zk*zk
                     rirkr3 = sqrt(ri2*rk2*r2) * r2
                     dotp = xi*xk + yi*yk + zi*zk
                     doti = xi*xr + yi*yr + zi*zr
                     dotk = xk*xr + yk*yr + zk*zr
                     fik = fi * bdpl(k)
                     if (use_polymer) then
                        if (r2 .lt. polycut2) then
                           if (k1.eq.i1 .or. k1.eq.i2 .or.
     &                         k2.eq.i1 .or. k2.eq.i2)  fik = 0.0d0
                        end if
                     end if
c
c     form the energy and master chain rule term for derivatives
c
                     e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3
                     de = -fik / (rirkr3*r2)
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        e = e * fgrp
                        de = de * fgrp
                     end if
c
c     secondary chain rule terms for derivative expressions
c
                     deddotp = -de * r2
                     deddoti = de * 3.0d0*dotk
                     deddotk = de * 3.0d0*doti
                     dedr = de * (3.0d0*dotp-15.0d0*doti*dotk/r2)
                     dedrirk = -e
                     dedrirkri2 = dedrirk / ri2
                     dedrirkrk2 = dedrirk / rk2
c
c     more chain rule terms for derivative expressions
c
                     termx = dedr*xr + deddoti*xi + deddotk*xk
                     termy = dedr*yr + deddoti*yi + deddotk*yk
                     termz = dedr*zr + deddoti*zi + deddotk*zk
                     termxi = dedrirkri2*xi + deddotp*xk + deddoti*xr
                     termyi = dedrirkri2*yi + deddotp*yk + deddoti*yr
                     termzi = dedrirkri2*zi + deddotp*zk + deddoti*zr
                     termxk = dedrirkrk2*xk + deddotp*xi + deddotk*xr
                     termyk = dedrirkrk2*yk + deddotp*yi + deddotk*yr
                     termzk = dedrirkrk2*zk + deddotp*zi + deddotk*zr
c
c     finally, the individual first derivative components
c
                     dedxi1 = si1*termx - termxi
                     dedyi1 = si1*termy - termyi
                     dedzi1 = si1*termz - termzi
                     dedxi2 = si2*termx + termxi
                     dedyi2 = si2*termy + termyi
                     dedzi2 = si2*termz + termzi
                     dedxk1 = -sk1*termx - termxk
                     dedyk1 = -sk1*termy - termyk
                     dedzk1 = -sk1*termz - termzk
                     dedxk2 = -sk2*termx + termxk
                     dedyk2 = -sk2*termy + termyk
                     dedzk2 = -sk2*termz + termzk
c
c     use energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        r = sqrt(r2)
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                              + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                        dtaper = dtaper * e/r
                        dtaperx = xr * dtaper
                        dtapery = yr * dtaper
                        dtaperz = zr * dtaper
                        e = e * taper
                        dedxi1 = dedxi1*taper + si1*dtaperx
                        dedyi1 = dedyi1*taper + si1*dtapery
                        dedzi1 = dedzi1*taper + si1*dtaperz
                        dedxi2 = dedxi2*taper + si2*dtaperx
                        dedyi2 = dedyi2*taper + si2*dtapery
                        dedzi2 = dedzi2*taper + si2*dtaperz
                        dedxk1 = dedxk1*taper - sk1*dtaperx
                        dedyk1 = dedyk1*taper - sk1*dtapery
                        dedzk1 = dedzk1*taper - sk1*dtaperz
                        dedxk2 = dedxk2*taper - sk2*dtaperx
                        dedyk2 = dedyk2*taper - sk2*dtapery
                        dedzk2 = dedzk2*taper - sk2*dtaperz
                     end if
c
c     increment the overall energy and derivative expressions
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ed = ed + e
                     ded(1,i1) = ded(1,i1) + dedxi1
                     ded(2,i1) = ded(2,i1) + dedyi1
                     ded(3,i1) = ded(3,i1) + dedzi1
                     ded(1,i2) = ded(1,i2) + dedxi2
                     ded(2,i2) = ded(2,i2) + dedyi2
                     ded(3,i2) = ded(3,i2) + dedzi2
                     if (i .ne. k) then
                        ded(1,k1) = ded(1,k1) + dedxk1
                        ded(2,k1) = ded(2,k1) + dedyk1
                        ded(3,k1) = ded(3,k1) + dedzk1
                        ded(1,k2) = ded(1,k2) + dedxk2
                        ded(2,k2) = ded(2,k2) + dedyk2
                        ded(3,k2) = ded(3,k2) + dedzk2
                     end if
c
c     increment the internal virial tensor components
c
                     xq1 = x(k1) - xq
                     yq1 = y(k1) - yq
                     zq1 = z(k1) - zq
                     xq2 = x(k2) - xq
                     yq2 = y(k2) - yq
                     zq2 = z(k2) - zq
                     vxx = xq1*dedxk1 + xq2*dedxk2
                     vyx = 0.5d0 * (yq1*dedxk1 + yq2*dedxk2
     &                                 + xq1*dedyk1 + xq2*dedyk2)
                     vzx = 0.5d0 * (zq1*dedxk1 + zq2*dedxk2
     &                                 + xq1*dedzk1 + xq2*dedzk2)
                     vyy = yq1*dedyk1 + yq2*dedyk2
                     vzy = 0.5d0 * (zq1*dedyk1 + zq2*dedyk2
     &                                 + yq1*dedzk1 + yq2*dedzk2)
                     vzz = zq1*dedzk1 + zq2*dedzk2
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine edipole2  --  atomwise dipole-dipole Hessian  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "edipole2" calculates second derivatives of the
c     dipole-dipole interaction energy for a single atom
c
c
      subroutine edipole2 (i)
      use atoms
      use bound
      use cell
      use chgpot
      use dipole
      use group
      use hessn
      use units
      use shunt
      implicit none
      integer i,i1,i2,k1,k2
      integer jcell,idipole,kdipole
      real*8 f,fi,fik,fgrp
      real*8 xi,yi,zi,xk,yk,zk
      real*8 xq,yq,zq,xr,yr,zr
      real*8 e,r2,ri2,rk2,rirkr3
      real*8 doti,dotk,dotp
      real*8 si1,si2,sk1,sk2
      real*8 de,dedr,dedrirk
      real*8 deddoti,deddotk,deddotp
      real*8 termx,termy,termz
      real*8 termxi,termyi,termzi
      real*8 termxk,termyk,termzk
      real*8 enum,r2inv,ri2inv
      real*8 dotik,xrr2,yrr2,zrr2
      real*8 xiri2,yiri2,ziri2
      real*8 xkrk2,ykrk2,zkrk2
      real*8 xixr,xiyr,xizr
      real*8 yixr,yiyr,yizr
      real*8 zixr,ziyr,zizr
      real*8 xkxr,xkyr,xkzr
      real*8 ykxr,ykyr,ykzr
      real*8 zkxr,zkyr,zkzr
      real*8 xixk,xiyk,xizk
      real*8 yixk,yiyk,yizk
      real*8 zixk,ziyk,zizk
      real*8 xrxr,xryr,xrzr
      real*8 yryr,yrzr,zrzr
      real*8 xidotk,yidotk,zidotk
      real*8 xkdoti,ykdoti,zkdoti
      real*8 factor,factori,factork
      real*8 part,partik
      real*8 dedxi1,dedyi1,dedzi1
      real*8 dedxi2,dedyi2,dedzi2
      real*8 dedxk1,dedyk1,dedzk1
      real*8 dedxk2,dedyk2,dedzk2
      real*8 dtdxi1,dtdyi1,dtdzi1
      real*8 dtdxi2,dtdyi2,dtdzi2
      real*8 dtxdxi1,dtxidxi1,dtxkdxi1
      real*8 dtxdxi2,dtxidxi2,dtxkdxi2
      real*8 dtydxi1,dtyidxi1,dtykdxi1
      real*8 dtydxi2,dtyidxi2,dtykdxi2
      real*8 dtzdxi1,dtzidxi1,dtzkdxi1
      real*8 dtzdxi2,dtzidxi2,dtzkdxi2
      real*8 dtxdyi1,dtxidyi1,dtxkdyi1
      real*8 dtxdyi2,dtxidyi2,dtxkdyi2
      real*8 dtydyi1,dtyidyi1,dtykdyi1
      real*8 dtydyi2,dtyidyi2,dtykdyi2
      real*8 dtzdyi1,dtzidyi1,dtzkdyi1
      real*8 dtzdyi2,dtzidyi2,dtzkdyi2
      real*8 dtxdzi1,dtxidzi1,dtxkdzi1
      real*8 dtxdzi2,dtxidzi2,dtxkdzi2
      real*8 dtydzi1,dtyidzi1,dtykdzi1
      real*8 dtydzi2,dtyidzi2,dtykdzi2
      real*8 dtzdzi1,dtzidzi1,dtzkdzi1
      real*8 dtzdzi2,dtzidzi2,dtzkdzi2
      real*8 r,r3,r4,r5
      real*8 taper,dtaper,d2taper
      real*8 dtaperx,dtapery,dtaperz
      real*8 d2taperxx,d2taperyy,d2taperzz
      real*8 d2taperxy,d2taperxz,d2taperyz
      logical proceed
      character*6 mode
c
c
c     set conversion factor and switching function coefficients
c
      if (ndipole .eq. 0)  return
      f = electric / (debye**2 * dielec)
      mode = 'DIPOLE'
      call switch (mode)
c
c     calculate the dipole interaction energy Hessian elements
c
      do idipole = 1, ndipole
         i1 = idpl(1,idipole)
         i2 = idpl(2,idipole)
         si1 = 1.0d0 - sdpl(idipole)
         si2 = sdpl(idipole)
         if (i1.ne.i .and. i2.ne.i)  goto 10
         xi = x(i2) - x(i1)
         yi = y(i2) - y(i1)
         zi = z(i2) - z(i1)
         if (use_polymer)  call imager (xi,yi,zi,-1)
         ri2 = xi*xi + yi*yi + zi*zi
         xq = x(i1) + xi*si2
         yq = y(i1) + yi*si2
         zq = z(i1) + zi*si2
         fi = f * bdpl(idipole)
c
c     decide whether to compute the current interaction
c
         do kdipole = 1, ndipole
            k1 = idpl(1,kdipole)
            k2 = idpl(2,kdipole)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i1,i2,k1,k2,0,0)
            if (proceed)  proceed = (k1.ne.i1 .and. k1.ne.i2 .and.
     &                                 k2.ne.i1 .and. k2.ne.i2)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               sk1 = 1.0d0 - sdpl(kdipole)
               sk2 = sdpl(kdipole)
               xk = x(k2) - x(k1)
               yk = y(k2) - y(k1)
               zk = z(k2) - z(k1)
               if (use_polymer)  call imager (xk,yk,zk,-1)
               xr = xq - x(k1) - xk*sk2
               yr = yq - y(k1) - yk*sk2
               zr = zq - z(k1) - zk*sk2
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  rk2 = xk*xk + yk*yk + zk*zk
                  rirkr3 = sqrt(ri2*rk2*r2) * r2
                  dotp = xi*xk + yi*yk + zi*zk
                  doti = xi*xr + yi*yr + zi*zr
                  dotk = xk*xr + yk*yr + zk*zr
                  fik = fi * bdpl(kdipole)
c
c     some abbreviations used in various chain rule terms
c
                  dotik = doti * dotk
                  enum = dotp*r2 - 3.0d0*dotik
                  r2inv = 15.0d0 / r2
                  ri2inv = 1.0d0 / ri2
                  xrr2 = xr / r2
                  yrr2 = yr / r2
                  zrr2 = zr / r2
                  xiri2 = xi / ri2
                  yiri2 = yi / ri2
                  ziri2 = zi / ri2
                  xkrk2 = xk / rk2
                  ykrk2 = yk / rk2
                  zkrk2 = zk / rk2
                  xixr = xi * xr
                  xiyr = xi * yr
                  xizr = xi * zr
                  yixr = yi * xr
                  yiyr = yi * yr
                  yizr = yi * zr
                  zixr = zi * xr
                  ziyr = zi * yr
                  zizr = zi * zr
                  xkxr = xk * xr
                  xkyr = xk * yr
                  xkzr = xk * zr
                  ykxr = yk * xr
                  ykyr = yk * yr
                  ykzr = yk * zr
                  zkxr = zk * xr
                  zkyr = zk * yr
                  zkzr = zk * zr
                  xixk = xi * xk
                  xiyk = xi * yk
                  xizk = xi * zk
                  yixk = yi * xk
                  yiyk = yi * yk
                  yizk = yi * zk
                  zixk = zi * xk
                  ziyk = zi * yk
                  zizk = zi * zk
                  xrxr = 3.0d0 * xr * xr
                  xryr = 3.0d0 * xr * yr
                  xrzr = 3.0d0 * xr * zr
                  yryr = 3.0d0 * yr * yr
                  yrzr = 3.0d0 * yr * zr
                  zrzr = 3.0d0 * zr * zr
                  xidotk = xi * dotk
                  yidotk = yi * dotk
                  zidotk = zi * dotk
                  xkdoti = xk * doti
                  ykdoti = yk * doti
                  zkdoti = zk * doti
c
c     scale the interaction based on its group membership
c
                  if (use_group)  fik = fik * fgrp
c
c     form the master chain rule term for derivatives
c
                  de = -fik / (rirkr3*r2)
c
c     form the chain rule terms for first derivatives
c
                  deddotp = -de * r2
                  deddoti = de * 3.0d0*dotk
                  deddotk = de * 3.0d0*doti
                  dedr = de * (3.0d0*dotp-15.0d0*dotik/r2)
                  dedrirk = de * enum
c
c     more first derivative chain rule expressions
c
                  termx = dedr*xr + deddoti*xi + deddotk*xk
                  termy = dedr*yr + deddoti*yi + deddotk*yk
                  termz = dedr*zr + deddoti*zi + deddotk*zk
                  termxi = dedrirk*xiri2 + deddotp*xk + deddoti*xr
                  termyi = dedrirk*yiri2 + deddotp*yk + deddoti*yr
                  termzi = dedrirk*ziri2 + deddotp*zk + deddoti*zr
                  termxk = dedrirk*xkrk2 + deddotp*xi + deddotk*xr
                  termyk = dedrirk*ykrk2 + deddotp*yi + deddotk*yr
                  termzk = dedrirk*zkrk2 + deddotp*zi + deddotk*zr
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3
                     dedxi1 = si1*termx - termxi
                     dedyi1 = si1*termy - termyi
                     dedzi1 = si1*termz - termzi
                     dedxi2 = si2*termx + termxi
                     dedyi2 = si2*termy + termyi
                     dedzi2 = si2*termz + termzi
                     dedxk1 = -sk1*termx - termxk
                     dedyk1 = -sk1*termy - termyk
                     dedzk1 = -sk1*termz - termzk
                     dedxk2 = -sk2*termx + termxk
                     dedyk2 = -sk2*termy + termyk
                     dedzk2 = -sk2*termz + termzk
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2
     &                            + 6.0d0*c3*r + 2.0d0*c2
                     dtaper = dtaper / r
                     dtaperx = xr * dtaper
                     dtapery = yr * dtaper
                     dtaperz = zr * dtaper
                     d2taper = e * (d2taper-dtaper)
                     dtaper = e * dtaper
                     d2taperxx = xr*xrr2*d2taper + dtaper
                     d2taperxy = xr*yrr2*d2taper
                     d2taperxz = xr*zrr2*d2taper
                     d2taperyy = yr*yrr2*d2taper + dtaper
                     d2taperyz = yr*zrr2*d2taper
                     d2taperzz = zr*zrr2*d2taper + dtaper
                     de = de * taper
                     termx = termx * taper
                     termy = termy * taper
                     termz = termz * taper
                     termxi = termxi * taper
                     termyi = termyi * taper
                     termzi = termzi * taper
                     termxk = termxk * taper
                     termyk = termyk * taper
                     termzk = termzk * taper
                  end if
c
c     chain rule terms for second derivative components
c
                  if (i .eq. i1) then
                     dtdxi1 = -5.0d0*si1*xrr2 + xiri2
                     part = si1*xkdoti - dotk*xr + si1*xidotk
     &                         - 2.0d0*si1*dotik*xrr2
                     partik = -xk*r2 + 2.0d0*si1*dotp*xr
     &                           - 3.0d0*si1*xkdoti + 3.0d0*xr*dotk
     &                           - 3.0d0*si1*xidotk
                     factor = 3.0d0*si1*dotp - 6.0d0*xkxr
     &                           + 6.0d0*si1*xixk - 3.0d0*dotk
     &                           - r2inv*(xr*part+si1*dotik)
                     factori = 3.0d0*si1*dotk + si1*xkxr + xiri2*partik
     &                            - enum*(ri2inv-2.0d0*xiri2*xiri2)
                     factork = r2 + 3.0d0*si1*doti + si1*xixr
     &                            - xrxr + xkrk2*partik
                     dtxdxi1 = dtdxi1*termx + de*factor
                     dtxidxi1 = dtdxi1*termxi + de*factori
                     dtxkdxi1 = dtdxi1*termxk + de*factork
                     factor = -3.0d0*xkyr - 3.0d0*ykxr + 3.0d0*si1*xiyk
     &                           + 3.0d0*si1*yixk - r2inv*yr*part
                     factori = -2.0d0*si1*ykxr + 3.0d0*si1*xkyr
     &                           + yiri2*partik + 2.0d0*enum*yiri2*xiri2
                     factork = -2.0d0*si1*yixr - xryr + 3.0d0*si1*xiyr
     &                            + ykrk2*partik
                     dtydxi1 = dtdxi1*termy + de*factor
                     dtyidxi1 = dtdxi1*termyi + de*factori
                     dtykdxi1 = dtdxi1*termyk + de*factork
                     factor = -3.0d0*xkzr - 3.0d0*zkxr + 3.0d0*si1*xizk
     &                           + 3.0d0*si1*zixk - r2inv*zr*part
                     factori = -2.0d0*si1*zkxr + 3.0d0*si1*xkzr
     &                           + ziri2*partik + 2.0d0*enum*ziri2*xiri2
                     factork = -2.0d0*si1*zixr - xrzr + 3.0d0*si1*xizr
     &                            + zkrk2*partik
                     dtzdxi1 = dtdxi1*termz + de*factor
                     dtzidxi1 = dtdxi1*termzi + de*factori
                     dtzkdxi1 = dtdxi1*termzk + de*factork
                     dtdyi1 = -5.0d0*si1*yrr2 + yiri2
                     part = si1*ykdoti - dotk*yr + si1*yidotk
     &                         - 2.0d0*si1*dotik*yrr2
                     partik = -yk*r2 + 2.0d0*si1*dotp*yr
     &                           - 3.0d0*si1*ykdoti + 3.0d0*yr*dotk
     &                           - 3.0d0*si1*yidotk
                     factor = -3.0d0*ykxr - 3.0d0*xkyr + 3.0d0*si1*yixk
     &                           + 3.0d0*si1*xiyk - r2inv*xr*part
                     factori = -2.0d0*si1*xkyr + 3.0d0*si1*ykxr
     &                           + xiri2*partik + 2.0d0*enum*xiri2*yiri2
                     factork = -2.0d0*si1*xiyr - xryr + 3.0d0*si1*yixr
     &                            + xkrk2*partik
                     dtxdyi1 = dtdyi1*termx + de*factor
                     dtxidyi1 = dtdyi1*termxi + de*factori
                     dtxkdyi1 = dtdyi1*termxk + de*factork
                     factor = 3.0d0*si1*dotp - 6.0d0*ykyr
     &                           + 6.0d0*si1*yiyk - 3.0d0*dotk
     &                           - r2inv*(yr*part+si1*dotik)
                     factori = 3.0d0*si1*dotk + si1*ykyr + yiri2*partik
     &                            - enum*(ri2inv-2.0d0*yiri2*yiri2)
                     factork = r2 + 3.0d0*si1*doti + si1*yiyr
     &                            - yryr + ykrk2*partik
                     dtydyi1 = dtdyi1*termy + de*factor
                     dtyidyi1 = dtdyi1*termyi + de*factori
                     dtykdyi1 = dtdyi1*termyk + de*factork
                     factor = -3.0d0*ykzr - 3.0d0*zkyr + 3.0d0*si1*yizk
     &                           + 3.0d0*si1*ziyk - r2inv*zr*part
                     factori = -2.0d0*si1*zkyr + 3.0d0*si1*ykzr
     &                           + ziri2*partik + 2.0d0*enum*ziri2*yiri2
                     factork = -2.0d0*si1*ziyr - yrzr + 3.0d0*si1*yizr
     &                            + zkrk2*partik
                     dtzdyi1 = dtdyi1*termz + de*factor
                     dtzidyi1 = dtdyi1*termzi + de*factori
                     dtzkdyi1 = dtdyi1*termzk + de*factork
                     dtdzi1 = -5.0d0*si1*zrr2 + ziri2
                     part = si1*zkdoti - dotk*zr + si1*zidotk
     &                         - 2.0d0*si1*dotik*zrr2
                     partik = -zk*r2 + 2.0d0*si1*dotp*zr
     &                           - 3.0d0*si1*zkdoti + 3.0d0*zr*dotk
     &                           - 3.0d0*si1*zidotk
                     factor = -3.0d0*zkxr - 3.0d0*xkzr + 3.0d0*si1*zixk
     &                           + 3.0d0*si1*xizk - r2inv*xr*part
                     factori = -2.0d0*si1*xkzr + 3.0d0*si1*zkxr
     &                           + xiri2*partik + 2.0d0*enum*xiri2*ziri2
                     factork = -2.0d0*si1*xizr - xrzr + 3.0d0*si1*zixr
     &                            + xkrk2*partik
                     dtxdzi1 = dtdzi1*termx + de*factor
                     dtxidzi1 = dtdzi1*termxi + de*factori
                     dtxkdzi1 = dtdzi1*termxk + de*factork
                     factor = -3.0d0*zkyr - 3.0d0*ykzr + 3.0d0*si1*ziyk
     &                           + 3.0d0*si1*yizk - r2inv*yr*part
                     factori = -2.0d0*si1*ykzr + 3.0d0*si1*zkyr
     &                           + yiri2*partik + 2.0d0*enum*yiri2*ziri2
                     factork = -2.0d0*si1*yizr - yrzr + 3.0d0*si1*ziyr
     &                            + ykrk2*partik
                     dtydzi1 = dtdzi1*termy + de*factor
                     dtyidzi1 = dtdzi1*termyi + de*factori
                     dtykdzi1 = dtdzi1*termyk + de*factork
                     factor = 3.0d0*si1*dotp - 6.0d0*zkzr
     &                           + 6.0d0*si1*zizk - 3.0d0*dotk
     &                           - r2inv*(zr*part+si1*dotik)
                     factori = 3.0d0*si1*dotk + si1*zkzr + ziri2*partik
     &                            - enum*(ri2inv-2.0d0*ziri2*ziri2)
                     factork = r2 + 3.0d0*si1*doti + si1*zizr
     &                            - zrzr + zkrk2*partik
                     dtzdzi1 = dtdzi1*termz + de*factor
                     dtzidzi1 = dtdzi1*termzi + de*factori
                     dtzkdzi1 = dtdzi1*termzk + de*factork
                  else if (i .eq. i2) then
                     dtdxi2 = -5.0d0*si2*xrr2 - xiri2
                     part = si2*xkdoti + dotk*xr + si2*xidotk
     &                         - 2.0d0*si2*dotik*xrr2
                     partik = xk*r2 + 2.0d0*si2*dotp*xr
     &                           - 3.0d0*si2*xkdoti - 3.0d0*xr*dotk
     &                           - 3.0d0*si2*xidotk
                     factor = 3.0d0*si2*dotp + 6.0d0*xkxr
     &                           + 6.0d0*si2*xixk + 3.0d0*dotk
     &                           - r2inv*(xr*part+si2*dotik)
                     factori = 3.0d0*si2*dotk + si2*xkxr + xiri2*partik
     &                            + enum*(ri2inv-2.0d0*xiri2*xiri2)
                     factork = -r2 + 3.0d0*si2*doti + si2*xixr
     &                            + xrxr + xkrk2*partik
                     dtxdxi2 = dtdxi2*termx + de*factor
                     dtxidxi2 = dtdxi2*termxi + de*factori
                     dtxkdxi2 = dtdxi2*termxk + de*factork
                     factor = 3.0d0*xkyr + 3.0d0*ykxr + 3.0d0*si2*xiyk
     &                           + 3.0d0*si2*yixk - r2inv*yr*part
                     factori = -2.0d0*si2*ykxr + 3.0d0*si2*xkyr
     &                           + yiri2*partik - 2.0d0*enum*yiri2*xiri2
                     factork = -2.0d0*si2*yixr + xryr + 3.0d0*si2*xiyr
     &                            + ykrk2*partik
                     dtydxi2 = dtdxi2*termy + de*factor
                     dtyidxi2 = dtdxi2*termyi + de*factori
                     dtykdxi2 = dtdxi2*termyk + de*factork
                     factor = 3.0d0*xkzr + 3.0d0*zkxr + 3.0d0*si2*xizk
     &                           + 3.0d0*si2*zixk - r2inv*zr*part
                     factori = -2.0d0*si2*zkxr + 3.0d0*si2*xkzr
     &                           + ziri2*partik - 2.0d0*enum*ziri2*xiri2
                     factork = -2.0d0*si2*zixr + xrzr + 3.0d0*si2*xizr
     &                            + zkrk2*partik
                     dtzdxi2 = dtdxi2*termz + de*factor
                     dtzidxi2 = dtdxi2*termzi + de*factori
                     dtzkdxi2 = dtdxi2*termzk + de*factork
                     dtdyi2 = -5.0d0*si2*yrr2 - yiri2
                     part = si2*ykdoti + dotk*yr + si2*yidotk
     &                         - 2.0d0*si2*dotik*yrr2
                     partik = yk*r2 + 2.0d0*si2*dotp*yr
     &                           - 3.0d0*si2*ykdoti - 3.0d0*yr*dotk
     &                           - 3.0d0*si2*yidotk
                     factor = 3.0d0*ykxr + 3.0d0*xkyr + 3.0d0*si2*yixk
     &                           + 3.0d0*si2*xiyk - r2inv*xr*part
                     factori = -2.0d0*si2*xkyr + 3.0d0*si2*ykxr
     &                           + xiri2*partik - 2.0d0*enum*xiri2*yiri2
                     factork = -2.0d0*si2*xiyr + xryr + 3.0d0*si2*yixr
     &                            + xkrk2*partik
                     dtxdyi2 = dtdyi2*termx + de*factor
                     dtxidyi2 = dtdyi2*termxi + de*factori
                     dtxkdyi2 = dtdyi2*termxk + de*factork
                     factor = 3.0d0*si2*dotp + 6.0d0*ykyr
     &                           + 6.0d0*si2*yiyk + 3.0d0*dotk
     &                           - r2inv*(yr*part+si2*dotik)
                     factori = 3.0d0*si2*dotk + si2*ykyr + yiri2*partik
     &                            + enum*(ri2inv-2.0d0*yiri2*yiri2)
                     factork = -r2 + 3.0d0*si2*doti + si2*yiyr
     &                            + yryr + ykrk2*partik
                     dtydyi2 = dtdyi2*termy + de*factor
                     dtyidyi2 = dtdyi2*termyi + de*factori
                     dtykdyi2 = dtdyi2*termyk + de*factork
                     factor = 3.0d0*ykzr + 3.0d0*zkyr + 3.0d0*si2*yizk
     &                           + 3.0d0*si2*ziyk - r2inv*zr*part
                     factori = -2.0d0*si2*zkyr + 3.0d0*si2*ykzr
     &                           + ziri2*partik - 2.0d0*enum*ziri2*yiri2
                     factork = -2.0d0*si2*ziyr + yrzr + 3.0d0*si2*yizr
     &                            + zkrk2*partik
                     dtzdyi2 = dtdyi2*termz + de*factor
                     dtzidyi2 = dtdyi2*termzi + de*factori
                     dtzkdyi2 = dtdyi2*termzk + de*factork
                     dtdzi2 = -5.0d0*si2*zrr2 - ziri2
                     part = si2*zkdoti + dotk*zr + si2*zidotk
     &                         - 2.0d0*si2*dotik*zrr2
                     partik = zk*r2 + 2.0d0*si2*dotp*zr
     &                           - 3.0d0*si2*zkdoti - 3.0d0*zr*dotk
     &                           - 3.0d0*si2*zidotk
                     factor = 3.0d0*zkxr + 3.0d0*xkzr + 3.0d0*si2*zixk
     &                           + 3.0d0*si2*xizk - r2inv*xr*part
                     factori = -2.0d0*si2*xkzr + 3.0d0*si2*zkxr
     &                           + xiri2*partik - 2.0d0*enum*xiri2*ziri2
                     factork = -2.0d0*si2*xizr + xrzr + 3.0d0*si2*zixr
     &                            + xkrk2*partik
                     dtxdzi2 = dtdzi2*termx + de*factor
                     dtxidzi2 = dtdzi2*termxi + de*factori
                     dtxkdzi2 = dtdzi2*termxk + de*factork
                     factor = 3.0d0*zkyr + 3.0d0*ykzr + 3.0d0*si2*ziyk
     &                           + 3.0d0*si2*yizk - r2inv*yr*part
                     factori = -2.0d0*si2*ykzr + 3.0d0*si2*zkyr
     &                           + yiri2*partik - 2.0d0*enum*yiri2*ziri2
                     factork = -2.0d0*si2*yizr + yrzr + 3.0d0*si2*ziyr
     &                            + ykrk2*partik
                     dtydzi2 = dtdzi2*termy + de*factor
                     dtyidzi2 = dtdzi2*termyi + de*factori
                     dtykdzi2 = dtdzi2*termyk + de*factork
                     factor = 3.0d0*si2*dotp + 6.0d0*zkzr
     &                           + 6.0d0*si2*zizk + 3.0d0*dotk
     &                           - r2inv*(zr*part+si2*dotik)
                     factori = 3.0d0*si2*dotk + si2*zkzr + ziri2*partik
     &                            + enum*(ri2inv-2.0d0*ziri2*ziri2)
                     factork = -r2 + 3.0d0*si2*doti + si2*zizr
     &                            + zrzr + zkrk2*partik
                     dtzdzi2 = dtdzi2*termz + de*factor
                     dtzidzi2 = dtdzi2*termzi + de*factori
                     dtzkdzi2 = dtdzi2*termzk + de*factork
                  end if
c
c     increment diagonal and off-diagonal Hessian elements
c
                  if (i .eq. i1) then
                     hessx(1,i1) = hessx(1,i1) + si1*dtxdxi1 - dtxidxi1
                     hessx(2,i1) = hessx(2,i1) + si1*dtydxi1 - dtyidxi1
                     hessx(3,i1) = hessx(3,i1) + si1*dtzdxi1 - dtzidxi1
                     hessx(1,i2) = hessx(1,i2) + si2*dtxdxi1 + dtxidxi1
                     hessx(2,i2) = hessx(2,i2) + si2*dtydxi1 + dtyidxi1
                     hessx(3,i2) = hessx(3,i2) + si2*dtzdxi1 + dtzidxi1
                     hessx(1,k1) = hessx(1,k1) - sk1*dtxdxi1 - dtxkdxi1
                     hessx(2,k1) = hessx(2,k1) - sk1*dtydxi1 - dtykdxi1
                     hessx(3,k1) = hessx(3,k1) - sk1*dtzdxi1 - dtzkdxi1
                     hessx(1,k2) = hessx(1,k2) - sk2*dtxdxi1 + dtxkdxi1
                     hessx(2,k2) = hessx(2,k2) - sk2*dtydxi1 + dtykdxi1
                     hessx(3,k2) = hessx(3,k2) - sk2*dtzdxi1 + dtzkdxi1
                     hessy(1,i1) = hessy(1,i1) + si1*dtxdyi1 - dtxidyi1
                     hessy(2,i1) = hessy(2,i1) + si1*dtydyi1 - dtyidyi1
                     hessy(3,i1) = hessy(3,i1) + si1*dtzdyi1 - dtzidyi1
                     hessy(1,i2) = hessy(1,i2) + si2*dtxdyi1 + dtxidyi1
                     hessy(3,i2) = hessy(3,i2) + si2*dtzdyi1 + dtzidyi1
                     hessy(2,i2) = hessy(2,i2) + si2*dtydyi1 + dtyidyi1
                     hessy(1,k1) = hessy(1,k1) - sk1*dtxdyi1 - dtxkdyi1
                     hessy(2,k1) = hessy(2,k1) - sk1*dtydyi1 - dtykdyi1
                     hessy(3,k1) = hessy(3,k1) - sk1*dtzdyi1 - dtzkdyi1
                     hessy(1,k2) = hessy(1,k2) - sk2*dtxdyi1 + dtxkdyi1
                     hessy(2,k2) = hessy(2,k2) - sk2*dtydyi1 + dtykdyi1
                     hessy(3,k2) = hessy(3,k2) - sk2*dtzdyi1 + dtzkdyi1
                     hessz(1,i1) = hessz(1,i1) + si1*dtxdzi1 - dtxidzi1
                     hessz(2,i1) = hessz(2,i1) + si1*dtydzi1 - dtyidzi1
                     hessz(3,i1) = hessz(3,i1) + si1*dtzdzi1 - dtzidzi1
                     hessz(1,i2) = hessz(1,i2) + si2*dtxdzi1 + dtxidzi1
                     hessz(2,i2) = hessz(2,i2) + si2*dtydzi1 + dtyidzi1
                     hessz(3,i2) = hessz(3,i2) + si2*dtzdzi1 + dtzidzi1
                     hessz(1,k1) = hessz(1,k1) - sk1*dtxdzi1 - dtxkdzi1
                     hessz(2,k1) = hessz(2,k1) - sk1*dtydzi1 - dtykdzi1
                     hessz(3,k1) = hessz(3,k1) - sk1*dtzdzi1 - dtzkdzi1
                     hessz(1,k2) = hessz(1,k2) - sk2*dtxdzi1 + dtxkdzi1
                     hessz(2,k2) = hessz(2,k2) - sk2*dtydzi1 + dtykdzi1
                     hessz(3,k2) = hessz(3,k2) - sk2*dtzdzi1 + dtzkdzi1
                  else if (i .eq. i2) then
                     hessx(1,i1) = hessx(1,i1) + si1*dtxdxi2 - dtxidxi2
                     hessx(2,i1) = hessx(2,i1) + si1*dtydxi2 - dtyidxi2
                     hessx(3,i1) = hessx(3,i1) + si1*dtzdxi2 - dtzidxi2
                     hessx(1,i2) = hessx(1,i2) + si2*dtxdxi2 + dtxidxi2
                     hessx(2,i2) = hessx(2,i2) + si2*dtydxi2 + dtyidxi2
                     hessx(3,i2) = hessx(3,i2) + si2*dtzdxi2 + dtzidxi2
                     hessx(1,k1) = hessx(1,k1) - sk1*dtxdxi2 - dtxkdxi2
                     hessx(2,k1) = hessx(2,k1) - sk1*dtydxi2 - dtykdxi2
                     hessx(3,k1) = hessx(3,k1) - sk1*dtzdxi2 - dtzkdxi2
                     hessx(1,k2) = hessx(1,k2) - sk2*dtxdxi2 + dtxkdxi2
                     hessx(2,k2) = hessx(2,k2) - sk2*dtydxi2 + dtykdxi2
                     hessx(3,k2) = hessx(3,k2) - sk2*dtzdxi2 + dtzkdxi2
                     hessy(1,i1) = hessy(1,i1) + si1*dtxdyi2 - dtxidyi2
                     hessy(2,i1) = hessy(2,i1) + si1*dtydyi2 - dtyidyi2
                     hessy(3,i1) = hessy(3,i1) + si1*dtzdyi2 - dtzidyi2
                     hessy(1,i2) = hessy(1,i2) + si2*dtxdyi2 + dtxidyi2
                     hessy(2,i2) = hessy(2,i2) + si2*dtydyi2 + dtyidyi2
                     hessy(3,i2) = hessy(3,i2) + si2*dtzdyi2 + dtzidyi2
                     hessy(1,k1) = hessy(1,k1) - sk1*dtxdyi2 - dtxkdyi2
                     hessy(2,k1) = hessy(2,k1) - sk1*dtydyi2 - dtykdyi2
                     hessy(3,k1) = hessy(3,k1) - sk1*dtzdyi2 - dtzkdyi2
                     hessy(1,k2) = hessy(1,k2) - sk2*dtxdyi2 + dtxkdyi2
                     hessy(2,k2) = hessy(2,k2) - sk2*dtydyi2 + dtykdyi2
                     hessy(3,k2) = hessy(3,k2) - sk2*dtzdyi2 + dtzkdyi2
                     hessz(1,i1) = hessz(1,i1) + si1*dtxdzi2 - dtxidzi2
                     hessz(2,i1) = hessz(2,i1) + si1*dtydzi2 - dtyidzi2
                     hessz(3,i1) = hessz(3,i1) + si1*dtzdzi2 - dtzidzi2
                     hessz(1,i2) = hessz(1,i2) + si2*dtxdzi2 + dtxidzi2
                     hessz(2,i2) = hessz(2,i2) + si2*dtydzi2 + dtyidzi2
                     hessz(3,i2) = hessz(3,i2) + si2*dtzdzi2 + dtzidzi2
                     hessz(1,k1) = hessz(1,k1) - sk1*dtxdzi2 - dtxkdzi2
                     hessz(2,k1) = hessz(2,k1) - sk1*dtydzi2 - dtykdzi2
                     hessz(3,k1) = hessz(3,k1) - sk1*dtzdzi2 - dtzkdzi2
                     hessz(1,k2) = hessz(1,k2) - sk2*dtxdzi2 + dtxkdzi2
                     hessz(2,k2) = hessz(2,k2) - sk2*dtydzi2 + dtykdzi2
                     hessz(3,k2) = hessz(3,k2) - sk2*dtzdzi2 + dtzkdzi2
                  end if
c
c     more energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     if (i .eq. i1) then
                        hessx(1,i1) = hessx(1,i1) + si1*dtaperx*dedxi1
     &                         + si1*dtaperx*dedxi1 + si1*si1*d2taperxx
                        hessx(2,i1) = hessx(2,i1) + si1*dtapery*dedxi1
     &                         + si1*dtaperx*dedyi1 + si1*si1*d2taperxy
                        hessx(3,i1) = hessx(3,i1) + si1*dtaperz*dedxi1
     &                         + si1*dtaperx*dedzi1 + si1*si1*d2taperxz
                        hessx(1,i2) = hessx(1,i2) + si2*dtaperx*dedxi1
     &                         + si1*dtaperx*dedxi2 + si2*si1*d2taperxx
                        hessx(2,i2) = hessx(2,i2) + si2*dtapery*dedxi1
     &                         + si1*dtaperx*dedyi2 + si2*si1*d2taperxy
                        hessx(3,i2) = hessx(3,i2) + si2*dtaperz*dedxi1
     &                         + si1*dtaperx*dedzi2 + si2*si1*d2taperxz
                        hessx(1,k1) = hessx(1,k1) - sk1*dtaperx*dedxi1
     &                         + si1*dtaperx*dedxk1 - sk1*si1*d2taperxx
                        hessx(2,k1) = hessx(2,k1) - sk1*dtapery*dedxi1
     &                         + si1*dtaperx*dedyk1 - sk1*si1*d2taperxy
                        hessx(3,k1) = hessx(3,k1) - sk1*dtaperz*dedxi1
     &                         + si1*dtaperx*dedzk1 - sk1*si1*d2taperxz
                        hessx(1,k2) = hessx(1,k2) - sk2*dtaperx*dedxi1
     &                         + si1*dtaperx*dedxk2 - sk2*si1*d2taperxx
                        hessx(2,k2) = hessx(2,k2) - sk2*dtapery*dedxi1
     &                         + si1*dtaperx*dedyk2 - sk2*si1*d2taperxy
                        hessx(3,k2) = hessx(3,k2) - sk2*dtaperz*dedxi1
     &                         + si1*dtaperx*dedzk2 - sk2*si1*d2taperxz
                        hessy(1,i1) = hessy(1,i1) + si1*dtaperx*dedyi1
     &                         + si1*dtapery*dedxi1 + si1*si1*d2taperxy
                        hessy(2,i1) = hessy(2,i1) + si1*dtapery*dedyi1
     &                         + si1*dtapery*dedyi1 + si1*si1*d2taperyy
                        hessy(3,i1) = hessy(3,i1) + si1*dtaperz*dedyi1
     &                         + si1*dtapery*dedzi1 + si1*si1*d2taperyz
                        hessy(1,i2) = hessy(1,i2) + si2*dtaperx*dedyi1
     &                         + si1*dtapery*dedxi2 + si2*si1*d2taperxy
                        hessy(2,i2) = hessy(2,i2) + si2*dtapery*dedyi1
     &                         + si1*dtapery*dedyi2 + si2*si1*d2taperyy
                        hessy(3,i2) = hessy(3,i2) + si2*dtaperz*dedyi1
     &                         + si1*dtapery*dedzi2 + si2*si1*d2taperyz
                        hessy(1,k1) = hessy(1,k1) - sk1*dtaperx*dedyi1
     &                         + si1*dtapery*dedxk1 - sk1*si1*d2taperxy
                        hessy(2,k1) = hessy(2,k1) - sk1*dtapery*dedyi1
     &                         + si1*dtapery*dedyk1 - sk1*si1*d2taperyy
                        hessy(3,k1) = hessy(3,k1) - sk1*dtaperz*dedyi1
     &                         + si1*dtapery*dedzk1 - sk1*si1*d2taperyz
                        hessy(1,k2) = hessy(1,k2) - sk2*dtaperx*dedyi1
     &                         + si1*dtapery*dedxk2 - sk2*si1*d2taperxy
                        hessy(2,k2) = hessy(2,k2) - sk2*dtapery*dedyi1
     &                         + si1*dtapery*dedyk2 - sk2*si1*d2taperyy
                        hessy(3,k2) = hessy(3,k2) - sk2*dtaperz*dedyi1
     &                         + si1*dtapery*dedzk2 - sk2*si1*d2taperyz
                        hessz(1,i1) = hessz(1,i1) + si1*dtaperx*dedzi1
     &                         + si1*dtaperz*dedxi1 + si1*si1*d2taperxz
                        hessz(2,i1) = hessz(2,i1) + si1*dtapery*dedzi1
     &                         + si1*dtaperz*dedyi1 + si1*si1*d2taperyz
                        hessz(3,i1) = hessz(3,i1) + si1*dtaperz*dedzi1
     &                         + si1*dtaperz*dedzi1 + si1*si1*d2taperzz
                        hessz(1,i2) = hessz(1,i2) + si2*dtaperx*dedzi1
     &                         + si1*dtaperz*dedxi2 + si2*si1*d2taperxz
                        hessz(2,i2) = hessz(2,i2) + si2*dtapery*dedzi1
     &                         + si1*dtaperz*dedyi2 + si2*si1*d2taperyz
                        hessz(3,i2) = hessz(3,i2) + si2*dtaperz*dedzi1
     &                         + si1*dtaperz*dedzi2 + si2*si1*d2taperzz
                        hessz(1,k1) = hessz(1,k1) - sk1*dtaperx*dedzi1
     &                         + si1*dtaperz*dedxk1 - sk1*si1*d2taperxz
                        hessz(2,k1) = hessz(2,k1) - sk1*dtapery*dedzi1
     &                         + si1*dtaperz*dedyk1 - sk1*si1*d2taperyz
                        hessz(3,k1) = hessz(3,k1) - sk1*dtaperz*dedzi1
     &                         + si1*dtaperz*dedzk1 - sk1*si1*d2taperzz
                        hessz(1,k2) = hessz(1,k2) - sk2*dtaperx*dedzi1
     &                         + si1*dtaperz*dedxk2 - sk2*si1*d2taperxz
                        hessz(2,k2) = hessz(2,k2) - sk2*dtapery*dedzi1
     &                         + si1*dtaperz*dedyk2 - sk2*si1*d2taperyz
                        hessz(3,k2) = hessz(3,k2) - sk2*dtaperz*dedzi1
     &                         + si1*dtaperz*dedzk2 - sk2*si1*d2taperzz
                     else if (i .eq. i2) then
                        hessx(1,i1) = hessx(1,i1) + si1*dtaperx*dedxi2
     &                         + si2*dtaperx*dedxi1 + si1*si2*d2taperxx
                        hessx(2,i1) = hessx(2,i1) + si1*dtapery*dedxi2
     &                         + si2*dtaperx*dedyi1 + si1*si2*d2taperxy
                        hessx(3,i1) = hessx(3,i1) + si1*dtaperz*dedxi2
     &                         + si2*dtaperx*dedzi1 + si1*si2*d2taperxz
                        hessx(1,i2) = hessx(1,i2) + si2*dtaperx*dedxi2
     &                         + si2*dtaperx*dedxi2 + si2*si2*d2taperxx
                        hessx(2,i2) = hessx(2,i2) + si2*dtapery*dedxi2
     &                         + si2*dtaperx*dedyi2 + si2*si2*d2taperxy
                        hessx(3,i2) = hessx(3,i2) + si2*dtaperz*dedxi2
     &                         + si2*dtaperx*dedzi2 + si2*si2*d2taperxz
                        hessx(1,k1) = hessx(1,k1) - sk1*dtaperx*dedxi2
     &                         + si2*dtaperx*dedxk1 - sk1*si2*d2taperxx
                        hessx(2,k1) = hessx(2,k1) - sk1*dtapery*dedxi2
     &                         + si2*dtaperx*dedyk1 - sk1*si2*d2taperxy
                        hessx(3,k1) = hessx(3,k1) - sk1*dtaperz*dedxi2
     &                         + si2*dtaperx*dedzk1 - sk1*si2*d2taperxz
                        hessx(1,k2) = hessx(1,k2) - sk2*dtaperx*dedxi2
     &                         + si2*dtaperx*dedxk2 - sk2*si2*d2taperxx
                        hessx(2,k2) = hessx(2,k2) - sk2*dtapery*dedxi2
     &                         + si2*dtaperx*dedyk2 - sk2*si2*d2taperxy
                        hessx(3,k2) = hessx(3,k2) - sk2*dtaperz*dedxi2
     &                         + si2*dtaperx*dedzk2 - sk2*si2*d2taperxz
                        hessy(1,i1) = hessy(1,i1) + si1*dtaperx*dedyi2
     &                         + si2*dtapery*dedxi1 + si1*si2*d2taperxy
                        hessy(2,i1) = hessy(2,i1) + si1*dtapery*dedyi2
     &                         + si2*dtapery*dedyi1 + si1*si2*d2taperyy
                        hessy(3,i1) = hessy(3,i1) + si1*dtaperz*dedyi2
     &                         + si2*dtapery*dedzi1 + si1*si2*d2taperyz
                        hessy(1,i2) = hessy(1,i2) + si2*dtaperx*dedyi2
     &                         + si2*dtapery*dedxi2 + si2*si2*d2taperxy
                        hessy(2,i2) = hessy(2,i2) + si2*dtapery*dedyi2
     &                         + si2*dtapery*dedyi2 + si2*si2*d2taperyy
                        hessy(3,i2) = hessy(3,i2) + si2*dtaperz*dedyi2
     &                         + si2*dtapery*dedzi2 + si2*si2*d2taperyz
                        hessy(1,k1) = hessy(1,k1) - sk1*dtaperx*dedyi2
     &                         + si2*dtapery*dedxk1 - sk1*si2*d2taperxy
                        hessy(2,k1) = hessy(2,k1) - sk1*dtapery*dedyi2
     &                         + si2*dtapery*dedyk1 - sk1*si2*d2taperyy
                        hessy(3,k1) = hessy(3,k1) - sk1*dtaperz*dedyi2
     &                         + si2*dtapery*dedzk1 - sk1*si2*d2taperyz
                        hessy(1,k2) = hessy(1,k2) - sk2*dtaperx*dedyi2
     &                         + si2*dtapery*dedxk2 - sk2*si2*d2taperxy
                        hessy(2,k2) = hessy(2,k2) - sk2*dtapery*dedyi2
     &                         + si2*dtapery*dedyk2 - sk2*si2*d2taperyy
                        hessy(3,k2) = hessy(3,k2) - sk2*dtaperz*dedyi2
     &                         + si2*dtapery*dedzk2 - sk2*si2*d2taperyz
                        hessz(1,i1) = hessz(1,i1) + si1*dtaperx*dedzi2
     &                         + si2*dtaperz*dedxi1 + si1*si2*d2taperxz
                        hessz(2,i1) = hessz(2,i1) + si1*dtapery*dedzi2
     &                         + si2*dtaperz*dedyi1 + si1*si2*d2taperyz
                        hessz(3,i1) = hessz(3,i1) + si1*dtaperz*dedzi2
     &                         + si2*dtaperz*dedzi1 + si1*si2*d2taperzz
                        hessz(1,i2) = hessz(1,i2) + si2*dtaperx*dedzi2
     &                         + si2*dtaperz*dedxi2 + si2*si2*d2taperxz
                        hessz(2,i2) = hessz(2,i2) + si2*dtapery*dedzi2
     &                         + si2*dtaperz*dedyi2 + si2*si2*d2taperyz
                        hessz(3,i2) = hessz(3,i2) + si2*dtaperz*dedzi2
     &                         + si2*dtaperz*dedzi2 + si2*si2*d2taperzz
                        hessz(1,k1) = hessz(1,k1) - sk1*dtaperx*dedzi2
     &                         + si2*dtaperz*dedxk1 - sk1*si2*d2taperxz
                        hessz(2,k1) = hessz(2,k1) - sk1*dtapery*dedzi2
     &                         + si2*dtaperz*dedyk1 - sk1*si2*d2taperyz
                        hessz(3,k1) = hessz(3,k1) - sk1*dtaperz*dedzi2
     &                         + si2*dtaperz*dedzk1 - sk1*si2*d2taperzz
                        hessz(1,k2) = hessz(1,k2) - sk2*dtaperx*dedzi2
     &                         + si2*dtaperz*dedxk2 - sk2*si2*d2taperxz
                        hessz(2,k2) = hessz(2,k2) - sk2*dtapery*dedzi2
     &                         + si2*dtaperz*dedyk2 - sk2*si2*d2taperyz
                        hessz(3,k2) = hessz(3,k2) - sk2*dtaperz*dedzi2
     &                         + si2*dtaperz*dedzk2 - sk2*si2*d2taperzz
                     end if
                  end if
               end if
            end if
         end do
   10    continue
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do idipole = 1, ndipole
         i1 = idpl(1,idipole)
         i2 = idpl(2,idipole)
         si1 = 1.0d0 - sdpl(idipole)
         si2 = sdpl(idipole)
         if (i1.ne.i .and. i2.ne.i)  goto 30
         xi = x(i2) - x(i1)
         yi = y(i2) - y(i1)
         zi = z(i2) - z(i1)
         if (use_polymer)  call imager (xi,yi,zi,-1)
         ri2 = xi*xi + yi*yi + zi*zi
         xq = x(i1) + xi*si2
         yq = y(i1) + yi*si2
         zq = z(i1) + zi*si2
         fi = f * bdpl(idipole)
c
c     decide whether to compute the current interaction
c
         do kdipole = 1, ndipole
            k1 = idpl(1,kdipole)
            k2 = idpl(2,kdipole)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i1,i2,k1,k2,0,0)
            if (.not. proceed)  goto 20
c
c     compute the energy contribution for this interaction
c
            sk1 = 1.0d0 - sdpl(kdipole)
            sk2 = sdpl(kdipole)
            do jcell = 2, ncell
               xk = x(k2) - x(k1)
               yk = y(k2) - y(k1)
               zk = z(k2) - z(k1)
               if (use_polymer)  call imager (xk,yk,zk,-1)
               xr = xq - x(k1) - xk*sk2
               yr = yq - y(k1) - yk*sk2
               zr = zq - z(k1) - zk*sk2
               call imager (xr,yr,zr,jcell)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  rk2 = xk*xk + yk*yk + zk*zk
                  rirkr3 = sqrt(ri2*rk2*r2) * r2
                  dotp = xi*xk + yi*yk + zi*zk
                  doti = xi*xr + yi*yr + zi*zr
                  dotk = xk*xr + yk*yr + zk*zr
                  fik = fi * bdpl(kdipole)
                  if (use_polymer) then
                     if (r2 .lt. polycut2) then
                        if (k1.eq.i1 .or. k1.eq.i2 .or.
     &                      k2.eq.i1 .or. k2.eq.i2)  fik = 0.0d0
                     end if
                  end if
c
c     some abbreviations used in various chain rule terms
c
                  dotik = doti * dotk
                  enum = dotp*r2 - 3.0d0*dotik
                  r2inv = 15.0d0 / r2
                  ri2inv = 1.0d0 / ri2
                  xrr2 = xr / r2
                  yrr2 = yr / r2
                  zrr2 = zr / r2
                  xiri2 = xi / ri2
                  yiri2 = yi / ri2
                  ziri2 = zi / ri2
                  xkrk2 = xk / rk2
                  ykrk2 = yk / rk2
                  zkrk2 = zk / rk2
                  xixr = xi * xr
                  xiyr = xi * yr
                  xizr = xi * zr
                  yixr = yi * xr
                  yiyr = yi * yr
                  yizr = yi * zr
                  zixr = zi * xr
                  ziyr = zi * yr
                  zizr = zi * zr
                  xkxr = xk * xr
                  xkyr = xk * yr
                  xkzr = xk * zr
                  ykxr = yk * xr
                  ykyr = yk * yr
                  ykzr = yk * zr
                  zkxr = zk * xr
                  zkyr = zk * yr
                  zkzr = zk * zr
                  xixk = xi * xk
                  xiyk = xi * yk
                  xizk = xi * zk
                  yixk = yi * xk
                  yiyk = yi * yk
                  yizk = yi * zk
                  zixk = zi * xk
                  ziyk = zi * yk
                  zizk = zi * zk
                  xrxr = 3.0d0 * xr * xr
                  xryr = 3.0d0 * xr * yr
                  xrzr = 3.0d0 * xr * zr
                  yryr = 3.0d0 * yr * yr
                  yrzr = 3.0d0 * yr * zr
                  zrzr = 3.0d0 * zr * zr
                  xidotk = xi * dotk
                  yidotk = yi * dotk
                  zidotk = zi * dotk
                  xkdoti = xk * doti
                  ykdoti = yk * doti
                  zkdoti = zk * doti
c
c     scale the interaction based on its group membership
c
                  if (use_group)  fik = fik * fgrp
c
c     form the master chain rule term for derivatives
c
                  de = -fik / (rirkr3*r2)
c
c     form the chain rule terms for first derivatives
c
                  deddotp = -de * r2
                  deddoti = de * 3.0d0*dotk
                  deddotk = de * 3.0d0*doti
                  dedr = de * (3.0d0*dotp-15.0d0*dotik/r2)
                  dedrirk = de * enum
c
c     more first derivative chain rule expressions
c
                  termx = dedr*xr + deddoti*xi + deddotk*xk
                  termy = dedr*yr + deddoti*yi + deddotk*yk
                  termz = dedr*zr + deddoti*zi + deddotk*zk
                  termxi = dedrirk*xiri2 + deddotp*xk + deddoti*xr
                  termyi = dedrirk*yiri2 + deddotp*yk + deddoti*yr
                  termzi = dedrirk*ziri2 + deddotp*zk + deddoti*zr
                  termxk = dedrirk*xkrk2 + deddotp*xi + deddotk*xr
                  termyk = dedrirk*ykrk2 + deddotp*yi + deddotk*yr
                  termzk = dedrirk*zkrk2 + deddotp*zi + deddotk*zr
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3
                     dedxi1 = si1*termx - termxi
                     dedyi1 = si1*termy - termyi
                     dedzi1 = si1*termz - termzi
                     dedxi2 = si2*termx + termxi
                     dedyi2 = si2*termy + termyi
                     dedzi2 = si2*termz + termzi
                     dedxk1 = -sk1*termx - termxk
                     dedyk1 = -sk1*termy - termyk
                     dedzk1 = -sk1*termz - termzk
                     dedxk2 = -sk2*termx + termxk
                     dedyk2 = -sk2*termy + termyk
                     dedzk2 = -sk2*termz + termzk
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2
     &                            + 6.0d0*c3*r + 2.0d0*c2
                     dtaper = dtaper / r
                     dtaperx = xr * dtaper
                     dtapery = yr * dtaper
                     dtaperz = zr * dtaper
                     d2taper = e * (d2taper-dtaper)
                     dtaper = e * dtaper
                     d2taperxx = xr*xrr2*d2taper + dtaper
                     d2taperxy = xr*yrr2*d2taper
                     d2taperxz = xr*zrr2*d2taper
                     d2taperyy = yr*yrr2*d2taper + dtaper
                     d2taperyz = yr*zrr2*d2taper
                     d2taperzz = zr*zrr2*d2taper + dtaper
                     de = de * taper
                     termx = termx * taper
                     termy = termy * taper
                     termz = termz * taper
                     termxi = termxi * taper
                     termyi = termyi * taper
                     termzi = termzi * taper
                     termxk = termxk * taper
                     termyk = termyk * taper
                     termzk = termzk * taper
                  end if
c
c     chain rule terms for second derivative components
c
                  if (i .eq. i1) then
                     dtdxi1 = -5.0d0*si1*xrr2 + xiri2
                     part = si1*xkdoti - dotk*xr + si1*xidotk
     &                         - 2.0d0*si1*dotik*xrr2
                     partik = -xk*r2 + 2.0d0*si1*dotp*xr
     &                           - 3.0d0*si1*xkdoti + 3.0d0*xr*dotk
     &                           - 3.0d0*si1*xidotk
                     factor = 3.0d0*si1*dotp - 6.0d0*xkxr
     &                           + 6.0d0*si1*xixk - 3.0d0*dotk
     &                           - r2inv*(xr*part+si1*dotik)
                     factori = 3.0d0*si1*dotk + si1*xkxr + xiri2*partik
     &                            - enum*(ri2inv-2.0d0*xiri2*xiri2)
                     factork = r2 + 3.0d0*si1*doti + si1*xixr
     &                            - xrxr + xkrk2*partik
                     dtxdxi1 = dtdxi1*termx + de*factor
                     dtxidxi1 = dtdxi1*termxi + de*factori
                     dtxkdxi1 = dtdxi1*termxk + de*factork
                     factor = -3.0d0*xkyr - 3.0d0*ykxr + 3.0d0*si1*xiyk
     &                           + 3.0d0*si1*yixk - r2inv*yr*part
                     factori = -2.0d0*si1*ykxr + 3.0d0*si1*xkyr
     &                           + yiri2*partik + 2.0d0*enum*yiri2*xiri2
                     factork = -2.0d0*si1*yixr - xryr + 3.0d0*si1*xiyr
     &                            + ykrk2*partik
                     dtydxi1 = dtdxi1*termy + de*factor
                     dtyidxi1 = dtdxi1*termyi + de*factori
                     dtykdxi1 = dtdxi1*termyk + de*factork
                     factor = -3.0d0*xkzr - 3.0d0*zkxr + 3.0d0*si1*xizk
     &                           + 3.0d0*si1*zixk - r2inv*zr*part
                     factori = -2.0d0*si1*zkxr + 3.0d0*si1*xkzr
     &                           + ziri2*partik + 2.0d0*enum*ziri2*xiri2
                     factork = -2.0d0*si1*zixr - xrzr + 3.0d0*si1*xizr
     &                            + zkrk2*partik
                     dtzdxi1 = dtdxi1*termz + de*factor
                     dtzidxi1 = dtdxi1*termzi + de*factori
                     dtzkdxi1 = dtdxi1*termzk + de*factork
                     dtdyi1 = -5.0d0*si1*yrr2 + yiri2
                     part = si1*ykdoti - dotk*yr + si1*yidotk
     &                         - 2.0d0*si1*dotik*yrr2
                     partik = -yk*r2 + 2.0d0*si1*dotp*yr
     &                           - 3.0d0*si1*ykdoti + 3.0d0*yr*dotk
     &                           - 3.0d0*si1*yidotk
                     factor = -3.0d0*ykxr - 3.0d0*xkyr + 3.0d0*si1*yixk
     &                           + 3.0d0*si1*xiyk - r2inv*xr*part
                     factori = -2.0d0*si1*xkyr + 3.0d0*si1*ykxr
     &                           + xiri2*partik + 2.0d0*enum*xiri2*yiri2
                     factork = -2.0d0*si1*xiyr - xryr + 3.0d0*si1*yixr
     &                            + xkrk2*partik
                     dtxdyi1 = dtdyi1*termx + de*factor
                     dtxidyi1 = dtdyi1*termxi + de*factori
                     dtxkdyi1 = dtdyi1*termxk + de*factork
                     factor = 3.0d0*si1*dotp - 6.0d0*ykyr
     &                           + 6.0d0*si1*yiyk - 3.0d0*dotk
     &                           - r2inv*(yr*part+si1*dotik)
                     factori = 3.0d0*si1*dotk + si1*ykyr + yiri2*partik
     &                            - enum*(ri2inv-2.0d0*yiri2*yiri2)
                     factork = r2 + 3.0d0*si1*doti + si1*yiyr
     &                            - yryr + ykrk2*partik
                     dtydyi1 = dtdyi1*termy + de*factor
                     dtyidyi1 = dtdyi1*termyi + de*factori
                     dtykdyi1 = dtdyi1*termyk + de*factork
                     factor = -3.0d0*ykzr - 3.0d0*zkyr + 3.0d0*si1*yizk
     &                           + 3.0d0*si1*ziyk - r2inv*zr*part
                     factori = -2.0d0*si1*zkyr + 3.0d0*si1*ykzr
     &                           + ziri2*partik + 2.0d0*enum*ziri2*yiri2
                     factork = -2.0d0*si1*ziyr - yrzr + 3.0d0*si1*yizr
     &                            + zkrk2*partik
                     dtzdyi1 = dtdyi1*termz + de*factor
                     dtzidyi1 = dtdyi1*termzi + de*factori
                     dtzkdyi1 = dtdyi1*termzk + de*factork
                     dtdzi1 = -5.0d0*si1*zrr2 + ziri2
                     part = si1*zkdoti - dotk*zr + si1*zidotk
     &                         - 2.0d0*si1*dotik*zrr2
                     partik = -zk*r2 + 2.0d0*si1*dotp*zr
     &                           - 3.0d0*si1*zkdoti + 3.0d0*zr*dotk
     &                           - 3.0d0*si1*zidotk
                     factor = -3.0d0*zkxr - 3.0d0*xkzr + 3.0d0*si1*zixk
     &                           + 3.0d0*si1*xizk - r2inv*xr*part
                     factori = -2.0d0*si1*xkzr + 3.0d0*si1*zkxr
     &                           + xiri2*partik + 2.0d0*enum*xiri2*ziri2
                     factork = -2.0d0*si1*xizr - xrzr + 3.0d0*si1*zixr
     &                            + xkrk2*partik
                     dtxdzi1 = dtdzi1*termx + de*factor
                     dtxidzi1 = dtdzi1*termxi + de*factori
                     dtxkdzi1 = dtdzi1*termxk + de*factork
                     factor = -3.0d0*zkyr - 3.0d0*ykzr + 3.0d0*si1*ziyk
     &                           + 3.0d0*si1*yizk - r2inv*yr*part
                     factori = -2.0d0*si1*ykzr + 3.0d0*si1*zkyr
     &                           + yiri2*partik + 2.0d0*enum*yiri2*ziri2
                     factork = -2.0d0*si1*yizr - yrzr + 3.0d0*si1*ziyr
     &                            + ykrk2*partik
                     dtydzi1 = dtdzi1*termy + de*factor
                     dtyidzi1 = dtdzi1*termyi + de*factori
                     dtykdzi1 = dtdzi1*termyk + de*factork
                     factor = 3.0d0*si1*dotp - 6.0d0*zkzr
     &                           + 6.0d0*si1*zizk - 3.0d0*dotk
     &                           - r2inv*(zr*part+si1*dotik)
                     factori = 3.0d0*si1*dotk + si1*zkzr + ziri2*partik
     &                            - enum*(ri2inv-2.0d0*ziri2*ziri2)
                     factork = r2 + 3.0d0*si1*doti + si1*zizr
     &                            - zrzr + zkrk2*partik
                     dtzdzi1 = dtdzi1*termz + de*factor
                     dtzidzi1 = dtdzi1*termzi + de*factori
                     dtzkdzi1 = dtdzi1*termzk + de*factork
                  else if (i .eq. i2) then
                     dtdxi2 = -5.0d0*si2*xrr2 - xiri2
                     part = si2*xkdoti + dotk*xr + si2*xidotk
     &                         - 2.0d0*si2*dotik*xrr2
                     partik = xk*r2 + 2.0d0*si2*dotp*xr
     &                           - 3.0d0*si2*xkdoti - 3.0d0*xr*dotk
     &                           - 3.0d0*si2*xidotk
                     factor = 3.0d0*si2*dotp + 6.0d0*xkxr
     &                           + 6.0d0*si2*xixk + 3.0d0*dotk
     &                           - r2inv*(xr*part+si2*dotik)
                     factori = 3.0d0*si2*dotk + si2*xkxr + xiri2*partik
     &                            + enum*(ri2inv-2.0d0*xiri2*xiri2)
                     factork = -r2 + 3.0d0*si2*doti + si2*xixr
     &                            + xrxr + xkrk2*partik
                     dtxdxi2 = dtdxi2*termx + de*factor
                     dtxidxi2 = dtdxi2*termxi + de*factori
                     dtxkdxi2 = dtdxi2*termxk + de*factork
                     factor = 3.0d0*xkyr + 3.0d0*ykxr + 3.0d0*si2*xiyk
     &                           + 3.0d0*si2*yixk - r2inv*yr*part
                     factori = -2.0d0*si2*ykxr + 3.0d0*si2*xkyr
     &                           + yiri2*partik - 2.0d0*enum*yiri2*xiri2
                     factork = -2.0d0*si2*yixr + xryr + 3.0d0*si2*xiyr
     &                            + ykrk2*partik
                     dtydxi2 = dtdxi2*termy + de*factor
                     dtyidxi2 = dtdxi2*termyi + de*factori
                     dtykdxi2 = dtdxi2*termyk + de*factork
                     factor = 3.0d0*xkzr + 3.0d0*zkxr + 3.0d0*si2*xizk
     &                           + 3.0d0*si2*zixk - r2inv*zr*part
                     factori = -2.0d0*si2*zkxr + 3.0d0*si2*xkzr
     &                           + ziri2*partik - 2.0d0*enum*ziri2*xiri2
                     factork = -2.0d0*si2*zixr + xrzr + 3.0d0*si2*xizr
     &                            + zkrk2*partik
                     dtzdxi2 = dtdxi2*termz + de*factor
                     dtzidxi2 = dtdxi2*termzi + de*factori
                     dtzkdxi2 = dtdxi2*termzk + de*factork
                     dtdyi2 = -5.0d0*si2*yrr2 - yiri2
                     part = si2*ykdoti + dotk*yr + si2*yidotk
     &                         - 2.0d0*si2*dotik*yrr2
                     partik = yk*r2 + 2.0d0*si2*dotp*yr
     &                           - 3.0d0*si2*ykdoti - 3.0d0*yr*dotk
     &                           - 3.0d0*si2*yidotk
                     factor = 3.0d0*ykxr + 3.0d0*xkyr + 3.0d0*si2*yixk
     &                           + 3.0d0*si2*xiyk - r2inv*xr*part
                     factori = -2.0d0*si2*xkyr + 3.0d0*si2*ykxr
     &                           + xiri2*partik - 2.0d0*enum*xiri2*yiri2
                     factork = -2.0d0*si2*xiyr + xryr + 3.0d0*si2*yixr
     &                            + xkrk2*partik
                     dtxdyi2 = dtdyi2*termx + de*factor
                     dtxidyi2 = dtdyi2*termxi + de*factori
                     dtxkdyi2 = dtdyi2*termxk + de*factork
                     factor = 3.0d0*si2*dotp + 6.0d0*ykyr
     &                           + 6.0d0*si2*yiyk + 3.0d0*dotk
     &                           - r2inv*(yr*part+si2*dotik)
                     factori = 3.0d0*si2*dotk + si2*ykyr + yiri2*partik
     &                            + enum*(ri2inv-2.0d0*yiri2*yiri2)
                     factork = -r2 + 3.0d0*si2*doti + si2*yiyr
     &                            + yryr + ykrk2*partik
                     dtydyi2 = dtdyi2*termy + de*factor
                     dtyidyi2 = dtdyi2*termyi + de*factori
                     dtykdyi2 = dtdyi2*termyk + de*factork
                     factor = 3.0d0*ykzr + 3.0d0*zkyr + 3.0d0*si2*yizk
     &                           + 3.0d0*si2*ziyk - r2inv*zr*part
                     factori = -2.0d0*si2*zkyr + 3.0d0*si2*ykzr
     &                           + ziri2*partik - 2.0d0*enum*ziri2*yiri2
                     factork = -2.0d0*si2*ziyr + yrzr + 3.0d0*si2*yizr
     &                            + zkrk2*partik
                     dtzdyi2 = dtdyi2*termz + de*factor
                     dtzidyi2 = dtdyi2*termzi + de*factori
                     dtzkdyi2 = dtdyi2*termzk + de*factork
                     dtdzi2 = -5.0d0*si2*zrr2 - ziri2
                     part = si2*zkdoti + dotk*zr + si2*zidotk
     &                         - 2.0d0*si2*dotik*zrr2
                     partik = zk*r2 + 2.0d0*si2*dotp*zr
     &                           - 3.0d0*si2*zkdoti - 3.0d0*zr*dotk
     &                           - 3.0d0*si2*zidotk
                     factor = 3.0d0*zkxr + 3.0d0*xkzr + 3.0d0*si2*zixk
     &                           + 3.0d0*si2*xizk - r2inv*xr*part
                     factori = -2.0d0*si2*xkzr + 3.0d0*si2*zkxr
     &                           + xiri2*partik - 2.0d0*enum*xiri2*ziri2
                     factork = -2.0d0*si2*xizr + xrzr + 3.0d0*si2*zixr
     &                            + xkrk2*partik
                     dtxdzi2 = dtdzi2*termx + de*factor
                     dtxidzi2 = dtdzi2*termxi + de*factori
                     dtxkdzi2 = dtdzi2*termxk + de*factork
                     factor = 3.0d0*zkyr + 3.0d0*ykzr + 3.0d0*si2*ziyk
     &                           + 3.0d0*si2*yizk - r2inv*yr*part
                     factori = -2.0d0*si2*ykzr + 3.0d0*si2*zkyr
     &                           + yiri2*partik - 2.0d0*enum*yiri2*ziri2
                     factork = -2.0d0*si2*yizr + yrzr + 3.0d0*si2*ziyr
     &                            + ykrk2*partik
                     dtydzi2 = dtdzi2*termy + de*factor
                     dtyidzi2 = dtdzi2*termyi + de*factori
                     dtykdzi2 = dtdzi2*termyk + de*factork
                     factor = 3.0d0*si2*dotp + 6.0d0*zkzr
     &                           + 6.0d0*si2*zizk + 3.0d0*dotk
     &                           - r2inv*(zr*part+si2*dotik)
                     factori = 3.0d0*si2*dotk + si2*zkzr + ziri2*partik
     &                            + enum*(ri2inv-2.0d0*ziri2*ziri2)
                     factork = -r2 + 3.0d0*si2*doti + si2*zizr
     &                            + zrzr + zkrk2*partik
                     dtzdzi2 = dtdzi2*termz + de*factor
                     dtzidzi2 = dtdzi2*termzi + de*factori
                     dtzkdzi2 = dtdzi2*termzk + de*factork
                  end if
c
c     increment diagonal and off-diagonal Hessian elements
c
                  if (i .eq. i1) then
                     hessx(1,i1) = hessx(1,i1) + si1*dtxdxi1 - dtxidxi1
                     hessx(2,i1) = hessx(2,i1) + si1*dtydxi1 - dtyidxi1
                     hessx(3,i1) = hessx(3,i1) + si1*dtzdxi1 - dtzidxi1
                     hessx(1,i2) = hessx(1,i2) + si2*dtxdxi1 + dtxidxi1
                     hessx(2,i2) = hessx(2,i2) + si2*dtydxi1 + dtyidxi1
                     hessx(3,i2) = hessx(3,i2) + si2*dtzdxi1 + dtzidxi1
                     hessx(1,k1) = hessx(1,k1) - sk1*dtxdxi1 - dtxkdxi1
                     hessx(2,k1) = hessx(2,k1) - sk1*dtydxi1 - dtykdxi1
                     hessx(3,k1) = hessx(3,k1) - sk1*dtzdxi1 - dtzkdxi1
                     hessx(1,k2) = hessx(1,k2) - sk2*dtxdxi1 + dtxkdxi1
                     hessx(2,k2) = hessx(2,k2) - sk2*dtydxi1 + dtykdxi1
                     hessx(3,k2) = hessx(3,k2) - sk2*dtzdxi1 + dtzkdxi1
                     hessy(1,i1) = hessy(1,i1) + si1*dtxdyi1 - dtxidyi1
                     hessy(2,i1) = hessy(2,i1) + si1*dtydyi1 - dtyidyi1
                     hessy(3,i1) = hessy(3,i1) + si1*dtzdyi1 - dtzidyi1
                     hessy(1,i2) = hessy(1,i2) + si2*dtxdyi1 + dtxidyi1
                     hessy(3,i2) = hessy(3,i2) + si2*dtzdyi1 + dtzidyi1
                     hessy(2,i2) = hessy(2,i2) + si2*dtydyi1 + dtyidyi1
                     hessy(1,k1) = hessy(1,k1) - sk1*dtxdyi1 - dtxkdyi1
                     hessy(2,k1) = hessy(2,k1) - sk1*dtydyi1 - dtykdyi1
                     hessy(3,k1) = hessy(3,k1) - sk1*dtzdyi1 - dtzkdyi1
                     hessy(1,k2) = hessy(1,k2) - sk2*dtxdyi1 + dtxkdyi1
                     hessy(2,k2) = hessy(2,k2) - sk2*dtydyi1 + dtykdyi1
                     hessy(3,k2) = hessy(3,k2) - sk2*dtzdyi1 + dtzkdyi1
                     hessz(1,i1) = hessz(1,i1) + si1*dtxdzi1 - dtxidzi1
                     hessz(2,i1) = hessz(2,i1) + si1*dtydzi1 - dtyidzi1
                     hessz(3,i1) = hessz(3,i1) + si1*dtzdzi1 - dtzidzi1
                     hessz(1,i2) = hessz(1,i2) + si2*dtxdzi1 + dtxidzi1
                     hessz(2,i2) = hessz(2,i2) + si2*dtydzi1 + dtyidzi1
                     hessz(3,i2) = hessz(3,i2) + si2*dtzdzi1 + dtzidzi1
                     hessz(1,k1) = hessz(1,k1) - sk1*dtxdzi1 - dtxkdzi1
                     hessz(2,k1) = hessz(2,k1) - sk1*dtydzi1 - dtykdzi1
                     hessz(3,k1) = hessz(3,k1) - sk1*dtzdzi1 - dtzkdzi1
                     hessz(1,k2) = hessz(1,k2) - sk2*dtxdzi1 + dtxkdzi1
                     hessz(2,k2) = hessz(2,k2) - sk2*dtydzi1 + dtykdzi1
                     hessz(3,k2) = hessz(3,k2) - sk2*dtzdzi1 + dtzkdzi1
                  else if (i .eq. i2) then
                     hessx(1,i1) = hessx(1,i1) + si1*dtxdxi2 - dtxidxi2
                     hessx(2,i1) = hessx(2,i1) + si1*dtydxi2 - dtyidxi2
                     hessx(3,i1) = hessx(3,i1) + si1*dtzdxi2 - dtzidxi2
                     hessx(1,i2) = hessx(1,i2) + si2*dtxdxi2 + dtxidxi2
                     hessx(2,i2) = hessx(2,i2) + si2*dtydxi2 + dtyidxi2
                     hessx(3,i2) = hessx(3,i2) + si2*dtzdxi2 + dtzidxi2
                     hessx(1,k1) = hessx(1,k1) - sk1*dtxdxi2 - dtxkdxi2
                     hessx(2,k1) = hessx(2,k1) - sk1*dtydxi2 - dtykdxi2
                     hessx(3,k1) = hessx(3,k1) - sk1*dtzdxi2 - dtzkdxi2
                     hessx(1,k2) = hessx(1,k2) - sk2*dtxdxi2 + dtxkdxi2
                     hessx(2,k2) = hessx(2,k2) - sk2*dtydxi2 + dtykdxi2
                     hessx(3,k2) = hessx(3,k2) - sk2*dtzdxi2 + dtzkdxi2
                     hessy(1,i1) = hessy(1,i1) + si1*dtxdyi2 - dtxidyi2
                     hessy(2,i1) = hessy(2,i1) + si1*dtydyi2 - dtyidyi2
                     hessy(3,i1) = hessy(3,i1) + si1*dtzdyi2 - dtzidyi2
                     hessy(1,i2) = hessy(1,i2) + si2*dtxdyi2 + dtxidyi2
                     hessy(2,i2) = hessy(2,i2) + si2*dtydyi2 + dtyidyi2
                     hessy(3,i2) = hessy(3,i2) + si2*dtzdyi2 + dtzidyi2
                     hessy(1,k1) = hessy(1,k1) - sk1*dtxdyi2 - dtxkdyi2
                     hessy(2,k1) = hessy(2,k1) - sk1*dtydyi2 - dtykdyi2
                     hessy(3,k1) = hessy(3,k1) - sk1*dtzdyi2 - dtzkdyi2
                     hessy(1,k2) = hessy(1,k2) - sk2*dtxdyi2 + dtxkdyi2
                     hessy(2,k2) = hessy(2,k2) - sk2*dtydyi2 + dtykdyi2
                     hessy(3,k2) = hessy(3,k2) - sk2*dtzdyi2 + dtzkdyi2
                     hessz(1,i1) = hessz(1,i1) + si1*dtxdzi2 - dtxidzi2
                     hessz(2,i1) = hessz(2,i1) + si1*dtydzi2 - dtyidzi2
                     hessz(3,i1) = hessz(3,i1) + si1*dtzdzi2 - dtzidzi2
                     hessz(1,i2) = hessz(1,i2) + si2*dtxdzi2 + dtxidzi2
                     hessz(2,i2) = hessz(2,i2) + si2*dtydzi2 + dtyidzi2
                     hessz(3,i2) = hessz(3,i2) + si2*dtzdzi2 + dtzidzi2
                     hessz(1,k1) = hessz(1,k1) - sk1*dtxdzi2 - dtxkdzi2
                     hessz(2,k1) = hessz(2,k1) - sk1*dtydzi2 - dtykdzi2
                     hessz(3,k1) = hessz(3,k1) - sk1*dtzdzi2 - dtzkdzi2
                     hessz(1,k2) = hessz(1,k2) - sk2*dtxdzi2 + dtxkdzi2
                     hessz(2,k2) = hessz(2,k2) - sk2*dtydzi2 + dtykdzi2
                     hessz(3,k2) = hessz(3,k2) - sk2*dtzdzi2 + dtzkdzi2
                  end if
c
c     more energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     if (i .eq. i1) then
                        hessx(1,i1) = hessx(1,i1) + si1*dtaperx*dedxi1
     &                         + si1*dtaperx*dedxi1 + si1*si1*d2taperxx
                        hessx(2,i1) = hessx(2,i1) + si1*dtapery*dedxi1
     &                         + si1*dtaperx*dedyi1 + si1*si1*d2taperxy
                        hessx(3,i1) = hessx(3,i1) + si1*dtaperz*dedxi1
     &                         + si1*dtaperx*dedzi1 + si1*si1*d2taperxz
                        hessx(1,i2) = hessx(1,i2) + si2*dtaperx*dedxi1
     &                         + si1*dtaperx*dedxi2 + si2*si1*d2taperxx
                        hessx(2,i2) = hessx(2,i2) + si2*dtapery*dedxi1
     &                         + si1*dtaperx*dedyi2 + si2*si1*d2taperxy
                        hessx(3,i2) = hessx(3,i2) + si2*dtaperz*dedxi1
     &                         + si1*dtaperx*dedzi2 + si2*si1*d2taperxz
                        hessx(1,k1) = hessx(1,k1) - sk1*dtaperx*dedxi1
     &                         + si1*dtaperx*dedxk1 - sk1*si1*d2taperxx
                        hessx(2,k1) = hessx(2,k1) - sk1*dtapery*dedxi1
     &                         + si1*dtaperx*dedyk1 - sk1*si1*d2taperxy
                        hessx(3,k1) = hessx(3,k1) - sk1*dtaperz*dedxi1
     &                         + si1*dtaperx*dedzk1 - sk1*si1*d2taperxz
                        hessx(1,k2) = hessx(1,k2) - sk2*dtaperx*dedxi1
     &                         + si1*dtaperx*dedxk2 - sk2*si1*d2taperxx
                        hessx(2,k2) = hessx(2,k2) - sk2*dtapery*dedxi1
     &                         + si1*dtaperx*dedyk2 - sk2*si1*d2taperxy
                        hessx(3,k2) = hessx(3,k2) - sk2*dtaperz*dedxi1
     &                         + si1*dtaperx*dedzk2 - sk2*si1*d2taperxz
                        hessy(1,i1) = hessy(1,i1) + si1*dtaperx*dedyi1
     &                         + si1*dtapery*dedxi1 + si1*si1*d2taperxy
                        hessy(2,i1) = hessy(2,i1) + si1*dtapery*dedyi1
     &                         + si1*dtapery*dedyi1 + si1*si1*d2taperyy
                        hessy(3,i1) = hessy(3,i1) + si1*dtaperz*dedyi1
     &                         + si1*dtapery*dedzi1 + si1*si1*d2taperyz
                        hessy(1,i2) = hessy(1,i2) + si2*dtaperx*dedyi1
     &                         + si1*dtapery*dedxi2 + si2*si1*d2taperxy
                        hessy(2,i2) = hessy(2,i2) + si2*dtapery*dedyi1
     &                         + si1*dtapery*dedyi2 + si2*si1*d2taperyy
                        hessy(3,i2) = hessy(3,i2) + si2*dtaperz*dedyi1
     &                         + si1*dtapery*dedzi2 + si2*si1*d2taperyz
                        hessy(1,k1) = hessy(1,k1) - sk1*dtaperx*dedyi1
     &                         + si1*dtapery*dedxk1 - sk1*si1*d2taperxy
                        hessy(2,k1) = hessy(2,k1) - sk1*dtapery*dedyi1
     &                         + si1*dtapery*dedyk1 - sk1*si1*d2taperyy
                        hessy(3,k1) = hessy(3,k1) - sk1*dtaperz*dedyi1
     &                         + si1*dtapery*dedzk1 - sk1*si1*d2taperyz
                        hessy(1,k2) = hessy(1,k2) - sk2*dtaperx*dedyi1
     &                         + si1*dtapery*dedxk2 - sk2*si1*d2taperxy
                        hessy(2,k2) = hessy(2,k2) - sk2*dtapery*dedyi1
     &                         + si1*dtapery*dedyk2 - sk2*si1*d2taperyy
                        hessy(3,k2) = hessy(3,k2) - sk2*dtaperz*dedyi1
     &                         + si1*dtapery*dedzk2 - sk2*si1*d2taperyz
                        hessz(1,i1) = hessz(1,i1) + si1*dtaperx*dedzi1
     &                         + si1*dtaperz*dedxi1 + si1*si1*d2taperxz
                        hessz(2,i1) = hessz(2,i1) + si1*dtapery*dedzi1
     &                         + si1*dtaperz*dedyi1 + si1*si1*d2taperyz
                        hessz(3,i1) = hessz(3,i1) + si1*dtaperz*dedzi1
     &                         + si1*dtaperz*dedzi1 + si1*si1*d2taperzz
                        hessz(1,i2) = hessz(1,i2) + si2*dtaperx*dedzi1
     &                         + si1*dtaperz*dedxi2 + si2*si1*d2taperxz
                        hessz(2,i2) = hessz(2,i2) + si2*dtapery*dedzi1
     &                         + si1*dtaperz*dedyi2 + si2*si1*d2taperyz
                        hessz(3,i2) = hessz(3,i2) + si2*dtaperz*dedzi1
     &                         + si1*dtaperz*dedzi2 + si2*si1*d2taperzz
                        hessz(1,k1) = hessz(1,k1) - sk1*dtaperx*dedzi1
     &                         + si1*dtaperz*dedxk1 - sk1*si1*d2taperxz
                        hessz(2,k1) = hessz(2,k1) - sk1*dtapery*dedzi1
     &                         + si1*dtaperz*dedyk1 - sk1*si1*d2taperyz
                        hessz(3,k1) = hessz(3,k1) - sk1*dtaperz*dedzi1
     &                         + si1*dtaperz*dedzk1 - sk1*si1*d2taperzz
                        hessz(1,k2) = hessz(1,k2) - sk2*dtaperx*dedzi1
     &                         + si1*dtaperz*dedxk2 - sk2*si1*d2taperxz
                        hessz(2,k2) = hessz(2,k2) - sk2*dtapery*dedzi1
     &                         + si1*dtaperz*dedyk2 - sk2*si1*d2taperyz
                        hessz(3,k2) = hessz(3,k2) - sk2*dtaperz*dedzi1
     &                         + si1*dtaperz*dedzk2 - sk2*si1*d2taperzz
                     else if (i .eq. i2) then
                        hessx(1,i1) = hessx(1,i1) + si1*dtaperx*dedxi2
     &                         + si2*dtaperx*dedxi1 + si1*si2*d2taperxx
                        hessx(2,i1) = hessx(2,i1) + si1*dtapery*dedxi2
     &                         + si2*dtaperx*dedyi1 + si1*si2*d2taperxy
                        hessx(3,i1) = hessx(3,i1) + si1*dtaperz*dedxi2
     &                         + si2*dtaperx*dedzi1 + si1*si2*d2taperxz
                        hessx(1,i2) = hessx(1,i2) + si2*dtaperx*dedxi2
     &                         + si2*dtaperx*dedxi2 + si2*si2*d2taperxx
                        hessx(2,i2) = hessx(2,i2) + si2*dtapery*dedxi2
     &                         + si2*dtaperx*dedyi2 + si2*si2*d2taperxy
                        hessx(3,i2) = hessx(3,i2) + si2*dtaperz*dedxi2
     &                         + si2*dtaperx*dedzi2 + si2*si2*d2taperxz
                        hessx(1,k1) = hessx(1,k1) - sk1*dtaperx*dedxi2
     &                         + si2*dtaperx*dedxk1 - sk1*si2*d2taperxx
                        hessx(2,k1) = hessx(2,k1) - sk1*dtapery*dedxi2
     &                         + si2*dtaperx*dedyk1 - sk1*si2*d2taperxy
                        hessx(3,k1) = hessx(3,k1) - sk1*dtaperz*dedxi2
     &                         + si2*dtaperx*dedzk1 - sk1*si2*d2taperxz
                        hessx(1,k2) = hessx(1,k2) - sk2*dtaperx*dedxi2
     &                         + si2*dtaperx*dedxk2 - sk2*si2*d2taperxx
                        hessx(2,k2) = hessx(2,k2) - sk2*dtapery*dedxi2
     &                         + si2*dtaperx*dedyk2 - sk2*si2*d2taperxy
                        hessx(3,k2) = hessx(3,k2) - sk2*dtaperz*dedxi2
     &                         + si2*dtaperx*dedzk2 - sk2*si2*d2taperxz
                        hessy(1,i1) = hessy(1,i1) + si1*dtaperx*dedyi2
     &                         + si2*dtapery*dedxi1 + si1*si2*d2taperxy
                        hessy(2,i1) = hessy(2,i1) + si1*dtapery*dedyi2
     &                         + si2*dtapery*dedyi1 + si1*si2*d2taperyy
                        hessy(3,i1) = hessy(3,i1) + si1*dtaperz*dedyi2
     &                         + si2*dtapery*dedzi1 + si1*si2*d2taperyz
                        hessy(1,i2) = hessy(1,i2) + si2*dtaperx*dedyi2
     &                         + si2*dtapery*dedxi2 + si2*si2*d2taperxy
                        hessy(2,i2) = hessy(2,i2) + si2*dtapery*dedyi2
     &                         + si2*dtapery*dedyi2 + si2*si2*d2taperyy
                        hessy(3,i2) = hessy(3,i2) + si2*dtaperz*dedyi2
     &                         + si2*dtapery*dedzi2 + si2*si2*d2taperyz
                        hessy(1,k1) = hessy(1,k1) - sk1*dtaperx*dedyi2
     &                         + si2*dtapery*dedxk1 - sk1*si2*d2taperxy
                        hessy(2,k1) = hessy(2,k1) - sk1*dtapery*dedyi2
     &                         + si2*dtapery*dedyk1 - sk1*si2*d2taperyy
                        hessy(3,k1) = hessy(3,k1) - sk1*dtaperz*dedyi2
     &                         + si2*dtapery*dedzk1 - sk1*si2*d2taperyz
                        hessy(1,k2) = hessy(1,k2) - sk2*dtaperx*dedyi2
     &                         + si2*dtapery*dedxk2 - sk2*si2*d2taperxy
                        hessy(2,k2) = hessy(2,k2) - sk2*dtapery*dedyi2
     &                         + si2*dtapery*dedyk2 - sk2*si2*d2taperyy
                        hessy(3,k2) = hessy(3,k2) - sk2*dtaperz*dedyi2
     &                         + si2*dtapery*dedzk2 - sk2*si2*d2taperyz
                        hessz(1,i1) = hessz(1,i1) + si1*dtaperx*dedzi2
     &                         + si2*dtaperz*dedxi1 + si1*si2*d2taperxz
                        hessz(2,i1) = hessz(2,i1) + si1*dtapery*dedzi2
     &                         + si2*dtaperz*dedyi1 + si1*si2*d2taperyz
                        hessz(3,i1) = hessz(3,i1) + si1*dtaperz*dedzi2
     &                         + si2*dtaperz*dedzi1 + si1*si2*d2taperzz
                        hessz(1,i2) = hessz(1,i2) + si2*dtaperx*dedzi2
     &                         + si2*dtaperz*dedxi2 + si2*si2*d2taperxz
                        hessz(2,i2) = hessz(2,i2) + si2*dtapery*dedzi2
     &                         + si2*dtaperz*dedyi2 + si2*si2*d2taperyz
                        hessz(3,i2) = hessz(3,i2) + si2*dtaperz*dedzi2
     &                         + si2*dtaperz*dedzi2 + si2*si2*d2taperzz
                        hessz(1,k1) = hessz(1,k1) - sk1*dtaperx*dedzi2
     &                         + si2*dtaperz*dedxk1 - sk1*si2*d2taperxz
                        hessz(2,k1) = hessz(2,k1) - sk1*dtapery*dedzi2
     &                         + si2*dtaperz*dedyk1 - sk1*si2*d2taperyz
                        hessz(3,k1) = hessz(3,k1) - sk1*dtaperz*dedzi2
     &                         + si2*dtaperz*dedzk1 - sk1*si2*d2taperzz
                        hessz(1,k2) = hessz(1,k2) - sk2*dtaperx*dedzi2
     &                         + si2*dtaperz*dedxk2 - sk2*si2*d2taperxz
                        hessz(2,k2) = hessz(2,k2) - sk2*dtapery*dedzi2
     &                         + si2*dtaperz*dedyk2 - sk2*si2*d2taperyz
                        hessz(3,k2) = hessz(3,k2) - sk2*dtaperz*dedzi2
     &                         + si2*dtaperz*dedzk2 - sk2*si2*d2taperzz
                     end if
                  end if
               end if
            end do
   20       continue
         end do
   30    continue
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine edipole3  --  dipole-dipole energy & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "edipole3" calculates the dipole-dipole interaction energy;
c     also partitions the energy among the atoms
c
c
      subroutine edipole3
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use cell
      use chgpot
      use dipole
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use shunt
      use units
      use usage
      implicit none
      integer i,j,k
      integer i1,i2,k1,k2
      real*8 xi,yi,zi
      real*8 xk,yk,zk
      real*8 xq,yq,zq
      real*8 xr,yr,zr
      real*8 f,fi,fik
      real*8 taper,fgrp
      real*8 e,ri2,rk2,rirkr3
      real*8 doti,dotk,dotp
      real*8 r,r2,r3,r4,r5
      logical proceed
      logical header,huge
      character*6 mode
c
c
c     zero out the overall dipole interaction energy contribution
c     and set up the constants for the calculation
c
      ned = 0
      ed = 0.0d0
      do i = 1, n
         aed(i) = 0.0d0
      end do
      if (ndipole .eq. 0)  return
c
c     set conversion factor and switching function coefficients
c
      f = electric / (debye**2 * dielec)
      mode = 'DIPOLE'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. ndipole.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Dipole-Dipole Interactions :',
     &           //,' Type',15x,'Dipole 1',14x,'Dipole 2',
     &              8x,'Distance',6x,'Energy',/)
      end if
c
c     compute and partition the dipole interaction energy
c
      do i = 1, ndipole-1
         i1 = idpl(1,i)
         i2 = idpl(2,i)
         xi = x(i2) - x(i1)
         yi = y(i2) - y(i1)
         zi = z(i2) - z(i1)
         if (use_polymer)  call imager (xi,yi,zi,-1)
         ri2 = xi*xi + yi*yi + zi*zi
         xq = x(i1) + xi*sdpl(i)
         yq = y(i1) + yi*sdpl(i)
         zq = z(i1) + zi*sdpl(i)
         fi = f * bdpl(i)
c
c     decide whether to compute the current interaction
c
         do k = i+1, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i1,i2,k1,k2,0,0)
            if (proceed)  proceed = (use(i1) .or. use(i2) .or.
     &                                 use(k1) .or. use(k2))
            if (proceed)  proceed = (k1.ne.i1 .and. k1.ne.i2 .and.
     &                                 k2.ne.i1 .and. k2.ne.i2)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xk = x(k2) - x(k1)
               yk = y(k2) - y(k1)
               zk = z(k2) - z(k1)
               if (use_polymer)  call imager (xk,yk,zk,-1)
               xr = xq - x(k1) - xk*sdpl(k)
               yr = yq - y(k1) - yk*sdpl(k)
               zr = zq - z(k1) - zk*sdpl(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  rk2 = xk*xk + yk*yk + zk*zk
                  rirkr3 = sqrt(ri2*rk2*r2) * r2
                  dotp = xi*xk + yi*yk + zi*zk
                  doti = xi*xr + yi*yr + zi*zr
                  dotk = xk*xr + yk*yr + zk*zr
                  fik = fi * bdpl(k)
                  e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall dipole-dipole energy component
c
                  ned = ned + 1
                  ed = ed + e
                  aed(i1) = aed(i1) + 0.25d0*e
                  aed(i2) = aed(i2) + 0.25d0*e
                  aed(k1) = aed(k1) + 0.25d0*e
                  aed(k2) = aed(k2) + 0.25d0*e
c
c     increment the total intermolecular energy
c
                  if (molcule(i1) .ne. molcule(k1)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(e) .gt. 10.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Dipole-Dipole',
     &                             ' Interactions :',
     &                          //,' Type',15x,'Dipole 1',14x,
     &                             'Dipole 2',8x,'Distance',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i1,name(i1),i2,name(i2),
     &                                k1,name(k1),k2,name(k2),
     &                                sqrt(r2),e
   30                format (' Dipole',4x,4(i7,'-',a3),f11.4,f12.4)
                  end if
               end if
            end if
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do i = 1, ndipole
         i1 = idpl(1,i)
         i2 = idpl(2,i)
         xi = x(i2) - x(i1)
         yi = y(i2) - y(i1)
         zi = z(i2) - z(i1)
         if (use_polymer)  call imager (xi,yi,zi,-1)
         ri2 = xi*xi + yi*yi + zi*zi
         xq = x(i1) + xi*sdpl(i)
         yq = y(i1) + yi*sdpl(i)
         zq = z(i1) + zi*sdpl(i)
         fi = f * bdpl(i)
c
c     decide whether to compute the current interaction
c
         do k = i, ndipole
            k1 = idpl(1,k)
            k2 = idpl(2,k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i1,i2,k1,k2,0,0)
            if (proceed)  proceed = (use(i1) .or. use(i2) .or.
     &                                 use(k1) .or. use(k2))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xk = x(k2) - x(k1)
                  yk = y(k2) - y(k1)
                  zk = z(k2) - z(k1)
                  if (use_polymer)  call imager (xk,yk,zk,-1)
                  xr = xq - x(k1) - xk*sdpl(k)
                  yr = yq - y(k1) - yk*sdpl(k)
                  zr = zq - z(k1) - zk*sdpl(k)
                  call imager (xr,yr,zr,j)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     rk2 = xk*xk + yk*yk + zk*zk
                     rirkr3 = sqrt(ri2*rk2*r2) * r2
                     dotp = xi*xk + yi*yk + zi*zk
                     doti = xi*xr + yi*yr + zi*zr
                     dotk = xk*xr + yk*yr + zk*zr
                     fik = fi * bdpl(k)
                     if (use_polymer) then
                        if (r2 .lt. polycut2) then
                           if (k1.eq.i1 .or. k1.eq.i2 .or.
     &                         k2.eq.i1 .or. k2.eq.i2)  fik = 0.0d0
                        end if
                     end if
                     e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3
c
c     use energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        r = sqrt(r2)
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall dipole-dipole energy component
c
                     if (e .ne. 0.0d0)  ned = ned + 1
                     if (i .eq. k) then
                        ed = ed + 0.5d0*e
                        aed(i1) = aed(i1) + 0.25d0*e
                        aed(i2) = aed(i2) + 0.25d0*e
                     else
                        ed = ed + e
                        aed(i1) = aed(i1) + 0.25d0*e
                        aed(i2) = aed(i2) + 0.25d0*e
                        aed(k1) = aed(k1) + 0.25d0*e
                        aed(k2) = aed(k2) + 0.25d0*e
                     end if
c
c     increment the total intermolecular energy
c
                     einter = einter + e
c
c     print a message if the energy of this interaction is large
c
                     huge = (abs(e) .gt. 10.0d0)
                     if ((debug.and.e.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual Dipole-Dipole',
     &                                ' Interactions :',
     &                             //,' Type',15x,'Dipole 1',14x,
     &                                'Dipole 2',8x,'Distance',
     &                                6x,'Energy',/)
                        end if
                        write (iout,50)  i1,name(i1),i2,name(i2),
     &                                   k1,name(k1),k2,name(k2),
     &                                   sqrt(r2),e
   50                format (' Dipole',4x,4(i7,'-',a3),f11.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine edisp  --  damped dispersion potential energy  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "edisp" calculates the damped dispersion potential energy
c
c     literature reference:
c
c     J. A. Rackers, C. Liu, P. Ren and J. W. Ponder, "A Physically
c     Grounded Damped Dispersion Model with Particle Mesh Ewald
c     Summation", Journal of Chemical Physics, 149, 084115 (2018)
c
c
      subroutine edisp
      use dsppot
      use energi
      use ewald
      use limits
      implicit none
      real*8 elrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_dewald) then
         if (use_dlist) then
            call edisp0d
         else
            call edisp0c
         end if
      else
         if (use_dlist) then
            call edisp0b
         else
            call edisp0a
         end if
      end if
c
c     apply long range dispersion correction if desired
c
      if (use_dcorr .and. .not.use_dewald) then
         mode = 'DISP'
         call evcorr (mode,elrc)
         edsp = edsp + elrc
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine edisp0a  --  damped dispersion via double loop  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "edisp0a" calculates the damped dispersion potential energy
c     using a pairwise double loop
c
c
      subroutine edisp0a
      use atoms
      use bound
      use boxes
      use couple
      use cell
      use disp
      use dsppot
      use energi
      use group
      use mutant
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,fgrp
      real*8 ci,ck
      real*8 r,r2,r3
      real*8 r4,r5,r6
      real*8 ai,ai2
      real*8 ak,ak2
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk
      real*8 damp3,damp5
      real*8 damp,taper
      real*8 vterm,eps
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     zero out the total damped dispersion energy
c
      edsp = 0.0d0
      if (ndisp .eq. 0) return
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3)
      end if
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DISP'
      call switch (mode)
c
c     find the damped dispersion energy via double loop search
c
      do ii = 1, ndisp-1
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  r6 = r2**3
                  e = -ci * ck / r6
c
c     find the damping factor for the dispersion interaction
c
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                  else
                     ai2 = ai * ai
                     ak2 = ak * ak
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     ti2 = ti * ti
                     tk = ai2 / (ai2-ak2)
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                  e = e * dspscale(k) * damp**2
                  if (use_group)  e = e * fgrp
c
c     set use of lambda scaling for decoupling or annihilation
c
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        e = e * vterm
                     else if (.not.muti .or. .not.mutk) then
                        e = e * vterm
                     end if
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     increment the overall damped dispersion energy component
c
                  edsp = edsp + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, ndisp
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do jcell = 2, ncell
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     r6 = r2**3
                     e = -ci * ck / r6
c
c     find the damping factor for the dispersion interaction
c
                     di = ai * r
                     di2 = di * di
                     di3 = di * di2
                     dk = ak * r
                     expi = exp(-di)
                     expk = exp(-dk)
                     if (abs(ai-ak) .lt. eps) then
                        di4 = di2 * di2
                        di5 = di2 * di3
                        damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                             +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                        damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                           +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                     else
                        ai2 = ai * ai
                        ak2 = ak * ak
                        dk2 = dk * dk
                        dk3 = dk * dk2
                        ti = ak2 / (ak2-ai2)
                        ti2 = ti * ti
                        tk = ai2 / (ai2-ak2)
                        tk2 = tk * tk
                        damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                             - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                             - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                        damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                          +di3/6.0d0)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2
     &                                       +dk3/6.0d0)*expk
     &                           - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                           - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                     end if
                     damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                     e = e * damp**2
                     if (use_polymer) then
                        if (r2 .le. polycut2)  e = e * dspscale(k)
                     end if
                     if (use_group)  e = e * fgrp
                     if (i .eq. k)  e = 0.5d0 * e
c
c     set use of lambda scaling for decoupling or annihilation
c
                     if (muti .or. mutk) then
                        if (vcouple .eq. 1) then
                           e = e * vterm
                        else if (.not.muti .or. .not.mutk) then
                           e = e * vterm
                        end if
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        e = e * taper
                     end if
c
c     increment the overall damped dispersion energy component
c
                     edsp = edsp + e
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine edisp0b  --  damp dispersion via neighbor list  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "edisp0b" calculates the damped dispersion potential energy
c     using a pairwise neighbor list
c
c
      subroutine edisp0b
      use atoms
      use bound
      use boxes
      use couple
      use cell
      use disp
      use dsppot
      use energi
      use group
      use mutant
      use neigh
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,fgrp
      real*8 ci,ck
      real*8 r,r2,r3
      real*8 r4,r5,r6
      real*8 ai,ai2
      real*8 ak,ak2
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk
      real*8 damp3,damp5
      real*8 damp,taper
      real*8 vterm,eps
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     zero out the total damped dispersion energy
c
      edsp = 0.0d0
      if (ndisp .eq. 0) return
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3)
      end if
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DISP'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ndisp,idisp,csix,adisp,use,
!$OMP& x,y,z,n12,n13,n14,n15,i12,i13,i14,i15,nvlst,vlst,use_group,
!$OMP& dsp2scale,dsp3scale,dsp4scale,dsp5scale,mut,off2,cut2,
!$OMP& c0,c1,c2,c3,c4,c5,vcouple,vterm,eps)
!$OMP& firstprivate(dspscale) shared(edsp)
!$OMP DO reduction(+:edsp)
c
c     find the damped dispersion energy via neighbor list search
c
      do ii = 1, ndisp
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  r6 = r2**3
                  e = -ci * ck / r6
c
c     find the damping factor for the dispersion interaction
c
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                  else
                     ai2 = ai * ai
                     ak2 = ak * ak
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     ti2 = ti * ti
                     tk = ai2 / (ai2-ak2)
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                  e = e * dspscale(k) * damp**2
                  if (use_group)  e = e * fgrp
c
c     set use of lambda scaling for decoupling or annihilation
c
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        e = e * vterm
                     else if (.not.muti .or. .not.mutk) then
                        e = e * vterm
                     end if
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     increment the overall dispersion energy component
c
                  edsp = edsp + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c                                                                        
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine edisp0c  --  Ewald dispersion energy via loop  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "edisp0c" calculates the dispersion interaction energy using
c     particle mesh Ewald summation and a double loop
c
c
      subroutine edisp0c
      use disp
      use energi
      use ewald
      use pme
      implicit none
      integer i,ii
      real*8 e
c
c
c     zero out the total damped dispersion energy
c
      edsp = 0.0d0
      if (ndisp .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = ndfft1
      nfft2 = ndfft2
      nfft3 = ndfft3
      bsorder = bsdorder
      aewald = adewald
c
c     compute the real space portion of the Ewald summation
c
      call edreal0c
c
c     compute the reciprocal space part of the Ewald summation
c
      call edrecip
c
c     compute the self-energy portion of the Ewald summation
c
      do ii = 1, ndisp
         i = idisp(i)
         e = csix(i)**2 * aewald**6 / 12.0d0
         edsp = edsp + e
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine edreal0c  --  real space dispersion via loop  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "edreal0c" calculates the damped dispersion potential energy
c     using a particle mesh Ewald sum and pairwise double loop
c
c
      subroutine edreal0c
      use atoms
      use bound
      use boxes
      use couple
      use cell
      use disp
      use dsppot
      use energi
      use ewald
      use group
      use mutant
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,fgrp
      real*8 ci,ck
      real*8 r,r2,r6
      real*8 ai,ai2
      real*8 ak,ak2
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk
      real*8 ralpha2
      real*8 expa,term
      real*8 damp3,damp5
      real*8 damp,scale
      real*8 vterm,eps
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3)
      end if
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DEWALD'
      call switch (mode)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, ndisp-1
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  r6 = r2**3
                  e = -ci * ck / r6
                  ralpha2 = r2 * aewald**2
                  term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2
                  expa = exp(-ralpha2) * term
c
c     find the damping factor for the dispersion interaction
c
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                  else
                     ai2 = ai * ai
                     ak2 = ak * ak
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     ti2 = ti * ti
                     tk = ai2 / (ai2-ak2)
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                  scale = dspscale(k) * damp**2
                  if (use_group)  scale = scale * fgrp
c
c     set use of lambda scaling for decoupling or annihilation
c
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        scale = scale * vterm
                     else if (.not.muti .or. .not.mutk) then
                        scale = scale * vterm
                     end if
                  end if
c
c     increment the overall dispersion energy component
c
                  scale = scale - 1.0d0
                  e = e * (expa+scale)
                  edsp = edsp + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, ndisp
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do jcell = 2, ncell
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     r6 = r2**3
                     e = -ci * ck / r6
                     ralpha2 = r2 * aewald**2
                     term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2
                     expa = exp(-ralpha2) * term
c
c     find the damping factor for the dispersion interaction
c
                     di = ai * r
                     di2 = di * di
                     di3 = di * di2
                     dk = ak * r
                     expi = exp(-di)
                     expk = exp(-dk)
                     if (abs(ai-ak) .lt. eps) then
                        di4 = di2 * di2
                        di5 = di2 * di3
                        damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                             +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                        damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                           +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                     else
                        ai2 = ai * ai
                        ak2 = ak * ak
                        dk2 = dk * dk
                        dk3 = dk * dk2
                        ti = ak2 / (ak2-ai2)
                        ti2 = ti * ti
                        tk = ai2 / (ai2-ak2)
                        tk2 = tk * tk
                        damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                             - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                             - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                        damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                          +di3/6.0d0)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2
     &                                       +dk3/6.0d0)*expk
     &                            - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                            - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                     end if
                     damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                     scale = damp**2
                     if (use_group)  scale = scale * fgrp
                     if (use_polymer) then
                        if (r2 .le. polycut2) then
                           scale = scale * dspscale(k)
                        end if
                     end if
c
c     set use of lambda scaling for decoupling or annihilation
c
                     if (muti .or. mutk) then
                        if (vcouple .eq. 1) then
                           scale = scale * vterm
                        else if (.not.muti .or. .not.mutk) then
                           scale = scale * vterm
                        end if
                     end if
c
c     increment the overall dispersion energy component
c
                     scale = scale - 1.0d0
                     e = e * (expa+scale)
                     if (i .eq. k)  e = 0.5d0 * e
                     edsp = edsp + e
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine edisp0d  --  Ewald dispersion energy via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "edisp0d" calculates the dispersion interaction energy using
c     particle mesh Ewald summation and a neighbor list
c
c
      subroutine edisp0d
      use disp
      use energi
      use ewald
      use pme
      implicit none
      integer i,ii
      real*8 e
c
c
c     zero out the total damped dispersion energy
c
      edsp = 0.0d0
      if (ndisp .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = ndfft1
      nfft2 = ndfft2
      nfft3 = ndfft3
      bsorder = bsdorder
      aewald = adewald
c
c     compute the real space portion of the Ewald summation
c
      call edreal0d
c
c     compute the reciprocal space part of the Ewald summation
c
      call edrecip
c
c     compute the self-energy portion of the Ewald summation
c
      do ii = 1, ndisp
         i = idisp(ii)
         e = csix(i)**2 * aewald**6 / 12.0d0
         edsp = edsp + e
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine edreal0d  --  real space dispersion via list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "edreal0d" calculates the real space portion of the damped
c     dispersion energy using a neighbor list
c
c
      subroutine edreal0d
      use atoms
      use bound
      use boxes
      use couple
      use cell
      use disp
      use dsppot
      use energi
      use ewald
      use group
      use mutant
      use neigh
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,fgrp
      real*8 ci,ck
      real*8 r,r2,r6
      real*8 ai,ai2
      real*8 ak,ak2
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk
      real*8 ralpha2
      real*8 expa,term
      real*8 damp3,damp5
      real*8 damp,scale
      real*8 vterm,eps
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3)
      end if
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DEWALD'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ndisp,idisp,csix,adisp,use,
!$OMP& x,y,z,n12,n13,n14,n15,i12,i13,i14,i15,nvlst,vlst,use_group,
!$OMP& dsp2scale,dsp3scale,dsp4scale,dsp5scale,mut,off2,aewald,
!$OMP& vcouple,vterm,eps)
!$OMP& firstprivate(dspscale) shared(edsp)
!$OMP DO reduction(+:edsp)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, ndisp
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  r6 = r2**3
                  e = -ci * ck / r6
                  ralpha2 = r2 * aewald**2
                  term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2
                  expa = exp(-ralpha2) * term
c
c     find the damping factor for the dispersion interaction
c
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                  else
                     ai2 = ai * ai
                     ak2 = ak * ak
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     ti2 = ti * ti
                     tk = ai2 / (ai2-ak2)
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                  scale = dspscale(k) * damp**2
                  if (use_group)  scale = scale * fgrp
c
c     set use of lambda scaling for decoupling or annihilation
c
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        scale = scale * vterm
                     else if (.not.muti .or. .not.mutk) then
                        scale = scale * vterm
                     end if
                  end if
c
c     increment the overall dispersion energy component
c
                  scale = scale - 1.0d0
                  e = e * (expa+scale)
                  edsp = edsp + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c                                                                        
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine edrecip  --  PME recip space damped dispersion  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "edrecip" evaluates the reciprocal space portion of the particle
c     mesh Ewald energy due to damped dispersion
c
c
      subroutine edrecip
      use boxes
      use bound
      use disp
      use energi
      use ewald
      use math
      use pme
      implicit none
      integer i,j
      integer k1,k2,k3
      integer m1,m2,m3
      integer ntot,nff
      integer nf1,nf2,nf3
      real*8 e,denom
      real*8 r1,r2,r3
      real*8 h1,h2,h3
      real*8 term,expterm
      real*8 eterm,denom0
      real*8 hsq,struc2
      real*8 h,hhh,b,bfac
      real*8 fac1,fac2,fac3
      real*8 erfcterm
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
c
c     perform dynamic allocation of some global arrays
c
      ntot = nfft1 * nfft2 * nfft3
      if (allocated(qgrid)) then
         if (size(qgrid) .ne. 2*ntot)  call fftclose
      end if
      if (.not. allocated(qgrid))  call fftsetup
c
c     setup spatial decomposition and B-spline coefficients
c
      call getchunk
      call moduli
      call bspline_fill
      call table_fill
c
c     assign PME grid and perform 3-D FFT forward transform
c
      call grid_disp
      call fftfront
c
c     use scalar sum to get the reciprocal space energy
c
      bfac = pi / aewald
      fac1 = 2.0d0 * pi**(3.5d0)
      fac2 = aewald**3
      fac3 = -2.0d0 * aewald * pi**2
      denom0 = (6.0d0*volbox) / (pi**1.5d0)
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      nff = nfft1 * nfft2
      ntot = nff * nfft3
      do i = 1, ntot-1
         k3 = i/nff + 1
         j = i - (k3-1)*nff
         k2 = j/nfft1 + 1
         k1 = j - (k2-1)*nfft1 + 1
         m1 = k1 - 1
         m2 = k2 - 1
         m3 = k3 - 1
         if (k1 .gt. nf1)  m1 = m1 - nfft1
         if (k2 .gt. nf2)  m2 = m2 - nfft2
         if (k3 .gt. nf3)  m3 = m3 - nfft3
         r1 = dble(m1)
         r2 = dble(m2)
         r3 = dble(m3)
         h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
         h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
         h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
         hsq = h1*h1 + h2*h2 + h3*h3
         h = sqrt(hsq)
         b = h * bfac
         hhh = h * hsq
         term = -b * b
         if (term .gt. -50.0d0) then
            denom = denom0 * bsmod1(k1) * bsmod2(k2) * bsmod3(k3)
            expterm = exp(term)
            erfcterm = erfc(b)
            if (.not. use_bounds) then
               expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
               erfcterm = erfcterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
            else if (nonprism) then
               if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
               if (mod(m1+m2+m3,2) .ne. 0)  erfcterm = 0.0d0
            end if
            eterm = (-fac1*erfcterm*hhh-expterm*(fac2+fac3*hsq))/denom
            struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2
            e = eterm * struc2
            edsp = edsp + e
         end if
      end do
c
c     account for the total energy correction term
c
      e = -csixpr * aewald**3 / denom0
      edsp = edsp + e
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine edisp1  --  damped dispersion energy & derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "edisp1" calculates the damped dispersion energy and first
c     derivatives with respect to Cartesian coordinates
c
c     literature reference:
c
c     J. A. Rackers, C. Liu, P. Ren and J. W. Ponder, "A Physically
c     Grounded Damped Dispersion Model with Particle Mesh Ewald
c     Summation", Journal of Chemical Physics, 149, 084115 (2018)
c
c
      subroutine edisp1
      use dsppot
      use energi
      use ewald
      use limits
      use virial
      implicit none
      real*8 elrc,vlrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_dewald) then
         if (use_dlist) then
            call edisp1d
         else
            call edisp1c
         end if
      else
         if (use_dlist) then
            call edisp1b
         else
            call edisp1a
         end if
      end if
c
c     apply long range dispersion correction if desired
c
      if (use_dcorr .and. .not.use_dewald) then
         mode = 'DISP'
         call evcorr1 (mode,elrc,vlrc)
         edsp = edsp + elrc
         vir(1,1) = vir(1,1) + vlrc
         vir(2,2) = vir(2,2) + vlrc
         vir(3,3) = vir(3,3) + vlrc
      end if
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine edisp1a  --  double loop dispersion derivs  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "edisp1a" calculates the damped dispersion energy and
c     derivatives with respect to Cartesian coordinates using
c     a pairwise double loop
c
c
      subroutine edisp1a
      use atoms
      use bound
      use cell
      use couple
      use deriv
      use disp
      use dsppot
      use energi
      use group
      use mutant
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,de,fgrp
      real*8 ci,ck
      real*8 r,r2,r3
      real*8 r4,r5,r6
      real*8 ai,ai2,ai3
      real*8 ak,ak2,ak3
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk
      real*8 damp3,damp5
      real*8 damp,ddamp
      real*8 vterm,eps
      real*8 taper,dtaper
      real*8 dedx,dedy,dedz
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     zero out the dispersion energy and derivatives
c
      edsp = 0.0d0
      do i = 1, n
         dedsp(1,i) = 0.0d0
         dedsp(2,i) = 0.0d0
         dedsp(3,i) = 0.0d0
      end do
      if (ndisp .eq. 0) return
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3)
      end if
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DISP'
      call switch (mode)
c
c     find dispersion energy and derivatives via double loop
c
      do ii = 1, ndisp-1
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  r6 = r2**3
                  e = -ci * ck / r6
                  de = -6.0d0 * e / r
c
c     find the damping factor for the dispersion interaction
c
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                     ddamp = ai * expi * (di5-3.0d0*di3-3.0d0*di2)
     &                          / 96.0d0
                  else
                     ai2 = ai * ai
                     ai3 = ai * ai2
                     ak2 = ak * ak
                     ak3 = ak * ak2
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     tk = ai2 / (ai2-ak2)
                     ti2 = ti * ti
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                     ddamp = 0.25d0 * di2 * ti2 * ai * expi
     &                          * (r*ai+4.0d0*tk-1.0d0)
     &                       + 0.25d0 * dk2 * tk2 * ak * expk
     &                            * (r*ak+4.0d0*ti-1.0d0)
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     set use of lambda scaling for decoupling or annihilation
c
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        de = de * vterm
                        e = e * vterm
                     else if (.not.muti .or. .not.mutk) then
                        de = de * vterm
                        e = e * vterm
                     end if
                  end if
c
c     apply damping and scaling factors for this interaction
c
                  de = de*damp**2 + 2.0d0*e*damp*ddamp
                  e = e * damp**2
                  e = e * dspscale(k)
                  de = de * dspscale(k)
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     increment the overall damped dispersion energy component
c
                  edsp = edsp + e
c
c     increment the damped dispersion derivative components
c
                  dedx = de * xr/r
                  dedy = de * yr/r
                  dedz = de * zr/r
                  dedsp(1,i) = dedsp(1,i) + dedx
                  dedsp(2,i) = dedsp(2,i) + dedy
                  dedsp(3,i) = dedsp(3,i) + dedz
                  dedsp(1,k) = dedsp(1,k) - dedx
                  dedsp(2,k) = dedsp(2,k) - dedy
                  dedsp(3,k) = dedsp(3,k) - dedz
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, ndisp
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do jcell = 2, ncell
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     r6 = r2**3
                     e = -ci * ck / r6
                     de = -6.0d0 * e / r
c
c     find the damping factor for the dispersion interaction
c
                     di = ai * r
                     di2 = di * di
                     di3 = di * di2
                     dk = ak * r
                     expi = exp(-di)
                     expk = exp(-dk)
                     if (abs(ai-ak) .lt. eps) then
                        di4 = di2 * di2
                        di5 = di2 * di3
                        damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                             +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                        damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                           +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                        ddamp = ai * expi * (di5-3.0d0*di3-3.0d0*di2)
     &                             / 96.0d0
                     else
                        ai2 = ai * ai
                        ai3 = ai * ai2
                        ak2 = ak * ak
                        ak3 = ak * ak2
                        dk2 = dk * dk
                        dk3 = dk * dk2
                        ti = ak2 / (ak2-ai2)
                        tk = ai2 / (ai2-ak2)
                        ti2 = ti * ti
                        tk2 = tk * tk
                        damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                             - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                             - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                        damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                          +di3/6.0d0)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2
     &                                       +dk3/6.0d0)*expk
     &                            - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                            - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                        ddamp = 0.25d0 * di2 * ti2 * ai * expi
     &                             * (r*ai+4.0d0*tk-1.0d0)
     &                          + 0.25d0 * dk2 * tk2 * ak * expk
     &                               * (r*ak+4.0d0*ti-1.0d0)
                     end if
                     damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     set use of lambda scaling for decoupling or annihilation
c
                     if (muti .or. mutk) then
                        if (vcouple .eq. 1) then
                           de = de * vterm
                           e = e * vterm
                        else if (.not.muti .or. .not.mutk) then
                           de = de * vterm
                           e = e * vterm
                        end if
                     end if
c
c     apply damping and scaling factors for this interaction
c
                     de = de*damp**2 + 2.0d0*e*damp*ddamp
                     e = e * damp**2
                     if (use_polymer) then
                        if (r2 .le. polycut2) then
                           e = e * dspscale(k)
                           de = de * dspscale(k)
                        end if
                     end if
                     if (use_group) then
                        e = e * fgrp
                        de = de * fgrp
                     end if
                     if (i .eq. k) then
                        e = 0.5d0 * e
                        de = 0.5d0 * de
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                              + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                        de = e*dtaper + de*taper
                        e = e * taper
                     end if
c
c     increment the overall damped dispersion energy component
c
                     edsp = edsp + e
c
c     increment the damped dispersion derivative components
c
                     dedx = de * xr/r
                     dedy = de * yr/r
                     dedz = de * zr/r
                     dedsp(1,i) = dedsp(1,i) + dedx
                     dedsp(2,i) = dedsp(2,i) + dedy
                     dedsp(3,i) = dedsp(3,i) + dedz
                     dedsp(1,k) = dedsp(1,k) - dedx
                     dedsp(2,k) = dedsp(2,k) - dedy
                     dedsp(3,k) = dedsp(3,k) - dedz
c
c     increment the internal virial tensor components
c
                     vxx = xr * dedx
                     vyx = yr * dedx
                     vzx = zr * dedx
                     vyy = yr * dedy
                     vzy = zr * dedy
                     vzz = zr * dedz
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine edisp1b  --  neighbor list dispersion derivs  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "edisp1b" calculates the damped dispersion energy and
c     derivatives with respect to Cartesian coordinates using
c     a pairwise neighbor list
c
c
      subroutine edisp1b
      use atoms
      use bound
      use cell
      use couple
      use deriv
      use disp
      use dsppot
      use energi
      use group
      use mutant
      use neigh
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,de,fgrp
      real*8 ci,ck
      real*8 r,r2,r3
      real*8 r4,r5,r6
      real*8 ai,ai2,ai3
      real*8 ak,ak2,ak3
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk
      real*8 damp3,damp5
      real*8 damp,ddamp
      real*8 vterm,eps
      real*8 taper,dtaper
      real*8 dedx,dedy,dedz
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     zero out the dispersion energy and derivatives
c
      edsp = 0.0d0
      do i = 1, n
         dedsp(1,i) = 0.0d0
         dedsp(2,i) = 0.0d0
         dedsp(3,i) = 0.0d0
      end do
      if (ndisp .eq. 0) return
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3)
      end if
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DISP'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ndisp,idisp,csix,adisp,use,
!$OMP& x,y,z,n12,n13,n14,n15,i12,i13,i14,i15,nvlst,vlst,use_group,
!$OMP& dsp2scale,dsp3scale,dsp4scale,dsp5scale,mut,off2,cut2,
!$OMP& c0,c1,c2,c3,c4,c5,vcouple,vterm,eps)
!$OMP& firstprivate(dspscale) shared(edsp,dedsp,vir)
!$OMP DO reduction(+:edsp,dedsp,vir)
c
c     find dispersion energy and derivatives via neighbor list
c
      do ii = 1, ndisp-1
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  r6 = r2**3
                  e = -ci * ck / r6
                  de = -6.0d0 * e / r
c
c     find the damping factor for the dispersion interaction
c
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                     ddamp = ai * expi * (di5-3.0d0*di3-3.0d0*di2)
     &                          / 96.0d0
                  else
                     ai2 = ai * ai
                     ai3 = ai * ai2
                     ak2 = ak * ak
                     ak3 = ak * ak2
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     tk = ai2 / (ai2-ak2)
                     ti2 = ti * ti
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                     ddamp = 0.25d0 * di2 * ti2 * ai * expi
     &                          * (r*ai+4.0d0*tk-1.0d0)
     &                       + 0.25d0 * dk2 * tk2 * ak * expk
     &                            * (r*ak+4.0d0*ti-1.0d0)
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     set use of lambda scaling for decoupling or annihilation
c
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        de = de * vterm
                        e = e * vterm
                     else if (.not.muti .or. .not.mutk) then
                        de = de * vterm
                        e = e * vterm
                     end if
                  end if
c
c     apply damping and scaling factors for this interaction
c
                  de = de*damp**2 + 2.0d0*e*damp*ddamp
                  e = e * damp**2
                  e = e * dspscale(k)
                  de = de * dspscale(k)
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     increment the overall damped dispersion energy component
c
                  edsp = edsp + e
c
c     increment the damped dispersion derivative components
c
                  dedx = de * xr/r
                  dedy = de * yr/r
                  dedz = de * zr/r
                  dedsp(1,i) = dedsp(1,i) + dedx
                  dedsp(2,i) = dedsp(2,i) + dedy
                  dedsp(3,i) = dedsp(3,i) + dedz
                  dedsp(1,k) = dedsp(1,k) - dedx
                  dedsp(2,k) = dedsp(2,k) - dedy
                  dedsp(3,k) = dedsp(3,k) - dedz
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c                                                                        
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine edisp1c  --  Ewald dispersion derivs via loop  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "edisp1c" calculates the damped dispersion energy and
c     derivatives with respect to Cartesian coordinates using
c     particle mesh Ewald summation and a double loop
c
c
      subroutine edisp1c
      use atoms
      use deriv
      use disp
      use energi
      use ewald
      use pme
      implicit none
      integer i,ii
      real*8 e
c
c
c     zero out the dispersion energy and derivatives
c
      edsp = 0.0d0
      do i = 1, n
         dedsp(1,i) = 0.0d0
         dedsp(2,i) = 0.0d0
         dedsp(3,i) = 0.0d0
      end do
      if (ndisp .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = ndfft1
      nfft2 = ndfft2
      nfft3 = ndfft3
      bsorder = bsdorder
      aewald = adewald
c
c     compute the real space portion of the Ewald summation
c
      call edreal1c
c
c     compute the reciprocal space part of the Ewald summation
c
      call edrecip1
c
c     compute the self-energy portion of the Ewald summation
c
      do ii = 1, ndisp
         i = idisp(ii)
         e = csix(i)**2 * aewald**6 / 12.0d0
         edsp = edsp + e
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine edreal1c  --  Ewald real disp derivs via loop  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "edreal1c" evaluates the real space portion of the Ewald
c     summation energy and gradient due to damped dispersion
c     interactions via a double loop
c
c
      subroutine edreal1c
      use atoms
      use bound
      use boxes
      use couple
      use cell
      use disp
      use dsppot
      use deriv
      use energi
      use ewald
      use group
      use mutant
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,de,fgrp
      real*8 ci,ck
      real*8 r,r2,r6,r7
      real*8 ai,ai2
      real*8 ak,ak2
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk
      real*8 damp3,damp5
      real*8 damp,ddamp
      real*8 vterm,eps
      real*8 ralpha2,scale
      real*8 expterm,term
      real*8 expa,rterm
      real*8 dedx,dedy,dedz
      real*8 vxx,vyx,vzx
      real*8 vyy,vzy,vzz
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3)
      end if
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DEWALD'
      call switch (mode)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, ndisp-1
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r6 = r2**3
                  e = -ci * ck / r6
                  ralpha2 = r2 * aewald**2
                  term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2
                  expterm = exp(-ralpha2)
                  expa = expterm * term
c
c     find the damping factor for the dispersion interaction
c
                  r = sqrt(r2)
                  r7 = r6 * r
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                     ddamp = ai * expi * (di5-3.0d0*di3-3.0d0*di2)
     &                          / 96.0d0
                  else
                     ai2 = ai * ai
                     ak2 = ak * ak
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     ti2 = ti * ti
                     tk = ai2 / (ai2-ak2)
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                     ddamp = 0.25d0 * di2 * ti2 * ai * expi
     &                          * (r*ai+4.0d0*tk-1.0d0)
     &                       + 0.25d0 * dk2 * tk2 * ak * expk
     &                            * (r*ak+4.0d0*ti-1.0d0)
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                  scale = dspscale(k) * damp**2
                  if (use_group)  scale = scale * fgrp
c
c     set use of lambda scaling for decoupling or annihilation
c
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        scale = scale * vterm
                        ddamp = ddamp * vterm
                     else if (.not.muti .or. .not.mutk) then
                        scale = scale * vterm
                        ddamp = ddamp * vterm
                     end if
                  end if
c
c     increment the overall damped dispersion energy component
c
                  scale = scale - 1.0d0
                  e = e * (expa+scale)
                  edsp = edsp + e
c
c     increment the damped dispersion derivative components
c
                  rterm = -(ralpha2**3) * expterm / r
                  de = -6.0d0*e/r2 - ci*ck*rterm/r7
     &                    - 2.0d0*ci*ck*dspscale(k)*damp*ddamp/r7
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
                  dedsp(1,i) = dedsp(1,i) + dedx
                  dedsp(2,i) = dedsp(2,i) + dedy
                  dedsp(3,i) = dedsp(3,i) + dedz
                  dedsp(1,k) = dedsp(1,k) - dedx
                  dedsp(2,k) = dedsp(2,k) - dedy
                  dedsp(3,k) = dedsp(3,k) - dedz
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, ndisp
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do jcell = 2, ncell
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     r6 = r2**3
                     e = -ci * ck / r6
                     ralpha2 = r2 * aewald**2
                     term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2
                     expterm = exp(-ralpha2)
                     expa = expterm * term
c
c     find the damping factor for the dispersion interaction
c
                     r = sqrt(r2)
                     r7 = r6 * r
                     di = ai * r
                     di2 = di * di
                     di3 = di * di2
                     dk = ak * r
                     expi = exp(-di)
                     expk = exp(-dk)
                     if (abs(ai-ak) .lt. eps) then
                        di4 = di2 * di2
                        di5 = di2 * di3
                        damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                             +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                        damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                           +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                        ddamp = ai * expi * (di5-3.0d0*di3-3.0d0*di2)
     &                             / 96.0d0
                     else
                        ai2 = ai * ai
                        ak2 = ak * ak
                        dk2 = dk * dk
                        dk3 = dk * dk2
                        ti = ak2 / (ak2-ai2)
                        ti2 = ti * ti
                        tk = ai2 / (ai2-ak2)
                        tk2 = tk * tk
                        damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                             - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                             - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                        damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                          +di3/6.0d0)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2
     &                                       +dk3/6.0d0)*expk
     &                            - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                            - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                        ddamp = 0.25d0 * di2 * ti2 * ai * expi
     &                             * (r*ai+4.0d0*tk-1.0d0)
     &                          + 0.25d0 * dk2 * tk2 * ak * expk
     &                               * (r*ak+4.0d0*ti-1.0d0)
                     end if
                     damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                     scale = dspscale(k) * damp**2
                     if (use_group)  scale = scale * fgrp
c
c     set use of lambda scaling for decoupling or annihilation
c
                     if (muti .or. mutk) then
                        if (vcouple .eq. 1) then
                           scale = scale * vterm
                           ddamp = ddamp * vterm
                        else if (.not.muti .or. .not.mutk) then
                           scale = scale * vterm
                           ddamp = ddamp * vterm
                        end if
                     end if
c
c     increment the overall damped dispersion energy component
c
                     scale = scale - 1.0d0
                     e = e * (expa+scale)
                     rterm = -(ralpha2**3) * expterm / r
                     de = -6.0d0*e/r2 - ci*ck*rterm/r7
     &                       - 2.0d0*ci*ck*dspscale(k)*damp*ddamp/r7
                     if (ii .eq. kk) then
                        e = 0.5d0 * e
                        de = 0.5d0 * de
                     end if
                     edsp = edsp + e
c
c     increment the damped dispersion derivative components
c
                     dedx = de * xr
                     dedy = de * yr
                     dedz = de * zr
                     dedsp(1,i) = dedsp(1,i) + dedx
                     dedsp(2,i) = dedsp(2,i) + dedy
                     dedsp(3,i) = dedsp(3,i) + dedz
                     dedsp(1,k) = dedsp(1,k) - dedx
                     dedsp(2,k) = dedsp(2,k) - dedy
                     dedsp(3,k) = dedsp(3,k) - dedz
c
c     increment the internal virial tensor components
c
                     vxx = xr * dedx
                     vyx = yr * dedx
                     vzx = zr * dedx
                     vyy = yr * dedy
                     vzy = zr * dedy
                     vzz = zr * dedz
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      stop
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine edisp1d  --  Ewald dispersion derivs via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "edisp1d" calculates the damped dispersion energy and
c     derivatives with respect to Cartesian coordinates using
c     particle mesh Ewald summation and a neighbor list
c
c
      subroutine edisp1d
      use atoms
      use deriv
      use disp
      use energi
      use ewald
      use pme
      implicit none
      integer i,ii
      real*8 e
c
c
c     zero out the dispersion energy and derivatives
c
      edsp = 0.0d0
      do i = 1, n
         dedsp(1,i) = 0.0d0
         dedsp(2,i) = 0.0d0
         dedsp(3,i) = 0.0d0
      end do
      if (ndisp .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = ndfft1
      nfft2 = ndfft2
      nfft3 = ndfft3
      bsorder = bsdorder
      aewald = adewald
c
c     compute the real space portion of the Ewald summation
c
      call edreal1d
c
c     compute the reciprocal space part of the Ewald summation
c
      call edrecip1
c
c     compute the self-energy portion of the Ewald summation
c
      do ii = 1, ndisp
         i = idisp(ii)
         e = csix(i)**2 * aewald**6 / 12.0d0
         edsp = edsp + e
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine edreal1d  --  Ewald real disp derivs via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "edreal1d" calculates the real space portion of the Ewald
c     summation energy and gradient due to damped dispersion
c     interactions via a neighbor list
c
c
      subroutine edreal1d
      use atoms
      use bound
      use boxes
      use couple
      use cell
      use deriv
      use disp
      use dsppot
      use energi
      use ewald
      use group
      use mutant
      use neigh
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,de,fgrp
      real*8 ci,ck
      real*8 r,r2,r6,r7
      real*8 ai,ai2
      real*8 ak,ak2
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk
      real*8 damp3,damp5
      real*8 damp,ddamp
      real*8 vterm,eps
      real*8 ralpha2,scale
      real*8 expterm,term
      real*8 expa,rterm
      real*8 dedx,dedy,dedz
      real*8 vxx,vyx,vzx
      real*8 vyy,vzy,vzz
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3)
      end if
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DEWALD'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ndisp,idisp,csix,adisp,use,
!$OMP& x,y,z,n12,n13,n14,n15,i12,i13,i14,i15,nvlst,vlst,use_group,
!$OMP& dsp2scale,dsp3scale,dsp4scale,dsp5scale,mut,off2,aewald,
!$OMP& vcouple,vterm,eps)
!$OMP& firstprivate(dspscale) shared(edsp,dedsp,vir)
!$OMP DO reduction(+:edsp,dedsp,vir)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, ndisp
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r6 = r2**3
                  e = -ci * ck / r6
                  ralpha2 = r2 * aewald**2
                  term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2
                  expterm = exp(-ralpha2)
                  expa = expterm * term
c
c     find the damping factor for the dispersion interaction
c
                  r = sqrt(r2)
                  r7 = r6 * r
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                     ddamp = ai * expi * (di5-3.0d0*di3-3.0d0*di2)
     &                          / 96.0d0
                  else
                     ai2 = ai * ai
                     ak2 = ak * ak
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     ti2 = ti * ti
                     tk = ai2 / (ai2-ak2)
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                     ddamp = 0.25d0 * di2 * ti2 * ai * expi
     &                          * (r*ai+4.0d0*tk-1.0d0)
     &                       + 0.25d0 * dk2 * tk2 * ak * expk
     &                            * (r*ak+4.0d0*ti-1.0d0)
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                  scale = dspscale(k) * damp**2
                  if (use_group)  scale = scale * fgrp
c
c     set use of lambda scaling for decoupling or annihilation
c
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        scale = scale * vterm
                        ddamp = ddamp * vterm
                     else if (.not.muti .or. .not.mutk) then
                        scale = scale * vterm
                        ddamp = ddamp * vterm
                     end if
                  end if
c
c     increment the overall damped dispersion energy component
c
                  scale = scale - 1.0d0
                  e = e * (expa+scale)
                  edsp = edsp + e
c
c     increment the damped dispersion derivative components
c
                  rterm = -(ralpha2**3) * expterm / r
                  de = -6.0d0*e/r2 - ci*ck*rterm/r7
     &                    - 2.0d0*ci*ck*dspscale(k)*damp*ddamp/r7
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
                  dedsp(1,i) = dedsp(1,i) + dedx
                  dedsp(2,i) = dedsp(2,i) + dedy
                  dedsp(3,i) = dedsp(3,i) + dedz
                  dedsp(1,k) = dedsp(1,k) - dedx
                  dedsp(2,k) = dedsp(2,k) - dedy
                  dedsp(3,k) = dedsp(3,k) - dedz
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c                                                                        
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine edrecip1  --  PME recip disp energy & derivs  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "edrecip1" evaluates the reciprocal space portion of particle
c     mesh Ewald energy and gradient due to damped dispersion
c
c
      subroutine edrecip1
      use boxes
      use bound
      use disp
      use deriv
      use energi
      use ewald
      use math
      use pme
      use virial
      implicit none
      integer i,j,k,ii
      integer k1,k2,k3
      integer m1,m2,m3
      integer nf1,nf2,nf3
      integer nff,ntot
      integer i0,iatm,igrd0
      integer it1,it2,it3
      integer j0,jgrd0
      integer k0,kgrd0
      real*8 e,fi,denom
      real*8 r1,r2,r3
      real*8 h1,h2,h3
      real*8 term,denom0
      real*8 eterm,vterm
      real*8 expterm
      real*8 erfcterm
      real*8 hsq,struc2
      real*8 h,hhh,b,bfac
      real*8 fac1,fac2,fac3
      real*8 de1,de2,de3
      real*8 dn1,dn2,dn3
      real*8 dt1,dt2,dt3
      real*8 t1,t2,t3
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
c
c     perform dynamic allocation of some global arrays
c
      ntot = nfft1 * nfft2 * nfft3
      if (allocated(qgrid)) then
         if (size(qgrid) .ne. 2*ntot)  call fftclose
      end if
      if (.not. allocated(qgrid))  call fftsetup
c
c     setup spatial decomposition and B-spline coefficients
c
      call getchunk
      call moduli
      call bspline_fill
      call table_fill
c
c     assign PME grid and perform 3-D FFT forward transform
c
      call grid_disp
      call fftfront
c
c     use scalar sum to get the reciprocal space energy
c
      qgrid(1,1,1,1) = 0.0d0
      qgrid(2,1,1,1) = 0.0d0
      bfac = pi / aewald
      fac1 = 2.0d0*pi**(3.5d0)
      fac2 = aewald**3
      fac3 = -2.0d0*aewald*pi**2
      denom0 = (6.0d0*volbox)/(pi**1.5d0)
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      nff = nfft1 * nfft2
      ntot = nff * nfft3
      do i = 1, ntot-1
         k3 = i/nff + 1
         j = i - (k3-1)*nff
         k2 = j/ndfft1 + 1
         k1 = j - (k2-1)*ndfft1 + 1
         m1 = k1 - 1
         m2 = k2 - 1
         m3 = k3 - 1
         if (k1 .gt. nf1)  m1 = m1 - ndfft1
         if (k2 .gt. nf2)  m2 = m2 - ndfft2
         if (k3 .gt. nf3)  m3 = m3 - ndfft3
         r1 = dble(m1)
         r2 = dble(m2)
         r3 = dble(m3)
         h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
         h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
         h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
         hsq = h1*h1 + h2*h2 + h3*h3
         h = sqrt(hsq)
         b = h*bfac
         hhh = h*hsq
         term = -b*b
         eterm = 0.0d0
         denom = denom0*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
         if (term .gt. -50.0d0) then
            expterm = exp(term)
            erfcterm = erfc(b)
            if (.not. use_bounds) then
               expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
               erfcterm = erfcterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
            else if (nonprism) then
               if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
               if (mod(m1+m2+m3,2) .ne. 0)  erfcterm = 0.0d0
            end if
            eterm = (-fac1*erfcterm*hhh - expterm*(fac2+fac3*hsq))/denom
            struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2
            vterm = 3.0d0*(fac1*erfcterm*h + fac3*expterm)*struc2/denom
            e = eterm * struc2
            edsp = edsp + e
            vir(1,1) = vir(1,1) + h1*h1*vterm - e
            vir(2,1) = vir(2,1) + h1*h2*vterm
            vir(3,1) = vir(3,1) + h1*h3*vterm
            vir(1,2) = vir(1,2) + h2*h1*vterm
            vir(2,2) = vir(2,2) + h2*h2*vterm - e
            vir(3,2) = vir(3,2) + h2*h3*vterm
            vir(1,3) = vir(1,3) + h3*h1*vterm
            vir(2,3) = vir(2,3) + h3*h2*vterm
            vir(3,3) = vir(3,3) + h3*h3*vterm - e
         end if
         qgrid(1,k1,k2,k3) = eterm * qgrid(1,k1,k2,k3) 
         qgrid(2,k1,k2,k3) = eterm * qgrid(2,k1,k2,k3)
      end do
c
c     perform the 3-D FFT backward transformation
c
      call fftback
c
c     get first derivatives of the reciprocal space energy 
c
      dn1 = dble(ndfft1)
      dn2 = dble(ndfft2)
      dn3 = dble(ndfft3)
      do ii = 1, ndisp
         iatm = idisp(ii)
         igrd0 = igrid(1,iatm)
         jgrd0 = igrid(2,iatm)
         kgrd0 = igrid(3,iatm)
         fi = csix(iatm)
         de1 = 0.0d0
         de2 = 0.0d0
         de3 = 0.0d0
         k0 = kgrd0
         do it3 = 1, bsorder
            k0 = k0 + 1
            k = k0 + 1 + (ndfft3-sign(ndfft3,k0))/2
            t3 = thetai3(1,it3,iatm)
            dt3 = dn3 * thetai3(2,it3,iatm)
            j0 = jgrd0
            do it2 = 1, bsorder
               j0 = j0 + 1
               j = j0 + 1 + (ndfft2-sign(ndfft2,j0))/2
               t2 = thetai2(1,it2,iatm)
               dt2 = dn2 * thetai2(2,it2,iatm)
               i0 = igrd0
               do it1 = 1, bsorder
                  i0 = i0 + 1
                  i = i0 + 1 + (ndfft1-sign(ndfft1,i0))/2
                  t1 = thetai1(1,it1,iatm)
                  dt1 = dn1 * thetai1(2,it1,iatm)
                  term = qgrid(1,i,j,k)
                  de1 = de1 + 2.0d0*term*dt1*t2*t3
                  de2 = de2 + 2.0d0*term*dt2*t1*t3
                  de3 = de3 + 2.0d0*term*dt3*t1*t2
               end do
            end do
         end do
         dedsp(1,iatm) = dedsp(1,iatm) + fi*(recip(1,1)*de1
     &                            +recip(1,2)*de2+recip(1,3)*de3)
         dedsp(2,iatm) = dedsp(2,iatm) + fi*(recip(2,1)*de1
     &                            +recip(2,2)*de2+recip(2,3)*de3)
         dedsp(3,iatm) = dedsp(3,iatm) + fi*(recip(3,1)*de1
     &                            +recip(3,2)*de2+recip(3,3)*de3)
      end do
c
c     account for the energy and virial correction terms
c
      term = csixpr * aewald**3 / denom0
      edsp = edsp - term
      vir(1,1) = vir(1,1) + term
      vir(2,2) = vir(2,2) + term
      vir(3,3) = vir(3,3) + term
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine edisp2  --  atomwise damped dispersion Hessian  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "edisp2" calculates the damped dispersion second derivatives
c     for a single atom at a time
c
c     literature reference:
c
c     J. A. Rackers, C. Liu, P. Ren and J. W. Ponder, "A Physically
c     Grounded Damped Dispersion Model with Particle Mesh Ewald
c     Summation", Journal of Chemical Physics, 149, 084115 (2018)
c
c
      subroutine edisp2 (iatom)
      use atoms
      use bound
      use cell
      use couple
      use disp
      use dsppot
      use group
      use hessn
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer iatom,jcell
      integer nlist,list(5)
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,de,d2e
      real*8 ci,ck,fgrp
      real*8 r,r2,r3
      real*8 r4,r5,r6
      real*8 ai,ai2
      real*8 ai3,ai4
      real*8 ak,ak2
      real*8 ak3,ak4
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk,eps
      real*8 damp3,damp5
      real*8 damp,ddamp
      real*8 ddampi,ddampk
      real*8 d2damp
      real*8 taper,dtaper
      real*8 d2taper
      real*8 d2edx,d2edy,d2edz
      real*8 term(3,3)
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DISP'
      call switch (mode)
c
c     check to see if atom of interest is a dispersion site
c
      nlist = 0
      do k = 1, ndisp
         if (idisp(k) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = iatom
            goto 10
         end if
      end do
      return
   10 continue
c
c     calculate the dispersion energy Hessian elements
c
      do ii = 1, nlist
         i = list(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = csix(i)
         ai = adisp(i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (k .ne. i)
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  r6 = r2**3
                  e = -ci * ck / r6
                  de = -6.0d0 * e / r
                  d2e = -7.0d0 * de / r
c
c     find the damping factor for the dispersion interaction
c
                  ai2 = ai * ai
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                     ddamp = (di5-3.0d0*di3-3.0d0*di2)
     &                           *ai*expi/96.0d0
                     d2damp = (5.0d0*di4-9.0d0*di2-6.0d0*di)
     &                            *ai2*expi/96.0d0 - ai*ddamp
                  else
                     ai3 = ai * ai2
                     ai4 = ai2 * ai2
                     ak2 = ak * ak
                     ak3 = ak * ak2
                     ak4 = ak2 * ak2
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     tk = ai2 / (ai2-ak2)
                     ti2 = ti * ti
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                     ddampi = 0.25d0 * di2 * ti2 * ai * expi
     &                           * (r*ai+4.0d0*tk-1.0d0)
                     ddampk = 0.25d0 * dk2 * tk2 * ak * expk
     &                           * (r*ak+4.0d0*ti-1.0d0)
                     ddamp = ddampi + ddampk
                     d2damp = 2.0d0*ddamp/r - ai*ddampi - ak*ddampk
     &                           + 0.25d0*di2*ti2*ai2*expi
     &                           + 0.25d0*dk2*tk2*ak2*expk
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                  d2e = d2e*damp**2 + 4.0d0*de*damp*ddamp
     &                     + 2.0d0*e*(ddamp**2+damp*d2damp)
                  de = de*damp**2 + 2.0d0*e*damp*ddamp
                  e = e * damp**2
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2
     &                            + 6.0d0*c3*r + 2.0d0*c2
                     d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper
                     de = e*dtaper + de*taper
                  end if
c
c     scale the interaction based on its group membership
c
                  de = de * dspscale(k)
                  d2e = d2e * dspscale(k)
                  if (use_group) then
                     de = de * fgrp
                     d2e = d2e * fgrp
                  end if
c
c     get chain rule terms for damped dispersion Hessian elements
c
                  de = de / r
                  d2e = (d2e-de) / r2
                  d2edx = d2e * xr
                  d2edy = d2e * yr
                  d2edz = d2e * zr
                  term(1,1) = d2edx*xr + de
                  term(1,2) = d2edx*yr
                  term(1,3) = d2edx*zr
                  term(2,1) = term(1,2)
                  term(2,2) = d2edy*yr + de
                  term(2,3) = d2edy*zr
                  term(3,1) = term(1,3)
                  term(3,2) = term(2,3)
                  term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                  do j = 1, 3
                     hessx(j,i) = hessx(j,i) + term(1,j)
                     hessy(j,i) = hessy(j,i) + term(2,j)
                     hessz(j,i) = hessz(j,i) + term(3,j)
                     hessx(j,k) = hessx(j,k) - term(1,j)
                     hessy(j,k) = hessy(j,k) - term(2,j)
                     hessz(j,k) = hessz(j,k) - term(3,j)
                  end do
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nlist
         i = list(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = csix(i)
         ai = adisp(i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               do jcell = 2, ncell
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  call image (xr,yr,zr)
                  r2 = xr*xr + yr* yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     r6 = r2**3
                     e = -ci * ck / r6
                     de = -6.0d0 * e / r
                     d2e = -7.0d0 * de / r
c
c     find the damping factor for the dispersion interaction
c
                     ai2 = ai * ai
                     di = ai * r
                     di2 = di * di
                     di3 = di * di2
                     dk = ak * r
                     expi = exp(-di)
                     expk = exp(-dk)
                     if (abs(ai-ak) .lt. eps) then
                        di4 = di2 * di2
                        di5 = di2 * di3
                        damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                             +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                        damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                           +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                        ddamp = (di5-3.0d0*di3-3.0d0*di2)
     &                              *ai*expi/96.0d0
                        d2damp = (5.0d0*di4-9.0d0*di2-6.0d0*di)
     &                               *ai2*expi/96.0d0 - ai*ddamp
                     else
                        ai3 = ai * ai2
                        ai4 = ai2 * ai2
                        ak2 = ak * ak
                        ak3 = ak * ak2
                        ak4 = ak2 * ak2
                        dk2 = dk * dk
                        dk3 = dk * dk2
                        ti = ak2 / (ak2-ai2)
                        tk = ai2 / (ai2-ak2)
                        ti2 = ti * ti
                        tk2 = tk * tk
                        damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                             - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                             - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                        damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                          +di3/6.0d0)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2
     &                                       +dk3/6.0d0)*expk
     &                            - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                            - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                        ddampi = 0.25d0 * di2 * ti2 * ai * expi
     &                              * (r*ai+4.0d0*tk-1.0d0)
                        ddampk = 0.25d0 * dk2 * tk2 * ak * expk
     &                              * (r*ak+4.0d0*ti-1.0d0)
                        ddamp = ddampi + ddampk
                        d2damp = 2.0d0*ddamp/r - ai*ddampi - ak*ddampk
     &                              + 0.25d0*di2*ti2*ai2*expi
     &                              + 0.25d0*dk2*tk2*ak2*expk
                     end if
                     damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                     d2e = d2e*damp**2 + 4.0d0*de*damp*ddamp
     &                        + 2.0d0*e*(ddamp**2+damp*d2damp)
                     de = de*damp**2 + 2.0d0*e*damp*ddamp
                     e = e * damp**2
c
c     use energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                              + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                        d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2
     &                               + 6.0d0*c3*r + 2.0d0*c2
                        d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper
                        de = e*dtaper + de*taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_polymer) then
                        if (r2 .le. polycut2) then
                           de = de * dspscale(k)
                           d2e = d2e * dspscale(k)
                        end if
                     end if
                     if (use_group) then
                        de = de * fgrp
                        d2e = d2e * fgrp
                     end if
                     if (i .eq. k) then
                        de = 0.5d0 * de
                        d2e = 0.5d0 * d2e
                     end if
c
c     get chain rule terms for damped dispersion Hessian elements
c
                     de = de / r
                     d2e = (d2e-de) / r2
                     d2edx = d2e * xr
                     d2edy = d2e * yr
                     d2edz = d2e * zr
                     term(1,1) = d2edx*xr + de
                     term(1,2) = d2edx*yr
                     term(1,3) = d2edx*zr
                     term(2,1) = term(1,2)
                     term(2,2) = d2edy*yr + de
                     term(2,3) = d2edy*zr
                     term(3,1) = term(1,3)
                     term(3,2) = term(2,3)
                     term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                     do j = 1, 3
                        hessx(j,ii) = hessx(j,ii) + term(1,j)
                        hessy(j,ii) = hessy(j,ii) + term(2,j)
                        hessz(j,ii) = hessz(j,ii) + term(3,j)
                        hessx(j,kk) = hessx(j,kk) - term(1,j)
                        hessy(j,kk) = hessy(j,kk) - term(2,j)
                        hessz(j,kk) = hessz(j,kk) - term(3,j)
                     end do
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine edisp3  --  damped dispersion energy & analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "edisp3" calculates the dispersion energy; also partitions
c     the energy among the atoms
c
c     literature reference:
c
c     J. A. Rackers, C. Liu, P. Ren and J. W. Ponder, "A Physically
c     Grounded Damped Dispersion Model with Particle Mesh Ewald
c     Summation", Journal of Chemical Physics, 149, 084115 (2018)
c
c
      subroutine edisp3
      use analyz
      use atoms
      use dsppot
      use energi
      use ewald
      use inform
      use iounit
      use limits
      implicit none
      integer i
      real*8 elrc,aelrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_dewald) then
         if (use_dlist) then
            call edisp3d
         else
            call edisp3c
         end if
      else
         if (use_dlist) then
            call edisp3b
         else
            call edisp3a
         end if
      end if
c
c     apply long range dispersion correction if desired
c
      if (use_dcorr .and. .not.use_dewald) then
         mode = 'DISP'
         call evcorr (mode,elrc)
         edsp = edsp + elrc
         aelrc = elrc / dble(n)
         do i = 1, n
            aedsp(i) = aedsp(i) + aelrc
         end do
         if (verbose .and. elrc.ne.0.0d0) then
            if (digits .ge. 8) then
               write (iout,10)  elrc
   10          format (/,' Long-Range Dispersion :',9x,f16.8)
            else if (digits .ge. 6) then
               write (iout,20)  elrc
   20          format (/,' Long-Range Dispersion :',9x,f16.6)
            else
               write (iout,30)  elrc
   30          format (/,' Long-Range Dispersion :',9x,f16.4)
            end if
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine edisp3a  --  damp dispersion analysis via loop  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "edisp3a" calculates the dispersion potential energy and
c     also partitions the energy among the atoms using a pairwise
c     double loop
c
c
      subroutine edisp3a
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use cell
      use disp
      use dsppot
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mutant
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,fgrp
      real*8 ci,ck
      real*8 r,r2,r3
      real*8 r4,r5,r6
      real*8 ai,ai2
      real*8 ak,ak2
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk
      real*8 damp3,damp5
      real*8 damp,taper
      real*8 vterm,eps
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      logical header,huge
      logical muti,mutk
      character*6 mode
c
c
c     zero out the dispersion energy and partitioning terms
c
      nedsp = 0
      edsp = 0.0d0
      do i = 1, n
         aedsp(i) = 0.0d0
      end do
      if (ndisp .eq. 0) return
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3)
      end if
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DISP'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. ndisp.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Dispersion Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     find the damped dispersion energy via double loop search
c
      do ii = 1, ndisp-1
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  r6 = r2**3
                  e = -ci * ck / r6
c
c     find the damping factor for the dispersion interaction
c
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                  else
                     ai2 = ai * ai
                     ak2 = ak * ak
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     ti2 = ti * ti
                     tk = ai2 / (ai2-ak2)
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                  e = e * dspscale(k) * damp**2
                  if (use_group)  e = e * fgrp
c
c     set use of lambda scaling for decoupling or annihilation
c
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        e = e * vterm
                     else if (.not.muti .or. .not.mutk) then
                        e = e * vterm
                     end if
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c     
c     increment the overall dispersion energy components
c
                  if (e .ne. 0.0d0) then
                     edsp = edsp + e
                     nedsp = nedsp + 1
                     aedsp(i) = aedsp(i) + 0.5d0*e
                     aedsp(k) = aedsp(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(e) .gt. 4.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Dispersion',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             15x,'Distance',8x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),r,e
   30                format (' Disper',4x,2(i7,'-',a3),
     &                          9x,f10.4,2x,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, ndisp
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do jcell = 2, ncell
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     r6 = r2**3
                     e = -ci * ck / r6
c
c     find the damping factor for the dispersion interaction
c
                     di = ai * r
                     di2 = di * di
                     di3 = di * di2
                     dk = ak * r
                     expi = exp(-di)
                     expk = exp(-dk)
                     if (abs(ai-ak) .lt. eps) then
                        ai2 = ai * ai
                        ak2 = ak * ak
                        dk2 = dk * dk
                        dk3 = dk * dk2
                        ti = ak2 / (ak2-ai2)
                        ti2 = ti * ti
                        tk = ai2 / (ai2-ak2)
                        tk2 = tk * tk
                        damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                             - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                             - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                        damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                          +di3/6.0d0)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2
     &                                       +dk3/6.0d0)*expk
     &                           - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                           - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                     else
                        di4 = di2 * di2
                        di5 = di2 * di3
                        damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                             +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                        damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                           +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                     end if
                     damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                     e = e * damp**2
                     if (use_polymer) then
                        if (r2 .le. polycut2)  e = e * dspscale(k)
                     end if
                     if (use_group)  e = e * fgrp
                     if (i .eq. k)  e = 0.5d0 * e
c
c     set use of lambda scaling for decoupling or annihilation
c
                     if (muti .or. mutk) then
                        if (vcouple .eq. 1) then
                           e = e * vterm
                        else if (.not.muti .or. .not.mutk) then
                           e = e * vterm
                        end if
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (r2 .gt. cut2) then
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        e = e * taper
                     end if
c     
c     increment the overall dispersion energy components
c
                     if (e .ne. 0.0d0) then
                        edsp = edsp + e
                        nedsp = nedsp + 1
                        aedsp(i) = aedsp(i) + 0.5d0*e
                        aedsp(k) = aedsp(k) + 0.5d0*e
                     end if
c
c     increment the total intermolecular energy
c
                     if (molcule(i) .ne. molcule(k)) then
                        einter = einter + e
                     end if
c
c     print a message if the energy of this interaction is large
c
                     huge = (abs(e) .gt. 4.0d0)
                     if ((debug.and.e.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual Dispersion',
     &                                ' Interactions :',
     &                             //,' Type',14x,'Atom Names',
     &                                15x,'Distance',8x,'Energy',/)
                        end if
                        write (iout,50)  i,name(i),k,name(k),r,e
   50                   format (' Disper',4x,2(i7,'-',a3),1x,
     &                             '(XTAL)',2x,f10.4,2x,f12.4)
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine edisp3b  --  damp dispersion analysis via list  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "edisp3b" calculates the damped dispersion potential energy
c     and also partitions the energy among the atoms using a pairwise
c     neighbor list
c
c
      subroutine edisp3b
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use cell
      use disp
      use dsppot
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mutant
      use neigh
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,fgrp
      real*8 ci,ck
      real*8 r,r2,r3
      real*8 r4,r5,r6
      real*8 ai,ai2
      real*8 ak,ak2
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk
      real*8 damp3,damp5
      real*8 damp,taper
      real*8 vterm,eps
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      logical header,huge
      logical muti,mutk
      character*6 mode
c
c
c     zero out the dispersion energy and partitioning terms
c
      nedsp = 0
      edsp = 0.0d0
      do i = 1, n
         aedsp(i) = 0.0d0
      end do
      if (ndisp .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3)
      end if
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DISP'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. ndisp.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Dispersion Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ndisp,idisp,csix,adisp,use,
!$OMP& x,y,z,n12,n13,n14,n15,i12,i13,i14,i15,nvlst,vlst,use_group,
!$OMP& dsp2scale,dsp3scale,dsp4scale,dsp5scale,mut,off2,cut2,c0,c1,
!$OMP& c2,c3,c4,c5,vcouple,vterm,eps,molcule,name,verbose,debug,
!$OMP& header,iout)
!$OMP& firstprivate(dspscale),shared(edsp,nedsp,aedsp,einter)
!$OMP DO reduction(+:edsp,nedsp,aedsp,einter)
c
c     find the damped dispersion energy via neighbor list search
c
      do ii = 1, ndisp
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  r6 = r2**3
                  e = -ci * ck / r6
c
c     find the damping factor for the dispersion interaction
c
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                  else
                     ai2 = ai * ai
                     ak2 = ak * ak
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     ti2 = ti * ti
                     tk = ai2 / (ai2-ak2)
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                  e = e * dspscale(k) * damp**2
                  if (use_group)  e = e * fgrp
c
c     set use of lambda scaling for decoupling or annihilation
c
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        e = e * vterm
                     else if (.not.muti .or. .not.mutk) then
                        e = e * vterm
                     end if
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c     
c     increment the overall dispersion energy components
c
                  if (e .ne. 0.0d0) then
                     edsp = edsp + e
                     nedsp = nedsp + 1
                     aedsp(i) = aedsp(i) + 0.5d0*e
                     aedsp(k) = aedsp(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(e) .gt. 4.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Dispersion',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             15x,'Distance',8x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),r,e
   30                format (' Disper',4x,2(i7,'-',a3),
     &                          9x,f10.4,2x,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c                                                                        
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine edisp3c  --  Ewald dispersion analysis via loop  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "edisp3c" calculates the dispersion interaction energy using
c     particle mesh Ewald summation and a double loop
c
c
      subroutine edisp3c
      use action
      use analyz
      use atoms
      use disp
      use energi
      use ewald
      use pme
      implicit none
      integer i,ii
      real*8 e
c
c
c     zero out the dispersion energy and partitioning terms
c
      nedsp = 0
      edsp = 0.0d0
      do i = 1, n
         aedsp(i) = 0.0d0
      end do
      if (ndisp .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = ndfft1
      nfft2 = ndfft2
      nfft3 = ndfft3
      bsorder = bsdorder
      aewald = adewald
c
c     compute the real space portion of the Ewald summation
c
      call edreal3c
c
c     compute the reciprocal space part of the Ewald summation
c
      call edrecip
c
c     compute the self-energy portion of the Ewald summation
c
      do ii = 1, ndisp
         i = idisp(ii)
         e = csix(i)**2 * aewald**6 / 12.0d0
         edsp = edsp + e
         nedsp = nedsp + 1
         aedsp(i) = aedsp(i) + e 
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine edreal3c  --  real space dispersion via loop  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "edreal3c" calculates the real space portion of the damped
c     dispersion energy and analysis using Ewald and a double loop
c
c
      subroutine edreal3c
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use cell
      use disp
      use dsppot
      use energi
      use ewald
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mutant
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,efull
      real*8 fgrp,ci,ck
      real*8 r,r2,r6
      real*8 ai,ai2
      real*8 ak,ak2
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk
      real*8 ralpha2
      real*8 expa,term
      real*8 damp3,damp5
      real*8 damp,scale
      real*8 vterm,eps
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      logical muti,mutk
      logical header,huge
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3)
      end if
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DEWALD'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. ndisp.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Dispersion Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, ndisp-1
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  r6 = r2**3
                  e = -ci * ck / r6
                  ralpha2 = r2 * aewald**2
                  term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2
                  expa = exp(-ralpha2) * term
c
c     find the damping factor for the dispersion interaction
c
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                  else
                     ai2 = ai * ai
                     ak2 = ak * ak
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     ti2 = ti * ti
                     tk = ai2 / (ai2-ak2)
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                  scale = dspscale(k) * damp**2
                  if (use_group)  scale = scale * fgrp
c
c     set use of lambda scaling for decoupling or annihilation
c
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        scale = scale * vterm
                     else if (.not.muti .or. .not.mutk) then
                        scale = scale * vterm
                     end if
                  end if
c     
c     compute the full undamped energy for this interaction
c
                  efull = e * scale
                  if (efull .ne. 0.0d0) then
                     nedsp = nedsp + 1
                     aedsp(i) = aedsp(i) + 0.5d0*efull
                     aedsp(k) = aedsp(k) + 0.5d0*efull
                     if (molcule(i) .ne. molcule(k)) then
                        einter = einter + efull
                     end if
                  end if
c
c     increment the overall dispersion energy component
c
                  scale = scale - 1.0d0
                  e = e * (expa+scale)
                  edsp = edsp + e
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(efull) .gt. 4.0d0)
                  if ((debug.and.efull.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Dispersion',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             15x,'Distance',8x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),r,efull
   30                format (' Disper',4x,2(i7,'-',a3),9x,
     &                          f10.4,2x,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, ndisp
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, ndisp
            k = idisp(kk)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do jcell = 2, ncell
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     r6 = r2**3
                     ralpha2 = r2 * aewald**2
                     term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2
                     expa = exp(-ralpha2) * term
c
c     find the damping factor for the dispersion interaction
c
                     di = ai * r
                     di2 = di * di
                     di3 = di * di2
                     dk = ak * r
                     expi = exp(-di)
                     expk = exp(-dk)
                     if (abs(ai-ak) .lt. eps) then
                        di4 = di2 * di2
                        di5 = di2 * di3
                        damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                             +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                        damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                           +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                     else
                        ai2 = ai * ai
                        ak2 = ak * ak
                        dk2 = dk * dk
                        dk3 = dk * dk2
                        ti = ak2 / (ak2-ai2)
                        ti2 = ti * ti
                        tk = ai2 / (ai2-ak2)
                        tk2 = tk * tk
                        damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                             - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                             - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                        damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                          +di3/6.0d0)*expi
     &                             - tk2*(1.0d0+dk+0.5d0*dk2
     &                                       +dk3/6.0d0)*expk
     &                            - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                            - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                     end if
                     damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                     scale = damp**2
                     if (use_group)  scale = scale * fgrp
                     if (use_polymer) then
                        if (r2 .le. polycut2) then
                           scale = scale * dspscale(k)
                        end if
                     end if
c
c     set use of lambda scaling for decoupling or annihilation
c
                     if (muti .or. mutk) then
                        if (vcouple .eq. 1) then
                           scale = scale * vterm
                        else if (.not.muti .or. .not.mutk) then
                           scale = scale * vterm
                        end if
                     end if
c     
c     compute the full undamped energy for this interaction
c
                     if (i .eq. k)  e = 0.5d0 * e
                     efull = e * scale
                     if (efull .ne. 0.0d0) then
                        nedsp = nedsp + 1
                        aedsp(i) = aedsp(i) + 0.5d0*efull
                        aedsp(k) = aedsp(k) + 0.5d0*efull
                        if (molcule(i) .ne. molcule(k)) then
                           einter = einter + efull
                        end if
                     end if
c
c     increment the overall dispersion energy component
c
                     scale = scale - 1.0d0
                     e = e * (expa+scale)
                     edsp = edsp + e
c
c     print a message if the energy of this interaction is large
c
                     huge = (abs(efull) .gt. 4.0d0)
                     if ((debug.and.efull.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual Dispersion',
     &                                ' Interactions :',
     &                             //,' Type',14x,'Atom Names',
     &                                15x,'Distance',8x,'Energy',/)
                        end if
                        write (iout,50)  i,name(i),k,name(k),r,efull
   50                   format (' Disper',4x,2(i7,'-',a3),1x,
     &                             '(XTAL)',2x,f10.4,2x,f12.4)
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine edisp3d  --  Ewald dispersion analysis via list  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "edisp3d" calculates the damped dispersion energy and analysis
c     using particle mesh Ewald summation and a neighbor list
c
c
      subroutine edisp3d
      use action
      use analyz
      use atoms
      use disp
      use energi
      use ewald
      use pme
      implicit none
      integer i,ii
      real*8 e
c
c
c     zero out the dispersion energy and partitioning terms
c
      nedsp = 0
      edsp = 0.0d0
      do i = 1, n
         aedsp(i) = 0.0d0
      end do
      if (ndisp .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = ndfft1
      nfft2 = ndfft2
      nfft3 = ndfft3
      bsorder = bsdorder
      aewald = adewald
c
c     compute the real space portion of the Ewald summation
c
      call edreal3d
c
c     compute the reciprocal space part of the Ewald summation
c
      call edrecip
c
c     compute the self-energy portion of the Ewald summation
c
      do ii = 1, ndisp
         i = idisp(ii)
         e = csix(i)**2 * aewald**6 / 12.0d0
         edsp = edsp + e
         nedsp = nedsp + 1
         aedsp(i) = aedsp(i) + e 
      end do
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine edreal3d  --  real space disp analysis via list  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "edreal3d" calculates the real space portion of the damped
c     dispersion energy and analysis using Ewald and a neighbor list
c
c
      subroutine edreal3d
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use cell
      use disp
      use dsppot
      use energi
      use ewald
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mutant
      use neigh
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 e,efull
      real*8 fgrp,ci,ck
      real*8 r,r2,r6
      real*8 ai,ai2
      real*8 ak,ak2
      real*8 di,di2,di3
      real*8 di4,di5
      real*8 dk,dk2,dk3
      real*8 ti,ti2
      real*8 tk,tk2
      real*8 expi,expk
      real*8 ralpha2
      real*8 expa,term
      real*8 damp3,damp5
      real*8 damp,scale
      real*8 vterm,eps
      real*8, allocatable :: dspscale(:)
      logical proceed,usei
      logical muti,mutk
      logical header,huge
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (dspscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         dspscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3)
      end if
c
c     set damping tolerance, cutoff and switching coefficients
c
      eps = 0.0001d0
      mode = 'DEWALD'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. ndisp.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Dispersion Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ndisp,idisp,csix,adisp,use,
!$OMP& x,y,z,n12,n13,n14,n15,i12,i13,i14,i15,nvlst,vlst,use_group,
!$OMP& dsp2scale,dsp3scale,dsp4scale,dsp5scale,mut,off2,aewald,
!$OMP& molcule,vcouple,vterm,eps,name,verbose,debug,header,iout)
!$OMP& firstprivate(dspscale),shared(edsp,nedsp,aedsp,einter)
!$OMP DO reduction(+:edsp,nedsp,aedsp,einter)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, ndisp
         i = idisp(ii)
         ci = csix(i)
         ai = adisp(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = dsp2scale
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = dsp3scale
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = dsp4scale
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = dsp5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            ck = csix(k)
            ak = adisp(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  r6 = r2**3
                  e = -ci * ck / r6
                  ralpha2 = r2 * aewald**2
                  term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2
                  expa = exp(-ralpha2) * term
c
c     find the damping factor for the dispersion interaction
c
                  di = ai * r
                  di2 = di * di
                  di3 = di * di2
                  dk = ak * r
                  expi = exp(-di)
                  expk = exp(-dk)
                  if (abs(ai-ak) .lt. eps) then
                     di4 = di2 * di2
                     di5 = di2 * di3
                     damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +7.0d0*di3/48.0d0+di4/48.0d0)*expi
                     damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2
     &                          +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi
                  else
                     ai2 = ai * ai
                     ak2 = ak * ak
                     dk2 = dk * dk
                     dk3 = dk * dk2
                     ti = ak2 / (ak2-ai2)
                     ti2 = ti * ti
                     tk = ai2 / (ai2-ak2)
                     tk2 = tk * tk
                     damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2)*expk
     &                          - 2.0d0*ti2*tk*(1.0d0+di)*expi
     &                          - 2.0d0*tk2*ti*(1.0d0+dk)*expk
                     damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2
     &                                       +di3/6.0d0)*expi
     &                          - tk2*(1.0d0+dk+0.5d0*dk2
     &                                    +dk3/6.0d0)*expk
     &                          - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi
     &                          - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk
                  end if
                  damp = 1.5d0*damp5 - 0.5d0*damp3
c
c     apply damping and scaling factors for this interaction
c
                  scale = dspscale(k) * damp**2
                  if (use_group)  scale = scale * fgrp
c
c     set use of lambda scaling for decoupling or annihilation
c
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        scale = scale * vterm
                     else if (.not.muti .or. .not.mutk) then
                        scale = scale * vterm
                     end if
                  end if
c     
c     compute the full undamped energy for this interaction
c
                  efull = e * scale
                  if (efull .ne. 0.0d0) then
                     nedsp = nedsp + 1
                     aedsp(i) = aedsp(i) + 0.5d0*efull
                     aedsp(k) = aedsp(k) + 0.5d0*efull
                     if (molcule(i) .ne. molcule(k)) then
                        einter = einter + efull
                     end if
                  end if
c
c     increment the overall dispersion energy component
c
                  scale = scale - 1.0d0
                  e = e * (expa+scale)
                  edsp = edsp + e
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(efull) .gt. 4.0d0)
                  if ((debug.and.efull.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Dispersion',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             15x,'Distance',8x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),r,efull
   30                format (' Disper',4x,2(i7,'-',a3),9x,
     &                          f10.4,2x,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            dspscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            dspscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            dspscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            dspscale(i15(j,i)) = 1.0d0
         end do
      end do
c                                                                        
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (dspscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1994  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine egauss  --  Gaussian van der Waals energy  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "egauss" calculates the Gaussian expansion van der Waals energy
c
c
      subroutine egauss
      use limits
      use warp
      implicit none
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_smooth) then
         call egauss0d
      else if (use_vlist) then
         call egauss0c
      else if (use_lights) then
         call egauss0b
      else
         call egauss0a
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine egauss0a  --  double loop Gaussian vdw energy  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "egauss0a" calculates the Gaussian expansion van der Waals
c     energy using a pairwise double loop
c
c
      subroutine egauss0a
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use energi
      use group
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k,m
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,eps,rdn
      real*8 rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expterm
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set cutoff distances and switching function coefficients
c
      mode = 'VDW'
      call switch (mode)
      expcut = -50.0d0
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rad2 = radmin(kt,it)**2
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rad2 = radmin4(kt,it)**2
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  do j = 1, ngauss
                     a(j) = igauss(1,j) * eps
                     b(j) = igauss(2,j) / rad2
                  end do
                  e = 0.0d0
                  do j = 1, ngauss
                     expterm = -b(j) * rik2
                     if (expterm .gt. expcut)
     &                  e = e + a(j)*exp(expterm)
                  end do
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do m = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,m)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rad2 = radmin(kt,it)**2
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rad2 = radmin4(kt,it)**2
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     do j = 1, ngauss
                        a(j) = igauss(1,j) * eps
                        b(j) = igauss(2,j) / rad2
                     end do
                     e = 0.0d0
                     do j = 1, ngauss
                        expterm = -b(j) * rik2
                        if (expterm .gt. expcut)
     &                     e = e + a(j)*exp(expterm)
                     end do
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik = sqrt(rik2)
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component;
c     interaction of an atom with its own image counts half
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ev = ev + e
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine egauss0b  --  Gaussian vdw energy via lights  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "egauss0b" calculates the Gaussian expansion van der Waals energy
c     using the method of lights
c
c
      subroutine egauss0b
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use couple
      use energi
      use group
      use light
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k,m
      integer ii,it,iv
      integer kk,kt,kv
      integer kgy,kgz
      integer start,stop
      integer, allocatable :: iv14(:)
      real*8 e,eps,rdn
      real*8 rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expterm
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set cutoff distances and switching function coefficients
c
      mode = 'VDW'
      call switch (mode)
      expcut = -50.0d0
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do m = start, stop
            kk = locx(m)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(m)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rad2 = radmin(kt,it)**2
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rad2 = radmin4(kt,it)**2
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
                  do j = 1, ngauss
                     a(j) = igauss(1,j) * eps
                     b(j) = igauss(2,j) / rad2
                  end do
                  e = 0.0d0
                  do j = 1, ngauss
                     expterm = -b(j) * rik2
                     if (expterm .gt. expcut)
     &                  e = e + a(j)*exp(expterm)
                  end do
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component
c
                  ev = ev + e
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine egauss0c  --  Gaussian vdw energy via list  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "egauss0c" calculates the Gaussian expansion van der Waals
c     energy using a pairwise neighbor list
c
c
      subroutine egauss0c
      use atomid
      use atoms
      use bound
      use couple
      use energi
      use group
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,eps,rdn
      real*8 rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expterm
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set cutoff distances and switching function coefficients
c
      mode = 'VDW'
      call switch (mode)
      expcut = -50.0d0
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13,
!$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group,off2,
!$OMP& radmin,epsilon,radmin4,epsilon4,ngauss,igauss,expcut,
!$OMP& cut2,c0,c1,c2,c3,c4,c5)
!$OMP& firstprivate(vscale,iv14) shared(ev)
!$OMP DO reduction(+:ev)
c
c     find the van der Waals energy via neighbor list search
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rad2 = radmin(kt,it)**2
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rad2 = radmin4(kt,it)**2
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  do j = 1, ngauss
                     a(j) = igauss(1,j) * eps
                     b(j) = igauss(2,j) / rad2
                  end do
                  e = 0.0d0
                  do j = 1, ngauss
                     expterm = -b(j) * rik2
                     if (expterm .gt. expcut)
     &                  e = e + a(j)*exp(expterm)
                  end do
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine egauss0d  --  Gaussian vdw energy for smoothing  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "egauss0d" calculates the Gaussian expansion van der Waals
c     energy for use with potential energy smoothing
c
c
      subroutine egauss0d
      use atomid
      use atoms
      use couple
      use energi
      use group
      use math
      use usage
      use vdw
      use vdwpot
      use warp
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,rik,rik2,rdn
      real*8 eps,rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 erf,expcut,broot
      real*8 expterm,expterm2
      real*8 width,wterm
      real*8 t1,t2,term
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      external erf
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the extent of smoothing to be performed
c
      expcut = -50.0d0
      width = 0.0d0
      if (use_dem) then
         width = 4.0d0 * diffv * deform
      else if (use_gda) then
         wterm = (2.0d0/3.0d0) * diffv
      else if (use_tophat) then
         width = max(diffv*deform,0.0001d0)
      end if
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               rad2 = radmin(kt,it)**2
               eps = epsilon(kt,it)
               if (iv14(k) .eq. i) then
                  rad2 = radmin4(kt,it)**2
                  eps = epsilon4(kt,it)
               end if
               eps = eps * vscale(k)
               do j = 1, ngauss
                  a(j) = igauss(1,j) * eps
                  b(j) = igauss(2,j) / rad2
               end do
               e = 0.0d0
c
c     transform the potential function via smoothing
c
               if (use_tophat) then
                  rik = sqrt(rik2)
                  do j = 1, ngauss
                     broot = sqrt(b(j))
                     expterm = -b(j) * (rik+width)**2
                     if (expterm .gt. expcut) then
                        expterm = exp(expterm)
                     else
                        expterm = 0.0d0
                     end if
                     expterm2 = -b(j) * (width-rik)**2
                     if (expterm2 .gt. expcut) then
                        expterm2 = exp(expterm2)
                     else
                        expterm2 = 0.0d0
                     end if
                     term = broot * (expterm-expterm2)
                     term = term + rootpi*b(j)*rik
     &                         * (erf(broot*(rik+width))
     &                           +erf(broot*(width-rik)))
                     e = e + term*a(j)/(b(j)*b(j)*broot)
                  end do
                  e = e * 3.0d0/(8.0d0*rik*width**3)
               else
                  if (use_gda)  width = wterm * (m2(i)+m2(k))
                  do j = 1, ngauss
                     t1 = 1.0d0 + b(j)*width
                     t2 = sqrt(t1**3)
                     expterm = -b(j) * rik2 / t1
                     if (expterm .gt. expcut)
     &                  e = e + (a(j)/t2)*exp(expterm)
                  end do
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
               ev = ev + e
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1994  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine egauss1  --  Gaussian vdw energy & derivatives  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "egauss1" calculates the Gaussian expansion van der Waals
c     interaction energy and its first derivatives with respect
c     to Cartesian coordinates
c
c
      subroutine egauss1
      use limits
      use warp
      implicit none
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_smooth) then
         call egauss1d
      else if (use_vlist) then
         call egauss1c
      else if (use_lights) then
         call egauss1b
      else
         call egauss1a
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine egauss1a  --  double loop Gaussian vdw derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "egauss1a" calculates the Gaussian expansion van der Waals
c     interaction energy and its first derivatives using a pairwise
c     double loop
c
c
      subroutine egauss1a
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use deriv
      use energi
      use group
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k,m
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,de,rdn
      real*8 eps,rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 expcut,expterm
      real*8 taper,dtaper
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
      expcut = -50.0d0
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find van der Waals energy and derivatives via double loop
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rad2 = radmin(kt,it)**2
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rad2 = radmin4(kt,it)**2
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  do j = 1, ngauss
                     a(j) = igauss(1,j) * eps
                     b(j) = igauss(2,j) / rad2
                  end do
                  e = 0.0d0
                  de = 0.0d0
                  rik = sqrt(rik2)
                  do j = 1, ngauss
                     expterm = -b(j) * rik2
                     if (expterm .gt. expcut) then
                        expterm = a(j)*exp(expterm)
                        e = e + expterm
                        de = de - 2.0d0*b(j)*rik*expterm
                     end if
                  end do
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do m = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,m)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rad2 = radmin(kt,it)**2
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rad2 = radmin4(kt,it)**2
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     do j = 1, ngauss
                        a(j) = igauss(1,j) * eps
                        b(j) = igauss(2,j) / rad2
                     end do
                     e = 0.0d0
                     de = 0.0d0
                     rik = sqrt(rik2)
                     do j = 1, ngauss
                        expterm = -b(j) * rik2
                        if (expterm .gt. expcut) then
                           expterm = a(j)*exp(expterm)
                           e = e + expterm
                           de = de - 2.0d0*b(j)*rik*expterm
                        end if
                     end do
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                              + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                        de = e*dtaper + de*taper
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        e = e * fgrp
                        de = de * fgrp
                     end if
c
c     find the chain rule terms for derivative components
c
                     de = de / rik
                     dedx = de * xr
                     dedy = de * yr
                     dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ev = ev + e
                     if (i .eq. iv) then
                        dev(1,i) = dev(1,i) + dedx
                        dev(2,i) = dev(2,i) + dedy
                        dev(3,i) = dev(3,i) + dedz
                     else
                        dev(1,i) = dev(1,i) + dedx*redi
                        dev(2,i) = dev(2,i) + dedy*redi
                        dev(3,i) = dev(3,i) + dedz*redi
                        dev(1,iv) = dev(1,iv) + dedx*rediv
                        dev(2,iv) = dev(2,iv) + dedy*rediv
                        dev(3,iv) = dev(3,iv) + dedz*rediv
                     end if
                     if (i .ne. k) then
                        if (k .eq. kv) then
                           dev(1,k) = dev(1,k) - dedx
                           dev(2,k) = dev(2,k) - dedy
                           dev(3,k) = dev(3,k) - dedz
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           dev(1,k) = dev(1,k) - dedx*redk
                           dev(2,k) = dev(2,k) - dedy*redk
                           dev(3,k) = dev(3,k) - dedz*redk
                           dev(1,kv) = dev(1,kv) - dedx*redkv
                           dev(2,kv) = dev(2,kv) - dedy*redkv
                           dev(3,kv) = dev(3,kv) - dedz*redkv
                        end if
                     end if
c
c     increment the internal virial tensor components
c
                     vxx = xr * dedx
                     vyx = yr * dedx
                     vzx = zr * dedx
                     vyy = yr * dedy
                     vzy = zr * dedy
                     vzz = zr * dedz
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine egauss1b  --  Gaussian vdw derivs via lights  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "egauss1b" calculates the Gaussian expansion van der Waals
c     energy and its first derivatives with respect to Cartesian
c     coordinates using the method of lights
c
c
      subroutine egauss1b
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use couple
      use deriv
      use energi
      use group
      use light
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k,m
      integer ii,it,iv
      integer kk,kt,kv
      integer kgy,kgz
      integer start,stop
      integer, allocatable :: iv14(:)
      real*8 e,de,rdn
      real*8 eps,rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 expcut,expterm
      real*8 taper,dtaper
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
      expcut = -50.0d0
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do m = start, stop
            kk = locx(m)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(m)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rad2 = radmin(kt,it)**2
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rad2 = radmin4(kt,it)**2
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
                  do j = 1, ngauss
                     a(j) = igauss(1,j) * eps
                     b(j) = igauss(2,j) / rad2
                  end do
                  e = 0.0d0
                  de = 0.0d0
                  rik = sqrt(rik2)
                  do j = 1, ngauss
                     expterm = -b(j) * rik2
                     if (expterm .gt. expcut) then
                        expterm = a(j)*exp(expterm)
                        e = e + expterm
                        de = de - 2.0d0*b(j)*rik*expterm
                     end if
                  end do
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine egauss1c  --  Gaussian vdw derivs via list  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "egauss1c" calculates the Gaussian expansion van der Waals
c     energy and its first derivatives with respect to Cartesian
c     coordinates using a pairwise neighbor list
c
c
      subroutine egauss1c
      use atomid
      use atoms
      use bound
      use couple
      use deriv
      use energi
      use group
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,de,rdn
      real*8 eps,rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 expcut,expterm
      real*8 taper,dtaper
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
      expcut = -50.0d0
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& kred,xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,
!$OMP& i12,i13,i14,i15,v2scale,v3scale,v4scale,v5scale,
!$OMP& use_group,off2,radmin,epsilon,radmin4,epsilon4,
!$OMP& ngauss,igauss,expcut,cut2,c0,c1,c2,c3,c4,c5)
!$OMP& firstprivate(vscale,iv14) shared(ev,dev,vir)
!$OMP DO reduction(+:ev,dev,vir)
c
c     find van der Waals energy and derivatives via neighbor list
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
             kv = ired(k)
           proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rad2 = radmin(kt,it)**2
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rad2 = radmin4(kt,it)**2
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  do j = 1, ngauss
                     a(j) = igauss(1,j) * eps
                     b(j) = igauss(2,j) / rad2
                  end do
                  e = 0.0d0
                  de = 0.0d0
                  rik = sqrt(rik2)
                  do j = 1, ngauss
                     expterm = -b(j) * rik2
                     if (expterm .gt. expcut) then
                        expterm = a(j)*exp(expterm)
                        e = e + expterm
                        de = de - 2.0d0*b(j)*rik*expterm
                     end if
                  end do
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine egauss1d  --  Gaussian vdw derivs for smoothing  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "egauss1d" calculates the Gaussian expansion van der Waals
c     interaction energy and its first derivatives for use with
c     potential energy smoothing
c
c
      subroutine egauss1d
      use atomid
      use atoms
      use couple
      use deriv
      use energi
      use group
      use math
      use usage
      use vdw
      use vdwpot
      use virial
      use warp
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,de,rdn
      real*8 eps,rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 expcut,broot
      real*8 erf,term,term2
      real*8 expterm,expterm2
      real*8 width,wterm
      real*8 rik,rik2
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8 t1,t2
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      external erf
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the extent of smoothing to be performed
c
      expcut = -50.0d0
      width = 0.0d0
      if (use_dem) then
         width = 4.0d0 * diffv * deform
      else if (use_gda) then
         wterm = (2.0d0/3.0d0) * diffv
      else if (use_tophat) then
         width = max(diffv*deform,0.0001d0)
      end if
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find van der Waals energy and derivatives via double loop
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               rad2 = radmin(kt,it)**2
               eps = epsilon(kt,it)
               if (iv14(k) .eq. i) then
                  rad2 = radmin4(kt,it)**2
                  eps = epsilon4(kt,it)
               end if
               eps = eps * vscale(k)
               do j = 1, ngauss
                  a(j) = igauss(1,j) * eps
                  b(j) = igauss(2,j) / rad2
               end do
               e = 0.0d0
               de = 0.0d0
               rik = sqrt(rik2)
c
c     transform the potential function via smoothing
c
               if (use_tophat) then
                  rik = sqrt(rik2)
                  do j = 1, ngauss
                     broot = sqrt(b(j))
                     expterm = -b(j) * (rik+width)**2
                     if (expterm .gt. expcut) then
                        expterm = exp(expterm)
                     else
                        expterm = 0.0d0
                     end if
                     expterm2 = -b(j) * (width-rik)**2
                     if (expterm2 .gt. expcut) then
                        expterm2 = exp(expterm2)
                     else
                        expterm2 = 0.0d0
                     end if
                     term = broot * (expterm-expterm2)
                     term = term + rootpi*b(j)*rik
     &                         * (erf(broot*(rik+width))
     &                           +erf(broot*(width-rik)))
                     e = e + term*a(j)/(b(j)*b(j)*broot)
                     term = expterm * (2.0d0*rik*b(j)*width+1.0d0)
                     term2 = expterm2 * (2.0d0*rik*b(j)*width-1.0d0)
                     de = de + a(j)*(term+term2)/(b(j)*b(j))
                  end do
                  term = 3.0d0 / (8.0d0*rik*width**3)
                  e = e * term
                  de = -de * term / rik
               else
                  if (use_gda)  width = wterm * (m2(i)+m2(k))
                  do j = 1, ngauss
                     t1 = 1.0d0 + b(j)*width
                     t2 = sqrt(t1**3)
                     expterm = -b(j) * rik2 / t1
                     if (expterm .gt. expcut) then
                        expterm = (a(j)/t2)*exp(expterm)
                        e = e + expterm
                        de = de - (2.0d0*b(j)*rik/t1)*expterm
                     end if
                  end do
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  e = e * fgrp
                  de = de * fgrp
               end if
c
c     find the chain rule terms for derivative components
c
               de = de / rik
               dedx = de * xr
               dedy = de * yr
               dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
               ev = ev + e
               if (i .eq. iv) then
                  dev(1,i) = dev(1,i) + dedx
                  dev(2,i) = dev(2,i) + dedy
                  dev(3,i) = dev(3,i) + dedz
               else
                  dev(1,i) = dev(1,i) + dedx*redi
                  dev(2,i) = dev(2,i) + dedy*redi
                  dev(3,i) = dev(3,i) + dedz*redi
                  dev(1,iv) = dev(1,iv) + dedx*rediv
                  dev(2,iv) = dev(2,iv) + dedy*rediv
                  dev(3,iv) = dev(3,iv) + dedz*rediv
               end if
               if (k .eq. kv) then
                  dev(1,k) = dev(1,k) - dedx
                  dev(2,k) = dev(2,k) - dedy
                  dev(3,k) = dev(3,k) - dedz
               else
                  redk = kred(k)
                  redkv = 1.0d0 - redk
                  dev(1,k) = dev(1,k) - dedx*redk
                  dev(2,k) = dev(2,k) - dedy*redk
                  dev(3,k) = dev(3,k) - dedz*redk
                  dev(1,kv) = dev(1,kv) - dedx*redkv
                  dev(2,kv) = dev(2,kv) - dedy*redkv
                  dev(3,kv) = dev(3,kv) - dedz*redkv
               end if
c
c     increment the internal virial tensor components
c
               vxx = xr * dedx
               vyx = yr * dedx
               vzx = zr * dedx
               vyy = yr * dedy
               vzy = zr * dedy
               vzz = zr * dedz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vyx
               vir(3,1) = vir(3,1) + vzx
               vir(1,2) = vir(1,2) + vyx
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vzy
               vir(1,3) = vir(1,3) + vzx
               vir(2,3) = vir(2,3) + vzy
               vir(3,3) = vir(3,3) + vzz
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1994  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine egauss2  --  atom-by-atom Gaussian vdw Hessian  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "egauss2" calculates the Gaussian expansion van der Waals
c     second derivatives for a single atom at a time
c
c
      subroutine egauss2 (i)
      use warp
      implicit none
      integer i
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_smooth) then
         call egauss2b (i)
      else
         call egauss2a (i)
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine egauss2a  --  double loop Gaussian vdw Hessian  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "egauss2a" calculates the Gaussian expansion van der Waals
c     second derivatives using a pairwise double loop
c
c
      subroutine egauss2a (iatom)
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use group
      use hessn
      use shunt
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer iatom,jcell
      integer nlist,list(5)
      integer, allocatable :: iv14(:)
      real*8 de,d2e
      real*8 rik,rik2
      real*8 eps,rdn
      real*8 rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 redi2,rediv2
      real*8 rediiv
      real*8 redik,redivk
      real*8 redikv,redivkv
      real*8 d2edx,d2edy,d2edz
      real*8 expcut,expterm
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      real*8 term(3,3)
      logical proceed
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
      expcut = -50.0d0
c
c     check to see if the atom of interest is a vdw site
c
      nlist = 0
      do k = 1, nvdw
         if (ivdw(k) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = iatom
            goto 10
         end if
      end do
      return
   10 continue
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     determine the atoms involved via reduction factors
c
      nlist = 1
      list(nlist) = iatom
      do k = 1, n12(iatom)
         i = i12(k,iatom)
         if (ired(i) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = i
         end if
      end do
c
c     find van der Waals Hessian elements for involved atoms
c
      do ii = 1, nlist
         i = list(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         if (i .ne. iv) then
            rediv = 1.0d0 - redi
            redi2 = redi * redi
            rediv2 = rediv * rediv
            rediiv = redi * rediv
         end if
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = (k .ne. i)
            if (proceed .and. use_group)
     &         call groups (proceed,fgrp,i,k,0,0,0,0)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rad2 = radmin(kt,it)**2
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rad2 = radmin4(kt,it)**2
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  do j = 1, ngauss
                     a(j) = igauss(1,j) * eps
                     b(j) = igauss(2,j) / rad2
                  end do
                  de = 0.0d0
                  d2e = 0.0d0
                  rik = sqrt(rik2)
                  do j = 1, ngauss
                     expterm = -b(j) * rik2
                     if (expterm .gt. expcut) then
                        expterm = a(j)*b(j)*exp(expterm)
                        de = de - 2.0d0*rik*expterm
                        d2e = d2e + (4.0d0*b(j)*rik2-2.0d0)*expterm
                     end if
                  end do
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     de = de * fgrp
                     d2e = d2e * fgrp
                  end if
c
c     get chain rule terms for van der Waals Hessian elements
c
                  de = de / rik
                  d2e = (d2e-de) / rik2
                  d2edx = d2e * xr
                  d2edy = d2e * yr
                  d2edz = d2e * zr
                  term(1,1) = d2edx*xr + de
                  term(1,2) = d2edx*yr
                  term(1,3) = d2edx*zr
                  term(2,1) = term(1,2)
                  term(2,2) = d2edy*yr + de
                  term(2,3) = d2edy*zr
                  term(3,1) = term(1,3)
                  term(3,2) = term(2,3)
                  term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                  if (i .eq. iatom) then
                     if (i.eq.iv .and. k.eq.kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)
                           hessy(j,i) = hessy(j,i) + term(2,j)
                           hessz(j,i) = hessz(j,i) + term(3,j)
                           hessx(j,k) = hessx(j,k) - term(1,j)
                           hessy(j,k) = hessy(j,k) - term(2,j)
                           hessz(j,k) = hessz(j,k) - term(3,j)
                        end do
                     else if (k .eq. kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                           hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                           hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                           hessx(j,k) = hessx(j,k) - term(1,j)*redi
                           hessy(j,k) = hessy(j,k) - term(2,j)*redi
                           hessz(j,k) = hessz(j,k) - term(3,j)*redi
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                        end do
                     else if (i .eq. iv) then
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)
                           hessy(j,i) = hessy(j,i) + term(2,j)
                           hessz(j,i) = hessz(j,i) + term(3,j)
                           hessx(j,k) = hessx(j,k) - term(1,j)*redk
                           hessy(j,k) = hessy(j,k) - term(2,j)*redk
                           hessz(j,k) = hessz(j,k) - term(3,j)*redk
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv
                        end do
                     else
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        redik = redi * redk
                        redikv = redi * redkv
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                           hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                           hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                           hessx(j,k) = hessx(j,k) - term(1,j)*redik
                           hessy(j,k) = hessy(j,k) - term(2,j)*redik
                           hessz(j,k) = hessz(j,k) - term(3,j)*redik
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv
                        end do
                     end if
                  else if (iv .eq. iatom) then
                     if (k .eq. kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                           hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                           hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                           hessx(j,k) = hessx(j,k) - term(1,j)*rediv
                           hessy(j,k) = hessy(j,k) - term(2,j)*rediv
                           hessz(j,k) = hessz(j,k) - term(3,j)*rediv
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                        end do
                     else
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        redivk = rediv * redk
                        redivkv = rediv * redkv
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                           hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                           hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                           hessx(j,k) = hessx(j,k) - term(1,j)*redivk
                           hessy(j,k) = hessy(j,k) - term(2,j)*redivk
                           hessz(j,k) = hessz(j,k) - term(3,j)*redivk
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv
                        end do
                     end if
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nlist
         i = list(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         if (i .ne. iv) then
            rediv = 1.0d0 - redi
            redi2 = redi * redi
            rediv2 = rediv * rediv
            rediiv = redi * rediv
         end if
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               do jcell = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,jcell)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rad2 = radmin(kt,it)**2
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rad2 = radmin4(kt,it)**2
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     do j = 1, ngauss
                        a(j) = igauss(1,j) * eps
                        b(j) = igauss(2,j) / rad2
                     end do
                     de = 0.0d0
                     d2e = 0.0d0
                     rik = sqrt(rik2)
                     do j = 1, ngauss
                        expterm = -b(j) * rik2
                        if (expterm .gt. expcut) then
                           expterm = a(j)*b(j)*exp(expterm)
                           de = de - 2.0d0*rik*expterm
                           d2e = d2e + (4.0d0*b(j)*rik2-2.0d0)*expterm
                        end if
                     end do
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        de = de * fgrp
                        d2e = d2e * fgrp
                     end if
c
c     get chain rule terms for van der Waals Hessian elements
c
                     de = de / rik
                     d2e = (d2e-de) / rik2
                     d2edx = d2e * xr
                     d2edy = d2e * yr
                     d2edz = d2e * zr
                     term(1,1) = d2edx*xr + de
                     term(1,2) = d2edx*yr
                     term(1,3) = d2edx*zr
                     term(2,1) = term(1,2)
                     term(2,2) = d2edy*yr + de
                     term(2,3) = d2edy*zr
                     term(3,1) = term(1,3)
                     term(3,2) = term(2,3)
                     term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                     if (i .eq. iatom) then
                        if (i.eq.iv .and. k.eq.kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)
                              hessy(j,i) = hessy(j,i) + term(2,j)
                              hessz(j,i) = hessz(j,i) + term(3,j)
                              hessx(j,k) = hessx(j,k) - term(1,j)
                              hessy(j,k) = hessy(j,k) - term(2,j)
                              hessz(j,k) = hessz(j,k) - term(3,j)
                           end do
                        else if (k .eq. kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                              hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                              hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                              hessx(j,k) = hessx(j,k) - term(1,j)*redi
                              hessy(j,k) = hessy(j,k) - term(2,j)*redi
                              hessz(j,k) = hessz(j,k) - term(3,j)*redi
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediiv
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediiv
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediiv
                           end do
                        else if (i .eq. iv) then
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)
                              hessy(j,i) = hessy(j,i) + term(2,j)
                              hessz(j,i) = hessz(j,i) + term(3,j)
                              hessx(j,k) = hessx(j,k) - term(1,j)*redk
                              hessy(j,k) = hessy(j,k) - term(2,j)*redk
                              hessz(j,k) = hessz(j,k) - term(3,j)*redk
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redkv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redkv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redkv
                           end do
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           redik = redi * redk
                           redikv = redi * redkv
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                              hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                              hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                              hessx(j,k) = hessx(j,k) - term(1,j)*redik
                              hessy(j,k) = hessy(j,k) - term(2,j)*redik
                              hessz(j,k) = hessz(j,k) - term(3,j)*redik
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediiv
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediiv
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediiv
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redikv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redikv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redikv
                           end do
                        end if
                     else if (iv .eq. iatom) then
                        if (k .eq. kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                              hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                              hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                              hessx(j,k) = hessx(j,k) - term(1,j)*rediv
                              hessy(j,k) = hessy(j,k) - term(2,j)*rediv
                              hessz(j,k) = hessz(j,k) - term(3,j)*rediv
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediv2
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediv2
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediv2
                           end do
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           redivk = rediv * redk
                           redivkv = rediv * redkv
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                              hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                              hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                              hessx(j,k) = hessx(j,k) - term(1,j)*redivk
                              hessy(j,k) = hessy(j,k) - term(2,j)*redivk
                              hessz(j,k) = hessz(j,k) - term(3,j)*redivk
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediv2
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediv2
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediv2
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redivkv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redivkv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redivkv
                           end do
                        end if
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine egauss2b  --  Gaussian Hessian for smoothing  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "egauss2b" calculates the Gaussian expansion van der Waals
c     second derivatives for use with potential energy smoothing
c
c
      subroutine egauss2b (iatom)
      use atomid
      use atoms
      use couple
      use group
      use hessn
      use vdw
      use vdwpot
      use warp
      implicit none
      integer i,j,k,iatom
      integer ii,it,iv
      integer kk,kt,kv
      integer nlist,list(5)
      integer, allocatable :: iv14(:)
      real*8 de,d2e
      real*8 rik,rik2
      real*8 eps,rdn
      real*8 rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 redi2,rediv2
      real*8 rediiv
      real*8 redik,redivk
      real*8 redikv,redivkv
      real*8 d2edx,d2edy,d2edz
      real*8 expcut,b2
      real*8 term1,term2
      real*8 width,wterm
      real*8 expterm
      real*8 expterm2
      real*8 t1,t2
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      real*8 term(3,3)
      logical proceed
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the extent of smoothing to be performed
c
      expcut = -50.0d0
      width = 0.0d0
      if (use_dem) then
         width = 4.0d0 * diffv * deform
      else if (use_gda) then
         wterm = (2.0d0/3.0d0) * diffv
      else if (use_tophat) then
         width = max(diffv*deform,0.0001d0)
      end if
c
c     check to see if the atom of interest is a vdw site
c
      nlist = 0
      do k = 1, nvdw
         if (ivdw(k) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = iatom
            goto 10
         end if
      end do
      return
   10 continue
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     determine the atoms involved via reduction factors
c
      nlist = 1
      list(nlist) = iatom
      do k = 1, n12(iatom)
         i = i12(k,iatom)
         if (ired(i) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = i
         end if
      end do
c
c     find van der Waals Hessian elements for involved atoms
c
      do ii = 1, nlist
         i = list(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         if (i .ne. iv) then
            rediv = 1.0d0 - redi
            redi2 = redi * redi
            rediv2 = rediv * rediv
            rediiv = redi * rediv
         end if
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = (k .ne. i)
            if (proceed .and. use_group)
     &         call groups (proceed,fgrp,i,k,0,0,0,0)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               rad2 = radmin(kt,it)**2
               eps = epsilon(kt,it)
               if (iv14(k) .eq. i) then
                  rad2 = radmin4(kt,it)**2
                  eps = epsilon4(kt,it)
               end if
               eps = eps * vscale(k)
               do j = 1, ngauss
                  a(j) = igauss(1,j) * eps
                  b(j) = igauss(2,j) / rad2
               end do
               de = 0.0d0
               d2e = 0.0d0
               rik = sqrt(rik2)
c
c     transform the potential function via smoothing
c
               if (use_tophat) then
                  rik = sqrt(rik2)
                  do j = 1, ngauss
                     expterm = -b(j) * (rik+width)**2
                     if (expterm .gt. expcut) then
                        expterm = exp(expterm)
                     else
                        expterm = 0.0d0
                     end if
                     expterm2 = -b(j) * (width-rik)**2
                     if (expterm2 .gt. expcut) then
                        expterm2 = exp(expterm2)
                     else
                        expterm2 = 0.0d0
                     end if
                     b2 = b(j)*b(j)
                     term1 = expterm * (2.0d0*rik*b(j)*width+1.0d0)
                     term2 = expterm2 * (2.0d0*rik*b(j)*width-1.0d0)
                     de = de + a(j)*(term1+term2)/b2
                     term1 = 2.0d0*b(j)*width*rik * (b(j)*rik2+1.0d0)
     &                          * (expterm+expterm2)
                     term2 = (2.0d0*rik2*(b(j)*width)**2 + 1.0d0
     &                          + b(j)*rik2) * (expterm-expterm2)
                     d2e = d2e + a(j)*(term1+term2)/b2
                  end do
                  term1 = 3.0d0 / (8.0d0*rik*width**3)
                  de = -de * term1
                  d2e = 2.0d0 * d2e * term1 / rik
               else
                  if (use_gda)  width = wterm * (m2(i)+m2(k))
                  do j = 1, ngauss
                     t1 = 1.0d0 + b(j)*width
                     t2 = sqrt(t1**3)
                     expterm = -b(j) * rik2 / t1
                     if (expterm .gt. expcut) then
                        expterm = (a(j)*b(j)/(t2*t1))*exp(expterm)
                        de = de - 2.0d0*rik*expterm
                        d2e = d2e + (4.0d0*b(j)*rik2/t1-2.0d0)*expterm
                     end if
                  end do
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  de = de * fgrp
                  d2e = d2e * fgrp
               end if
c
c     get chain rule terms for van der Waals Hessian elements
c
               de = de / rik
               d2e = (d2e-de) / rik2
               d2edx = d2e * xr
               d2edy = d2e * yr
               d2edz = d2e * zr
               term(1,1) = d2edx*xr + de
               term(1,2) = d2edx*yr
               term(1,3) = d2edx*zr
               term(2,1) = term(1,2)
               term(2,2) = d2edy*yr + de
               term(2,3) = d2edy*zr
               term(3,1) = term(1,3)
               term(3,2) = term(2,3)
               term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
               if (i .eq. iatom) then
                  if (i.eq.iv .and. k.eq.kv) then
                     do j = 1, 3
                        hessx(j,i) = hessx(j,i) + term(1,j)
                        hessy(j,i) = hessy(j,i) + term(2,j)
                        hessz(j,i) = hessz(j,i) + term(3,j)
                        hessx(j,k) = hessx(j,k) - term(1,j)
                        hessy(j,k) = hessy(j,k) - term(2,j)
                        hessz(j,k) = hessz(j,k) - term(3,j)
                     end do
                  else if (k .eq. kv) then
                     do j = 1, 3
                        hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                        hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                        hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                        hessx(j,k) = hessx(j,k) - term(1,j)*redi
                        hessy(j,k) = hessy(j,k) - term(2,j)*redi
                        hessz(j,k) = hessz(j,k) - term(3,j)*redi
                        hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                        hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                        hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                     end do
                  else if (i .eq. iv) then
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     do j = 1, 3
                        hessx(j,i) = hessx(j,i) + term(1,j)
                        hessy(j,i) = hessy(j,i) + term(2,j)
                        hessz(j,i) = hessz(j,i) + term(3,j)
                        hessx(j,k) = hessx(j,k) - term(1,j)*redk
                        hessy(j,k) = hessy(j,k) - term(2,j)*redk
                        hessz(j,k) = hessz(j,k) - term(3,j)*redk
                        hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv
                        hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv
                        hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv
                     end do
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     redik = redi * redk
                     redikv = redi * redkv
                     do j = 1, 3
                        hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                        hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                        hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                        hessx(j,k) = hessx(j,k) - term(1,j)*redik
                        hessy(j,k) = hessy(j,k) - term(2,j)*redik
                        hessz(j,k) = hessz(j,k) - term(3,j)*redik
                        hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                        hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                        hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                        hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv
                        hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv
                        hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv
                     end do
                  end if
               else if (iv .eq. iatom) then
                  if (k .eq. kv) then
                     do j = 1, 3
                        hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                        hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                        hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                        hessx(j,k) = hessx(j,k) - term(1,j)*rediv
                        hessy(j,k) = hessy(j,k) - term(2,j)*rediv
                        hessz(j,k) = hessz(j,k) - term(3,j)*rediv
                        hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                        hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                        hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                     end do
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     redivk = rediv * redk
                     redivkv = rediv * redkv
                     do j = 1, 3
                        hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                        hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                        hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                        hessx(j,k) = hessx(j,k) - term(1,j)*redivk
                        hessy(j,k) = hessy(j,k) - term(2,j)*redivk
                        hessz(j,k) = hessz(j,k) - term(3,j)*redivk
                        hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                        hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                        hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                        hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv
                        hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv
                        hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv
                     end do
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1994  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine egauss3  --  Gaussian vdw energy & analysis  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "egauss3" calculates the Gaussian expansion van der Waals
c     interaction energy and partitions the energy among the atoms
c
c
      subroutine egauss3
      use limits
      use warp
      implicit none
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_smooth) then
         call egauss3d
      else if (use_vlist) then
         call egauss3c
      else if (use_lights) then
         call egauss3b
      else
         call egauss3a
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine egauss3a  --  double loop Gaussian vdw analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "egauss3a" calculates the Gaussian expansion van der Waals
c     energy and partitions the energy among the atoms using a
c     pairwise double loop
c
c
      subroutine egauss3a
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k,m
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,eps,rdn
      real*8 rad,rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expterm
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical header,huge
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
      expcut = -50.0d0
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rad2 = radmin(kt,it)**2
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rad2 = radmin4(kt,it)**2
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  do j = 1, ngauss
                     a(j) = igauss(1,j) * eps
                     b(j) = igauss(2,j) / rad2
                  end do
                  e = 0.0d0
                  do j = 1, ngauss
                     expterm = -b(j) * rik2
                     if (expterm .gt. expcut)
     &                  e = e + a(j)*exp(expterm)
                  end do
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the total van der Waals energy components
c
                  nev = nev + 1
                  aev(i) = aev(i) + 0.5d0*e
                  aev(k) = aev(k) + 0.5d0*e
                  ev = ev + e
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     rad = sqrt(rad2)
                     write (iout,30)  i,name(i),k,name(k),
     &                                rad,sqrt(rik2),e
   30                format (' VDW-Gauss',1x,2(i7,'-',a3),
     &                          13x,2f10.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do m = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,m)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rad2 = radmin(kt,it)**2
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rad2 = radmin4(kt,it)**2
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     do j = 1, ngauss
                        a(j) = igauss(1,j) * eps
                        b(j) = igauss(2,j) / rad2
                     end do
                     e = 0.0d0
                     do j = 1, ngauss
                        expterm = -b(j) * rik2
                        if (expterm .gt. expcut)
     &                     e = e + a(j)*exp(expterm)
                     end do
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik = sqrt(rik2)
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component
c
                     if (e .ne. 0.0d0) then
                        nev = nev + 1
                        if (i .eq. k) then
                           ev = ev + 0.5d0*e
                           aev(i) = aev(i) + 0.5d0*e
                        else
                           ev = ev + e
                           aev(i) = aev(i) + 0.5d0*e
                           aev(k) = aev(k) + 0.5d0*e
                        end if
                     end if
c
c     increment the total intermolecular energy
c
                     einter = einter + e
c
c     print a message if the energy of this interaction is large
c
                     huge = (e .gt. 10.0d0)
                     if ((debug.and.e.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual van der Waals',
     &                                ' Interactions :',
     &                             //,' Type',14x,'Atom Names',
     &                                20x,'Minimum',4x,'Actual',
     &                                6x,'Energy',/)
                        end if
                        rad = sqrt(rad2)
                        write (iout,50)  i,name(i),k,name(k),
     &                                   rad,sqrt(rik2),e
   50                   format (' VDW-Gauss',1x,2(i7,'-',a3),
     &                             1x,'(XTAL)',6x,2f10.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine egauss3b  --  Gaussian vdw analysis via lights  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "egauss3b" calculates the Gaussian expansion van der Waals
c     energy and partitions the energy among the atoms using the
c     method of lights
c
c
      subroutine egauss3b
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use light
      use molcul
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k,m
      integer ii,it,iv
      integer kk,kt,kv
      integer kgy,kgz
      integer start,stop
      integer ikmin,ikmax
      integer, allocatable :: iv14(:)
      real*8 e,eps,rdn
      real*8 rad,rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expterm
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      logical header,huge
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set cutoff distances and switching function coefficients
c
      mode = 'VDW'
      call switch (mode)
      expcut = -50.0d0
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   20    continue
         do m = start, stop
            kk = locx(m)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 60
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 60
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 60
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 60
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(m)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rad2 = radmin(kt,it)**2
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rad2 = radmin4(kt,it)**2
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
                  do j = 1, ngauss
                     a(j) = igauss(1,j) * eps
                     b(j) = igauss(2,j) / rad2
                  end do
                  e = 0.0d0
                  do j = 1, ngauss
                     expterm = -b(j) * rik2
                     if (expterm .gt. expcut)
     &                  e = e + a(j)*exp(expterm)
                  end do
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (.not.prime .or. molcule(i).ne.molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,30)
   30                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     rad = sqrt(rad2)
                     ikmin = min(i,k)
                     ikmax = max(i,k)
                     if (prime) then
                        write (iout,40)  ikmin,name(ikmin),ikmax,
     &                                   name(ikmax),rad,sqrt(rik2),e
   40                   format (' VDW-Gauss',1x,2(i7,'-',a3),
     &                             13x,2f10.4,f12.4)
                     else
                        write (iout,50)  ikmin,name(ikmin),ikmax,
     &                                   name(ikmax),rad,sqrt(rik2),e
   50                   format (' VDW-Gauss',1x,2(i7,'-',a3),
     &                             1x,'(XTAL)',6x,2f10.4,f12.4)
                     end if
                  end if
               end if
            end if
   60       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 20
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine egauss3c  --  Gaussian vdw analysis via list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "egauss3c" calculates the Gaussian expansion van der Waals
c     energy and partitions the energy among the atoms using a
c     pairwise neighbor list
c
c
      subroutine egauss3c
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,eps,rdn
      real*8 rad,rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expterm
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical header,huge
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set cutoff distances and switching function coefficients
c
      mode = 'VDW'
      call switch (mode)
      expcut = -50.0d0
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13,
!$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group,
!$OMP& off2,radmin,epsilon,radmin4,epsilon4,ngauss,igauss,
!$OMP& expcut,cut2,c0,c1,c2,c3,c4,c5,molcule,name,verbose,
!$OMP& debug,header,iout)
!$OMP& firstprivate(vscale,iv14) shared(ev,nev,aev,einter)
!$OMP DO reduction(+:ev,nev,aev,einter)
c
c     find the van der Waals energy via neighbor list search
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rad2 = radmin(kt,it)**2
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rad2 = radmin4(kt,it)**2
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  do j = 1, ngauss
                     a(j) = igauss(1,j) * eps
                     b(j) = igauss(2,j) / rad2
                  end do
                  e = 0.0d0
                  do j = 1, ngauss
                     expterm = -b(j) * rik2
                     if (expterm .gt. expcut)
     &                  e = e + a(j)*exp(expterm)
                  end do
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the total van der Waals energy components
c
                  nev = nev + 1
                  aev(i) = aev(i) + 0.5d0*e
                  aev(k) = aev(k) + 0.5d0*e
                  ev = ev + e
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     rad = sqrt(rad2)
                     write (iout,30)  i,name(i),k,name(k),
     &                                rad,sqrt(rik2),e
   30                format (' VDW-Gauss',1x,2(i7,'-',a3),
     &                          13x,2f10.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine egauss3d  --  Gaussian analysis for smoothing  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "egauss3d" calculates the Gaussian expansion van der Waals
c     interaction energy and partitions the energy among the atoms
c     for use with potential energy smoothing
c
c
      subroutine egauss3d
      use action
      use analyz
      use atomid
      use atoms
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use math
      use molcul
      use usage
      use vdw
      use vdwpot
      use warp
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,eps,rdn
      real*8 rad,rad2,fgrp
      real*8 rik,rik2
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 erf,expcut,broot
      real*8 expterm,expterm2
      real*8 width,wterm
      real*8 t1,t2,term
      real*8 a(maxgauss)
      real*8 b(maxgauss)
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical header,huge
      external erf
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     set the extent of smoothing to be performed
c
      expcut = -50.0d0
      width = 0.0d0
      if (use_dem) then
         width = 4.0d0 * diffv * deform
      else if (use_gda) then
         wterm = (2.0d0/3.0d0) * diffv
      else if (use_tophat) then
         width = max(diffv*deform,0.0001d0)
      end if
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         do j = ii+1, nvdw
            vscale(ivdw(j)) = 1.0d0
         end do
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
            if (proceed)  proceed = (vscale(k) .ne. 0.0d0)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               rad2 = radmin(kt,it)**2
               eps = epsilon(kt,it)
               if (iv14(k) .eq. i) then
                  rad2 = radmin4(kt,it)**2
                  eps = epsilon4(kt,it)
               end if
               eps = eps * vscale(k)
               do j = 1, ngauss
                  a(j) = igauss(1,j) * eps
                  b(j) = igauss(2,j) / rad2
               end do
               e = 0.0d0
c
c     transform the potential function via smoothing
c
               if (use_tophat) then
                  rik = sqrt(rik2)
                  do j = 1, ngauss
                     broot = sqrt(b(j))
                     expterm = -b(j) * (rik+width)**2
                     if (expterm .gt. expcut) then
                        expterm = exp(expterm)
                     else
                        expterm = 0.0d0
                     end if
                     expterm2 = -b(j) * (width-rik)**2
                     if (expterm2 .gt. expcut) then
                        expterm2 = exp(expterm2)
                     else
                        expterm2 = 0.0d0
                     end if
                     term = broot * (expterm-expterm2)
                     term = term + rootpi*b(j)*rik
     &                         * (erf(broot*(rik+width))
     &                           +erf(broot*(width-rik)))
                     e = e + term*a(j)/(b(j)*b(j)*broot)
                  end do
                  e = e * 3.0d0/(8.0d0*rik*width**3)
               else
                  if (use_gda)  width = wterm * (m2(i)+m2(k))
                  do j = 1, ngauss
                     t1 = 1.0d0 + b(j)*width
                     t2 = sqrt(t1**3)
                     expterm = -b(j) * rik2 / t1
                     if (expterm .gt. expcut)
     &                  e = e + (a(j)/t2)*exp(expterm)
                  end do
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the total van der Waals energy components
c
               nev = nev + 1
               aev(i) = aev(i) + 0.5d0*e
               aev(k) = aev(k) + 0.5d0*e
               ev = ev + e
c
c     increment the total intermolecular energy
c
               if (molcule(i) .ne. molcule(k)) then
                  einter = einter + e
               end if
c
c     print a message if the energy of this interaction is large
c
               huge = (e .gt. 10.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual van der Waals',
     &                          ' Interactions :',
     &                       //,' Type',14x,'Atom Names',
     &                          20x,'Minimum',4x,'Actual',
     &                          6x,'Energy',/)
                  end if
                  rad = sqrt(rad2)
                  write (iout,30)  i,name(i),k,name(k),
     &                             rad,sqrt(rik2),e
   30             format (' VDW-Gauss',1x,2(i7,'-',a3),
     &                       13x,2f10.4,f12.4)
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine egeom  --  geometric restraint energy terms  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "egeom" calculates the energy due to restraints on positions,
c     distances, angles and torsions as well as Gaussian basin and
c     spherical droplet restraints
c
c
      subroutine egeom
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use energi
      use group
      use math
      use molcul
      use restrn
      use usage
      implicit none
      integer i,j,k
      integer ia,ib,ic,id
      real*8 e,eps,fgrp
      real*8 dt,dt2
      real*8 xr,yr,zr
      real*8 r,r2,r6,r12
      real*8 angle,target
      real*8 dot,force
      real*8 cosine,sine
      real*8 rab2,rcb2
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2
      real*8 rtru,rcb
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xab,yab,zab
      real*8 xba,yba,zba
      real*8 xcb,ycb,zcb
      real*8 xdc,ydc,zdc
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 df1,df2
      real*8 af1,af2
      real*8 tf1,tf2,t1,t2
      real*8 xa,ya,za
      real*8 xb,yb,zb
      real*8 xk,yk,zk
      real*8 gf1,gf2,weigh
      real*8 weigha,weighb
      real*8 mola,molb,molk
      real*8 cf1,cf2,vol
      real*8 c1,c2,c3
      real*8 xi,yi,zi,ri
      real*8 rflat2
      real*8 a,b,buffer,term
      real*8 xorig,xorig2
      real*8 yorig,yorig2
      real*8 zorig,zorig2
      logical proceed,intermol
c
c
c     zero out the geometric restraint energy terms
c
      eg = 0.0d0
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     disable replica mechanism when computing restraint terms
c
      if (use_replica) then
         xorig = xcell
         yorig = ycell
         zorig = zcell
         xorig2 = xcell2
         yorig2 = ycell2
         zorig2 = zcell2
         xcell = xbox
         ycell = ybox
         zcell = zbox
         xcell2 = xbox2
         ycell2 = ybox2
         zcell2 = zbox2
      end if
c
c     compute the energy for position restraint terms
c
      do i = 1, npfix
         ia = ipfix(i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,0,0,0,0,0)
         if (proceed)  proceed = (use(ia))
         if (proceed) then
            xr = 0.0d0
            yr = 0.0d0
            zr = 0.0d0
            if (kpfix(1,i) .ne. 0)  xr = x(ia) - xpfix(i)
            if (kpfix(2,i) .ne. 0)  yr = y(ia) - ypfix(i)
            if (kpfix(3,i) .ne. 0)  zr = z(ia) - zpfix(i)
            if (use_bounds)  call image (xr,yr,zr)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            force = pfix(1,i)
            dt = max(0.0d0,r-pfix(2,i))
            dt2 = dt * dt
            e = force * dt2
            if (use_group)  e = e * fgrp
            eg = eg + e
         end if
      end do
c
c     compute the energy for distance restraint terms
c
      do i = 1, ndfix
         ia = idfix(1,i)
         ib = idfix(2,i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,0,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib))
         if (proceed) then
            xr = x(ia) - x(ib)
            yr = y(ia) - y(ib)
            zr = z(ia) - z(ib)
            intermol = (molcule(ia) .ne. molcule(ib))
            if (use_bounds .and. intermol)  call image (xr,yr,zr)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            force = dfix(1,i)
            df1 = dfix(2,i)
            df2 = dfix(3,i)
            target = r
            if (r .lt. df1)  target = df1
            if (r .gt. df2)  target = df2
            dt = r - target
            dt2 = dt * dt
            e = force * dt2
            if (use_group)  e = e * fgrp
            eg = eg + e
         end if
      end do
c
c     compute the energy for angle restraint terms
c
      do i = 1, nafix
         ia = iafix(1,i)
         ib = iafix(2,i)
         ic = iafix(3,i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic))
         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)
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            rab2 = max(xab*xab+yab*yab+zab*zab,eps)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
            dot = xab*xcb + yab*ycb + zab*zcb
            cosine = dot / sqrt(rab2*rcb2)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            force = afix(1,i)
            af1 = afix(2,i)
            af2 = afix(3,i)
            target = angle
            if (angle .lt. af1)  target = af1
            if (angle .gt. af2)  target = af2
            dt = angle - target
            dt = dt / radian
            dt2 = dt * dt
            e = force * dt2
            if (use_group)  e = e * fgrp
            eg = eg + e
         end if
      end do
c
c     compute the energy for torsional restraint terms
c
      do i = 1, ntfix
         ia = itfix(1,i)
         ib = itfix(2,i)
         ic = itfix(3,i)
         id = itfix(4,i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
         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
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
            force = tfix(1,i)
            tf1 = tfix(2,i)
            tf2 = tfix(3,i)
            if (angle.gt.tf1 .and. angle.lt.tf2) then
               target = angle
            else if (angle.gt.tf1 .and. tf1.gt.tf2) then
               target = angle
            else if (angle.lt.tf2 .and. tf1.gt.tf2) then
               target = angle
            else
               t1 = angle - tf1
               t2 = angle - tf2
               if (t1 .gt. 180.0d0) then
                  t1 = t1 - 360.0d0
               else if (t1 .lt. -180.0d0) then
                  t1 = t1 + 360.0d0
               end if
               if (t2 .gt. 180.0d0) then
                  t2 = t2 - 360.0d0
               else if (t2 .lt. -180.0d0) then
                  t2 = t2 + 360.0d0
               end if
               if (abs(t1) .lt. abs(t2)) then
                  target = tf1
               else
                  target = tf2
               end if
            end if
            dt = angle - target
            if (dt .gt. 180.0d0) then
               dt = dt - 360.0d0
            else if (dt .lt. -180.0d0) then
               dt = dt + 360.0d0
            end if
            dt = dt / radian
            dt2 = dt * dt
            e = force * dt2
            if (use_group)  e = e * fgrp
            eg = eg + e
         end if
      end do
c
c     compute the energy for group distance restraint terms
c
      do i = 1, ngfix
         ia = igfix(1,i)
         ib = igfix(2,i)
         xa = 0.0d0
         ya = 0.0d0
         za = 0.0d0
         j = kgrp(igrp(1,ia))
         xr = x(j)
         yr = y(j)
         zr = z(j)
         mola = molcule(j)
         do j = igrp(1,ia), igrp(2,ia)
            k = kgrp(j)
            weigh = mass(k)
            xk = x(k) - xr
            yk = y(k) - yr
            zk = z(k) - zr
            molk = molcule(k)
            intermol = (molk .ne. mola)
            if (use_bounds .and. intermol)  call image (xk,yk,zk)
            xa = xa + xk*weigh
            ya = ya + yk*weigh
            za = za + zk*weigh
         end do
         weigha = max(1.0d0,grpmass(ia))
         xa = xr + xa/weigha
         ya = yr + ya/weigha
         za = zr + za/weigha
         xb = 0.0d0
         yb = 0.0d0
         zb = 0.0d0
         j = kgrp(igrp(1,ib))
         xr = x(j)
         yr = y(j)
         zr = z(j)
         molb = molcule(j)
         do j = igrp(1,ib), igrp(2,ib)
            k = kgrp(j)
            weigh = mass(k)
            xk = x(k) - xr
            yk = y(k) - yr
            zk = z(k) - zr
            molk = molcule(k)
            intermol = (molk .ne. molb)
            if (use_bounds .and. intermol)  call image (xk,yk,zk)
            xb = xb + xk*weigh
            yb = yb + yk*weigh
            zb = zb + zk*weigh
         end do
         weighb = max(1.0d0,grpmass(ib))
         xb = xr + xb/weighb
         yb = yr + yb/weighb
         zb = zr + zb/weighb
         xr = xa - xb
         yr = ya - yb
         zr = za - zb
         intermol = (mola .ne. molb)
         if (use_bounds .and. intermol)  call image (xr,yr,zr)
         r = sqrt(xr*xr + yr*yr + zr*zr)
         force = gfix(1,i)
         gf1 = gfix(2,i)
         gf2 = gfix(3,i)
         target = r
         if (r .lt. gf1)  target = gf1
         if (r .gt. gf2)  target = gf2
         dt = r - target
         dt2 = dt * dt
         e = force * dt2
         eg = eg + e
      end do
c
c     compute the energy for chirality restraint terms
c
      do i = 1, nchir
         ia = ichir(1,i)
         ib = ichir(2,i)
         ic = ichir(3,i)
         id = ichir(4,i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
         if (proceed) then
            xad = x(ia) - x(id)
            yad = y(ia) - y(id)
            zad = z(ia) - z(id)
            xbd = x(ib) - x(id)
            ybd = y(ib) - y(id)
            zbd = z(ib) - z(id)
            xcd = x(ic) - x(id)
            ycd = y(ic) - y(id)
            zcd = z(ic) - z(id)
            c1 = ybd*zcd - zbd*ycd
            c2 = ycd*zad - zcd*yad
            c3 = yad*zbd - zad*ybd
            vol = xad*c1 + xbd*c2 + xcd*c3
            force = chir(1,i)
            cf1 = chir(2,i)
            cf2 = chir(3,i)
            target = vol
            if (vol .lt. min(cf1,cf2))  target = min(cf1,cf2)
            if (vol .gt. max(cf1,cf2))  target = max(cf1,cf2)
            dt = vol - target
            dt2 = dt * dt
            e = force * dt2
            if (use_group)  e = e * fgrp
            eg = eg + e
         end if
      end do
c
c     compute the energy for a Gaussian basin restraint
c
      if (use_basin) then
         rflat2 = rflat * rflat
         do i = 1, n-1
            xi = x(i)
            yi = y(i)
            zi = z(i)
            do k = i+1, n
               proceed = .true.
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               if (proceed)  proceed = (use(i) .or. use(k))
               if (proceed) then
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  r2 = xr*xr + yr*yr + zr*zr
                  r2 = max(0.0d0,r2-rflat2)
                  term = -width * r2
                  e = 0.0d0
                  if (term .gt. -50.0d0)  e = depth * exp(term)
                  e = e - depth
                  if (use_group)  e = e * fgrp
                  eg = eg + e
               end if
            end do
         end do
      end if
c
c     compute the energy for a spherical droplet restraint
c
      if (use_wall) then
         buffer = 2.5d0
         a = 2048.0d0
         b = 64.0d0
         do i = 1, n
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,0,0,0,0,0)
            if (proceed)  proceed = (use(i))
            if (proceed) then
               xi = x(i)
               yi = y(i)
               zi = z(i)
               ri = sqrt(xi**2 + yi**2 + zi**2)
               r = rwall + buffer - ri
               r2 = r * r
               r6 = r2 * r2 * r2
               r12 = r6 * r6
               e = a/r12 - b/r6
               if (use_group)  e = e * fgrp
               eg = eg + e
            end if
         end do
      end if
c
c     reinstate the replica mechanism if it is being used
c
      if (use_replica) then
         xcell = xorig
         ycell = yorig
         zcell = zorig
         xcell2 = xorig2
         ycell2 = yorig2
         zcell2 = zorig2
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine egeom1  --  restraint energy & derivatives  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "egeom1" calculates the energy and first derivatives
c     with respect to Cartesian coordinates due to restraints
c     on positions, distances, angles and torsions as well as
c     Gaussian basin and spherical droplet restraints
c
c
      subroutine egeom1
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use deriv
      use energi
      use group
      use molcul
      use math
      use restrn
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ia,ib,ic,id
      real*8 e,eps,fgrp
      real*8 de,dt,dt2,deddt
      real*8 xr,yr,zr
      real*8 r,r2,r6,r12
      real*8 dedx,dedy,dedz
      real*8 angle,target
      real*8 dot,force
      real*8 cosine,sine
      real*8 terma,termc
      real*8 rab2,rcb2
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xab,yab,zab
      real*8 xba,yba,zba
      real*8 xcb,ycb,zcb
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 xp,yp,zp,rp
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru
      real*8 rcb,dedphi
      real*8 dedxt,dedyt,dedzt
      real*8 dedxu,dedyu,dedzu
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 df1,df2
      real*8 af1,af2
      real*8 tf1,tf2,t1,t2
      real*8 xa,ya,za
      real*8 xb,yb,zb
      real*8 xk,yk,zk
      real*8 gf1,gf2
      real*8 weigh,ratio
      real*8 weigha,weighb
      real*8 mola,molb,molk
      real*8 cf1,cf2,vol
      real*8 c1,c2,c3
      real*8 xi,yi,zi,ri
      real*8 rflat2
      real*8 a,b,buffer,term
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8 xorig,xorig2
      real*8 yorig,yorig2
      real*8 zorig,zorig2
      logical proceed,intermol
c
c
c     zero out the restraint energy term and first derivatives
c
      eg = 0.0d0
      do i = 1, n
         deg(1,i) = 0.0d0
         deg(2,i) = 0.0d0
         deg(3,i) = 0.0d0
      end do
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     disable replica mechanism when computing restraint terms
c
      if (use_replica) then
         xorig = xcell
         yorig = ycell
         zorig = zcell
         xorig2 = xcell2
         yorig2 = ycell2
         zorig2 = zcell2
         xcell = xbox
         ycell = ybox
         zcell = zbox
         xcell2 = xbox2
         ycell2 = ybox2
         zcell2 = zbox2
      end if
c
c     get energy and derivatives for position restraint terms
c
      do i = 1, npfix
         ia = ipfix(i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,0,0,0,0,0)
         if (proceed)  proceed = (use(ia))
         if (proceed) then
            xr = 0.0d0
            yr = 0.0d0
            zr = 0.0d0
            if (kpfix(1,i) .ne. 0)  xr = x(ia) - xpfix(i)
            if (kpfix(2,i) .ne. 0)  yr = y(ia) - ypfix(i)
            if (kpfix(3,i) .ne. 0)  zr = z(ia) - zpfix(i)
            if (use_bounds)  call image (xr,yr,zr)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            force = pfix(1,i)
            dt = max(0.0d0,r-pfix(2,i))
            dt2 = dt * dt
            e = force * dt2
            de = 2.0d0 * force * dt / max(r,eps)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e = e * fgrp
               de = de * fgrp
            end if
c
c     compute chain rule terms needed for derivatives
c
            dedx = de * xr
            dedy = de * yr
            dedz = de * zr
c
c     increment the total energy and first derivatives
c
            eg = eg + e
            deg(1,ia) = deg(1,ia) + dedx
            deg(2,ia) = deg(2,ia) + dedy
            deg(3,ia) = deg(3,ia) + dedz
c
c     increment the internal virial tensor components
c
            vxx = xr * dedx
            vyx = yr * dedx
            vzx = zr * dedx
            vyy = yr * dedy
            vzy = zr * dedy
            vzz = zr * dedz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     get energy and derivatives for distance restraint terms
c
      do i = 1, ndfix
         ia = idfix(1,i)
         ib = idfix(2,i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,0,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib))
         if (proceed) then
            xr = x(ia) - x(ib)
            yr = y(ia) - y(ib)
            zr = z(ia) - z(ib)
            intermol = (molcule(ia) .ne. molcule(ib))
            if (use_bounds .and. intermol)  call image (xr,yr,zr)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            force = dfix(1,i)
            df1 = dfix(2,i)
            df2 = dfix(3,i)
            target = r
            if (r .lt. df1)  target = df1
            if (r .gt. df2)  target = df2
            dt = r - target
            dt2 = dt * dt
            e = force * dt2
            de = 2.0d0 * force * dt / max(r,eps)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e = e * fgrp
               de = de * fgrp
            end if
c
c     compute chain rule terms needed for derivatives
c
            dedx = de * xr
            dedy = de * yr
            dedz = de * zr
c
c     increment the total energy and first derivatives
c
            eg = eg + e
            deg(1,ia) = deg(1,ia) + dedx
            deg(2,ia) = deg(2,ia) + dedy
            deg(3,ia) = deg(3,ia) + dedz
            deg(1,ib) = deg(1,ib) - dedx
            deg(2,ib) = deg(2,ib) - dedy
            deg(3,ib) = deg(3,ib) - dedz
c
c     increment the internal virial tensor components
c
            vxx = xr * dedx
            vyx = yr * dedx
            vzx = zr * dedx
            vyy = yr * dedy
            vzy = zr * dedy
            vzz = zr * dedz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     get energy and derivatives for angle restraint terms
c
      do i = 1, nafix
         ia = iafix(1,i)
         ib = iafix(2,i)
         ic = iafix(3,i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic))
         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)
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            rab2 = max(xab*xab+yab*yab+zab*zab,eps)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
            xp = ycb*zab - zcb*yab
            yp = zcb*xab - xcb*zab
            zp = xcb*yab - ycb*xab
            rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps))
            dot = xab*xcb + yab*ycb + zab*zcb
            cosine = dot / sqrt(rab2*rcb2)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            force = afix(1,i)
            af1 = afix(2,i)
            af2 = afix(3,i)
            target = angle
            if (angle .lt. af1)  target = af1
            if (angle .gt. af2)  target = af2
            dt = angle - target
            dt = dt / radian
            dt2 = dt * dt
            e = force * dt2
            deddt = 2.0d0 * force * dt
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e = e * fgrp
               deddt = deddt * fgrp
            end if
c
c     compute derivative components for this interaction
c
            terma = -deddt / (rab2*rp)
            termc = deddt / (rcb2*rp)
            dedxia = terma * (yab*zp-zab*yp)
            dedyia = terma * (zab*xp-xab*zp)
            dedzia = terma * (xab*yp-yab*xp)
            dedxic = termc * (ycb*zp-zcb*yp)
            dedyic = termc * (zcb*xp-xcb*zp)
            dedzic = termc * (xcb*yp-ycb*xp)
            dedxib = -dedxia - dedxic
            dedyib = -dedyia - dedyic
            dedzib = -dedzia - dedzic
c
c     increment the overall energy term and derivatives
c
            eg = eg + e
            deg(1,ia) = deg(1,ia) + dedxia
            deg(2,ia) = deg(2,ia) + dedyia
            deg(3,ia) = deg(3,ia) + dedzia
            deg(1,ib) = deg(1,ib) + dedxib
            deg(2,ib) = deg(2,ib) + dedyib
            deg(3,ib) = deg(3,ib) + dedzib
            deg(1,ic) = deg(1,ic) + dedxic
            deg(2,ic) = deg(2,ic) + dedyic
            deg(3,ic) = deg(3,ic) + dedzic
c
c     increment the internal virial tensor components
c
            vxx = xab*dedxia + xcb*dedxic
            vyx = yab*dedxia + ycb*dedxic
            vzx = zab*dedxia + zcb*dedxic
            vyy = yab*dedyia + ycb*dedyic
            vzy = zab*dedyia + zcb*dedyic
            vzz = zab*dedzia + zcb*dedzic
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     get energy and derivatives for torsion restraint terms
c
      do i = 1, ntfix
         ia = itfix(1,i)
         ib = itfix(2,i)
         ic = itfix(3,i)
         id = itfix(4,i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
         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
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
            force = tfix(1,i)
            tf1 = tfix(2,i)
            tf2 = tfix(3,i)
            if (angle.gt.tf1 .and. angle.lt.tf2) then
               target = angle
            else if (angle.gt.tf1 .and. tf1.gt.tf2) then
               target = angle
            else if (angle.lt.tf2 .and. tf1.gt.tf2) then
               target = angle
            else
               t1 = angle - tf1
               t2 = angle - tf2
               if (t1 .gt. 180.0d0) then
                  t1 = t1 - 360.0d0
               else if (t1 .lt. -180.0d0) then
                  t1 = t1 + 360.0d0
               end if
               if (t2 .gt. 180.0d0) then
                  t2 = t2 - 360.0d0
               else if (t2 .lt. -180.0d0) then
                  t2 = t2 + 360.0d0
               end if
               if (abs(t1) .lt. abs(t2)) then
                  target = tf1
               else
                  target = tf2
               end if
            end if
            dt = angle - target
            if (dt .gt. 180.0d0) then
               dt = dt - 360.0d0
            else if (dt .lt. -180.0d0) then
               dt = dt + 360.0d0
            end if
            dt = dt / radian
            dt2 = dt * dt
            e = force * dt2
            dedphi = 2.0d0 * force * dt
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     chain rule terms for first derivative components
c
            xca = xic - xia
            yca = yic - yia
            zca = zic - zia
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            dedxt = dedphi * (yt*zcb - ycb*zt) / (rt2*rcb)
            dedyt = dedphi * (zt*xcb - zcb*xt) / (rt2*rcb)
            dedzt = dedphi * (xt*ycb - xcb*yt) / (rt2*rcb)
            dedxu = -dedphi * (yu*zcb - ycb*zu) / (ru2*rcb)
            dedyu = -dedphi * (zu*xcb - zcb*xu) / (ru2*rcb)
            dedzu = -dedphi * (xu*ycb - xcb*yu) / (ru2*rcb)
c
c     compute derivative components for this interaction
c
            dedxia = zcb*dedyt - ycb*dedzt
            dedyia = xcb*dedzt - zcb*dedxt
            dedzia = ycb*dedxt - xcb*dedyt
            dedxib = yca*dedzt - zca*dedyt + zdc*dedyu - ydc*dedzu
            dedyib = zca*dedxt - xca*dedzt + xdc*dedzu - zdc*dedxu
            dedzib = xca*dedyt - yca*dedxt + ydc*dedxu - xdc*dedyu
            dedxic = zba*dedyt - yba*dedzt + ydb*dedzu - zdb*dedyu
            dedyic = xba*dedzt - zba*dedxt + zdb*dedxu - xdb*dedzu
            dedzic = yba*dedxt - xba*dedyt + xdb*dedyu - ydb*dedxu
            dedxid = zcb*dedyu - ycb*dedzu
            dedyid = xcb*dedzu - zcb*dedxu
            dedzid = ycb*dedxu - xcb*dedyu
c
c     increment the overall energy term and derivatives
c
            eg = eg + e
            deg(1,ia) = deg(1,ia) + dedxia
            deg(2,ia) = deg(2,ia) + dedyia
            deg(3,ia) = deg(3,ia) + dedzia
            deg(1,ib) = deg(1,ib) + dedxib
            deg(2,ib) = deg(2,ib) + dedyib
            deg(3,ib) = deg(3,ib) + dedzib
            deg(1,ic) = deg(1,ic) + dedxic
            deg(2,ic) = deg(2,ic) + dedyic
            deg(3,ic) = deg(3,ic) + dedzic
            deg(1,id) = deg(1,id) + dedxid
            deg(2,id) = deg(2,id) + dedyid
            deg(3,id) = deg(3,id) + dedzid
c
c     increment the internal virial tensor components
c
            vxx = xcb*(dedxic+dedxid) - xba*dedxia + xdc*dedxid
            vyx = ycb*(dedxic+dedxid) - yba*dedxia + ydc*dedxid
            vzx = zcb*(dedxic+dedxid) - zba*dedxia + zdc*dedxid
            vyy = ycb*(dedyic+dedyid) - yba*dedyia + ydc*dedyid
            vzy = zcb*(dedyic+dedyid) - zba*dedyia + zdc*dedyid
            vzz = zcb*(dedzic+dedzid) - zba*dedzia + zdc*dedzid
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     get energy and derivatives for group distance restraint terms
c
      do i = 1, ngfix
         ia = igfix(1,i)
         ib = igfix(2,i)
         xa = 0.0d0
         ya = 0.0d0
         za = 0.0d0
         j = kgrp(igrp(1,ia))
         xr = x(j)
         yr = y(j)
         zr = z(j)
         mola = molcule(j)
         do j = igrp(1,ia), igrp(2,ia)
            k = kgrp(j)
            weigh = mass(k)
            xk = x(k) - xr
            yk = y(k) - yr
            zk = z(k) - zr
            molk = molcule(k)
            intermol = (molk .ne. mola)
            if (use_bounds .and. intermol)  call image (xk,yk,zk)
            xa = xa + xk*weigh
            ya = ya + yk*weigh
            za = za + zk*weigh
         end do
         weigha = max(1.0d0,grpmass(ia))
         xa = xr + xa/weigha
         ya = yr + ya/weigha
         za = zr + za/weigha
         xb = 0.0d0
         yb = 0.0d0
         zb = 0.0d0
         j = kgrp(igrp(1,ib))
         xr = x(j)
         yr = y(j)
         zr = z(j)
         molb = molcule(j)
         do j = igrp(1,ib), igrp(2,ib)
            k = kgrp(j)
            weigh = mass(k)
            xk = x(k) - xr
            yk = y(k) - yr
            zk = z(k) - zr
            molk = molcule(k)
            intermol = (molk .ne. molb)
            if (use_bounds .and. intermol)  call image (xk,yk,zk)
            xb = xb + xk*weigh
            yb = yb + yk*weigh
            zb = zb + zk*weigh
         end do
         weighb = max(1.0d0,grpmass(ib))
         xb = xr + xb/weighb
         yb = yr + yb/weighb
         zb = zr + zb/weighb
         xr = xa - xb
         yr = ya - yb
         zr = za - zb
         intermol = (mola .ne. molb)
         if (use_bounds .and. intermol)  call image (xr,yr,zr)
         r = sqrt(xr*xr + yr*yr + zr*zr)
         force = gfix(1,i)
         gf1 = gfix(2,i)
         gf2 = gfix(3,i)
         target = r
         if (r .lt. gf1)  target = gf1
         if (r .gt. gf2)  target = gf2
         dt = r - target
         dt2 = dt * dt
         e = force * dt2
         de = 2.0d0 * force * dt / max(r,eps)
c
c     compute chain rule terms needed for derivatives
c
         dedx = de * xr
         dedy = de * yr
         dedz = de * zr
c
c     increment the total energy and first derivatives
c
         eg = eg + e
         do j = igrp(1,ia), igrp(2,ia)
            k = kgrp(j)
            ratio = mass(k) / weigha
            deg(1,k) = deg(1,k) + dedx*ratio
            deg(2,k) = deg(2,k) + dedy*ratio
            deg(3,k) = deg(3,k) + dedz*ratio
         end do
         do j = igrp(1,ib), igrp(2,ib)
            k = kgrp(j)
            ratio = mass(k) / weighb
            deg(1,k) = deg(1,k) - dedx*ratio
            deg(2,k) = deg(2,k) - dedy*ratio
            deg(3,k) = deg(3,k) - dedz*ratio
         end do
c
c     increment the internal virial tensor components
c
         vxx = xr * dedx
         vyx = yr * dedx
         vzx = zr * dedx
         vyy = yr * dedy
         vzy = zr * dedy
         vzz = zr * dedz
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vyx
         vir(3,1) = vir(3,1) + vzx
         vir(1,2) = vir(1,2) + vyx
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vzy
         vir(1,3) = vir(1,3) + vzx
         vir(2,3) = vir(2,3) + vzy
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     get energy and derivatives for chirality restraint terms
c
      do i = 1, nchir
         ia = ichir(1,i)
         ib = ichir(2,i)
         ic = ichir(3,i)
         id = ichir(4,i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
         if (proceed) then
            xad = x(ia) - x(id)
            yad = y(ia) - y(id)
            zad = z(ia) - z(id)
            xbd = x(ib) - x(id)
            ybd = y(ib) - y(id)
            zbd = z(ib) - z(id)
            xcd = x(ic) - x(id)
            ycd = y(ic) - y(id)
            zcd = z(ic) - z(id)
            c1 = ybd*zcd - zbd*ycd
            c2 = ycd*zad - zcd*yad
            c3 = yad*zbd - zad*ybd
            vol = xad*c1 + xbd*c2 + xcd*c3
            force = chir(1,i)
            cf1 = chir(2,i)
            cf2 = chir(3,i)
            target = vol
            if (vol .lt. min(cf1,cf2))  target = min(cf1,cf2)
            if (vol .gt. max(cf1,cf2))  target = max(cf1,cf2)
            dt = vol - target
            dt2 = dt * dt
            e = force * dt2
            deddt = 2.0d0 * force * dt
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e = e * fgrp
               deddt = deddt * fgrp
            end if
c
c     compute derivative components for this interaction
c
            dedxia = deddt * (ybd*zcd - zbd*ycd)
            dedyia = deddt * (zbd*xcd - xbd*zcd)
            dedzia = deddt * (xbd*ycd - ybd*xcd)
            dedxib = deddt * (zad*ycd - yad*zcd)
            dedyib = deddt * (xad*zcd - zad*xcd)
            dedzib = deddt * (yad*xcd - xad*ycd)
            dedxic = deddt * (yad*zbd - zad*ybd)
            dedyic = deddt * (zad*xbd - xad*zbd)
            dedzic = deddt * (xad*ybd - yad*xbd)
            dedxid = -dedxia - dedxib - dedxic
            dedyid = -dedyia - dedyib - dedyic
            dedzid = -dedzia - dedzib - dedzic
c
c     increment the overall energy term and derivatives
c
            eg = eg + e
            deg(1,ia) = deg(1,ia) + dedxia
            deg(2,ia) = deg(2,ia) + dedyia
            deg(3,ia) = deg(3,ia) + dedzia
            deg(1,ib) = deg(1,ib) + dedxib
            deg(2,ib) = deg(2,ib) + dedyib
            deg(3,ib) = deg(3,ib) + dedzib
            deg(1,ic) = deg(1,ic) + dedxic
            deg(2,ic) = deg(2,ic) + dedyic
            deg(3,ic) = deg(3,ic) + dedzic
            deg(1,id) = deg(1,id) + dedxid
            deg(2,id) = deg(2,id) + dedyid
            deg(3,id) = deg(3,id) + dedzid
c
c     increment the internal virial tensor components
c
            vxx = xad*dedxia + xbd*dedxib + xcd*dedxic
            vyx = yad*dedxia + ybd*dedxib + ycd*dedxic
            vzx = zad*dedxia + zbd*dedxib + zcd*dedxic
            vyy = yad*dedyia + ybd*dedyib + ycd*dedyic
            vzy = zad*dedyia + zbd*dedyib + zcd*dedyic
            vzz = zad*dedzia + zbd*dedzib + zcd*dedzic
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     get energy and derivatives for a Gaussian basin restraint
c
      if (use_basin) then
         rflat2 = rflat * rflat
         do i = 1, n-1
            xi = x(i)
            yi = y(i)
            zi = z(i)
            do k = i+1, n
               proceed = .true.
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               if (proceed)  proceed = (use(i) .or. use(k))
               if (proceed) then
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  r2 = xr*xr + yr*yr + zr*zr
                  r2 = max(0.0d0,r2-rflat2)
                  term = -width * r2
                  e = 0.0d0
                  if (term .gt. -50.0d0)  e = depth * exp(term)
                  de = -2.0d0 * width * e
                  e = e - depth
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     compute chain rule terms needed for derivatives
c
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the overall energy term and derivatives
c
                  eg = eg + e
                  deg(1,i) = deg(1,i) + dedx
                  deg(2,i) = deg(2,i) + dedy
                  deg(3,i) = deg(3,i) + dedz
                  deg(1,k) = deg(1,k) - dedx
                  deg(2,k) = deg(2,k) - dedy
                  deg(3,k) = deg(3,k) - dedz
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end do
         end do
      end if
c
c     get energy and derivatives for a spherical droplet restraint
c
      if (use_wall) then
         buffer = 2.5d0
         a = 2048.0d0
         b = 64.0d0
         do i = 1, n
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,0,0,0,0,0)
            if (proceed)  proceed = (use(i))
            if (proceed) then
               xi = x(i)
               yi = y(i)
               zi = z(i)
               ri = sqrt(xi**2 + yi**2 + zi**2)
               r = rwall + buffer - ri
               r2 = r * r
               r6 = r2 * r2 * r2
               r12 = r6 * r6
               e = a/r12 - b/r6
               if (ri .eq. 0.0d0)  ri = 1.0d0
               de = (12.0d0*a/r12 - 6.0d0*b/r6) / (r*ri)
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  e = e * fgrp
                  de = de * fgrp
               end if
c
c     compute chain rule terms needed for derivatives
c
               dedx = de * xi
               dedy = de * yi
               dedz = de * zi
c
c     increment the overall energy term and derivatives
c
               eg = eg + e
               deg(1,i) = deg(1,i) + dedx
               deg(2,i) = deg(2,i) + dedy
               deg(3,i) = deg(3,i) + dedz
c
c     increment the internal virial tensor components
c
               xr = r * xi/ri
               yr = r * yi/ri
               zr = r * zi/ri
               vxx = xr * dedx
               vyx = yr * dedx
               vzx = zr * dedx
               vyy = yr * dedy
               vzy = zr * dedy
               vzz = zr * dedz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vyx
               vir(3,1) = vir(3,1) + vzx
               vir(1,2) = vir(1,2) + vyx
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vzy
               vir(1,3) = vir(1,3) + vzx
               vir(2,3) = vir(2,3) + vzy
               vir(3,3) = vir(3,3) + vzz
            end if
         end do
      end if
c
c     reinstate the replica mechanism if it is being used
c
      if (use_replica) then
         xcell = xorig
         ycell = yorig
         zcell = zorig
         xcell2 = xorig2
         ycell2 = yorig2
         zcell2 = zorig2
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine egeom2  --  atom-by-atom restraint Hessian  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "egeom2" calculates second derivatives of restraints
c     on positions, distances, angles and torsions as well
c     as Gaussian basin and spherical droplet restraints
c
c     note that the Hessian is discontinuous when an upper and
c     lower bound range is used instead of a single distance
c
c
      subroutine egeom2 (i)
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use deriv
      use group
      use hessn
      use math
      use molcul
      use restrn
      implicit none
      integer i,j,k,m
      integer ia,ib,ic,id
      integer kpos,kdist,kang
      integer ktors,kchir
      real*8 eps,fgrp
      real*8 xr,yr,zr
      real*8 target,force
      real*8 dot,angle
      real*8 cosine,sine
      real*8 dt,dt2,deddt
      real*8 term,terma,termc
      real*8 termx,termy,termz
      real*8 de,d2eddt2
      real*8 d2e(3,3)
      real*8 dedphi,d2edphi2
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xab,yab,zab
      real*8 xba,yba,zba
      real*8 xcb,ycb,zcb
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 xrab,yrab,zrab
      real*8 xrcb,yrcb,zrcb
      real*8 xabp,yabp,zabp
      real*8 xcbp,ycbp,zcbp
      real*8 rab2,rcb2
      real*8 xpo,ypo,zpo
      real*8 xp,yp,zp,rp,rp2
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru,rcb
      real*8 df1,df2,af1,af2
      real*8 tf1,tf2,t1,t2
      real*8 xa,ya,za
      real*8 xb,yb,zb
      real*8 xk,yk,zk
      real*8 gf1,gf2
      real*8 weigh,ratio
      real*8 weigha,weighb
      real*8 mola,molb,molk
      real*8 cf1,cf2,vol
      real*8 c1,c2,c3
      real*8 ddtdxia,ddtdyia,ddtdzia
      real*8 ddtdxib,ddtdyib,ddtdzib
      real*8 ddtdxic,ddtdyic,ddtdzic
      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 xycb2,xzcb2,yzcb2
      real*8 rcbxt,rcbyt,rcbzt,rcbt2
      real*8 rcbxu,rcbyu,rcbzu,rcbu2
      real*8 dphidxibt,dphidyibt,dphidzibt
      real*8 dphidxibu,dphidyibu,dphidzibu
      real*8 dphidxict,dphidyict,dphidzict
      real*8 dphidxicu,dphidyicu,dphidzicu
      real*8 dxiaxia,dyiayia,dziazia
      real*8 dxibxib,dyibyib,dzibzib
      real*8 dxicxic,dyicyic,dziczic
      real*8 dxidxid,dyidyid,dzidzid
      real*8 dxiayia,dxiazia,dyiazia
      real*8 dxibyib,dxibzib,dyibzib
      real*8 dxicyic,dxiczic,dyiczic
      real*8 dxidyid,dxidzid,dyidzid
      real*8 dxiaxib,dxiayib,dxiazib
      real*8 dyiaxib,dyiayib,dyiazib
      real*8 dziaxib,dziayib,dziazib
      real*8 dxiaxic,dxiayic,dxiazic
      real*8 dyiaxic,dyiayic,dyiazic
      real*8 dziaxic,dziayic,dziazic
      real*8 dxiaxid,dxiayid,dxiazid
      real*8 dyiaxid,dyiayid,dyiazid
      real*8 dziaxid,dziayid,dziazid
      real*8 dxibxia,dxibyia,dxibzia
      real*8 dyibxia,dyibyia,dyibzia
      real*8 dzibxia,dzibyia,dzibzia
      real*8 dxibxic,dxibyic,dxibzic
      real*8 dyibxic,dyibyic,dyibzic
      real*8 dzibxic,dzibyic,dzibzic
      real*8 dxibxid,dxibyid,dxibzid
      real*8 dyibxid,dyibyid,dyibzid
      real*8 dzibxid,dzibyid,dzibzid
      real*8 dxicxid,dxicyid,dxiczid
      real*8 dyicxid,dyicyid,dyiczid
      real*8 dzicxid,dzicyid,dziczid
      real*8 ddtdxid,ddtdyid,ddtdzid
      real*8 dedr,d2edr2,expterm
      real*8 xi,yi,zi,ri,ri2
      real*8 r,r2,r6,r12
      real*8 rflat2
      real*8 a,b,buffer
      real*8 xorig,xorig2
      real*8 yorig,yorig2
      real*8 zorig,zorig2
      logical proceed,intermol,linear
c
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     disable replica mechanism when computing restraint terms
c
      if (use_replica) then
         xorig = xcell
         yorig = ycell
         zorig = zcell
         xorig2 = xcell2
         yorig2 = ycell2
         zorig2 = zcell2
         xcell = xbox
         ycell = ybox
         zcell = zbox
         xcell2 = xbox2
         ycell2 = ybox2
         zcell2 = zbox2
      end if
c
c     compute the Hessian elements for position restraints
c
      do kpos = 1, npfix
         ia = ipfix(kpos)
         proceed = (i .eq. ia)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,0,0,0,0,0)
         if (proceed) then
            xr = 0.0d0
            yr = 0.0d0
            zr = 0.0d0
            if (kpfix(1,i) .ne. 0)  xr = x(ia) - xpfix(kpos)
            if (kpfix(2,i) .ne. 0)  yr = y(ia) - ypfix(kpos)
            if (kpfix(3,i) .ne. 0)  zr = z(ia) - zpfix(kpos)
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            r = sqrt(r2)
            force = pfix(1,kpos)
            dt = max(0.0d0,r-pfix(2,kpos))
            dt2 = dt * dt
            deddt = 2.0d0 * force
c
c     scale the interaction based on its group membership
c
            if (use_group)  deddt = deddt * fgrp
c
c     set the chain rule terms for the Hessian elements
c
            r = max(r,eps)
            r2 = r * r
            de = deddt * dt/r
            term = (deddt-de) / r2
            termx = term * xr
            termy = term * yr
            termz = term * zr
            d2e(1,1) = termx*xr + de
            d2e(1,2) = termx*yr
            d2e(1,3) = termx*zr
            d2e(2,1) = d2e(1,2)
            d2e(2,2) = termy*yr + de
            d2e(2,3) = termy*zr
            d2e(3,1) = d2e(1,3)
            d2e(3,2) = d2e(2,3)
            d2e(3,3) = termz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
            do j = 1, 3
               hessx(j,ia) = hessx(j,ia) + d2e(1,j)
               hessy(j,ia) = hessy(j,ia) + d2e(2,j)
               hessz(j,ia) = hessz(j,ia) + d2e(3,j)
            end do
         end if
      end do
c
c     compute the Hessian elements for distance restraints
c
      do kdist = 1, ndfix
         ia = idfix(1,kdist)
         ib = idfix(2,kdist)
         proceed = (i.eq.ia .or. i.eq.ib)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,0,0,0,0)
         if (proceed) then
            if (i .eq. ib) then
               ib = ia
               ia = i
            end if
            xr = x(ia) - x(ib)
            yr = y(ia) - y(ib)
            zr = z(ia) - z(ib)
            intermol = (molcule(ia) .ne. molcule(ib))
            if (use_bounds .and. intermol)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            r = sqrt(r2)
            force = dfix(1,kdist)
            df1 = dfix(2,kdist)
            df2 = dfix(3,kdist)
            target = r
            if (r .lt. df1)  target = df1
            if (r .gt. df2)  target = df2
            dt = r - target
            deddt = 2.0d0 * force
c
c     scale the interaction based on its group membership
c
            if (use_group)  deddt = deddt * fgrp
c
c     set the chain rule terms for the Hessian elements
c
            r = max(r,eps)
            r2 = r * r
            de = deddt * dt/r
            term = (deddt-de) / r2
            termx = term * xr
            termy = term * yr
            termz = term * zr
            d2e(1,1) = termx*xr + de
            d2e(1,2) = termx*yr
            d2e(1,3) = termx*zr
            d2e(2,1) = d2e(1,2)
            d2e(2,2) = termy*yr + de
            d2e(2,3) = termy*zr
            d2e(3,1) = d2e(1,3)
            d2e(3,2) = d2e(2,3)
            d2e(3,3) = termz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
            do j = 1, 3
               hessx(j,ia) = hessx(j,ia) + d2e(1,j)
               hessy(j,ia) = hessy(j,ia) + d2e(2,j)
               hessz(j,ia) = hessz(j,ia) + d2e(3,j)
               hessx(j,ib) = hessx(j,ib) - d2e(1,j)
               hessy(j,ib) = hessy(j,ib) - d2e(2,j)
               hessz(j,ib) = hessz(j,ib) - d2e(3,j)
            end do
         end if
      end do
c
c     compute the Hessian elements for angle restraints
c
      do kang = 1, nafix
         ia = iafix(1,kang)
         ib = iafix(2,kang)
         ic = iafix(3,kang)
         proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,0,0,0)
         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)
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            rab2 = max(xab*xab+yab*yab+zab*zab,eps)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
            xp = ycb*zab - zcb*yab
            yp = zcb*xab - xcb*zab
            zp = xcb*yab - ycb*xab
            rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps))
            dot = xab*xcb + yab*ycb + zab*zcb
            cosine = dot / sqrt(rab2*rcb2)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            force = afix(1,kang)
            af1 = afix(2,kang)
            af2 = afix(3,kang)
            target = angle
            if (angle .lt. af1)  target = af1
            if (angle .gt. af2)  target = af2
            dt = angle - target
            dt = dt / radian
            dt2 = dt * dt
            deddt = 2.0d0 * force * dt
            d2eddt2 = 2.0d0 * force
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               deddt = deddt * fgrp
               d2eddt2 = d2eddt2 * fgrp
            end if
c
c     construct an orthogonal direction for linear angles
c
            linear = .false.
            if (rp .lt. eps) then
               linear = .true.
               if (xab.ne.0.0d0 .and. yab.ne.0.0d0) then
                  xp = -yab
                  yp = xab
                  zp = 0.0d0
               else if (xab.eq.0.0d0 .and. yab.eq.0.0d0) then
                  xp = 1.0d0
                  yp = 0.0d0
                  zp = 0.0d0
               else if (xab.ne.0.0d0 .and. yab.eq.0.0d0) then
                  xp = 0.0d0
                  yp = 1.0d0
                  zp = 0.0d0
               else if (xab.eq.0.0d0 .and. yab.ne.0.0d0) then
                  xp = 1.0d0
                  yp = 0.0d0
                  zp = 0.0d0
               end if
               rp = sqrt(xp*xp + yp*yp + zp*zp)
            end if
c
c     first derivatives of bond angle with respect to coordinates
c
   10       continue
            terma = -1.0d0 / (rab2*rp)
            termc = 1.0d0 / (rcb2*rp)
            ddtdxia = terma * (yab*zp-zab*yp)
            ddtdyia = terma * (zab*xp-xab*zp)
            ddtdzia = terma * (xab*yp-yab*xp)
            ddtdxic = termc * (ycb*zp-zcb*yp)
            ddtdyic = termc * (zcb*xp-xcb*zp)
            ddtdzic = termc * (xcb*yp-ycb*xp)
            ddtdxib = -ddtdxia - ddtdxic
            ddtdyib = -ddtdyia - ddtdyic
            ddtdzib = -ddtdzia - ddtdzic
c
c     abbreviations used in defining chain rule terms
c
            xrab = 2.0d0 * xab / rab2
            yrab = 2.0d0 * yab / rab2
            zrab = 2.0d0 * zab / rab2
            xrcb = 2.0d0 * xcb / rcb2
            yrcb = 2.0d0 * ycb / rcb2
            zrcb = 2.0d0 * zcb / rcb2
            rp2 = 1.0d0 / (rp*rp)
            xabp = (yab*zp-zab*yp) * rp2
            yabp = (zab*xp-xab*zp) * rp2
            zabp = (xab*yp-yab*xp) * rp2
            xcbp = (ycb*zp-zcb*yp) * rp2
            ycbp = (zcb*xp-xcb*zp) * rp2
            zcbp = (xcb*yp-ycb*xp) * rp2
c
c     chain rule terms for second derivative components
c
            dxiaxia = terma*(xab*xcb-dot) + ddtdxia*(xcbp-xrab)
            dxiayia = terma*(zp+yab*xcb) + ddtdxia*(ycbp-yrab)
            dxiazia = terma*(zab*xcb-yp) + ddtdxia*(zcbp-zrab)
            dyiayia = terma*(yab*ycb-dot) + ddtdyia*(ycbp-yrab)
            dyiazia = terma*(xp+zab*ycb) + ddtdyia*(zcbp-zrab)
            dziazia = terma*(zab*zcb-dot) + ddtdzia*(zcbp-zrab)
            dxicxic = termc*(dot-xab*xcb) - ddtdxic*(xabp+xrcb)
            dxicyic = termc*(zp-ycb*xab) - ddtdxic*(yabp+yrcb)
            dxiczic = -termc*(yp+zcb*xab) - ddtdxic*(zabp+zrcb)
            dyicyic = termc*(dot-yab*ycb) - ddtdyic*(yabp+yrcb)
            dyiczic = termc*(xp-zcb*yab) - ddtdyic*(zabp+zrcb)
            dziczic = termc*(dot-zab*zcb) - ddtdzic*(zabp+zrcb)
            dxiaxic = terma*(yab*yab+zab*zab) - ddtdxia*xabp
            dxiayic = -terma*xab*yab - ddtdxia*yabp
            dxiazic = -terma*xab*zab - ddtdxia*zabp
            dyiaxic = -terma*xab*yab - ddtdyia*xabp
            dyiayic = terma*(xab*xab+zab*zab) - ddtdyia*yabp
            dyiazic = -terma*yab*zab - ddtdyia*zabp
            dziaxic = -terma*xab*zab - ddtdzia*xabp
            dziayic = -terma*yab*zab - ddtdzia*yabp
            dziazic = terma*(xab*xab+yab*yab) - ddtdzia*zabp
c
c     get some second derivative chain rule terms by difference
c
            dxibxia = -dxiaxia - dxiaxic
            dxibyia = -dxiayia - dyiaxic
            dxibzia = -dxiazia - dziaxic
            dyibxia = -dxiayia - dxiayic
            dyibyia = -dyiayia - dyiayic
            dyibzia = -dyiazia - dziayic
            dzibxia = -dxiazia - dxiazic
            dzibyia = -dyiazia - dyiazic
            dzibzia = -dziazia - dziazic
            dxibxic = -dxicxic - dxiaxic
            dxibyic = -dxicyic - dxiayic
            dxibzic = -dxiczic - dxiazic
            dyibxic = -dxicyic - dyiaxic
            dyibyic = -dyicyic - dyiayic
            dyibzic = -dyiczic - dyiazic
            dzibxic = -dxiczic - dziaxic
            dzibyic = -dyiczic - dziayic
            dzibzic = -dziczic - dziazic
            dxibxib = -dxibxia - dxibxic
            dxibyib = -dxibyia - dxibyic
            dxibzib = -dxibzia - dxibzic
            dyibyib = -dyibyia - dyibyic
            dyibzib = -dyibzia - dyibzic
            dzibzib = -dzibzia - dzibzic
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (ia .eq. i) then
               hessx(1,ia) = hessx(1,ia) + deddt*dxiaxia
     &                            + d2eddt2*ddtdxia*ddtdxia
               hessx(2,ia) = hessx(2,ia) + deddt*dxiayia
     &                            + d2eddt2*ddtdxia*ddtdyia
               hessx(3,ia) = hessx(3,ia) + deddt*dxiazia
     &                            + d2eddt2*ddtdxia*ddtdzia
               hessy(1,ia) = hessy(1,ia) + deddt*dxiayia
     &                            + d2eddt2*ddtdyia*ddtdxia
               hessy(2,ia) = hessy(2,ia) + deddt*dyiayia
     &                            + d2eddt2*ddtdyia*ddtdyia
               hessy(3,ia) = hessy(3,ia) + deddt*dyiazia
     &                            + d2eddt2*ddtdyia*ddtdzia
               hessz(1,ia) = hessz(1,ia) + deddt*dxiazia
     &                            + d2eddt2*ddtdzia*ddtdxia
               hessz(2,ia) = hessz(2,ia) + deddt*dyiazia
     &                            + d2eddt2*ddtdzia*ddtdyia
               hessz(3,ia) = hessz(3,ia) + deddt*dziazia
     &                            + d2eddt2*ddtdzia*ddtdzia
               hessx(1,ib) = hessx(1,ib) + deddt*dxibxia
     &                            + d2eddt2*ddtdxia*ddtdxib
               hessx(2,ib) = hessx(2,ib) + deddt*dyibxia
     &                            + d2eddt2*ddtdxia*ddtdyib
               hessx(3,ib) = hessx(3,ib) + deddt*dzibxia
     &                            + d2eddt2*ddtdxia*ddtdzib
               hessy(1,ib) = hessy(1,ib) + deddt*dxibyia
     &                            + d2eddt2*ddtdyia*ddtdxib
               hessy(2,ib) = hessy(2,ib) + deddt*dyibyia
     &                            + d2eddt2*ddtdyia*ddtdyib
               hessy(3,ib) = hessy(3,ib) + deddt*dzibyia
     &                            + d2eddt2*ddtdyia*ddtdzib
               hessz(1,ib) = hessz(1,ib) + deddt*dxibzia
     &                            + d2eddt2*ddtdzia*ddtdxib
               hessz(2,ib) = hessz(2,ib) + deddt*dyibzia
     &                            + d2eddt2*ddtdzia*ddtdyib
               hessz(3,ib) = hessz(3,ib) + deddt*dzibzia
     &                            + d2eddt2*ddtdzia*ddtdzib
               hessx(1,ic) = hessx(1,ic) + deddt*dxiaxic
     &                            + d2eddt2*ddtdxia*ddtdxic
               hessx(2,ic) = hessx(2,ic) + deddt*dxiayic
     &                            + d2eddt2*ddtdxia*ddtdyic
               hessx(3,ic) = hessx(3,ic) + deddt*dxiazic
     &                            + d2eddt2*ddtdxia*ddtdzic
               hessy(1,ic) = hessy(1,ic) + deddt*dyiaxic
     &                            + d2eddt2*ddtdyia*ddtdxic
               hessy(2,ic) = hessy(2,ic) + deddt*dyiayic
     &                            + d2eddt2*ddtdyia*ddtdyic
               hessy(3,ic) = hessy(3,ic) + deddt*dyiazic
     &                            + d2eddt2*ddtdyia*ddtdzic
               hessz(1,ic) = hessz(1,ic) + deddt*dziaxic
     &                            + d2eddt2*ddtdzia*ddtdxic
               hessz(2,ic) = hessz(2,ic) + deddt*dziayic
     &                            + d2eddt2*ddtdzia*ddtdyic
               hessz(3,ic) = hessz(3,ic) + deddt*dziazic
     &                            + d2eddt2*ddtdzia*ddtdzic
            else if (ib .eq. i) then
               hessx(1,ib) = hessx(1,ib) + deddt*dxibxib
     &                            + d2eddt2*ddtdxib*ddtdxib
               hessx(2,ib) = hessx(2,ib) + deddt*dxibyib
     &                            + d2eddt2*ddtdxib*ddtdyib
               hessx(3,ib) = hessx(3,ib) + deddt*dxibzib
     &                            + d2eddt2*ddtdxib*ddtdzib
               hessy(1,ib) = hessy(1,ib) + deddt*dxibyib
     &                            + d2eddt2*ddtdyib*ddtdxib
               hessy(2,ib) = hessy(2,ib) + deddt*dyibyib
     &                            + d2eddt2*ddtdyib*ddtdyib
               hessy(3,ib) = hessy(3,ib) + deddt*dyibzib
     &                            + d2eddt2*ddtdyib*ddtdzib
               hessz(1,ib) = hessz(1,ib) + deddt*dxibzib
     &                            + d2eddt2*ddtdzib*ddtdxib
               hessz(2,ib) = hessz(2,ib) + deddt*dyibzib
     &                            + d2eddt2*ddtdzib*ddtdyib
               hessz(3,ib) = hessz(3,ib) + deddt*dzibzib
     &                            + d2eddt2*ddtdzib*ddtdzib
               hessx(1,ia) = hessx(1,ia) + deddt*dxibxia
     &                            + d2eddt2*ddtdxib*ddtdxia
               hessx(2,ia) = hessx(2,ia) + deddt*dxibyia
     &                            + d2eddt2*ddtdxib*ddtdyia
               hessx(3,ia) = hessx(3,ia) + deddt*dxibzia
     &                            + d2eddt2*ddtdxib*ddtdzia
               hessy(1,ia) = hessy(1,ia) + deddt*dyibxia
     &                            + d2eddt2*ddtdyib*ddtdxia
               hessy(2,ia) = hessy(2,ia) + deddt*dyibyia
     &                            + d2eddt2*ddtdyib*ddtdyia
               hessy(3,ia) = hessy(3,ia) + deddt*dyibzia
     &                            + d2eddt2*ddtdyib*ddtdzia
               hessz(1,ia) = hessz(1,ia) + deddt*dzibxia
     &                            + d2eddt2*ddtdzib*ddtdxia
               hessz(2,ia) = hessz(2,ia) + deddt*dzibyia
     &                            + d2eddt2*ddtdzib*ddtdyia
               hessz(3,ia) = hessz(3,ia) + deddt*dzibzia
     &                            + d2eddt2*ddtdzib*ddtdzia
               hessx(1,ic) = hessx(1,ic) + deddt*dxibxic
     &                            + d2eddt2*ddtdxib*ddtdxic
               hessx(2,ic) = hessx(2,ic) + deddt*dxibyic
     &                            + d2eddt2*ddtdxib*ddtdyic
               hessx(3,ic) = hessx(3,ic) + deddt*dxibzic
     &                            + d2eddt2*ddtdxib*ddtdzic
               hessy(1,ic) = hessy(1,ic) + deddt*dyibxic
     &                            + d2eddt2*ddtdyib*ddtdxic
               hessy(2,ic) = hessy(2,ic) + deddt*dyibyic
     &                            + d2eddt2*ddtdyib*ddtdyic
               hessy(3,ic) = hessy(3,ic) + deddt*dyibzic
     &                            + d2eddt2*ddtdyib*ddtdzic
               hessz(1,ic) = hessz(1,ic) + deddt*dzibxic
     &                            + d2eddt2*ddtdzib*ddtdxic
               hessz(2,ic) = hessz(2,ic) + deddt*dzibyic
     &                            + d2eddt2*ddtdzib*ddtdyic
               hessz(3,ic) = hessz(3,ic) + deddt*dzibzic
     &                            + d2eddt2*ddtdzib*ddtdzic
            else if (ic .eq. i) then
               hessx(1,ic) = hessx(1,ic) + deddt*dxicxic
     &                            + d2eddt2*ddtdxic*ddtdxic
               hessx(2,ic) = hessx(2,ic) + deddt*dxicyic
     &                            + d2eddt2*ddtdxic*ddtdyic
               hessx(3,ic) = hessx(3,ic) + deddt*dxiczic
     &                            + d2eddt2*ddtdxic*ddtdzic
               hessy(1,ic) = hessy(1,ic) + deddt*dxicyic
     &                            + d2eddt2*ddtdyic*ddtdxic
               hessy(2,ic) = hessy(2,ic) + deddt*dyicyic
     &                            + d2eddt2*ddtdyic*ddtdyic
               hessy(3,ic) = hessy(3,ic) + deddt*dyiczic
     &                            + d2eddt2*ddtdyic*ddtdzic
               hessz(1,ic) = hessz(1,ic) + deddt*dxiczic
     &                            + d2eddt2*ddtdzic*ddtdxic
               hessz(2,ic) = hessz(2,ic) + deddt*dyiczic
     &                            + d2eddt2*ddtdzic*ddtdyic
               hessz(3,ic) = hessz(3,ic) + deddt*dziczic
     &                            + d2eddt2*ddtdzic*ddtdzic
               hessx(1,ib) = hessx(1,ib) + deddt*dxibxic
     &                            + d2eddt2*ddtdxic*ddtdxib
               hessx(2,ib) = hessx(2,ib) + deddt*dyibxic
     &                            + d2eddt2*ddtdxic*ddtdyib
               hessx(3,ib) = hessx(3,ib) + deddt*dzibxic
     &                            + d2eddt2*ddtdxic*ddtdzib
               hessy(1,ib) = hessy(1,ib) + deddt*dxibyic
     &                            + d2eddt2*ddtdyic*ddtdxib
               hessy(2,ib) = hessy(2,ib) + deddt*dyibyic
     &                            + d2eddt2*ddtdyic*ddtdyib
               hessy(3,ib) = hessy(3,ib) + deddt*dzibyic
     &                            + d2eddt2*ddtdyic*ddtdzib
               hessz(1,ib) = hessz(1,ib) + deddt*dxibzic
     &                            + d2eddt2*ddtdzic*ddtdxib
               hessz(2,ib) = hessz(2,ib) + deddt*dyibzic
     &                            + d2eddt2*ddtdzic*ddtdyib
               hessz(3,ib) = hessz(3,ib) + deddt*dzibzic
     &                            + d2eddt2*ddtdzic*ddtdzib
               hessx(1,ia) = hessx(1,ia) + deddt*dxiaxic
     &                            + d2eddt2*ddtdxic*ddtdxia
               hessx(2,ia) = hessx(2,ia) + deddt*dyiaxic
     &                            + d2eddt2*ddtdxic*ddtdyia
               hessx(3,ia) = hessx(3,ia) + deddt*dziaxic
     &                            + d2eddt2*ddtdxic*ddtdzia
               hessy(1,ia) = hessy(1,ia) + deddt*dxiayic
     &                            + d2eddt2*ddtdyic*ddtdxia
               hessy(2,ia) = hessy(2,ia) + deddt*dyiayic
     &                            + d2eddt2*ddtdyic*ddtdyia
               hessy(3,ia) = hessy(3,ia) + deddt*dziayic
     &                            + d2eddt2*ddtdyic*ddtdzia
               hessz(1,ia) = hessz(1,ia) + deddt*dxiazic
     &                            + d2eddt2*ddtdzic*ddtdxia
               hessz(2,ia) = hessz(2,ia) + deddt*dyiazic
     &                            + d2eddt2*ddtdzic*ddtdyia
               hessz(3,ia) = hessz(3,ia) + deddt*dziazic
     &                            + d2eddt2*ddtdzic*ddtdzia
            end if
c
c     construct a second orthogonal direction for linear angles
c
            if (linear) then
               linear = .false.
               xpo = xp
               ypo = yp
               zpo = zp
               xp = ypo*zab - zpo*yab
               yp = zpo*xab - xpo*zab
               zp = xpo*yab - ypo*xab
               rp = sqrt(xp*xp + yp*yp + zp*zp)
               goto 10
            end if
         end if
      end do
c
c     compute the Hessian elements for torsion restraints
c
      do ktors = 1, ntfix
         ia = itfix(1,ktors)
         ib = itfix(2,ktors)
         ic = itfix(3,ktors)
         id = itfix(4,ktors)
         proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic .or. i.eq.id)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         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
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
            force = tfix(1,ktors)
            tf1 = tfix(2,ktors)
            tf2 = tfix(3,ktors)
            if (angle.gt.tf1 .and. angle.lt.tf2) then
               target = angle
            else if (angle.gt.tf1 .and. tf1.gt.tf2) then
               target = angle
            else if (angle.lt.tf2 .and. tf1.gt.tf2) then
               target = angle
            else
               t1 = angle - tf1
               t2 = angle - tf2
               if (t1 .gt. 180.0d0) then
                  t1 = t1 - 360.0d0
               else if (t1 .lt. -180.0d0) then
                  t1 = t1 + 360.0d0
               end if
               if (t2 .gt. 180.0d0) then
                  t2 = t2 - 360.0d0
               else if (t2 .lt. -180.0d0) then
                  t2 = t2 + 360.0d0
               end if
               if (abs(t1) .lt. abs(t2)) then
                  target = tf1
               else
                  target = tf2
               end if
            end if
            dt = angle - target
            if (dt .gt. 180.0d0) then
               dt = dt - 360.0d0
            else if (dt .lt. -180.0d0) then
               dt = dt + 360.0d0
            end if
            dt = dt / radian
            dedphi = 2.0d0 * force * dt
            d2edphi2 = 2.0d0 * force
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               dedphi = dedphi * fgrp
               d2edphi2 = d2edphi2 * 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     abbreviations for second derivative chain rule terms
c
            xycb2 = xcb*xcb + ycb*ycb
            xzcb2 = xcb*xcb + zcb*zcb
            yzcb2 = ycb*ycb + zcb*zcb
            rcbxt = -2.0d0 * rcb * dphidxt
            rcbyt = -2.0d0 * rcb * dphidyt
            rcbzt = -2.0d0 * rcb * dphidzt
            rcbt2 = rcb * rt2
            rcbxu = 2.0d0 * rcb * dphidxu
            rcbyu = 2.0d0 * rcb * dphidyu
            rcbzu = 2.0d0 * rcb * dphidzu
            rcbu2 = rcb * ru2
            dphidxibt = yca*dphidzt - zca*dphidyt
            dphidxibu = zdc*dphidyu - ydc*dphidzu
            dphidyibt = zca*dphidxt - xca*dphidzt
            dphidyibu = xdc*dphidzu - zdc*dphidxu
            dphidzibt = xca*dphidyt - yca*dphidxt
            dphidzibu = ydc*dphidxu - xdc*dphidyu
            dphidxict = zba*dphidyt - yba*dphidzt
            dphidxicu = ydb*dphidzu - zdb*dphidyu
            dphidyict = xba*dphidzt - zba*dphidxt
            dphidyicu = zdb*dphidxu - xdb*dphidzu
            dphidzict = yba*dphidxt - xba*dphidyt
            dphidzicu = xdb*dphidyu - ydb*dphidxu
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 = dphidxibt + dphidxibu
            dphidyib = dphidyibt + dphidyibu
            dphidzib = dphidzibt + dphidzibu
            dphidxic = dphidxict + dphidxicu
            dphidyic = dphidyict + dphidyicu
            dphidzic = dphidzict + dphidzicu
            dphidxid = zcb*dphidyu - ycb*dphidzu
            dphidyid = xcb*dphidzu - zcb*dphidxu
            dphidzid = ycb*dphidxu - xcb*dphidyu
c
c     chain rule terms for second derivative components
c
            dxiaxia = rcbxt*dphidxia
            dxiayia = rcbxt*dphidyia - zcb*rcb/rt2
            dxiazia = rcbxt*dphidzia + ycb*rcb/rt2
            dxiaxic = rcbxt*dphidxict + xcb*xt/rcbt2
            dxiayic = rcbxt*dphidyict - dphidzt
     &                   - (xba*zcb*xcb+zba*yzcb2)/rcbt2
            dxiazic = rcbxt*dphidzict + dphidyt
     &                   + (xba*ycb*xcb+yba*yzcb2)/rcbt2
            dxiaxid = 0.0d0
            dxiayid = 0.0d0
            dxiazid = 0.0d0
            dyiayia = rcbyt*dphidyia
            dyiazia = rcbyt*dphidzia - xcb*rcb/rt2
            dyiaxib = rcbyt*dphidxibt - dphidzt
     &                   - (yca*zcb*ycb+zca*xzcb2)/rcbt2
            dyiaxic = rcbyt*dphidxict + dphidzt
     &                   + (yba*zcb*ycb+zba*xzcb2)/rcbt2
            dyiayic = rcbyt*dphidyict + ycb*yt/rcbt2
            dyiazic = rcbyt*dphidzict - dphidxt
     &                   - (yba*xcb*ycb+xba*xzcb2)/rcbt2
            dyiaxid = 0.0d0
            dyiayid = 0.0d0
            dyiazid = 0.0d0
            dziazia = rcbzt*dphidzia
            dziaxib = rcbzt*dphidxibt + dphidyt
     &                   + (zca*ycb*zcb+yca*xycb2)/rcbt2
            dziayib = rcbzt*dphidyibt - dphidxt
     &                   - (zca*xcb*zcb+xca*xycb2)/rcbt2
            dziaxic = rcbzt*dphidxict - dphidyt
     &                   - (zba*ycb*zcb+yba*xycb2)/rcbt2
            dziayic = rcbzt*dphidyict + dphidxt
     &                   + (zba*xcb*zcb+xba*xycb2)/rcbt2
            dziazic = rcbzt*dphidzict + zcb*zt/rcbt2
            dziaxid = 0.0d0
            dziayid = 0.0d0
            dziazid = 0.0d0
            dxibxic = -xcb*dphidxib/(rcb*rcb)
     &          - (yca*(zba*xcb+yt)-zca*(yba*xcb-zt))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidxibt/rt2
     &          - (zdc*(ydb*xcb+zu)-ydc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidxibu/ru2
            dxibyic = -ycb*dphidxib/(rcb*rcb) + dphidzt + dphidzu
     &          - (yca*(zba*ycb-xt)+zca*(xba*xcb+zcb*zba))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidxibt/rt2
     &          + (zdc*(xdb*xcb+zcb*zdb)+ydc*(zdb*ycb+xu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidxibu/ru2
            dxibxid = rcbxu*dphidxibu + xcb*xu/rcbu2
            dxibyid = rcbyu*dphidxibu - dphidzu
     &                   - (ydc*zcb*ycb+zdc*xzcb2)/rcbu2
            dxibzid = rcbzu*dphidxibu + dphidyu
     &                   + (zdc*ycb*zcb+ydc*xycb2)/rcbu2
            dyibzib = ycb*dphidzib/(rcb*rcb)
     &          - (xca*(xca*xcb+zcb*zca)+yca*(ycb*xca+zt))/rcbt2
     &          - 2.0d0*(xt*zca-xca*zt)*dphidzibt/rt2
     &          + (ydc*(xdc*ycb-zu)+xdc*(xdc*xcb+zcb*zdc))/rcbu2
     &          + 2.0d0*(xu*zdc-xdc*zu)*dphidzibu/ru2
            dyibxic = -xcb*dphidyib/(rcb*rcb) - dphidzt - dphidzu
     &          + (xca*(zba*xcb+yt)+zca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidyibt/rt2
     &          - (zdc*(zdb*zcb+ycb*ydb)+xdc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidyibu/ru2
            dyibyic = -ycb*dphidyib/(rcb*rcb)
     &          - (zca*(xba*ycb+zt)-xca*(zba*ycb-xt))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidyibt/rt2
     &          - (xdc*(zdb*ycb+xu)-zdc*(xdb*ycb-zu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidyibu/ru2
            dyibxid = rcbxu*dphidyibu + dphidzu
     &                   + (xdc*zcb*xcb+zdc*yzcb2)/rcbu2
            dyibyid = rcbyu*dphidyibu + ycb*yu/rcbu2
            dyibzid = rcbzu*dphidyibu - dphidxu
     &                   - (zdc*xcb*zcb+xdc*xycb2)/rcbu2
            dzibxic = -xcb*dphidzib/(rcb*rcb) + dphidyt + dphidyu
     &          - (xca*(yba*xcb-zt)+yca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidzibt/rt2
     &          + (ydc*(zdb*zcb+ycb*ydb)+xdc*(ydb*xcb+zu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidzibu/ru2
            dzibzic = -zcb*dphidzib/(rcb*rcb)
     &          - (xca*(yba*zcb+xt)-yca*(xba*zcb-yt))/rcbt2
     &          - 2.0d0*(xt*yba-xba*yt)*dphidzibt/rt2
     &          - (ydc*(xdb*zcb+yu)-xdc*(ydb*zcb-xu))/rcbu2
     &          + 2.0d0*(xu*ydb-xdb*yu)*dphidzibu/ru2
            dzibxid = rcbxu*dphidzibu - dphidyu
     &                   - (xdc*ycb*xcb+ydc*yzcb2)/rcbu2
            dzibyid = rcbyu*dphidzibu + dphidxu
     &                   + (ydc*xcb*ycb+xdc*xzcb2)/rcbu2
            dzibzid = rcbzu*dphidzibu + zcb*zu/rcbu2
            dxicxid = rcbxu*dphidxicu - xcb*(zdb*ycb-ydb*zcb)/rcbu2
            dxicyid = rcbyu*dphidxicu + dphidzu
     &                   + (ydb*zcb*ycb+zdb*xzcb2)/rcbu2
            dxiczid = rcbzu*dphidxicu - dphidyu
     &                   - (zdb*ycb*zcb+ydb*xycb2)/rcbu2
            dyicxid = rcbxu*dphidyicu - dphidzu
     &                   - (xdb*zcb*xcb+zdb*yzcb2)/rcbu2
            dyicyid = rcbyu*dphidyicu - ycb*(xdb*zcb-zdb*xcb)/rcbu2
            dyiczid = rcbzu*dphidyicu + dphidxu
     &                   + (zdb*xcb*zcb+xdb*xycb2)/rcbu2
            dzicxid = rcbxu*dphidzicu + dphidyu
     &                   + (xdb*ycb*xcb+ydb*yzcb2)/rcbu2
            dzicyid = rcbyu*dphidzicu - dphidxu
     &                   - (ydb*xcb*ycb+xdb*xzcb2)/rcbu2
            dziczid = rcbzu*dphidzicu - zcb*(ydb*xcb-xdb*ycb)/rcbu2
            dxidxid = rcbxu*dphidxid
            dxidyid = rcbxu*dphidyid + zcb*rcb/ru2
            dxidzid = rcbxu*dphidzid - ycb*rcb/ru2
            dyidyid = rcbyu*dphidyid
            dyidzid = rcbyu*dphidzid + xcb*rcb/ru2
            dzidzid = rcbzu*dphidzid
c
c     get some second derivative chain rule terms by difference
c
            dxiaxib = -dxiaxia - dxiaxic - dxiaxid
            dxiayib = -dxiayia - dxiayic - dxiayid
            dxiazib = -dxiazia - dxiazic - dxiazid
            dyiayib = -dyiayia - dyiayic - dyiayid
            dyiazib = -dyiazia - dyiazic - dyiazid
            dziazib = -dziazia - dziazic - dziazid
            dxibxib = -dxiaxib - dxibxic - dxibxid
            dxibyib = -dyiaxib - dxibyic - dxibyid
            dxibzib = -dxiazib - dzibxic - dzibxid
            dxibzic = -dziaxib - dxibzib - dxibzid
            dyibyib = -dyiayib - dyibyic - dyibyid
            dyibzic = -dziayib - dyibzib - dyibzid
            dzibzib = -dziazib - dzibzic - dzibzid
            dzibyic = -dyiazib - dyibzib - dzibyid
            dxicxic = -dxiaxic - dxibxic - dxicxid
            dxicyic = -dyiaxic - dyibxic - dxicyid
            dxiczic = -dziaxic - dzibxic - dxiczid
            dyicyic = -dyiayic - dyibyic - dyicyid
            dyiczic = -dziayic - dzibyic - dyiczid
            dziczic = -dziazic - dzibzic - dziczid
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (i .eq. ia) then
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia
     &                           + d2edphi2*dphidxia*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia
     &                           + d2edphi2*dphidxia*dphidyia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia
     &                           + d2edphi2*dphidxia*dphidzia
               hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia
     &                           + d2edphi2*dphidxia*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia
     &                           + d2edphi2*dphidyia*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia
     &                           + d2edphi2*dphidyia*dphidzia
               hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia
     &                           + d2edphi2*dphidxia*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia
     &                           + d2edphi2*dphidyia*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazia
     &                           + d2edphi2*dphidzia*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib
     &                           + d2edphi2*dphidxia*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib
     &                           + d2edphi2*dphidyia*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib
     &                           + d2edphi2*dphidzia*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib
     &                           + d2edphi2*dphidxia*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib
     &                           + d2edphi2*dphidyia*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dziayib
     &                           + d2edphi2*dphidzia*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib
     &                           + d2edphi2*dphidxia*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib
     &                           + d2edphi2*dphidyia*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dziazib
     &                           + d2edphi2*dphidzia*dphidzib
               hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic
     &                           + d2edphi2*dphidxia*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic
     &                           + d2edphi2*dphidyia*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic
     &                           + d2edphi2*dphidzia*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic
     &                           + d2edphi2*dphidxia*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic
     &                           + d2edphi2*dphidyia*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dziayic
     &                           + d2edphi2*dphidzia*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic
     &                           + d2edphi2*dphidxia*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic
     &                           + d2edphi2*dphidyia*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziazic
     &                           + d2edphi2*dphidzia*dphidzic
               hessx(1,id) = hessx(1,id) + dedphi*dxiaxid
     &                           + d2edphi2*dphidxia*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyiaxid
     &                           + d2edphi2*dphidyia*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dziaxid
     &                           + d2edphi2*dphidzia*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxiayid
     &                           + d2edphi2*dphidxia*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyiayid
     &                           + d2edphi2*dphidyia*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dziayid
     &                           + d2edphi2*dphidzia*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiazid
     &                           + d2edphi2*dphidxia*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiazid
     &                           + d2edphi2*dphidyia*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dziazid
     &                           + d2edphi2*dphidzia*dphidzid
            else if (i .eq. ib) then
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib
     &                           + d2edphi2*dphidxib*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib
     &                           + d2edphi2*dphidxib*dphidyib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib
     &                           + d2edphi2*dphidxib*dphidzib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib
     &                           + d2edphi2*dphidxib*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib
     &                           + d2edphi2*dphidyib*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib
     &                           + d2edphi2*dphidyib*dphidzib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib
     &                           + d2edphi2*dphidxib*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib
     &                           + d2edphi2*dphidyib*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib
     &                           + d2edphi2*dphidzib*dphidzib
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib
     &                           + d2edphi2*dphidxib*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib
     &                           + d2edphi2*dphidyib*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib
     &                           + d2edphi2*dphidzib*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib
     &                           + d2edphi2*dphidxib*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib
     &                           + d2edphi2*dphidyib*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib
     &                           + d2edphi2*dphidzib*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib
     &                           + d2edphi2*dphidxib*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayib
     &                           + d2edphi2*dphidyib*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazib
     &                           + d2edphi2*dphidzib*dphidzia
               hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic
     &                           + d2edphi2*dphidxib*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic
     &                           + d2edphi2*dphidyib*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic
     &                           + d2edphi2*dphidzib*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic
     &                           + d2edphi2*dphidxib*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic
     &                           + d2edphi2*dphidyib*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic
     &                           + d2edphi2*dphidzib*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic
     &                           + d2edphi2*dphidxib*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic
     &                           + d2edphi2*dphidyib*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic
     &                           + d2edphi2*dphidzib*dphidzic
               hessx(1,id) = hessx(1,id) + dedphi*dxibxid
     &                           + d2edphi2*dphidxib*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyibxid
     &                           + d2edphi2*dphidyib*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dzibxid
     &                           + d2edphi2*dphidzib*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxibyid
     &                           + d2edphi2*dphidxib*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyibyid
     &                           + d2edphi2*dphidyib*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dzibyid
     &                           + d2edphi2*dphidzib*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxibzid
     &                           + d2edphi2*dphidxib*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyibzid
     &                           + d2edphi2*dphidyib*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzibzid
     &                           + d2edphi2*dphidzib*dphidzid
            else if (i .eq. ic) then
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic
     &                           + d2edphi2*dphidxic*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic
     &                           + d2edphi2*dphidxic*dphidyic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic
     &                           + d2edphi2*dphidxic*dphidzic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic
     &                           + d2edphi2*dphidxic*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic
     &                           + d2edphi2*dphidyic*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic
     &                           + d2edphi2*dphidyic*dphidzic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic
     &                           + d2edphi2*dphidxic*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic
     &                           + d2edphi2*dphidyic*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczic
     &                           + d2edphi2*dphidzic*dphidzic
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic
     &                           + d2edphi2*dphidxic*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic
     &                           + d2edphi2*dphidyic*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic
     &                           + d2edphi2*dphidzic*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic
     &                           + d2edphi2*dphidxic*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic
     &                           + d2edphi2*dphidyic*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic
     &                           + d2edphi2*dphidzic*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic
     &                           + d2edphi2*dphidxic*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayic
     &                           + d2edphi2*dphidyic*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazic
     &                           + d2edphi2*dphidzic*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic
     &                           + d2edphi2*dphidxic*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic
     &                           + d2edphi2*dphidyic*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic
     &                           + d2edphi2*dphidzic*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic
     &                           + d2edphi2*dphidxic*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic
     &                           + d2edphi2*dphidyic*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic
     &                           + d2edphi2*dphidzic*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic
     &                           + d2edphi2*dphidxic*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic
     &                           + d2edphi2*dphidyic*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic
     &                           + d2edphi2*dphidzic*dphidzib
               hessx(1,id) = hessx(1,id) + dedphi*dxicxid
     &                           + d2edphi2*dphidxic*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyicxid
     &                           + d2edphi2*dphidyic*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dzicxid
     &                           + d2edphi2*dphidzic*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxicyid
     &                           + d2edphi2*dphidxic*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyicyid
     &                           + d2edphi2*dphidyic*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dzicyid
     &                           + d2edphi2*dphidzic*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiczid
     &                           + d2edphi2*dphidxic*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiczid
     &                           + d2edphi2*dphidyic*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dziczid
     &                           + d2edphi2*dphidzic*dphidzid
            else if (i .eq. id) then
               hessx(1,id) = hessx(1,id) + dedphi*dxidxid
     &                           + d2edphi2*dphidxid*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dxidyid
     &                           + d2edphi2*dphidxid*dphidyid
               hessz(1,id) = hessz(1,id) + dedphi*dxidzid
     &                           + d2edphi2*dphidxid*dphidzid
               hessx(2,id) = hessx(2,id) + dedphi*dxidyid
     &                           + d2edphi2*dphidxid*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyidyid
     &                           + d2edphi2*dphidyid*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dyidzid
     &                           + d2edphi2*dphidyid*dphidzid
               hessx(3,id) = hessx(3,id) + dedphi*dxidzid
     &                           + d2edphi2*dphidxid*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyidzid
     &                           + d2edphi2*dphidyid*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzidzid
     &                           + d2edphi2*dphidzid*dphidzid
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid
     &                           + d2edphi2*dphidxid*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid
     &                           + d2edphi2*dphidyid*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid
     &                           + d2edphi2*dphidzid*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid
     &                           + d2edphi2*dphidxid*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid
     &                           + d2edphi2*dphidyid*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid
     &                           + d2edphi2*dphidzid*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid
     &                           + d2edphi2*dphidxid*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayid
     &                           + d2edphi2*dphidyid*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazid
     &                           + d2edphi2*dphidzid*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid
     &                           + d2edphi2*dphidxid*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid
     &                           + d2edphi2*dphidyid*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid
     &                           + d2edphi2*dphidzid*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid
     &                           + d2edphi2*dphidxid*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid
     &                           + d2edphi2*dphidyid*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid
     &                           + d2edphi2*dphidzid*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid
     &                           + d2edphi2*dphidxid*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid
     &                           + d2edphi2*dphidyid*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid
     &                           + d2edphi2*dphidzid*dphidzib
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid
     &                           + d2edphi2*dphidxid*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid
     &                           + d2edphi2*dphidyid*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid
     &                           + d2edphi2*dphidzid*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid
     &                           + d2edphi2*dphidxid*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid
     &                           + d2edphi2*dphidyid*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid
     &                           + d2edphi2*dphidzid*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid
     &                           + d2edphi2*dphidxid*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid
     &                           + d2edphi2*dphidyid*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczid
     &                           + d2edphi2*dphidzid*dphidzic
            end if
         end if
      end do
c
c     compute the Hessian elements for group distance restraints
c
      do kdist = 1, ngfix
         ia = igfix(1,kdist)
         ib = igfix(2,kdist)
         proceed = (grplist(i).eq.ia .or. grplist(i).eq.ib)
         if (proceed) then
            if (grplist(i) .eq. ib) then
               ib = ia
               ia = grplist(i)
            end if
            xa = 0.0d0
            ya = 0.0d0
            za = 0.0d0
            j = kgrp(igrp(1,ia))
            xr = x(j)
            yr = y(j)
            zr = z(j)
            mola = molcule(j)
            do j = igrp(1,ia), igrp(2,ia)
               k = kgrp(j)
               weigh = mass(k)
               xk = x(k) - xr
               yk = y(k) - yr
               zk = z(k) - zr
               molk = molcule(k)
               intermol = (molk .ne. mola)
               if (use_bounds .and. intermol)  call image (xk,yk,zk)
               xa = xa + xk*weigh
               ya = ya + yk*weigh
               za = za + zk*weigh
            end do
            weigha = max(1.0d0,grpmass(ia))
            xa = xr + xa/weigha
            ya = yr + ya/weigha
            za = zr + za/weigha
            xb = 0.0d0
            yb = 0.0d0
            zb = 0.0d0
            j = kgrp(igrp(1,ib))
            xr = x(j)
            yr = y(j)
            zr = z(j)
            molb = molcule(j)
            do j = igrp(1,ib), igrp(2,ib)
               k = kgrp(j)
               weigh = mass(k)
               xk = x(k) - xr
               yk = y(k) - yr
               zk = z(k) - zr
               molk = molcule(k)
               intermol = (molk .ne. molb)
               if (use_bounds .and. intermol)  call image (xk,yk,zk)
               xb = xb + xk*weigh
               yb = yb + yk*weigh
               zb = zb + zk*weigh
            end do
            weighb = max(1.0d0,grpmass(ib))
            xb = xr + xb/weighb
            yb = yr + yb/weighb
            zb = zr + zb/weighb
            xr = xa - xb
            yr = ya - yb
            zr = za - zb
            intermol = (mola .ne. molb)
            if (use_bounds .and. intermol)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            r = sqrt(r2)
            force = gfix(1,kdist)
            gf1 = gfix(2,kdist)
            gf2 = gfix(3,kdist)
            target = r
            if (r .lt. gf1)  target = gf1
            if (r .gt. gf2)  target = gf2
            dt = r - target
            deddt = 2.0d0 * force
c
c     set the chain rule terms for the Hessian elements
c
            r = max(r,eps)
            r2 = r * r
            de = deddt * dt/r
            term = (deddt-de) / r2
            termx = term * xr
            termy = term * yr
            termz = term * zr
            d2e(1,1) = termx*xr + de
            d2e(1,2) = termx*yr
            d2e(1,3) = termx*zr
            d2e(2,1) = d2e(1,2)
            d2e(2,2) = termy*yr + de
            d2e(2,3) = termy*zr
            d2e(3,1) = d2e(1,3)
            d2e(3,2) = d2e(2,3)
            d2e(3,3) = termz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
            do k = igrp(1,ia), igrp(2,ia)
               m = kgrp(k)
               ratio = mass(i)*mass(m) / (weigha*weigha)
               do j = 1, 3
                  hessx(j,m) = hessx(j,m) + d2e(1,j)*ratio
                  hessy(j,m) = hessy(j,m) + d2e(2,j)*ratio
                  hessz(j,m) = hessz(j,m) + d2e(3,j)*ratio
               end do
            end do
            do k = igrp(1,ib), igrp(2,ib)
               m = kgrp(k)
               ratio = mass(i)*mass(m) / (weigha*weighb)
               do j = 1, 3
                  hessx(j,m) = hessx(j,m) - d2e(1,j)*ratio
                  hessy(j,m) = hessy(j,m) - d2e(2,j)*ratio
                  hessz(j,m) = hessz(j,m) - d2e(3,j)*ratio
               end do
            end do
         end if
      end do
c
c     compute the Hessian elements for chirality restraints
c
      do kchir = 1, nchir
         ia = ichir(1,kchir)
         ib = ichir(2,kchir)
         ic = ichir(3,kchir)
         id = ichir(4,kchir)
         proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic .or. i.eq.id)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed) then
            xad = x(ia) - x(id)
            yad = y(ia) - y(id)
            zad = z(ia) - z(id)
            xbd = x(ib) - x(id)
            ybd = y(ib) - y(id)
            zbd = z(ib) - z(id)
            xcd = x(ic) - x(id)
            ycd = y(ic) - y(id)
            zcd = z(ic) - z(id)
            c1 = ybd*zcd - zbd*ycd
            c2 = ycd*zad - zcd*yad
            c3 = yad*zbd - zad*ybd
            vol = xad*c1 + xbd*c2 + xcd*c3
            force = chir(1,kchir)
            cf1 = chir(2,kchir)
            cf2 = chir(3,kchir)
            target = vol
            if (vol .lt. min(cf1,cf2))  target = min(cf1,cf2)
            if (vol .gt. max(cf1,cf2))  target = max(cf1,cf2)
            dt = vol - target
            dt2 = dt * dt
            deddt = 2.0d0 * force * dt
            d2eddt2 = 2.0d0 * force
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               deddt = deddt * fgrp
               d2eddt2 = d2eddt2 * fgrp
            end if
c
c     chain rule terms for first derivative components
c
            term = sqrt(d2eddt2)
            ddtdxia = term * (ybd*zcd - zbd*ycd)
            ddtdyia = term * (zbd*xcd - xbd*zcd)
            ddtdzia = term * (xbd*ycd - ybd*xcd)
            ddtdxib = term * (zad*ycd - yad*zcd)
            ddtdyib = term * (xad*zcd - zad*xcd)
            ddtdzib = term * (yad*xcd - xad*ycd)
            ddtdxic = term * (yad*zbd - zad*ybd)
            ddtdyic = term * (zad*xbd - xad*zbd)
            ddtdzic = term * (xad*ybd - yad*xbd)
            ddtdxid = -ddtdxia - ddtdxib - ddtdxic
            ddtdyid = -ddtdyia - ddtdyib - ddtdyic
            ddtdzid = -ddtdzia - ddtdzib - ddtdzic
c
c     chain rule terms for second derivative components (*deddt)
c
            dyiaxib = -deddt * zcd
            dziaxib = deddt * ycd
            dxiayib = deddt * zcd
            dziayib = -deddt * xcd
            dxiazib = -deddt * ycd
            dyiazib = deddt * xcd
            dyiaxic = deddt * zbd
            dziaxic = -deddt * ybd
            dxiayic = -deddt * zbd
            dziayic = deddt * xbd
            dxiazic = deddt * ybd
            dyiazic = -deddt * xbd
            dyibxic = -deddt * zad
            dzibxic = deddt * yad
            dxibyic = deddt * zad
            dzibyic = -deddt * xad
            dxibzic = -deddt * yad
            dyibzic = deddt * xad
            dyiaxid = -dyiaxib - dyiaxic
            dziaxid = -dziaxib - dziaxic
            dxiayid = -dxiayib - dxiayic
            dziayid = -dziayib - dziayic
            dxiazid = -dxiazib - dxiazic
            dyiazid = -dyiazib - dyiazic
            dyibxid = -dxiayib - dyibxic
            dzibxid = -dxiazib - dzibxic
            dxibyid = -dyiaxib - dxibyic
            dzibyid = -dyiazib - dzibyic
            dxibzid = -dziaxib - dxibzic
            dyibzid = -dziayib - dyibzic
            dyicxid = -dxiayic - dxibyic
            dzicxid = -dxiazic - dxibzic
            dxicyid = -dyiaxic - dyibxic
            dzicyid = -dyiazic - dyibzic
            dxiczid = -dziaxic - dzibxic
            dyiczid = -dziayic - dzibyic
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (i .eq. ia) then
               hessx(1,ia) = hessx(1,ia) + ddtdxia*ddtdxia
               hessy(1,ia) = hessy(1,ia) + ddtdxia*ddtdyia
               hessz(1,ia) = hessz(1,ia) + ddtdxia*ddtdzia
               hessx(2,ia) = hessx(2,ia) + ddtdxia*ddtdyia
               hessy(2,ia) = hessy(2,ia) + ddtdyia*ddtdyia
               hessz(2,ia) = hessz(2,ia) + ddtdyia*ddtdzia
               hessx(3,ia) = hessx(3,ia) + ddtdxia*ddtdzia
               hessy(3,ia) = hessy(3,ia) + ddtdyia*ddtdzia
               hessz(3,ia) = hessz(3,ia) + ddtdzia*ddtdzia
               hessx(1,ib) = hessx(1,ib) + ddtdxia*ddtdxib
               hessy(1,ib) = hessy(1,ib) + ddtdyia*ddtdxib + dyiaxib
               hessz(1,ib) = hessz(1,ib) + ddtdzia*ddtdxib + dziaxib
               hessx(2,ib) = hessx(2,ib) + ddtdxia*ddtdyib + dxiayib
               hessy(2,ib) = hessy(2,ib) + ddtdyia*ddtdyib
               hessz(2,ib) = hessz(2,ib) + ddtdzia*ddtdyib + dziayib
               hessx(3,ib) = hessx(3,ib) + ddtdxia*ddtdzib + dxiazib
               hessy(3,ib) = hessy(3,ib) + ddtdyia*ddtdzib + dyiazib
               hessz(3,ib) = hessz(3,ib) + ddtdzia*ddtdzib
               hessx(1,ic) = hessx(1,ic) + ddtdxia*ddtdxic
               hessy(1,ic) = hessy(1,ic) + ddtdyia*ddtdxic + dyiaxic
               hessz(1,ic) = hessz(1,ic) + ddtdzia*ddtdxic + dziaxic
               hessx(2,ic) = hessx(2,ic) + ddtdxia*ddtdyic + dxiayic
               hessy(2,ic) = hessy(2,ic) + ddtdyia*ddtdyic
               hessz(2,ic) = hessz(2,ic) + ddtdzia*ddtdyic + dziayic
               hessx(3,ic) = hessx(3,ic) + ddtdxia*ddtdzic + dxiazic
               hessy(3,ic) = hessy(3,ic) + ddtdyia*ddtdzic + dyiazic
               hessz(3,ic) = hessz(3,ic) + ddtdzia*ddtdzic
               hessx(1,id) = hessx(1,id) + ddtdxia*ddtdxid
               hessy(1,id) = hessy(1,id) + ddtdyia*ddtdxid + dyiaxid
               hessz(1,id) = hessz(1,id) + ddtdzia*ddtdxid + dziaxid
               hessx(2,id) = hessx(2,id) + ddtdxia*ddtdyid + dxiayid
               hessy(2,id) = hessy(2,id) + ddtdyia*ddtdyid
               hessz(2,id) = hessz(2,id) + ddtdzia*ddtdyid + dziayid
               hessx(3,id) = hessx(3,id) + ddtdxia*ddtdzid + dxiazid
               hessy(3,id) = hessy(3,id) + ddtdyia*ddtdzid + dyiazid
               hessz(3,id) = hessz(3,id) + ddtdzia*ddtdzid
            else if (i .eq. ib) then
               hessx(1,ib) = hessx(1,ib) + ddtdxib*ddtdxib
               hessy(1,ib) = hessy(1,ib) + ddtdxib*ddtdyib
               hessz(1,ib) = hessz(1,ib) + ddtdxib*ddtdzib
               hessx(2,ib) = hessx(2,ib) + ddtdxib*ddtdyib
               hessy(2,ib) = hessy(2,ib) + ddtdyib*ddtdyib
               hessz(2,ib) = hessz(2,ib) + ddtdyib*ddtdzib
               hessx(3,ib) = hessx(3,ib) + ddtdxib*ddtdzib
               hessy(3,ib) = hessy(3,ib) + ddtdyib*ddtdzib
               hessz(3,ib) = hessz(3,ib) + ddtdzib*ddtdzib
               hessx(1,ia) = hessx(1,ia) + ddtdxib*ddtdxia
               hessy(1,ia) = hessy(1,ia) + ddtdyib*ddtdxia + dxiayib
               hessz(1,ia) = hessz(1,ia) + ddtdzib*ddtdxia + dxiazib
               hessx(2,ia) = hessx(2,ia) + ddtdxib*ddtdyia + dyiaxib
               hessy(2,ia) = hessy(2,ia) + ddtdyib*ddtdyia
               hessz(2,ia) = hessz(2,ia) + ddtdzib*ddtdyia + dyiazib
               hessx(3,ia) = hessx(3,ia) + ddtdxib*ddtdzia + dziaxib
               hessy(3,ia) = hessy(3,ia) + ddtdyib*ddtdzia + dziayib
               hessz(3,ia) = hessz(3,ia) + ddtdzib*ddtdzia
               hessx(1,ic) = hessx(1,ic) + ddtdxib*ddtdxic
               hessy(1,ic) = hessy(1,ic) + ddtdyib*ddtdxic + dyibxic
               hessz(1,ic) = hessz(1,ic) + ddtdzib*ddtdxic + dzibxic
               hessx(2,ic) = hessx(2,ic) + ddtdxib*ddtdyic + dxibyic
               hessy(2,ic) = hessy(2,ic) + ddtdyib*ddtdyic
               hessz(2,ic) = hessz(2,ic) + ddtdzib*ddtdyic + dzibyic
               hessx(3,ic) = hessx(3,ic) + ddtdxib*ddtdzic + dxibzic
               hessy(3,ic) = hessy(3,ic) + ddtdyib*ddtdzic + dyibzic
               hessz(3,ic) = hessz(3,ic) + ddtdzib*ddtdzic
               hessx(1,id) = hessx(1,id) + ddtdxib*ddtdxid
               hessy(1,id) = hessy(1,id) + ddtdyib*ddtdxid + dyibxid
               hessz(1,id) = hessz(1,id) + ddtdzib*ddtdxid + dzibxid
               hessx(2,id) = hessx(2,id) + ddtdxib*ddtdyid + dxibyid
               hessy(2,id) = hessy(2,id) + ddtdyib*ddtdyid
               hessz(2,id) = hessz(2,id) + ddtdzib*ddtdyid + dzibyid
               hessx(3,id) = hessx(3,id) + ddtdxib*ddtdzid + dxibzid
               hessy(3,id) = hessy(3,id) + ddtdyib*ddtdzid + dyibzid
               hessz(3,id) = hessz(3,id) + ddtdzib*ddtdzid
            else if (i .eq. ic) then
               hessx(1,ic) = hessx(1,ic) + ddtdxic*ddtdxic
               hessy(1,ic) = hessy(1,ic) + ddtdxic*ddtdyic
               hessz(1,ic) = hessz(1,ic) + ddtdxic*ddtdzic
               hessx(2,ic) = hessx(2,ic) + ddtdxic*ddtdyic
               hessy(2,ic) = hessy(2,ic) + ddtdyic*ddtdyic
               hessz(2,ic) = hessz(2,ic) + ddtdyic*ddtdzic
               hessx(3,ic) = hessx(3,ic) + ddtdxic*ddtdzic
               hessy(3,ic) = hessy(3,ic) + ddtdyic*ddtdzic
               hessz(3,ic) = hessz(3,ic) + ddtdzic*ddtdzic
               hessx(1,ia) = hessx(1,ia) + ddtdxic*ddtdxia
               hessy(1,ia) = hessy(1,ia) + ddtdyic*ddtdxia + dxiayic
               hessz(1,ia) = hessz(1,ia) + ddtdzic*ddtdxia + dxiazic
               hessx(2,ia) = hessx(2,ia) + ddtdxic*ddtdyia + dyiaxic
               hessy(2,ia) = hessy(2,ia) + ddtdyic*ddtdyia
               hessz(2,ia) = hessz(2,ia) + ddtdzic*ddtdyia + dyiazic
               hessx(3,ia) = hessx(3,ia) + ddtdxic*ddtdzia + dziaxic
               hessy(3,ia) = hessy(3,ia) + ddtdyic*ddtdzia + dziayic
               hessz(3,ia) = hessz(3,ia) + ddtdzic*ddtdzia
               hessx(1,ib) = hessx(1,ib) + ddtdxic*ddtdxib
               hessy(1,ib) = hessy(1,ib) + ddtdyic*ddtdxib + dxibyic
               hessz(1,ib) = hessz(1,ib) + ddtdzic*ddtdxib + dxibzic
               hessx(2,ib) = hessx(2,ib) + ddtdxic*ddtdyib + dyibxic
               hessy(2,ib) = hessy(2,ib) + ddtdyic*ddtdyib
               hessz(2,ib) = hessz(2,ib) + ddtdzic*ddtdyib + dyibzic
               hessx(3,ib) = hessx(3,ib) + ddtdxic*ddtdzib + dzibxic
               hessy(3,ib) = hessy(3,ib) + ddtdyic*ddtdzib + dzibyic
               hessz(3,ib) = hessz(3,ib) + ddtdzic*ddtdzib
               hessx(1,id) = hessx(1,id) + ddtdxic*ddtdxid
               hessy(1,id) = hessy(1,id) + ddtdyic*ddtdxid + dyicxid
               hessz(1,id) = hessz(1,id) + ddtdzic*ddtdxid + dzicxid
               hessx(2,id) = hessx(2,id) + ddtdxic*ddtdyid + dxicyid
               hessy(2,id) = hessy(2,id) + ddtdyic*ddtdyid
               hessz(2,id) = hessz(2,id) + ddtdzic*ddtdyid + dzicyid
               hessx(3,id) = hessx(3,id) + ddtdxic*ddtdzid + dxiczid
               hessy(3,id) = hessy(3,id) + ddtdyic*ddtdzid + dyiczid
               hessz(3,id) = hessz(3,id) + ddtdzic*ddtdzid
            else if (i .eq. id) then
               hessx(1,id) = hessx(1,id) + ddtdxid*ddtdxid
               hessy(1,id) = hessy(1,id) + ddtdxid*ddtdyid
               hessz(1,id) = hessz(1,id) + ddtdxid*ddtdzid
               hessx(2,id) = hessx(2,id) + ddtdxid*ddtdyid
               hessy(2,id) = hessy(2,id) + ddtdyid*ddtdyid
               hessz(2,id) = hessz(2,id) + ddtdyid*ddtdzid
               hessx(3,id) = hessx(3,id) + ddtdxid*ddtdzid
               hessy(3,id) = hessy(3,id) + ddtdyid*ddtdzid
               hessz(3,id) = hessz(3,id) + ddtdzid*ddtdzid
               hessx(1,ia) = hessx(1,ia) + ddtdxid*ddtdxia
               hessy(1,ia) = hessy(1,ia) + ddtdyid*ddtdxia + dxiayid
               hessz(1,ia) = hessz(1,ia) + ddtdzid*ddtdxia + dxiazid
               hessx(2,ia) = hessx(2,ia) + ddtdxid*ddtdyia + dyiaxid
               hessy(2,ia) = hessy(2,ia) + ddtdyid*ddtdyia
               hessz(2,ia) = hessz(2,ia) + ddtdzid*ddtdyia + dyiazid
               hessx(3,ia) = hessx(3,ia) + ddtdxid*ddtdzia + dziaxid
               hessy(3,ia) = hessy(3,ia) + ddtdyid*ddtdzia + dziayid
               hessz(3,ia) = hessz(3,ia) + ddtdzid*ddtdzia
               hessx(1,ib) = hessx(1,ib) + ddtdxid*ddtdxib
               hessy(1,ib) = hessy(1,ib) + ddtdyid*ddtdxib + dxibyid
               hessz(1,ib) = hessz(1,ib) + ddtdzid*ddtdxib + dxibzid
               hessx(2,ib) = hessx(2,ib) + ddtdxid*ddtdyib + dyibxid
               hessy(2,ib) = hessy(2,ib) + ddtdyid*ddtdyib
               hessz(2,ib) = hessz(2,ib) + ddtdzid*ddtdyib + dyibzid
               hessx(3,ib) = hessx(3,ib) + ddtdxid*ddtdzib + dzibxid
               hessy(3,ib) = hessy(3,ib) + ddtdyid*ddtdzib + dzibyid
               hessz(3,ib) = hessz(3,ib) + ddtdzid*ddtdzib
               hessx(1,ic) = hessx(1,ic) + ddtdxid*ddtdxic
               hessy(1,ic) = hessy(1,ic) + ddtdyid*ddtdxic + dxicyid
               hessz(1,ic) = hessz(1,ic) + ddtdzid*ddtdxic + dxiczid
               hessx(2,ic) = hessx(2,ic) + ddtdxid*ddtdyic + dyicxid
               hessy(2,ic) = hessy(2,ic) + ddtdyid*ddtdyic
               hessz(2,ic) = hessz(2,ic) + ddtdzid*ddtdyic + dyiczid
               hessx(3,ic) = hessx(3,ic) + ddtdxid*ddtdzic + dzicxid
               hessy(3,ic) = hessy(3,ic) + ddtdyid*ddtdzic + dzicyid
               hessz(3,ic) = hessz(3,ic) + ddtdzid*ddtdzic
            end if
         end if
      end do
c
c     compute Hessian elements for a Gaussian basin restraint
c
      if (use_basin) then
         rflat2 = rflat * rflat
         xi = x(i)
         yi = y(i)
         zi = z(i)
         do k = 1, n
            proceed = (k .ne. i)
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               r2 = max(0.0d0,r2-rflat2)
               term = -width * r2
               expterm = 0.0d0
               if (term .gt. -50.0d0)
     &            expterm = depth * width * exp(term)
               dedr = -2.0d0 * expterm
               d2edr2 = (-4.0d0*term-2.0d0) * expterm
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  dedr = dedr * fgrp
                  d2edr2 = d2edr2 * fgrp
               end if
c
c     set the chain rule terms for the Hessian elements
c
               if (r2 .eq. 0.0d0) then
                  term = 0.0d0
               else
                  term = (d2edr2-dedr) / r2
               end if
               termx = term * xr
               termy = term * yr
               termz = term * zr
               d2e(1,1) = termx*xr + dedr
               d2e(1,2) = termx*yr
               d2e(1,3) = termx*zr
               d2e(2,1) = d2e(1,2)
               d2e(2,2) = termy*yr + dedr
               d2e(2,3) = termy*zr
               d2e(3,1) = d2e(1,3)
               d2e(3,2) = d2e(2,3)
               d2e(3,3) = termz*zr + dedr
c
c     increment diagonal and off-diagonal Hessian elements
c
               do j = 1, 3
                  hessx(j,i) = hessx(j,i) + d2e(1,j)
                  hessy(j,i) = hessy(j,i) + d2e(2,j)
                  hessz(j,i) = hessz(j,i) + d2e(3,j)
                  hessx(j,k) = hessx(j,k) - d2e(1,j)
                  hessy(j,k) = hessy(j,k) - d2e(2,j)
                  hessz(j,k) = hessz(j,k) - d2e(3,j)
               end do
            end if
         end do
      end if
c
c     compute Hessian elements for a spherical droplet restraint
c
      if (use_wall) then
         buffer = 2.5d0
         a = 2048.0d0
         b = 64.0d0
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,i,0,0,0,0,0)
         if (proceed) then
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ri2 = xi**2 + yi**2 + zi**2
            ri = sqrt(ri2)
            r = rwall + buffer - ri
            r2 = r * r
            r6 = r2 * r2 * r2
            r12 = r6 * r6
            if (ri .eq. 0.0d0) then
               ri = 1.0d0
               ri2 = 1.0d0
            end if
            dedr = (12.0d0*a/r12 - 6.0d0*b/r6) / (r*ri)
            d2edr2 = (156.0d0*a/r12 - 42.0d0*b/r6) / (r2*ri2)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               dedr = dedr * fgrp
               d2edr2 = d2edr2 * fgrp
            end if
c
c     set the chain rule terms for the Hessian elements
c
            d2edr2 = d2edr2 - dedr/ri2
            termx = d2edr2 * xi
            termy = d2edr2 * yi
            termz = d2edr2 * zi
            d2e(1,1) = termx*xi + dedr
            d2e(1,2) = termx*yi
            d2e(1,3) = termx*zi
            d2e(2,1) = d2e(1,2)
            d2e(2,2) = termy*yi + dedr
            d2e(2,3) = termy*zi
            d2e(3,1) = d2e(1,3)
            d2e(3,2) = d2e(2,3)
            d2e(3,3) = termz*zi + dedr
c
c     increment diagonal and off-diagonal Hessian elements
c
            do j = 1, 3
               hessx(j,i) = hessx(j,i) + d2e(1,j)
               hessy(j,i) = hessy(j,i) + d2e(2,j)
               hessz(j,i) = hessz(j,i) + d2e(3,j)
            end do
         end if
      end if
c
c     reinstate the replica mechanism if it is being used
c
      if (use_replica) then
         xcell = xorig
         ycell = yorig
         zcell = zorig
         xcell2 = xorig2
         ycell2 = yorig2
         zcell2 = zorig2
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine egeom3  --  restraint energy terms & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "egeom3" calculates the energy due to restraints on positions,
c     distances, angles and torsions as well as Gaussian basin and
c     droplet restraints; also partitions energy among the atoms
c
c
      subroutine egeom3
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use energi
      use group
      use inform
      use inter
      use iounit
      use math
      use molcul
      use restrn
      use usage
      implicit none
      integer i,j,k
      integer ia,ib,ic,id
      real*8 e,eps,fgrp
      real*8 dt,dt2
      real*8 xr,yr,zr
      real*8 r,r2,r6,r12
      real*8 angle,target
      real*8 dot,force
      real*8 cosine,sine
      real*8 rab2,rcb2
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2
      real*8 rtru,rcb
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xab,yab,zab
      real*8 xba,yba,zba
      real*8 xcb,ycb,zcb
      real*8 xdc,ydc,zdc
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 df1,df2
      real*8 af1,af2
      real*8 tf1,tf2,t1,t2
      real*8 xa,ya,za
      real*8 xb,yb,zb
      real*8 xk,yk,zk
      real*8 gf1,gf2
      real*8 weigh,size
      real*8 weigha,weighb
      real*8 mola,molb,molk
      real*8 cf1,cf2,vol
      real*8 c1,c2,c3
      real*8 xi,yi,zi,ri
      real*8 rflat2
      real*8 a,b,buffer,term
      real*8 xorig,xorig2
      real*8 yorig,yorig2
      real*8 zorig,zorig2
      logical proceed,intermol
      logical header,huge
c
c
c     zero out the restraint energy and partitioning terms
c
      neg = 0
      eg = 0.0d0
      do i = 1, n
         aeg(i) = 0.0d0
      end do
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     disable replica mechanism when computing restraint terms
c
      if (use_replica) then
         xorig = xcell
         yorig = ycell
         zorig = zcell
         xorig2 = xcell2
         yorig2 = ycell2
         zorig2 = zcell2
         xcell = xbox
         ycell = ybox
         zcell = zbox
         xcell2 = xbox2
         ycell2 = ybox2
         zcell2 = zbox2
      end if
c
c     compute the energy for position restraint terms
c
      header = .true.
      do i = 1, npfix
         ia = ipfix(i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,0,0,0,0,0)
         if (proceed)  proceed = (use(ia))
         if (proceed) then
            xr = 0.0d0
            yr = 0.0d0
            zr = 0.0d0
            if (kpfix(1,i) .ne. 0)  xr = x(ia) - xpfix(i)
            if (kpfix(2,i) .ne. 0)  yr = y(ia) - ypfix(i)
            if (kpfix(3,i) .ne. 0)  zr = z(ia) - zpfix(i)
            if (use_bounds)  call image (xr,yr,zr)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            force = pfix(1,i)
            dt = max(0.0d0,r-pfix(2,i))
            dt2 = dt * dt
            e = force * dt2
            if (use_group)  e = e * fgrp
            neg = neg + 1
            eg = eg + e
            aeg(ia) = aeg(ia) + e
            huge = (e .gt. 10.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,10)
   10             format (/,' Individual Atomic Position Restraint',
     &                       ' Terms :',
     &                    //,' Type',9x,'Atom Name',13x,'Target',
     &                       ' Position',7x,'Distance',6x,'Energy',/)
               end if
               dt = sqrt(dt2)
               if (kpfix(2,i).eq.0 .and. kpfix(3,i).eq.0) then
                  write (iout,20)  ia,name(ia),xpfix(i),dt,e
   20             format (' Position',2x,i7,'-',a3,4x,f10.4,
     &                       5x,'----',6x,'----',1x,f10.4,f12.4)
               else if (kpfix(1,i).eq.0 .and. kpfix(3,i).eq.0) then
                  write (iout,30)  ia,name(ia),ypfix(i),dt,e
   30             format (' Position',2x,i7,'-',a3,9x,'----',1x,
     &                       f10.4,5x,'----',1x,f10.4,f12.4)
               else if (kpfix(1,i).eq.0 .and. kpfix(2,i).eq.0) then
                  write (iout,40)  ia,name(ia),zpfix(i),dt,e
   40             format (' Position',2x,i7,'-',a3,9x,'----',
     &                       6x,'----',1x,2f10.4,f12.4)
               else
                  write (iout,50)  ia,name(ia),xpfix(i),ypfix(i),
     &                             zpfix(i),dt,e
   50             format (' Position',2x,i7,'-',a3,4x,4f10.4,f12.4)
               end if
            end if
         end if
      end do
c
c     compute the energy for distance restraint terms
c
      header = .true.
      do i = 1, ndfix
         ia = idfix(1,i)
         ib = idfix(2,i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,0,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib))
         if (proceed) then
            xr = x(ia) - x(ib)
            yr = y(ia) - y(ib)
            zr = z(ia) - z(ib)
            intermol = (molcule(ia) .ne. molcule(ib))
            if (use_bounds .and. intermol)  call image (xr,yr,zr)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            force = dfix(1,i)
            df1 = dfix(2,i)
            df2 = dfix(3,i)
            target = r
            if (r .lt. df1)  target = df1
            if (r .gt. df2)  target = df2
            dt = r - target
            dt2 = dt * dt
            e = force * dt2
            if (use_group)  e = e * fgrp
            neg = neg + 1
            eg = eg + e
            aeg(ia) = aeg(ia) + 0.5d0*e
            aeg(ib) = aeg(ib) + 0.5d0*e
            if (intermol) then
               einter = einter + e
            end if
            huge = (e .gt. 10.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,60)
   60             format (/,' Individual Interatomic Distance',
     &                       ' Restraint Terms :',
     &                    //,' Type',14x,'Atom Names',16x,'Ideal Range',
     &                       4x,'Actual',6x,'Energy',/)
               end if
               write (iout,70)  ia,name(ia),ib,name(ib),df1,df2,r,e
   70          format (' Distance',2x,2(i7,'-',a3),
     &                    7x,2f8.2,f10.4,f12.4)
            end if
         end if
      end do
c
c     compute the energy for angle restraint terms
c
      header = .true.
      do i = 1, nafix
         ia = iafix(1,i)
         ib = iafix(2,i)
         ic = iafix(3,i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic))
         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)
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            rab2 = max(xab*xab+yab*yab+zab*zab,eps)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
            dot = xab*xcb + yab*ycb + zab*zcb
            cosine = dot / sqrt(rab2*rcb2)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            force = afix(1,i)
            af1 = afix(2,i)
            af2 = afix(3,i)
            target = angle
            if (angle .lt. af1)  target = af1
            if (angle .gt. af2)  target = af2
            dt = angle - target
            dt = dt / radian
            dt2 = dt * dt
            e = force * dt2
            if (use_group)  e = e * fgrp
            neg = neg + 1
            eg = eg + e
            aeg(ib) = aeg(ib) + e
            if (molcule(ia).ne.molcule(ib) .or.
     &          molcule(ia).ne.molcule(ic)) then
               einter = einter + e
            end if
            huge = (e .gt. 10.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,80)
   80             format (/,' Individual Interatomic Angle',
     &                       ' Restraint Terms :',
     &                    //,' Type',14x,'Atom Numbers',14x,'Ideal',
     &                       ' Range',4x,'Actual',6x,'Energy',/)
               end if
               write (iout,90)  ia,ib,ic,af1,af2,angle,e
   90          format (' Angle',8x,3i6,8x,2f8.2,f10.4,f12.4)
            end if
         end if
      end do
c
c     compute the energy for torsional restraint terms
c
      header = .true.
      do i = 1, ntfix
         ia = itfix(1,i)
         ib = itfix(2,i)
         ic = itfix(3,i)
         id = itfix(4,i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
         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
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
            force = tfix(1,i)
            tf1 = tfix(2,i)
            tf2 = tfix(3,i)
            if (angle.gt.tf1 .and. angle.lt.tf2) then
               target = angle
            else if (angle.gt.tf1 .and. tf1.gt.tf2) then
               target = angle
            else if (angle.lt.tf2 .and. tf1.gt.tf2) then
               target = angle
            else
               t1 = angle - tf1
               t2 = angle - tf2
               if (t1 .gt. 180.0d0) then
                  t1 = t1 - 360.0d0
               else if (t1 .lt. -180.0d0) then
                  t1 = t1 + 360.0d0
               end if
               if (t2 .gt. 180.0d0) then
                  t2 = t2 - 360.0d0
               else if (t2 .lt. -180.0d0) then
                  t2 = t2 + 360.0d0
               end if
               if (abs(t1) .lt. abs(t2)) then
                  target = tf1
               else
                  target = tf2
               end if
            end if
            dt = angle - target
            if (dt .gt. 180.0d0) then
               dt = dt - 360.0d0
            else if (dt .lt. -180.0d0) then
               dt = dt + 360.0d0
            end if
            dt = dt / radian
            dt2 = dt * dt
            e = force * dt2
            if (use_group)  e = e * fgrp
            neg = neg + 1
            eg = eg + e
            aeg(ib) = aeg(ib) + 0.5d0*e
            aeg(ic) = aeg(ic) + 0.5d0*e
            if (molcule(ia).ne.molcule(ib) .or.
     &          molcule(ia).ne.molcule(ic) .or.
     &          molcule(ia).ne.molcule(id)) then
               einter = einter + e
            end if
            huge = (e .gt. 10.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,100)
  100             format (/,' Individual Torsional Angle Restraint',
     &                         ' Terms :',
     &                    //,' Type',14x,'Atom Numbers',14x,'Ideal',
     &                       ' Range',4x,'Actual',6x,'Energy',/)
               end if
               write (iout,110)  ia,ib,ic,id,tf1,tf2,angle,e
  110          format (' Torsion',4x,4i6,4x,2f8.2,f10.4,f12.4)
            end if
         end if
      end do
c
c     compute the energy for group distance restraint terms
c
      header = .true.
      do i = 1, ngfix
         ia = igfix(1,i)
         ib = igfix(2,i)
         xa = 0.0d0
         ya = 0.0d0
         za = 0.0d0
         j = kgrp(igrp(1,ia))
         xr = x(j)
         yr = y(j)
         zr = z(j)
         mola = molcule(j)
         do j = igrp(1,ia), igrp(2,ia)
            k = kgrp(j)
            weigh = mass(k)
            xk = x(k) - xr
            yk = y(k) - yr
            zk = z(k) - zr
            molk = molcule(k)
            intermol = (molk .ne. mola)
            if (use_bounds .and. intermol)  call image (xk,yk,zk)
            xa = xa + xk*weigh
            ya = ya + yk*weigh
            za = za + zk*weigh
         end do
         weigha = max(1.0d0,grpmass(ia))
         xa = xr + xa/weigha
         ya = yr + ya/weigha
         za = zr + za/weigha
         xb = 0.0d0
         yb = 0.0d0
         zb = 0.0d0
         j = kgrp(igrp(1,ib))
         xr = x(j)
         yr = y(j)
         zr = z(j)
         molb = molcule(j)
         do j = igrp(1,ib), igrp(2,ib)
            k = kgrp(j)
            weigh = mass(k)
            xk = x(k) - xr
            yk = y(k) - yr
            zk = z(k) - zr
            molk = molcule(k)
            intermol = (molk .ne. molb)
            if (use_bounds .and. intermol)  call image (xk,yk,zk)
            xb = xb + xk*weigh
            yb = yb + yk*weigh
            zb = zb + zk*weigh
         end do
         weighb = max(1.0d0,grpmass(ib))
         xb = xr + xb/weighb
         yb = yr + yb/weighb
         zb = zr + zb/weighb
         xr = xa - xb
         yr = ya - yb
         zr = za - zb
         intermol = (mola .ne. molb)
         if (use_bounds .and. intermol)  call image (xr,yr,zr)
         r = sqrt(xr*xr + yr*yr + zr*zr)
         force = gfix(1,i)
         gf1 = gfix(2,i)
         gf2 = gfix(3,i)
         target = r
         if (r .lt. gf1)  target = gf1
         if (r .gt. gf2)  target = gf2
         dt = r - target
         dt2 = dt * dt
         e = force * dt2
         neg = neg + 1
         eg = eg + e
         size = dble(igrp(2,ia) - igrp(1,ia) + 1)
         do j = igrp(1,ia), igrp(2,ia)
            k = kgrp(j)
            aeg(k) = aeg(k) + 0.5d0*e/size
         end do
         size = dble(igrp(2,ib) - igrp(1,ib) + 1)
         do j = igrp(1,ib), igrp(2,ib)
            k = kgrp(j)
            aeg(k) = aeg(k) + 0.5d0*e/size
         end do
         if (intermol) then
            einter = einter + e
         end if
         huge = (e .gt. 10.0d0)
         if (debug .or. (verbose.and.huge)) then
            if (header) then
               header = .false.
               write (iout,120)
  120          format (/,' Individual Intergroup Distance',
     &                    ' Restraint Terms :',
     &                 //,' Type',13x,'Group Numbers',14x,'Ideal Range',
     &                    4x,'Actual',6x,'Energy',/)
            end if
            write (iout,130)  ia,ib,gf1,gf2,r,e
  130       format (' Distance',7x,2i7,10x,2f8.2,f10.4,f12.4)
         end if
      end do
c
c     compute the energy for chirality restraint terms
c
      header = .true.
      do i = 1, nchir
         ia = ichir(1,i)
         ib = ichir(2,i)
         ic = ichir(3,i)
         id = ichir(4,i)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
         if (proceed) then
            xad = x(ia) - x(id)
            yad = y(ia) - y(id)
            zad = z(ia) - z(id)
            xbd = x(ib) - x(id)
            ybd = y(ib) - y(id)
            zbd = z(ib) - z(id)
            xcd = x(ic) - x(id)
            ycd = y(ic) - y(id)
            zcd = z(ic) - z(id)
            c1 = ybd*zcd - zbd*ycd
            c2 = ycd*zad - zcd*yad
            c3 = yad*zbd - zad*ybd
            vol = xad*c1 + xbd*c2 + xcd*c3
            force = chir(1,i)
            cf1 = chir(2,i)
            cf2 = chir(3,i)
            target = vol
            if (vol .lt. min(cf1,cf2))  target = min(cf1,cf2)
            if (vol .gt. max(cf1,cf2))  target = max(cf1,cf2)
            dt = vol - target
            dt2 = dt * dt
            e = force * dt2
            if (use_group)  e = e * fgrp
            neg = neg + 1
            eg = eg + e
            aeg(ia) = aeg(ia) + 0.25d0*e
            aeg(ib) = aeg(ib) + 0.25d0*e
            aeg(ic) = aeg(ic) + 0.25d0*e
            aeg(id) = aeg(id) + 0.25d0*e
            huge = (e .gt. 10.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,140)
  140             format (/,' Individual Chirality Restraint Terms :'
     &,                    //,' Type',14x,'Atom Numbers',14x,'Ideal',
     &                       ' Range',4x,'Actual',6x,'Energy',/)
               end if
               write (iout,150)  ia,ib,ic,id,cf1,cf2,vol,e
  150          format (' Chiral',5x,4i6,4x,2f8.2,f10.4,f12.4)
            end if
         end if
      end do
c
c     compute the energy for a Gaussian basin restraint
c
      if (use_basin) then
         header = .true.
         rflat2 = rflat * rflat
         do i = 1, n-1
            xi = x(i)
            yi = y(i)
            zi = z(i)
            do k = i+1, n
               proceed = .true.
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               if (proceed)  proceed = (use(i) .or. use(k))
               if (proceed) then
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  r2 = xr*xr + yr*yr + zr*zr
                  r2 = max(0.0d0,r2-rflat2)
                  term = -width * r2
                  e = 0.0d0
                  if (term .gt. -50.0d0)  e = depth * exp(term)
                  e = e - depth
                  if (use_group)  e = e * fgrp
                  neg = neg + 1
                  eg = eg + e
                  aeg(i) = aeg(i) + 0.5d0*e
                  aeg(k) = aeg(k) + 0.5d0*e
                  huge = (e .gt. 10.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,160)
  160                   format (/,' Individual Gaussian Basin',
     &                             ' Restraint Terms :',
     &                          //,' Type',14x,'Atom Names',22x,'Ideal',
     &                             4x,'Actual',6x,'Energy',/)
                     end if
                     r = sqrt(r2)
                     write (iout,170)  i,name(i),k,name(k),0.0d0,r,e
  170                format (' Distance',2x,2(i7,'-',a3),
     &                          13x,2f10.4,f12.4)
                  end if
               end if
            end do
         end do
      end if
c
c     compute the energy for a spherical droplet restraint
c
      if (use_wall) then
         header = .true.
         buffer = 2.5d0
         a = 2048.0d0
         b = 64.0d0
         do i = 1, n
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,0,0,0,0,0)
            if (proceed)  proceed = (use(i))
            if (proceed) then
               xi = x(i)
               yi = y(i)
               zi = z(i)
               ri = sqrt(xi**2 + yi**2 + zi**2)
               r = rwall + buffer - ri
               r2 = r * r
               r6 = r2 * r2 * r2
               r12 = r6 * r6
               e = a/r12 - b/r6
               if (use_group)  e = e * fgrp
               neg = neg + 1
               eg = eg + e
               aeg(i) = aeg(i) + e
               huge = (e .gt. 10.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,180)
  180                format (/,' Individual Spherical Boundary',
     &                          ' Restraint Terms :',
     &                       //,' Type',14x,'Atom Name',30x,'Distance',
     &                          6x,'Energy',/)
                  end if
                  write (iout,190)  i,name(i),ri,e
  190             format (' Wall',11x,i7,'-',a3,29x,f10.4,f12.4)
               end if
            end if
         end do
      end if
c
c     reinstate the replica mechanism if it is being used
c
      if (use_replica) then
         xcell = xorig
         ycell = yorig
         zcell = zorig
         xcell2 = xorig2
         ycell2 = yorig2
         zcell2 = zorig2
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ehal  --  buffered 14-7 van der Waals energy  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ehal" calculates the buffered 14-7 van der Waals energy
c
c
      subroutine ehal
      use energi
      use limits
      use vdwpot
      implicit none
      real*8 elrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_lights) then
         call ehal0b
      else if (use_vlist) then
         call ehal0c
      else
         call ehal0a
      end if
c
c     apply the long range van der Waals correction if used
c
      if (use_vcorr) then
         mode = 'VDW'
         call evcorr (mode,elrc)
         ev = ev + elrc
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ehal0a  --  buffered 14-7 vdw via double loop  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ehal0a" calculates the buffered 14-7 van der Waals energy
c     using a pairwise double loop
c
c
      subroutine ehal0a
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use energi
      use group
      use mutant
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,rv,rv7
      real*8 eps,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rho,tau,taper
      real*8 scal,t1,t2
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     rho = rik / rv
                     eps = eps * vlambda**scexp
                     scal = scalpha * (1.0d0-vlambda)**2
                     t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7)
                     t2 = (1.0d0+ghal) / (scal+rho**7+ghal)
                     e = eps * t1 * (t2-2.0d0)
                  else
                     rv7 = rv**7
                     rik7 = rik**7
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     e = eps * rv7 * tau**7
     &                      * ((ghal+1.0d0)*rv7/rho-2.0d0)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rik = sqrt(rik2)
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
c
c     set use of lambda scaling for decoupling or annihilation
c
                     mutik = .false.
                     if (muti .or. mutk) then
                        if (vcouple .eq. 1) then
                           mutik = .true.
                        else if (.not.muti .or. .not.mutk) then
                           mutik = .true.
                        end if
                     end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                     if (mutik) then
                        rho = rik / rv
                        eps = eps * vlambda**scexp
                        scal = scalpha * (1.0d0-vlambda)**2
                        t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7)
                        t2 = (1.0d0+ghal) / (scal+rho**7+ghal)
                        e = eps * t1 * (t2-2.0d0)
                     else
                        rv7 = rv**7
                        rik7 = rik**7
                        rho = rik7 + ghal*rv7
                        tau = (dhal+1.0d0) / (rik + dhal*rv)
                        e = eps * rv7 * tau**7
     &                         * ((ghal+1.0d0)*rv7/rho-2.0d0)
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component;
c     interaction of an atom with its own image counts half
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ev = ev + e
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ehal0b  --  buffered 14-7 vdw energy via lights  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ehal0b" calculates the buffered 14-7 van der Waals energy
c     using the method of lights
c
c
      subroutine ehal0b
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use couple
      use energi
      use group
      use light
      use mutant
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer kgy,kgz
      integer start,stop
      integer, allocatable :: iv14(:)
      real*8 e,rv,rv7
      real*8 eps,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rho,tau,taper
      real*8 scal,t1,t2
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rv = radmin4(kt,it)
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     rho = rik / rv
                     eps = eps * vlambda**scexp
                     scal = scalpha * (1.0d0-vlambda)**2
                     t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7)
                     t2 = (1.0d0+ghal) / (scal+rho**7+ghal)
                     e = eps * t1 * (t2-2.0d0)
                  else
                     rv7 = rv**7
                     rik7 = rik**7
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     e = eps * rv7 * tau**7
     &                      * ((ghal+1.0d0)*rv7/rho-2.0d0)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ehal0c  --  buffered 14-7 vdw energy via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ehal0c" calculates the buffered 14-7 van der Waals energy
c     using a pairwise neighbor list
c
c
      subroutine ehal0c
      use atomid
      use atoms
      use bound
      use couple
      use energi
      use group
      use mutant
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,eps,rdn
      real*8 fgrp,rv,rv7
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rho,tau,taper
      real*8 scal,t1,t2
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13,
!$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group,
!$OMP& off2,radmin,epsilon,radmin4,epsilon4,ghal,dhal,vcouple,
!$OMP& vlambda,mut,scexp,scalpha,cut2,c0,c1,c2,c3,c4,c5)
!$OMP& firstprivate(vscale,iv14) shared(ev)
!$OMP DO reduction(+:ev)
c
c     find the van der Waals energy via neighbor list search
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     rho = rik / rv
                     eps = eps * vlambda**scexp
                     scal = scalpha * (1.0d0-vlambda)**2
                     t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7)
                     t2 = (1.0d0+ghal) / (scal+rho**7+ghal)
                     e = eps * t1 * (t2-2.0d0)
                  else
                     rv7 = rv**7
                     rik7 = rik**7
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     e = eps * rv7 * tau**7
     &                      * ((ghal+1.0d0)*rv7/rho-2.0d0)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ehal1  --  buffered 14-7 energy & derivatives  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ehal1" calculates the buffered 14-7 van der Waals energy and
c     its first derivatives with respect to Cartesian coordinates
c
c
      subroutine ehal1
      use energi
      use limits
      use vdwpot
      use virial
      implicit none
      real*8 elrc,vlrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_lights) then
         call ehal1b
      else if (use_vlist) then
         call ehal1c
      else
         call ehal1a
      end if
c
c     apply the long range van der Waals correction if used
c
      if (use_vcorr) then
         mode = 'VDW'
         call evcorr1 (mode,elrc,vlrc)
         ev = ev + elrc
         vir(1,1) = vir(1,1) + vlrc
         vir(2,2) = vir(2,2) + vlrc
         vir(3,3) = vir(3,3) + vlrc
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ehal1a  --  double loop buffer 14-7 vdw derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ehal1a" calculates the buffered 14-7 van der Waals energy and
c     its first derivatives with respect to Cartesian coordinates
c     using a pairwise double loop
c
c
      subroutine ehal1a
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use deriv
      use energi
      use group
      use mutant
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,de,eps,rdn
      real*8 fgrp,rv,rv7
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rho,rho6,rho7
      real*8 tau,tau7,scal
      real*8 s1,s2,t1,t2
      real*8 dt1drho,dt2drho
      real*8 dtau,gtau
      real*8 taper,dtaper
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 rik6,rik7
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find van der Waals energy and derivatives via double loop
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     rho = rik / rv
                     rho6 = rho**6
                     rho7 = rho6 * rho
                     eps = eps * vlambda**scexp
                     scal = scalpha * (1.0d0-vlambda)**2
                     s1 = 1.0d0 / (scal+(rho+dhal)**7)
                     s2 = 1.0d0 / (scal+rho7+ghal)
                     t1 = (1.0d0+dhal)**7 * s1
                     t2 = (1.0d0+ghal) * s2
                     dt1drho = -7.0d0*(rho+dhal)**6 * t1 * s1
                     dt2drho = -7.0d0*rho6 * t2 * s2
                     e = eps * t1 * (t2-2.0d0)
                     de = eps * (dt1drho*(t2-2.0d0)+t1*dt2drho) / rv
                  else
                     rv7 = rv**7
                     rik6 = rik2**3
                     rik7 = rik6 * rik
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     tau7 = tau**7
                     dtau = tau / (dhal+1.0d0)
                     gtau = eps*tau7*rik6*(ghal+1.0d0)*(rv7/rho)**2
                     e = eps*tau7*rv7*((ghal+1.0d0)*rv7/rho-2.0d0)
                     de = -7.0d0 * (dtau*e+gtau)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = jvdw(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rik = sqrt(rik2)
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
c
c     set use of lambda scaling for decoupling or annihilation
c
                     mutik = .false.
                     if (muti .or. mutk) then
                        if (vcouple .eq. 1) then
                           mutik = .true.
                        else if (.not.muti .or. .not.mutk) then
                           mutik = .true.
                        end if
                     end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                     if (mutik) then
                        rho = rik / rv
                        rho6 = rho**6
                        rho7 = rho6 * rho
                        eps = eps * vlambda**scexp
                        scal = scalpha * (1.0d0-vlambda)**2
                        s1 = 1.0d0 / (scal+(rho+dhal)**7)
                        s2 = 1.0d0 / (scal+rho7+ghal)
                        t1 = (1.0d0+dhal)**7 * s1
                        t2 = (1.0d0+ghal) * s2
                        dt1drho = -7.0d0*(rho+dhal)**6 * t1 * s1
                        dt2drho = -7.0d0*rho6 * t2 * s2
                        e = eps * t1 * (t2-2.0d0)
                        de = eps * (dt1drho*(t2-2.0d0)+t1*dt2drho) / rv
                     else
                        rv7 = rv**7
                        rik6 = rik2**3
                        rik7 = rik6 * rik
                        rho = rik7 + ghal*rv7
                        tau = (dhal+1.0d0) / (rik + dhal*rv)
                        tau7 = tau**7
                        dtau = tau / (dhal+1.0d0)
                        gtau = eps*tau7*rik6*(ghal+1.0d0)*(rv7/rho)**2
                        e = eps*tau7*rv7*((ghal+1.0d0)*rv7/rho-2.0d0)
                        de = -7.0d0 * (dtau*e+gtau)
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                              + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                        de = e*dtaper + de*taper
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        e = e * fgrp
                        de = de * fgrp
                     end if
c
c     find the chain rule terms for derivative components
c
                     de = de / rik
                     dedx = de * xr
                     dedy = de * yr
                     dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ev = ev + e
                     if (i .eq. iv) then
                        dev(1,i) = dev(1,i) + dedx
                        dev(2,i) = dev(2,i) + dedy
                        dev(3,i) = dev(3,i) + dedz
                     else
                        dev(1,i) = dev(1,i) + dedx*redi
                        dev(2,i) = dev(2,i) + dedy*redi
                        dev(3,i) = dev(3,i) + dedz*redi
                        dev(1,iv) = dev(1,iv) + dedx*rediv
                        dev(2,iv) = dev(2,iv) + dedy*rediv
                        dev(3,iv) = dev(3,iv) + dedz*rediv
                     end if
                     if (i .ne. k) then
                        if (k .eq. kv) then
                           dev(1,k) = dev(1,k) - dedx
                           dev(2,k) = dev(2,k) - dedy
                           dev(3,k) = dev(3,k) - dedz
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           dev(1,k) = dev(1,k) - dedx*redk
                           dev(2,k) = dev(2,k) - dedy*redk
                           dev(3,k) = dev(3,k) - dedz*redk
                           dev(1,kv) = dev(1,kv) - dedx*redkv
                           dev(2,kv) = dev(2,kv) - dedy*redkv
                           dev(3,kv) = dev(3,kv) - dedz*redkv
                        end if
                     end if
c
c     increment the internal virial tensor components
c
                     vxx = xr * dedx
                     vyx = yr * dedx
                     vzx = zr * dedx
                     vyy = yr * dedy
                     vzy = zr * dedy
                     vzz = zr * dedz
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ehal1b  --  buffered 14-7 vdw derivs via lights  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ehal1b" calculates the buffered 14-7 van der Waals energy and
c     its first derivatives with respect to Cartesian coordinates
c     using the method of lights
c
c
      subroutine ehal1b
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use couple
      use deriv
      use energi
      use group
      use light
      use mutant
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer kgy,kgz
      integer start,stop
      integer, allocatable :: iv14(:)
      real*8 e,de,eps,rdn
      real*8 fgrp,rv,rv7
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rho,rho6,rho7
      real*8 tau,tau7,scal
      real*8 s1,s2,t1,t2
      real*8 dt1drho,dt2drho
      real*8 dtau,gtau
      real*8 taper,dtaper
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 rik6,rik7
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rv = radmin4(kt,it)
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     rho = rik / rv
                     rho6 = rho**6
                     rho7 = rho6 * rho
                     eps = eps * vlambda**scexp
                     scal = scalpha * (1.0d0-vlambda)**2
                     s1 = 1.0d0 / (scal+(rho+dhal)**7)
                     s2 = 1.0d0 / (scal+rho7+ghal)
                     t1 = (1.0d0+dhal)**7 * s1
                     t2 = (1.0d0+ghal) * s2
                     dt1drho = -7.0d0*(rho+dhal)**6 * t1 * s1
                     dt2drho = -7.0d0*rho6 * t2 * s2
                     e = eps * t1 * (t2-2.0d0)
                     de = eps * (dt1drho*(t2-2.0d0)+t1*dt2drho) / rv
                  else
                     rv7 = rv**7
                     rik6 = rik2**3
                     rik7 = rik6 * rik
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     tau7 = tau**7
                     dtau = tau / (dhal+1.0d0)
                     gtau = eps*tau7*rik6*(ghal+1.0d0)*(rv7/rho)**2
                     e = eps*tau7*rv7*((ghal+1.0d0)*rv7/rho-2.0d0)
                     de = -7.0d0 * (dtau*e+gtau)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ehal1c  --  buffered 14-7 vdw derivs via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ehal1c" calculates the buffered 14-7 van der Waals energy and
c     its first derivatives with respect to Cartesian coordinates
c     using a pairwise neighbor list
c
c
      subroutine ehal1c
      use atomid
      use atoms
      use bound
      use couple
      use deriv
      use energi
      use group
      use mutant
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,de,eps,rdn
      real*8 fgrp,rv,rv7
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rho,rho6,rho7
      real*8 tau,tau7,scal
      real*8 s1,s2,t1,t2
      real*8 dt1drho,dt2drho
      real*8 dtau,gtau
      real*8 taper,dtaper
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 rik6,rik7
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& kred,xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,
!$OMP& i12,i13,i14,i15,v2scale,v3scale,v4scale,v5scale,
!$OMP& use_group,off2,radmin,epsilon,radmin4,epsilon4,ghal,
!$OMP& dhal,cut2,vcouple,vlambda,mut,scexp,scalpha,c0,c1,
!$OMP& c2,c3,c4,c5)
!$OMP& firstprivate(vscale,iv14) shared(ev,dev,vir)
!$OMP DO reduction(+:ev,dev,vir)
c
c     find van der Waals energy and derivatives via neighbor list
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     rho = rik / rv
                     rho6 = rho**6
                     rho7 = rho6 * rho
                     eps = eps * vlambda**scexp
                     scal = scalpha * (1.0d0-vlambda)**2
                     s1 = 1.0d0 / (scal+(rho+dhal)**7)
                     s2 = 1.0d0 / (scal+rho7+ghal)
                     t1 = (1.0d0+dhal)**7 * s1
                     t2 = (1.0d0+ghal) * s2
                     dt1drho = -7.0d0*(rho+dhal)**6 * t1 * s1
                     dt2drho = -7.0d0*rho6 * t2 * s2
                     e = eps * t1 * (t2-2.0d0)
                     de = eps * (dt1drho*(t2-2.0d0)+t1*dt2drho) / rv
                  else
                     rv7 = rv**7
                     rik6 = rik2**3
                     rik7 = rik6 * rik
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     tau7 = tau**7
                     dtau = tau / (dhal+1.0d0)
                     gtau = eps*tau7*rik6*(ghal+1.0d0)*(rv7/rho)**2
                     e = eps*tau7*rv7*((ghal+1.0d0)*rv7/rho-2.0d0)
                     de = -7.0d0 * (dtau*e+gtau)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ehal2  --  atom-by-atom buffered 14-7 Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ehal2" calculates the buffered 14-7 van der Waals second
c     derivatives for a single atom at a time
c
c
      subroutine ehal2 (iatom)
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use group
      use hessn
      use shunt
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer iatom,jcell
      integer nlist,list(5)
      integer, allocatable :: iv14(:)
      real*8 e,de,d2e
      real*8 fgrp,eps
      real*8 rdn,rv,rv7
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 redi2,rediv2,rediiv
      real*8 redik,redivk
      real*8 redikv,redivkv
      real*8 rho,tau,tau7
      real*8 dtau,gtau
      real*8 taper,dtaper,d2taper
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 rik6,rik7
      real*8 d2edx,d2edy,d2edz
      real*8 term(3,3)
      real*8, allocatable :: vscale(:)
      logical proceed
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     check to see if the atom of interest is a vdw site
c
      nlist = 0
      do k = 1, nvdw
         if (ivdw(k) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = iatom
            goto 10
         end if
      end do
      return
   10 continue
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     determine the atoms involved via reduction factors
c
      nlist = 1
      list(nlist) = iatom
      do k = 1, n12(iatom)
         i = i12(k,iatom)
         if (ired(i) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = i
         end if
      end do
c
c     find van der Waals Hessian elements for involved atoms
c
      do ii = 1, nlist
         i = list(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         if (i .ne. iv) then
            rediv = 1.0d0 - redi
            redi2 = redi * redi
            rediv2 = rediv * rediv
            rediiv = redi * rediv
         end if
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (k .ne. i)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  rv7 = rv**7
                  rik6 = rik2**3
                  rik7 = rik6 * rik
                  rho = rik7 + ghal*rv7
                  tau = (dhal+1.0d0) / (rik + dhal*rv)
                  tau7 = tau**7
                  dtau = tau / (dhal+1.0d0)
                  gtau = eps*tau7*rik6*(ghal+1.0d0)*(rv7/rho)**2
                  e = eps*tau7*rv7*((ghal+1.0d0)*rv7/rho-2.0d0)
                  de = -7.0d0 * (dtau*e+gtau)
                  d2e = 56.0d0*dtau*dtau*e - 42.0d0*gtau/rik
     &                     + 98.0d0*gtau*(dtau+rik6/rho)
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik3 * rik2
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2
     &                            + 6.0d0*c3*rik + 2.0d0*c2
                     d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper
                     de = e*dtaper + de*taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     de = de * fgrp
                     d2e = d2e * fgrp
                  end if
c
c     get chain rule terms for van der Waals Hessian elements
c
                  de = de / rik
                  d2e = (d2e-de) / rik2
                  d2edx = d2e * xr
                  d2edy = d2e * yr
                  d2edz = d2e * zr
                  term(1,1) = d2edx*xr + de
                  term(1,2) = d2edx*yr
                  term(1,3) = d2edx*zr
                  term(2,1) = term(1,2)
                  term(2,2) = d2edy*yr + de
                  term(2,3) = d2edy*zr
                  term(3,1) = term(1,3)
                  term(3,2) = term(2,3)
                  term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                  if (i .eq. iatom) then
                     if (i.eq.iv .and. k.eq.kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)
                           hessy(j,i) = hessy(j,i) + term(2,j)
                           hessz(j,i) = hessz(j,i) + term(3,j)
                           hessx(j,k) = hessx(j,k) - term(1,j)
                           hessy(j,k) = hessy(j,k) - term(2,j)
                           hessz(j,k) = hessz(j,k) - term(3,j)
                        end do
                     else if (k .eq. kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                           hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                           hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                           hessx(j,k) = hessx(j,k) - term(1,j)*redi
                           hessy(j,k) = hessy(j,k) - term(2,j)*redi
                           hessz(j,k) = hessz(j,k) - term(3,j)*redi
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                        end do
                     else if (i .eq. iv) then
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)
                           hessy(j,i) = hessy(j,i) + term(2,j)
                           hessz(j,i) = hessz(j,i) + term(3,j)
                           hessx(j,k) = hessx(j,k) - term(1,j)*redk
                           hessy(j,k) = hessy(j,k) - term(2,j)*redk
                           hessz(j,k) = hessz(j,k) - term(3,j)*redk
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv
                        end do
                     else
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        redik = redi * redk
                        redikv = redi * redkv
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                           hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                           hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                           hessx(j,k) = hessx(j,k) - term(1,j)*redik
                           hessy(j,k) = hessy(j,k) - term(2,j)*redik
                           hessz(j,k) = hessz(j,k) - term(3,j)*redik
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv
                        end do
                     end if
                  else if (iv .eq. iatom) then
                     if (k .eq. kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                           hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                           hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                           hessx(j,k) = hessx(j,k) - term(1,j)*rediv
                           hessy(j,k) = hessy(j,k) - term(2,j)*rediv
                           hessz(j,k) = hessz(j,k) - term(3,j)*rediv
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                        end do
                     else
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        redivk = rediv * redk
                        redivkv = rediv * redkv
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                           hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                           hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                           hessx(j,k) = hessx(j,k) - term(1,j)*redivk
                           hessy(j,k) = hessy(j,k) - term(2,j)*redivk
                           hessz(j,k) = hessz(j,k) - term(3,j)*redivk
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv
                        end do
                     end if
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nlist
         i = list(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         if (i .ne. iv) then
            rediv = 1.0d0 - redi
            redi2 = redi * redi
            rediv2 = rediv * rediv
            rediiv = redi * rediv
         end if
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               do jcell = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,jcell)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rik = sqrt(rik2)
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     rv7 = rv**7
                     rik6 = rik2**3
                     rik7 = rik6 * rik
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     tau7 = tau**7
                     dtau = tau / (dhal+1.0d0)
                     gtau = eps*tau7*rik6*(ghal+1.0d0)*(rv7/rho)**2
                     e = eps*rv7*tau7*((ghal+1.0d0)*rv7/rho-2.0d0)
                     de = -7.0d0 * (dtau*e+gtau)
                     d2e = 56.0d0*dtau*dtau*e - 42.0d0*gtau/rik
     &                        + 98.0d0*gtau*(dtau+rik6/rho)
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik3 * rik2
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                        d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2
     &                             + 6.0d0*c3*rik + 2.0d0*c2
                        d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper
                        de = e*dtaper + de*taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        de = de * fgrp
                        d2e = d2e * fgrp
                     end if
c
c     get chain rule terms for van der Waals Hessian elements
c
                     de = de / rik
                     d2e = (d2e-de) / rik2
                     d2edx = d2e * xr
                     d2edy = d2e * yr
                     d2edz = d2e * zr
                     term(1,1) = d2edx*xr + de
                     term(1,2) = d2edx*yr
                     term(1,3) = d2edx*zr
                     term(2,1) = term(1,2)
                     term(2,2) = d2edy*yr + de
                     term(2,3) = d2edy*zr
                     term(3,1) = term(1,3)
                     term(3,2) = term(2,3)
                     term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                     if (i .eq. iatom) then
                        if (i.eq.iv .and. k.eq.kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)
                              hessy(j,i) = hessy(j,i) + term(2,j)
                              hessz(j,i) = hessz(j,i) + term(3,j)
                              hessx(j,k) = hessx(j,k) - term(1,j)
                              hessy(j,k) = hessy(j,k) - term(2,j)
                              hessz(j,k) = hessz(j,k) - term(3,j)
                           end do
                        else if (k .eq. kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                              hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                              hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                              hessx(j,k) = hessx(j,k) - term(1,j)*redi
                              hessy(j,k) = hessy(j,k) - term(2,j)*redi
                              hessz(j,k) = hessz(j,k) - term(3,j)*redi
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediiv
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediiv
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediiv
                           end do
                        else if (i .eq. iv) then
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)
                              hessy(j,i) = hessy(j,i) + term(2,j)
                              hessz(j,i) = hessz(j,i) + term(3,j)
                              hessx(j,k) = hessx(j,k) - term(1,j)*redk
                              hessy(j,k) = hessy(j,k) - term(2,j)*redk
                              hessz(j,k) = hessz(j,k) - term(3,j)*redk
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redkv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redkv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redkv
                           end do
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           redik = redi * redk
                           redikv = redi * redkv
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                              hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                              hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                              hessx(j,k) = hessx(j,k) - term(1,j)*redik
                              hessy(j,k) = hessy(j,k) - term(2,j)*redik
                              hessz(j,k) = hessz(j,k) - term(3,j)*redik
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediiv
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediiv
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediiv
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redikv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redikv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redikv
                           end do
                        end if
                     else if (iv .eq. iatom) then
                        if (k .eq. kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                              hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                              hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                              hessx(j,k) = hessx(j,k) - term(1,j)*rediv
                              hessy(j,k) = hessy(j,k) - term(2,j)*rediv
                              hessz(j,k) = hessz(j,k) - term(3,j)*rediv
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediv2
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediv2
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediv2
                           end do
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           redivk = rediv * redk
                           redivkv = rediv * redkv
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                              hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                              hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                              hessx(j,k) = hessx(j,k) - term(1,j)*redivk
                              hessy(j,k) = hessy(j,k) - term(2,j)*redivk
                              hessz(j,k) = hessz(j,k) - term(3,j)*redivk
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediv2
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediv2
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediv2
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redivkv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redivkv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redivkv
                           end do
                        end if
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ehal3  --  buffered 14-7 vdw energy & analysis  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ehal3" calculates the buffered 14-7 van der Waals energy
c     and partitions the energy among the atoms
c
c
      subroutine ehal3
      use analyz
      use atoms
      use energi
      use inform
      use iounit
      use limits
      use vdwpot
      implicit none
      integer i
      real*8 elrc,aelrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_lights) then
         call ehal3b
      else if (use_vlist) then
         call ehal3c
      else
         call ehal3a
      end if
c
c     apply the long range van der Waals correction if used
c
      if (use_vcorr) then
         mode = 'VDW'
         call evcorr (mode,elrc)
         ev = ev + elrc
         aelrc = elrc / dble(n)
         do i = 1, n
            aev(i) = aev(i) + aelrc
         end do
         if (verbose .and. elrc.ne.0.0d0) then
            if (digits .ge. 8) then
               write (iout,10)  elrc
   10          format (/,' Long-Range van der Waals :',6x,f16.8)
            else if (digits .ge. 6) then
               write (iout,20)  elrc
   20          format (/,' Long-Range van der Waals :',6x,f16.6)
            else
               write (iout,30)  elrc
   30          format (/,' Long-Range van der Waals :',6x,f16.4)
            end if
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ehal3a  --  double loop buffered 14-7 analysis  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ehal3a" calculates the buffered 14-7 van der Waals energy
c     and partitions the energy among the atoms using a pairwise
c     double loop
c
c
      subroutine ehal3a
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mutant
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,rv,rv7
      real*8 eps,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rho,tau,taper
      real*8 scal,t1,t2
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      logical header,huge
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     rho = rik / rv
                     eps = eps * vlambda**scexp
                     scal = scalpha * (1.0d0-vlambda)**2
                     t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7)
                     t2 = (1.0d0+ghal) / (scal+rho**7+ghal)
                     e = eps * t1 * (t2-2.0d0)
                  else
                     rv7 = rv**7
                     rik7 = rik**7
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     e = eps * rv7 * tau**7
     &                      * ((ghal+1.0d0)*rv7/rho-2.0d0)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   30                format (' VDW-Hal',3x,2(i7,'-',a3),
     &                          13x,2f10.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rik = sqrt(rik2)
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
c
c     set use of lambda scaling for decoupling or annihilation
c
                     mutik = .false.
                     if (muti .or. mutk) then
                        if (vcouple .eq. 1) then
                           mutik = .true.
                        else if (.not.muti .or. .not.mutk) then
                           mutik = .true.
                        end if
                     end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                     if (mutik) then
                        rho = rik / rv
                        eps = eps * vlambda**scexp
                        scal = scalpha * (1.0d0-vlambda)**2
                        t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7)
                        t2 = (1.0d0+ghal) / (scal+rho**7+ghal)
                        e = eps * t1 * (t2-2.0d0)
                     else
                        rv7 = rv**7
                        rik7 = rik**7
                        rho = rik7 + ghal*rv7
                        tau = (dhal+1.0d0) / (rik + dhal*rv)
                        e = eps * rv7 * tau**7
     &                         * ((ghal+1.0d0)*rv7/rho-2.0d0)
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik = sqrt(rik2)
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                                + c2*rik2 + c1*rik + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component
c
                     if (e .ne. 0.0d0) then
                        nev = nev + 1
                        if (i .eq. k) then
                           ev = ev + 0.5d0*e
                           aev(i) = aev(i) + 0.5d0*e
                        else
                           ev = ev + e
                           aev(i) = aev(i) + 0.5d0*e
                           aev(k) = aev(k) + 0.5d0*e
                        end if
                     end if
c
c     increment the total intermolecular energy
c
                     einter = einter + e
c
c     print a message if the energy of this interaction is large
c
                     huge = (e .gt. 10.0d0)
                     if ((debug.and.e.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual van der Waals',
     &                                ' Interactions :',
     &                             //,' Type',14x,'Atom Names',
     &                                20x,'Minimum',4x,'Actual',
     &                                6x,'Energy',/)
                        end if
                        write (iout,50)  i,name(i),k,name(k),
     &                                   rv,sqrt(rik2),e
   50                   format (' VDW-Hal',3x,2(i7,'-',a3),1x,
     &                             '(XTAL)',6x,2f10.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ehal3b  --  buffered 14-7 analysis via lights  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ehal3b" calculates the buffered 14-7 van der Waals energy
c     and also partitions the energy among the atoms using the
c     method of lights
c
c
      subroutine ehal3b
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use light
      use molcul
      use mutant
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer kgy,kgz
      integer start,stop
      integer ikmin,ikmax
      integer, allocatable :: iv14(:)
      real*8 e,rv,rv7
      real*8 eps,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rho,tau,taper
      real*8 scal,t1,t2
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      logical muti,mutk,mutik
      logical header,huge
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   20    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 60
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 60
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 60
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 60
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rv = radmin4(kt,it)
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     rho = rik / rv
                     eps = eps * vlambda**scexp
                     scal = scalpha * (1.0d0-vlambda)**2
                     t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7)
                     t2 = (1.0d0+ghal) / (scal+rho**7+ghal)
                     e = eps * t1 * (t2-2.0d0)
                  else
                     rv7 = rv**7
                     rik7 = rik**7
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     e = eps * rv7 * tau**7
     &                      * ((ghal+1.0d0)*rv7/rho-2.0d0)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (.not.prime .or. molcule(i).ne.molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,30)
   30                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     ikmin = min(i,k)
                     ikmax = max(i,k)
                     if (prime) then
                        write (iout,40)  ikmin,name(ikmin),ikmax,
     &                                   name(ikmax),rv,sqrt(rik2),e
   40                   format (' VDW-Hal',3x,2(i7,'-',a3),
     &                             13x,2f10.4,f12.4)
                     else
                        write (iout,50)  ikmax,name(ikmin),ikmax,
     &                                   name(ikmax),rv,sqrt(rik2),e
   50                   format (' VDW-Hal',3x,2(i7,'-',a3),1x,
     &                             '(XTAL)',6x,2f10.4,f12.4)
                     end if
                  end if
               end if
            end if
   60       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 20
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine ehal3c  --  buffered 14-7 analysis via list  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "ehal3c" calculates the buffered 14-7 van der Waals energy
c     and also partitions the energy among the atoms using a
c     pairwise neighbor list
c
c
      subroutine ehal3c
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mutant
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,eps,rdn
      real*8 fgrp,rv,rv7
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rho,tau,taper
      real*8 scal,t1,t2
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      logical header,huge
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,
!$OMP& ired,xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,
!$OMP& i12,i13,i14,i15,v2scale,v3scale,v4scale,v5scale,
!$OMP& use_group,off2,radmin,epsilon,radmin4,epsilon4,ghal,
!$OMP& dhal,vcouple,vlambda,mut,scexp,scalpha,cut2,c0,c1,
!$OMP& c2,c3,c4,c5,molcule,name,verbose,debug,header,iout)
!$OMP& firstprivate(vscale,iv14) shared(ev,nev,aev,einter)
!$OMP DO reduction(+:ev,nev,aev,einter)
c
c     find the van der Waals energy via neighbor list search
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     rho = rik / rv
                     eps = eps * vlambda**scexp
                     scal = scalpha * (1.0d0-vlambda)**2
                     t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7)
                     t2 = (1.0d0+ghal) / (scal+rho**7+ghal)
                     e = eps * t1 * (t2-2.0d0)
                  else
                     rv7 = rv**7
                     rik7 = rik**7
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     e = eps * rv7 * tau**7
     &                      * ((ghal+1.0d0)*rv7/rho-2.0d0)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   30                format (' VDW-Hal',3x,2(i7,'-',a3),
     &                          13x,2f10.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ########################################################
c     ##                                                    ##
c     ##  subroutine eimprop  --  improper dihedral energy  ##
c     ##                                                    ##
c     ########################################################
c
c
c     "eimprop" calculates the improper dihedral potential energy
c
c
      subroutine eimprop
      use atoms
      use bound
      use energi
      use group
      use improp
      use math
      use torpot
      use usage
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps,dt,fgrp
      real*8 ideal,force
      real*8 cosine,sine
      real*8 rcb,angle
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru
      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
      real*8 xdc,ydc,zdc
      logical proceed
c
c
c     zero out improper dihedral energy
c
      eid = 0.0d0
      if (niprop .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(niprop,iiprop,use,
!$OMP& x,y,z,kprop,vprop,idihunit,eps,use_group,use_polymer)
!$OMP& shared(eid)
!$OMP DO reduction(+:eid)
c
c     calculate the improper dihedral angle energy term
c
      do i = 1, niprop
         ia = iiprop(1,i)
         ib = iiprop(2,i)
         ic = iiprop(3,i)
         id = iiprop(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the improper dihedral 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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
c
c     set the improper dihedral parameters for this angle
c
            ideal = vprop(i)
            force = kprop(i)
            if (abs(angle+ideal) .lt. abs(angle-ideal))
     &         ideal = -ideal
            dt = angle - ideal
            do while (dt .gt. 180.0d0)
               dt = dt - 360.0d0
            end do
            do while (dt .lt. -180.0d0)
               dt = dt + 360.0d0
            end do
c
c     calculate the improper dihedral energy
c
            e = idihunit * force * dt**2
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total improper dihedral energy
c
            eid = eid + e
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine eimprop1  --  impr. dihedral energy & gradient  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "eimprop1" calculates improper dihedral energy and its
c     first derivatives with respect to Cartesian coordinates
c
c
      subroutine eimprop1
      use atoms
      use bound
      use deriv
      use energi
      use group
      use improp
      use math
      use torpot
      use usage
      use virial
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps,fgrp
      real*8 dt,term
      real*8 dedphi
      real*8 ideal,force
      real*8 cosine,sine
      real*8 rcb,angle
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru
      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
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 dedxt,dedyt,dedzt
      real*8 dedxu,dedyu,dedzu
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out energy and first derivative components
c
      eid = 0.0d0
      do i = 1, n
         deid(1,i) = 0.0d0
         deid(2,i) = 0.0d0
         deid(3,i) = 0.0d0
      end do
      if (niprop .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(niprop,iiprop,use,
!$OMP& x,y,z,kprop,vprop,idihunit,eps,use_group,use_polymer)
!$OMP& shared(eid,deid,vir)
!$OMP DO reduction(+:eid,deid,vir)
c
c     calculate the improper dihedral angle energy term
c
      do i = 1, niprop
         ia = iiprop(1,i)
         ib = iiprop(2,i)
         ic = iiprop(3,i)
         id = iiprop(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the improper dihedral 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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
c
c     set the improper dihedral parameters for this angle
c
            ideal = vprop(i)
            force = kprop(i)
            if (abs(angle+ideal) .lt. abs(angle-ideal))
     &         ideal = -ideal
            dt = angle - ideal
            do while (dt .gt. 180.0d0)
               dt = dt - 360.0d0
            end do
            do while (dt .lt. -180.0d0)
               dt = dt + 360.0d0
            end do
c
c     calculate improper energy and master chain rule term
c
            term = idihunit * force * dt
            e = term * dt
            dedphi = 2.0d0 * radian * term
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     chain rule terms for first derivative components
c
            xca = xic - xia
            yca = yic - yia
            zca = zic - zia
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            if (use_polymer) then
               call image (xca,yca,zca)
               call image (xdb,ydb,zdb)
            end if
            dedxt = dedphi * (yt*zcb - ycb*zt) / (rt2*rcb)
            dedyt = dedphi * (zt*xcb - zcb*xt) / (rt2*rcb)
            dedzt = dedphi * (xt*ycb - xcb*yt) / (rt2*rcb)
            dedxu = -dedphi * (yu*zcb - ycb*zu) / (ru2*rcb)
            dedyu = -dedphi * (zu*xcb - zcb*xu) / (ru2*rcb)
            dedzu = -dedphi * (xu*ycb - xcb*yu) / (ru2*rcb)
c
c     compute first derivative components for this angle
c
            dedxia = zcb*dedyt - ycb*dedzt
            dedyia = xcb*dedzt - zcb*dedxt
            dedzia = ycb*dedxt - xcb*dedyt
            dedxib = yca*dedzt - zca*dedyt + zdc*dedyu - ydc*dedzu
            dedyib = zca*dedxt - xca*dedzt + xdc*dedzu - zdc*dedxu
            dedzib = xca*dedyt - yca*dedxt + ydc*dedxu - xdc*dedyu
            dedxic = zba*dedyt - yba*dedzt + ydb*dedzu - zdb*dedyu
            dedyic = xba*dedzt - zba*dedxt + zdb*dedxu - xdb*dedzu
            dedzic = yba*dedxt - xba*dedyt + xdb*dedyu - ydb*dedxu
            dedxid = zcb*dedyu - ycb*dedzu
            dedyid = xcb*dedzu - zcb*dedxu
            dedzid = ycb*dedxu - xcb*dedyu
c
c     calculate improper dihedral energy and derivatives
c
            eid = eid + e
            deid(1,ia) = deid(1,ia) + dedxia
            deid(2,ia) = deid(2,ia) + dedyia
            deid(3,ia) = deid(3,ia) + dedzia
            deid(1,ib) = deid(1,ib) + dedxib
            deid(2,ib) = deid(2,ib) + dedyib
            deid(3,ib) = deid(3,ib) + dedzib
            deid(1,ic) = deid(1,ic) + dedxic
            deid(2,ic) = deid(2,ic) + dedyic
            deid(3,ic) = deid(3,ic) + dedzic
            deid(1,id) = deid(1,id) + dedxid
            deid(2,id) = deid(2,id) + dedyid
            deid(3,id) = deid(3,id) + dedzid
c
c     increment the internal virial tensor components
c
            vxx = xcb*(dedxic+dedxid) - xba*dedxia + xdc*dedxid
            vyx = ycb*(dedxic+dedxid) - yba*dedxia + ydc*dedxid
            vzx = zcb*(dedxic+dedxid) - zba*dedxia + zdc*dedxid
            vyy = ycb*(dedyic+dedyid) - yba*dedyia + ydc*dedyid
            vzy = zcb*(dedyic+dedyid) - zba*dedyia + zdc*dedyid
            vzz = zcb*(dedzic+dedzid) - zba*dedzia + zdc*dedzid
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eimprop2  --  atomwise imp. dihedral Hessian  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "eimprop2" calculates second derivatives of the improper
c     dihedral angle energy for a single atom
c
c
      subroutine eimprop2 (i)
      use atoms
      use bound
      use group
      use hessn
      use improp
      use math
      use torpot
      implicit none
      integer i,kiprop
      integer ia,ib,ic,id
      real*8 eps,fgrp
      real*8 ideal,force
      real*8 angle,dt,term
      real*8 dedphi,d2edphi2
      real*8 sine,cosine
      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
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 xt,yt,zt,xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru,rcb
      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 xycb2,xzcb2,yzcb2
      real*8 rcbxt,rcbyt,rcbzt,rcbt2
      real*8 rcbxu,rcbyu,rcbzu,rcbu2
      real*8 dphidxibt,dphidyibt,dphidzibt
      real*8 dphidxibu,dphidyibu,dphidzibu
      real*8 dphidxict,dphidyict,dphidzict
      real*8 dphidxicu,dphidyicu,dphidzicu
      real*8 dxiaxia,dyiayia,dziazia
      real*8 dxibxib,dyibyib,dzibzib
      real*8 dxicxic,dyicyic,dziczic
      real*8 dxidxid,dyidyid,dzidzid
      real*8 dxiayia,dxiazia,dyiazia
      real*8 dxibyib,dxibzib,dyibzib
      real*8 dxicyic,dxiczic,dyiczic
      real*8 dxidyid,dxidzid,dyidzid
      real*8 dxiaxib,dxiayib,dxiazib
      real*8 dyiaxib,dyiayib,dyiazib
      real*8 dziaxib,dziayib,dziazib
      real*8 dxiaxic,dxiayic,dxiazic
      real*8 dyiaxic,dyiayic,dyiazic
      real*8 dziaxic,dziayic,dziazic
      real*8 dxiaxid,dxiayid,dxiazid
      real*8 dyiaxid,dyiayid,dyiazid
      real*8 dziaxid,dziayid,dziazid
      real*8 dxibxic,dxibyic,dxibzic
      real*8 dyibxic,dyibyic,dyibzic
      real*8 dzibxic,dzibyic,dzibzic
      real*8 dxibxid,dxibyid,dxibzid
      real*8 dyibxid,dyibyid,dyibzid
      real*8 dzibxid,dzibyid,dzibzid
      real*8 dxicxid,dxicyid,dxiczid
      real*8 dyicxid,dyicyid,dyiczid
      real*8 dzicxid,dzicyid,dziczid
      logical proceed
c
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     compute Hessian elements for the improper dihedral angles
c
      do kiprop = 1, niprop
         ia = iiprop(1,kiprop)
         ib = iiprop(2,kiprop)
         ic = iiprop(3,kiprop)
         id = iiprop(4,kiprop)
c
c     decide whether to compute the current interaction
c
         proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic .or. i.eq.id)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,id,0,0)
c
c     compute the value of the improper dihedral 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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
c
c     set the improper dihedral parameters for this angle
c
            ideal = vprop(kiprop)
            force = kprop(kiprop)
            if (abs(angle+ideal) .lt. abs(angle-ideal))
     &         ideal = -ideal
            dt = angle - ideal
            do while (dt .gt. 180.0d0)
               dt = dt - 360.0d0
            end do
            do while (dt .lt. -180.0d0)
               dt = dt + 360.0d0
            end do
c
c     calculate the improper torsion master chain rule terms
c
            term = 2.0d0 * radian * idihunit * force
            dedphi = term * dt
            d2edphi2 = radian * term
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               dedphi = dedphi * fgrp
               d2edphi2 = d2edphi2 * 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
            if (use_polymer) then
               call image (xca,yca,zca)
               call image (xdb,ydb,zdb)
            end if
            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     abbreviations for second derivative chain rule terms
c
            xycb2 = xcb*xcb + ycb*ycb
            xzcb2 = xcb*xcb + zcb*zcb
            yzcb2 = ycb*ycb + zcb*zcb
            rcbxt = -2.0d0 * rcb * dphidxt
            rcbyt = -2.0d0 * rcb * dphidyt
            rcbzt = -2.0d0 * rcb * dphidzt
            rcbt2 = rcb * rt2
            rcbxu = 2.0d0 * rcb * dphidxu
            rcbyu = 2.0d0 * rcb * dphidyu
            rcbzu = 2.0d0 * rcb * dphidzu
            rcbu2 = rcb * ru2
            dphidxibt = yca*dphidzt - zca*dphidyt
            dphidxibu = zdc*dphidyu - ydc*dphidzu
            dphidyibt = zca*dphidxt - xca*dphidzt
            dphidyibu = xdc*dphidzu - zdc*dphidxu
            dphidzibt = xca*dphidyt - yca*dphidxt
            dphidzibu = ydc*dphidxu - xdc*dphidyu
            dphidxict = zba*dphidyt - yba*dphidzt
            dphidxicu = ydb*dphidzu - zdb*dphidyu
            dphidyict = xba*dphidzt - zba*dphidxt
            dphidyicu = zdb*dphidxu - xdb*dphidzu
            dphidzict = yba*dphidxt - xba*dphidyt
            dphidzicu = xdb*dphidyu - ydb*dphidxu
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 = dphidxibt + dphidxibu
            dphidyib = dphidyibt + dphidyibu
            dphidzib = dphidzibt + dphidzibu
            dphidxic = dphidxict + dphidxicu
            dphidyic = dphidyict + dphidyicu
            dphidzic = dphidzict + dphidzicu
            dphidxid = zcb*dphidyu - ycb*dphidzu
            dphidyid = xcb*dphidzu - zcb*dphidxu
            dphidzid = ycb*dphidxu - xcb*dphidyu
c
c     chain rule terms for second derivative components
c
            dxiaxia = rcbxt*dphidxia
            dxiayia = rcbxt*dphidyia - zcb*rcb/rt2
            dxiazia = rcbxt*dphidzia + ycb*rcb/rt2
            dxiaxic = rcbxt*dphidxict + xcb*xt/rcbt2
            dxiayic = rcbxt*dphidyict - dphidzt
     &                   - (xba*zcb*xcb+zba*yzcb2)/rcbt2
            dxiazic = rcbxt*dphidzict + dphidyt
     &                   + (xba*ycb*xcb+yba*yzcb2)/rcbt2
            dxiaxid = 0.0d0
            dxiayid = 0.0d0
            dxiazid = 0.0d0
            dyiayia = rcbyt*dphidyia
            dyiazia = rcbyt*dphidzia - xcb*rcb/rt2
            dyiaxib = rcbyt*dphidxibt - dphidzt
     &                   - (yca*zcb*ycb+zca*xzcb2)/rcbt2
            dyiaxic = rcbyt*dphidxict + dphidzt
     &                   + (yba*zcb*ycb+zba*xzcb2)/rcbt2
            dyiayic = rcbyt*dphidyict + ycb*yt/rcbt2
            dyiazic = rcbyt*dphidzict - dphidxt
     &                   - (yba*xcb*ycb+xba*xzcb2)/rcbt2
            dyiaxid = 0.0d0
            dyiayid = 0.0d0
            dyiazid = 0.0d0
            dziazia = rcbzt*dphidzia
            dziaxib = rcbzt*dphidxibt + dphidyt
     &                   + (zca*ycb*zcb+yca*xycb2)/rcbt2
            dziayib = rcbzt*dphidyibt - dphidxt
     &                   - (zca*xcb*zcb+xca*xycb2)/rcbt2
            dziaxic = rcbzt*dphidxict - dphidyt
     &                   - (zba*ycb*zcb+yba*xycb2)/rcbt2
            dziayic = rcbzt*dphidyict + dphidxt
     &                   + (zba*xcb*zcb+xba*xycb2)/rcbt2
            dziazic = rcbzt*dphidzict + zcb*zt/rcbt2
            dziaxid = 0.0d0
            dziayid = 0.0d0
            dziazid = 0.0d0
            dxibxic = -xcb*dphidxib/(rcb*rcb)
     &          - (yca*(zba*xcb+yt)-zca*(yba*xcb-zt))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidxibt/rt2
     &          - (zdc*(ydb*xcb+zu)-ydc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidxibu/ru2
            dxibyic = -ycb*dphidxib/(rcb*rcb) + dphidzt + dphidzu
     &          - (yca*(zba*ycb-xt)+zca*(xba*xcb+zcb*zba))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidxibt/rt2
     &          + (zdc*(xdb*xcb+zcb*zdb)+ydc*(zdb*ycb+xu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidxibu/ru2
            dxibxid = rcbxu*dphidxibu + xcb*xu/rcbu2
            dxibyid = rcbyu*dphidxibu - dphidzu
     &                   - (ydc*zcb*ycb+zdc*xzcb2)/rcbu2
            dxibzid = rcbzu*dphidxibu + dphidyu
     &                   + (zdc*ycb*zcb+ydc*xycb2)/rcbu2
            dyibzib = ycb*dphidzib/(rcb*rcb)
     &          - (xca*(xca*xcb+zcb*zca)+yca*(ycb*xca+zt))/rcbt2
     &          - 2.0d0*(xt*zca-xca*zt)*dphidzibt/rt2
     &          + (ydc*(xdc*ycb-zu)+xdc*(xdc*xcb+zcb*zdc))/rcbu2
     &          + 2.0d0*(xu*zdc-xdc*zu)*dphidzibu/ru2
            dyibxic = -xcb*dphidyib/(rcb*rcb) - dphidzt - dphidzu
     &          + (xca*(zba*xcb+yt)+zca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidyibt/rt2
     &          - (zdc*(zdb*zcb+ycb*ydb)+xdc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidyibu/ru2
            dyibyic = -ycb*dphidyib/(rcb*rcb)
     &          - (zca*(xba*ycb+zt)-xca*(zba*ycb-xt))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidyibt/rt2
     &          - (xdc*(zdb*ycb+xu)-zdc*(xdb*ycb-zu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidyibu/ru2
            dyibxid = rcbxu*dphidyibu + dphidzu
     &                   + (xdc*zcb*xcb+zdc*yzcb2)/rcbu2
            dyibyid = rcbyu*dphidyibu + ycb*yu/rcbu2
            dyibzid = rcbzu*dphidyibu - dphidxu
     &                   - (zdc*xcb*zcb+xdc*xycb2)/rcbu2
            dzibxic = -xcb*dphidzib/(rcb*rcb) + dphidyt + dphidyu
     &          - (xca*(yba*xcb-zt)+yca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidzibt/rt2
     &          + (ydc*(zdb*zcb+ycb*ydb)+xdc*(ydb*xcb+zu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidzibu/ru2
            dzibzic = -zcb*dphidzib/(rcb*rcb)
     &          - (xca*(yba*zcb+xt)-yca*(xba*zcb-yt))/rcbt2
     &          - 2.0d0*(xt*yba-xba*yt)*dphidzibt/rt2
     &          - (ydc*(xdb*zcb+yu)-xdc*(ydb*zcb-xu))/rcbu2
     &          + 2.0d0*(xu*ydb-xdb*yu)*dphidzibu/ru2
            dzibxid = rcbxu*dphidzibu - dphidyu
     &                   - (xdc*ycb*xcb+ydc*yzcb2)/rcbu2
            dzibyid = rcbyu*dphidzibu + dphidxu
     &                   + (ydc*xcb*ycb+xdc*xzcb2)/rcbu2
            dzibzid = rcbzu*dphidzibu + zcb*zu/rcbu2
            dxicxid = rcbxu*dphidxicu - xcb*(zdb*ycb-ydb*zcb)/rcbu2
            dxicyid = rcbyu*dphidxicu + dphidzu
     &                   + (ydb*zcb*ycb+zdb*xzcb2)/rcbu2
            dxiczid = rcbzu*dphidxicu - dphidyu
     &                   - (zdb*ycb*zcb+ydb*xycb2)/rcbu2
            dyicxid = rcbxu*dphidyicu - dphidzu
     &                   - (xdb*zcb*xcb+zdb*yzcb2)/rcbu2
            dyicyid = rcbyu*dphidyicu - ycb*(xdb*zcb-zdb*xcb)/rcbu2
            dyiczid = rcbzu*dphidyicu + dphidxu
     &                   + (zdb*xcb*zcb+xdb*xycb2)/rcbu2
            dzicxid = rcbxu*dphidzicu + dphidyu
     &                   + (xdb*ycb*xcb+ydb*yzcb2)/rcbu2
            dzicyid = rcbyu*dphidzicu - dphidxu
     &                   - (ydb*xcb*ycb+xdb*xzcb2)/rcbu2
            dziczid = rcbzu*dphidzicu - zcb*(ydb*xcb-xdb*ycb)/rcbu2
            dxidxid = rcbxu*dphidxid
            dxidyid = rcbxu*dphidyid + zcb*rcb/ru2
            dxidzid = rcbxu*dphidzid - ycb*rcb/ru2
            dyidyid = rcbyu*dphidyid
            dyidzid = rcbyu*dphidzid + xcb*rcb/ru2
            dzidzid = rcbzu*dphidzid
c
c     get some second derivative chain rule terms by difference
c
            dxiaxib = -dxiaxia - dxiaxic - dxiaxid
            dxiayib = -dxiayia - dxiayic - dxiayid
            dxiazib = -dxiazia - dxiazic - dxiazid
            dyiayib = -dyiayia - dyiayic - dyiayid
            dyiazib = -dyiazia - dyiazic - dyiazid
            dziazib = -dziazia - dziazic - dziazid
            dxibxib = -dxiaxib - dxibxic - dxibxid
            dxibyib = -dyiaxib - dxibyic - dxibyid
            dxibzib = -dxiazib - dzibxic - dzibxid
            dxibzic = -dziaxib - dxibzib - dxibzid
            dyibyib = -dyiayib - dyibyic - dyibyid
            dyibzic = -dziayib - dyibzib - dyibzid
            dzibzib = -dziazib - dzibzic - dzibzid
            dzibyic = -dyiazib - dyibzib - dzibyid
            dxicxic = -dxiaxic - dxibxic - dxicxid
            dxicyic = -dyiaxic - dyibxic - dxicyid
            dxiczic = -dziaxic - dzibxic - dxiczid
            dyicyic = -dyiayic - dyibyic - dyicyid
            dyiczic = -dziayic - dzibyic - dyiczid
            dziczic = -dziazic - dzibzic - dziczid
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (i .eq. ia) then
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia
     &                          + d2edphi2*dphidxia*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia
     &                          + d2edphi2*dphidyia*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazia
     &                          + d2edphi2*dphidzia*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxia*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib
     &                          + d2edphi2*dphidyia*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib
     &                          + d2edphi2*dphidzia*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib
     &                          + d2edphi2*dphidxia*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib
     &                          + d2edphi2*dphidyia*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dziayib
     &                          + d2edphi2*dphidzia*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib
     &                          + d2edphi2*dphidxia*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib
     &                          + d2edphi2*dphidyia*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dziazib
     &                          + d2edphi2*dphidzia*dphidzib
               hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxia*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic
     &                          + d2edphi2*dphidyia*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic
     &                          + d2edphi2*dphidzia*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic
     &                          + d2edphi2*dphidxia*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic
     &                          + d2edphi2*dphidyia*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dziayic
     &                          + d2edphi2*dphidzia*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic
     &                          + d2edphi2*dphidxia*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic
     &                          + d2edphi2*dphidyia*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziazic
     &                          + d2edphi2*dphidzia*dphidzic
               hessx(1,id) = hessx(1,id) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxia*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyiaxid
     &                          + d2edphi2*dphidyia*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dziaxid
     &                          + d2edphi2*dphidzia*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxiayid
     &                          + d2edphi2*dphidxia*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyiayid
     &                          + d2edphi2*dphidyia*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dziayid
     &                          + d2edphi2*dphidzia*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiazid
     &                          + d2edphi2*dphidxia*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiazid
     &                          + d2edphi2*dphidyia*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dziazid
     &                          + d2edphi2*dphidzia*dphidzid
            else if (i .eq. ib) then
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib
     &                          + d2edphi2*dphidxib*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib
     &                          + d2edphi2*dphidyib*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib
     &                          + d2edphi2*dphidzib*dphidzib
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxib*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib
     &                          + d2edphi2*dphidyib*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib
     &                          + d2edphi2*dphidzib*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib
     &                          + d2edphi2*dphidxib*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib
     &                          + d2edphi2*dphidyib*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib
     &                          + d2edphi2*dphidzib*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib
     &                          + d2edphi2*dphidxib*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayib
     &                          + d2edphi2*dphidyib*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazib
     &                          + d2edphi2*dphidzib*dphidzia
               hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic
     &                          + d2edphi2*dphidxib*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic
     &                          + d2edphi2*dphidyib*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic
     &                          + d2edphi2*dphidzib*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic
     &                          + d2edphi2*dphidxib*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic
     &                          + d2edphi2*dphidyib*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic
     &                          + d2edphi2*dphidzib*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic
     &                          + d2edphi2*dphidxib*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic
     &                          + d2edphi2*dphidyib*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic
     &                          + d2edphi2*dphidzib*dphidzic
               hessx(1,id) = hessx(1,id) + dedphi*dxibxid
     &                          + d2edphi2*dphidxib*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyibxid
     &                          + d2edphi2*dphidyib*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dzibxid
     &                          + d2edphi2*dphidzib*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxibyid
     &                          + d2edphi2*dphidxib*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyibyid
     &                          + d2edphi2*dphidyib*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dzibyid
     &                          + d2edphi2*dphidzib*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxibzid
     &                          + d2edphi2*dphidxib*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyibzid
     &                          + d2edphi2*dphidyib*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzibzid
     &                          + d2edphi2*dphidzib*dphidzid
            else if (i .eq. ic) then
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic
     &                          + d2edphi2*dphidxic*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic
     &                          + d2edphi2*dphidyic*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczic
     &                          + d2edphi2*dphidzic*dphidzic
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxic*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic
     &                          + d2edphi2*dphidyic*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic
     &                          + d2edphi2*dphidzic*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic
     &                          + d2edphi2*dphidxic*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic
     &                          + d2edphi2*dphidyic*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic
     &                          + d2edphi2*dphidzic*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic
     &                          + d2edphi2*dphidxic*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayic
     &                          + d2edphi2*dphidyic*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazic
     &                          + d2edphi2*dphidzic*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic
     &                          + d2edphi2*dphidxic*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic
     &                          + d2edphi2*dphidyic*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic
     &                          + d2edphi2*dphidzic*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic
     &                          + d2edphi2*dphidxic*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic
     &                          + d2edphi2*dphidyic*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic
     &                          + d2edphi2*dphidzic*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic
     &                          + d2edphi2*dphidxic*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic
     &                          + d2edphi2*dphidyic*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic
     &                          + d2edphi2*dphidzic*dphidzib
               hessx(1,id) = hessx(1,id) + dedphi*dxicxid
     &                          + d2edphi2*dphidxic*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyicxid
     &                          + d2edphi2*dphidyic*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dzicxid
     &                          + d2edphi2*dphidzic*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxicyid
     &                          + d2edphi2*dphidxic*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyicyid
     &                          + d2edphi2*dphidyic*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dzicyid
     &                          + d2edphi2*dphidzic*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiczid
     &                          + d2edphi2*dphidxic*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiczid
     &                          + d2edphi2*dphidyic*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dziczid
     &                          + d2edphi2*dphidzic*dphidzid
            else if (i .eq. id) then
               hessx(1,id) = hessx(1,id) + dedphi*dxidxid
     &                          + d2edphi2*dphidxid*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessz(1,id) = hessz(1,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessx(2,id) = hessx(2,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyidyid
     &                          + d2edphi2*dphidyid*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessx(3,id) = hessx(3,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzidzid
     &                          + d2edphi2*dphidzid*dphidzid
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxid*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid
     &                          + d2edphi2*dphidyid*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid
     &                          + d2edphi2*dphidzid*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid
     &                          + d2edphi2*dphidxid*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid
     &                          + d2edphi2*dphidyid*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid
     &                          + d2edphi2*dphidzid*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid
     &                          + d2edphi2*dphidxid*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayid
     &                          + d2edphi2*dphidyid*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazid
     &                          + d2edphi2*dphidzid*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid
     &                          + d2edphi2*dphidxid*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid
     &                          + d2edphi2*dphidyid*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid
     &                          + d2edphi2*dphidzid*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid
     &                          + d2edphi2*dphidxid*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid
     &                          + d2edphi2*dphidyid*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid
     &                          + d2edphi2*dphidzid*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid
     &                          + d2edphi2*dphidxid*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid
     &                          + d2edphi2*dphidyid*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid
     &                          + d2edphi2*dphidzid*dphidzib
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid
     &                          + d2edphi2*dphidxid*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid
     &                          + d2edphi2*dphidyid*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid
     &                          + d2edphi2*dphidzid*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid
     &                          + d2edphi2*dphidxid*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid
     &                          + d2edphi2*dphidyid*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid
     &                          + d2edphi2*dphidzid*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid
     &                          + d2edphi2*dphidxid*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid
     &                          + d2edphi2*dphidyid*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczid
     &                          + d2edphi2*dphidzid*dphidzic
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eimprop3  --  imp. dihedral energy & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "eimprop3" calculates the improper dihedral potential
c     energy; also partitions the energy terms among the atoms
c
c
      subroutine eimprop3
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use energi
      use group
      use improp
      use inform
      use iounit
      use math
      use torpot
      use usage
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps,dt,fgrp
      real*8 ideal,force
      real*8 cosine,sine
      real*8 rcb,angle
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru
      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
      real*8 xdc,ydc,zdc
      logical proceed
      logical header,huge
c
c
c     zero out improper dihedral energy and partitioning terms
c
      neid = 0
      eid = 0.0d0
      do i = 1, n
         aeid(i) = 0.0d0
      end do
      if (niprop .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. niprop.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Improper Dihedral Interactions :',
     &           //,' Type',25x,'Atom Names',21x,'Angle',
     &              6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(niprop,iiprop,use,
!$OMP& x,y,z,kprop,vprop,idihunit,eps,use_group,use_polymer,
!$OMP& name,verbose,debug,header,iout)
!$OMP& shared(eid,neid,aeid)
!$OMP DO reduction(+:eid,neid,aeid)
c
c     calculate the improper dihedral angle energy term
c
      do i = 1, niprop
         ia = iiprop(1,i)
         ib = iiprop(2,i)
         ic = iiprop(3,i)
         id = iiprop(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the improper dihedral 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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
c
c     set the improper dihedral parameters for this angle
c
            ideal = vprop(i)
            force = kprop(i)
            if (abs(angle+ideal) .lt. abs(angle-ideal))
     &         ideal = -ideal
            dt = angle - ideal
            do while (dt .gt. 180.0d0)
               dt = dt - 360.0d0
            end do
            do while (dt .lt. -180.0d0)
               dt = dt + 360.0d0
            end do
c
c     calculate the improper dihedral energy
c
            e = idihunit * force * dt**2
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total improper dihedral energy
c
            neid = neid + 1
            eid = eid + e
            aeid(ib) = aeid(ib) + 0.5d0*e
            aeid(ic) = aeid(ic) + 0.5d0*e
c
c     print a message if the energy of this interaction is large
c
            huge = (e .gt. 5.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Individual Improper Dihedral',
     &                       ' Interactions :',
     &                    //,' Type',25x,'Atom Names',21x,'Angle',
     &                       6x,'Energy',/)
               end if
               write (iout,30)  ia,name(ia),ib,name(ib),ic,
     &                          name(ic),id,name(id),angle,e
   30          format (' Improper',2x,4(i7,'-',a3),f11.4,f12.4)
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #######################################################
c     ##                                                   ##
c     ##  subroutine eimptor  --  improper torsion energy  ##
c     ##                                                   ##
c     #######################################################
c
c
c     "eimptor" calculates the improper torsion potential energy
c
c
      subroutine eimptor
      use atoms
      use bound
      use energi
      use group
      use imptor
      use torpot
      use usage
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps
      real*8 rcb,fgrp
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 sine3,cosine3
      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
      real*8 xdc,ydc,zdc
      logical proceed
c
c
c     zero out improper torsional energy
c
      eit = 0.0d0
      if (nitors .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nitors,iitors,use,x,y,z,
!$OMP& itors1,itors2,itors3,itorunit,eps,use_group,use_polymer)
!$OMP& shared(eit)
!$OMP DO reduction(+:eit)
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,ia,ib,ic,id,0,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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            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)
c
c     calculate the improper torsional energy for this angle
c
            e = itorunit * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total torsional angle energy
c
            eit = eit + e
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
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 torsion energy and its
c     first derivatives with respect to Cartesian coordinates
c
c
      subroutine eimptor1
      use atoms
      use bound
      use deriv
      use energi
      use group
      use imptor
      use torpot
      use usage
      use virial
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps,rcb
      real*8 dedphi,fgrp
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 sine3,cosine3
      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
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 dphi1,dphi2,dphi3
      real*8 dedxt,dedyt,dedzt
      real*8 dedxu,dedyu,dedzu
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      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
      if (nitors .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nitors,iitors,use,x,y,z,
!$OMP& itors1,itors2,itors3,itorunit,eps,use_group,use_polymer)
!$OMP& shared(eit,deit,vir)
!$OMP DO reduction(+:eit,deit,vir)
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,ia,ib,ic,id,0,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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            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 = itorunit * (v1*phi1+v2*phi2+v3*phi3)
            dedphi = itorunit * (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     chain rule terms for first derivative components
c
            xca = xic - xia
            yca = yic - yia
            zca = zic - zia
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            if (use_polymer) then
               call image (xca,yca,zca)
               call image (xdb,ydb,zdb)
            end if
            dedxt = dedphi * (yt*zcb - ycb*zt) / (rt2*rcb)
            dedyt = dedphi * (zt*xcb - zcb*xt) / (rt2*rcb)
            dedzt = dedphi * (xt*ycb - xcb*yt) / (rt2*rcb)
            dedxu = -dedphi * (yu*zcb - ycb*zu) / (ru2*rcb)
            dedyu = -dedphi * (zu*xcb - zcb*xu) / (ru2*rcb)
            dedzu = -dedphi * (xu*ycb - xcb*yu) / (ru2*rcb)
c
c     compute first derivative components for this angle
c
            dedxia = zcb*dedyt - ycb*dedzt
            dedyia = xcb*dedzt - zcb*dedxt
            dedzia = ycb*dedxt - xcb*dedyt
            dedxib = yca*dedzt - zca*dedyt + zdc*dedyu - ydc*dedzu
            dedyib = zca*dedxt - xca*dedzt + xdc*dedzu - zdc*dedxu
            dedzib = xca*dedyt - yca*dedxt + ydc*dedxu - xdc*dedyu
            dedxic = zba*dedyt - yba*dedzt + ydb*dedzu - zdb*dedyu
            dedyic = xba*dedzt - zba*dedxt + zdb*dedxu - xdb*dedzu
            dedzic = yba*dedxt - xba*dedyt + xdb*dedyu - ydb*dedxu
            dedxid = zcb*dedyu - ycb*dedzu
            dedyid = xcb*dedzu - zcb*dedxu
            dedzid = ycb*dedxu - xcb*dedyu
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 internal virial tensor components
c
            vxx = xcb*(dedxic+dedxid) - xba*dedxia + xdc*dedxid
            vyx = ycb*(dedxic+dedxid) - yba*dedxia + ydc*dedxid
            vzx = zcb*(dedxic+dedxid) - zba*dedxia + zdc*dedxid
            vyy = ycb*(dedyic+dedyid) - yba*dedyia + ydc*dedyid
            vzy = zcb*(dedyic+dedyid) - zba*dedyia + zdc*dedyid
            vzz = zcb*(dedzic+dedzid) - zba*dedzia + zdc*dedzid
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eimptor2  --  atomwise impr. torsion Hessian  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "eimptor2" calculates second derivatives of the improper
c     torsion energy for a single atom
c
c
      subroutine eimptor2 (i)
      use atoms
      use bound
      use group
      use hessn
      use imptor
      use torpot
      implicit none
      integer i,kitors
      integer ia,ib,ic,id
      real*8 eps,rcb,fgrp
      real*8 dedphi,d2edphi2
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 sine3,cosine3
      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
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 xt,yt,zt,xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru
      real*8 dphi1,dphi2,dphi3
      real*8 d2phi1,d2phi2,d2phi3
      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 xycb2,xzcb2,yzcb2
      real*8 rcbxt,rcbyt,rcbzt,rcbt2
      real*8 rcbxu,rcbyu,rcbzu,rcbu2
      real*8 dphidxibt,dphidyibt,dphidzibt
      real*8 dphidxibu,dphidyibu,dphidzibu
      real*8 dphidxict,dphidyict,dphidzict
      real*8 dphidxicu,dphidyicu,dphidzicu
      real*8 dxiaxia,dyiayia,dziazia
      real*8 dxibxib,dyibyib,dzibzib
      real*8 dxicxic,dyicyic,dziczic
      real*8 dxidxid,dyidyid,dzidzid
      real*8 dxiayia,dxiazia,dyiazia
      real*8 dxibyib,dxibzib,dyibzib
      real*8 dxicyic,dxiczic,dyiczic
      real*8 dxidyid,dxidzid,dyidzid
      real*8 dxiaxib,dxiayib,dxiazib
      real*8 dyiaxib,dyiayib,dyiazib
      real*8 dziaxib,dziayib,dziazib
      real*8 dxiaxic,dxiayic,dxiazic
      real*8 dyiaxic,dyiayic,dyiazic
      real*8 dziaxic,dziayic,dziazic
      real*8 dxiaxid,dxiayid,dxiazid
      real*8 dyiaxid,dyiayid,dyiazid
      real*8 dziaxid,dziayid,dziazid
      real*8 dxibxic,dxibyic,dxibzic
      real*8 dyibxic,dyibyic,dyibzic
      real*8 dzibxic,dzibyic,dzibzic
      real*8 dxibxid,dxibyid,dxibzid
      real*8 dyibxid,dyibyid,dyibzid
      real*8 dzibxid,dzibyid,dzibzid
      real*8 dxicxid,dxicyid,dxiczid
      real*8 dyicxid,dyicyid,dyiczid
      real*8 dzicxid,dzicyid,dziczid
      logical proceed
c
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     compute Hessian elements for the improper torsional angles
c
      do kitors = 1, nitors
         ia = iitors(1,kitors)
         ib = iitors(2,kitors)
         ic = iitors(3,kitors)
         id = iitors(4,kitors)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (i.eq.ia .or. i.eq.ib .or.
     &                              i.eq.ic .or. i.eq.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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            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,kitors)
            c1 = itors1(3,kitors)
            s1 = itors1(4,kitors)
            v2 = itors2(1,kitors)
            c2 = itors2(3,kitors)
            s2 = itors2(4,kitors)
            v3 = itors3(1,kitors)
            c3 = itors3(3,kitors)
            s3 = itors3(4,kitors)
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
            dphi1 = (cosine*s1 - sine*c1)
            dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2)
            dphi3 = 3.0d0 * (cosine3*s3 - sine3*c3)
            d2phi1 = -(cosine*c1 + sine*s1)
            d2phi2 = -4.0d0 * (cosine2*c2 + sine2*s2)
            d2phi3 = -9.0d0 * (cosine3*c3 + sine3*s3)
c
c     calculate the improper torsion master chain rule terms
c
            dedphi = itorunit * (v1*dphi1+v2*dphi2+v3*dphi3)
            d2edphi2 = itorunit * (v1*d2phi1+v2*d2phi2+v3*d2phi3)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               dedphi = dedphi * fgrp
               d2edphi2 = d2edphi2 * 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
            if (use_polymer) then
               call image (xca,yca,zca)
               call image (xdb,ydb,zdb)
            end if
            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     abbreviations for second derivative chain rule terms
c
            xycb2 = xcb*xcb + ycb*ycb
            xzcb2 = xcb*xcb + zcb*zcb
            yzcb2 = ycb*ycb + zcb*zcb
            rcbxt = -2.0d0 * rcb * dphidxt
            rcbyt = -2.0d0 * rcb * dphidyt
            rcbzt = -2.0d0 * rcb * dphidzt
            rcbt2 = rcb * rt2
            rcbxu = 2.0d0 * rcb * dphidxu
            rcbyu = 2.0d0 * rcb * dphidyu
            rcbzu = 2.0d0 * rcb * dphidzu
            rcbu2 = rcb * ru2
            dphidxibt = yca*dphidzt - zca*dphidyt
            dphidxibu = zdc*dphidyu - ydc*dphidzu
            dphidyibt = zca*dphidxt - xca*dphidzt
            dphidyibu = xdc*dphidzu - zdc*dphidxu
            dphidzibt = xca*dphidyt - yca*dphidxt
            dphidzibu = ydc*dphidxu - xdc*dphidyu
            dphidxict = zba*dphidyt - yba*dphidzt
            dphidxicu = ydb*dphidzu - zdb*dphidyu
            dphidyict = xba*dphidzt - zba*dphidxt
            dphidyicu = zdb*dphidxu - xdb*dphidzu
            dphidzict = yba*dphidxt - xba*dphidyt
            dphidzicu = xdb*dphidyu - ydb*dphidxu
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 = dphidxibt + dphidxibu
            dphidyib = dphidyibt + dphidyibu
            dphidzib = dphidzibt + dphidzibu
            dphidxic = dphidxict + dphidxicu
            dphidyic = dphidyict + dphidyicu
            dphidzic = dphidzict + dphidzicu
            dphidxid = zcb*dphidyu - ycb*dphidzu
            dphidyid = xcb*dphidzu - zcb*dphidxu
            dphidzid = ycb*dphidxu - xcb*dphidyu
c
c     chain rule terms for second derivative components
c
            dxiaxia = rcbxt*dphidxia
            dxiayia = rcbxt*dphidyia - zcb*rcb/rt2
            dxiazia = rcbxt*dphidzia + ycb*rcb/rt2
            dxiaxic = rcbxt*dphidxict + xcb*xt/rcbt2
            dxiayic = rcbxt*dphidyict - dphidzt
     &                   - (xba*zcb*xcb+zba*yzcb2)/rcbt2
            dxiazic = rcbxt*dphidzict + dphidyt
     &                   + (xba*ycb*xcb+yba*yzcb2)/rcbt2
            dxiaxid = 0.0d0
            dxiayid = 0.0d0
            dxiazid = 0.0d0
            dyiayia = rcbyt*dphidyia
            dyiazia = rcbyt*dphidzia - xcb*rcb/rt2
            dyiaxib = rcbyt*dphidxibt - dphidzt
     &                   - (yca*zcb*ycb+zca*xzcb2)/rcbt2
            dyiaxic = rcbyt*dphidxict + dphidzt
     &                   + (yba*zcb*ycb+zba*xzcb2)/rcbt2
            dyiayic = rcbyt*dphidyict + ycb*yt/rcbt2
            dyiazic = rcbyt*dphidzict - dphidxt
     &                   - (yba*xcb*ycb+xba*xzcb2)/rcbt2
            dyiaxid = 0.0d0
            dyiayid = 0.0d0
            dyiazid = 0.0d0
            dziazia = rcbzt*dphidzia
            dziaxib = rcbzt*dphidxibt + dphidyt
     &                   + (zca*ycb*zcb+yca*xycb2)/rcbt2
            dziayib = rcbzt*dphidyibt - dphidxt
     &                   - (zca*xcb*zcb+xca*xycb2)/rcbt2
            dziaxic = rcbzt*dphidxict - dphidyt
     &                   - (zba*ycb*zcb+yba*xycb2)/rcbt2
            dziayic = rcbzt*dphidyict + dphidxt
     &                   + (zba*xcb*zcb+xba*xycb2)/rcbt2
            dziazic = rcbzt*dphidzict + zcb*zt/rcbt2
            dziaxid = 0.0d0
            dziayid = 0.0d0
            dziazid = 0.0d0
            dxibxic = -xcb*dphidxib/(rcb*rcb)
     &          - (yca*(zba*xcb+yt)-zca*(yba*xcb-zt))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidxibt/rt2
     &          - (zdc*(ydb*xcb+zu)-ydc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidxibu/ru2
            dxibyic = -ycb*dphidxib/(rcb*rcb) + dphidzt + dphidzu
     &          - (yca*(zba*ycb-xt)+zca*(xba*xcb+zcb*zba))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidxibt/rt2
     &          + (zdc*(xdb*xcb+zcb*zdb)+ydc*(zdb*ycb+xu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidxibu/ru2
            dxibxid = rcbxu*dphidxibu + xcb*xu/rcbu2
            dxibyid = rcbyu*dphidxibu - dphidzu
     &                   - (ydc*zcb*ycb+zdc*xzcb2)/rcbu2
            dxibzid = rcbzu*dphidxibu + dphidyu
     &                   + (zdc*ycb*zcb+ydc*xycb2)/rcbu2
            dyibzib = ycb*dphidzib/(rcb*rcb)
     &          - (xca*(xca*xcb+zcb*zca)+yca*(ycb*xca+zt))/rcbt2
     &          - 2.0d0*(xt*zca-xca*zt)*dphidzibt/rt2
     &          + (ydc*(xdc*ycb-zu)+xdc*(xdc*xcb+zcb*zdc))/rcbu2
     &          + 2.0d0*(xu*zdc-xdc*zu)*dphidzibu/ru2
            dyibxic = -xcb*dphidyib/(rcb*rcb) - dphidzt - dphidzu
     &          + (xca*(zba*xcb+yt)+zca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidyibt/rt2
     &          - (zdc*(zdb*zcb+ycb*ydb)+xdc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidyibu/ru2
            dyibyic = -ycb*dphidyib/(rcb*rcb)
     &          - (zca*(xba*ycb+zt)-xca*(zba*ycb-xt))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidyibt/rt2
     &          - (xdc*(zdb*ycb+xu)-zdc*(xdb*ycb-zu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidyibu/ru2
            dyibxid = rcbxu*dphidyibu + dphidzu
     &                   + (xdc*zcb*xcb+zdc*yzcb2)/rcbu2
            dyibyid = rcbyu*dphidyibu + ycb*yu/rcbu2
            dyibzid = rcbzu*dphidyibu - dphidxu
     &                   - (zdc*xcb*zcb+xdc*xycb2)/rcbu2
            dzibxic = -xcb*dphidzib/(rcb*rcb) + dphidyt + dphidyu
     &          - (xca*(yba*xcb-zt)+yca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidzibt/rt2
     &          + (ydc*(zdb*zcb+ycb*ydb)+xdc*(ydb*xcb+zu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidzibu/ru2
            dzibzic = -zcb*dphidzib/(rcb*rcb)
     &          - (xca*(yba*zcb+xt)-yca*(xba*zcb-yt))/rcbt2
     &          - 2.0d0*(xt*yba-xba*yt)*dphidzibt/rt2
     &          - (ydc*(xdb*zcb+yu)-xdc*(ydb*zcb-xu))/rcbu2
     &          + 2.0d0*(xu*ydb-xdb*yu)*dphidzibu/ru2
            dzibxid = rcbxu*dphidzibu - dphidyu
     &                   - (xdc*ycb*xcb+ydc*yzcb2)/rcbu2
            dzibyid = rcbyu*dphidzibu + dphidxu
     &                   + (ydc*xcb*ycb+xdc*xzcb2)/rcbu2
            dzibzid = rcbzu*dphidzibu + zcb*zu/rcbu2
            dxicxid = rcbxu*dphidxicu - xcb*(zdb*ycb-ydb*zcb)/rcbu2
            dxicyid = rcbyu*dphidxicu + dphidzu
     &                   + (ydb*zcb*ycb+zdb*xzcb2)/rcbu2
            dxiczid = rcbzu*dphidxicu - dphidyu
     &                   - (zdb*ycb*zcb+ydb*xycb2)/rcbu2
            dyicxid = rcbxu*dphidyicu - dphidzu
     &                   - (xdb*zcb*xcb+zdb*yzcb2)/rcbu2
            dyicyid = rcbyu*dphidyicu - ycb*(xdb*zcb-zdb*xcb)/rcbu2
            dyiczid = rcbzu*dphidyicu + dphidxu
     &                   + (zdb*xcb*zcb+xdb*xycb2)/rcbu2
            dzicxid = rcbxu*dphidzicu + dphidyu
     &                   + (xdb*ycb*xcb+ydb*yzcb2)/rcbu2
            dzicyid = rcbyu*dphidzicu - dphidxu
     &                   - (ydb*xcb*ycb+xdb*xzcb2)/rcbu2
            dziczid = rcbzu*dphidzicu - zcb*(ydb*xcb-xdb*ycb)/rcbu2
            dxidxid = rcbxu*dphidxid
            dxidyid = rcbxu*dphidyid + zcb*rcb/ru2
            dxidzid = rcbxu*dphidzid - ycb*rcb/ru2
            dyidyid = rcbyu*dphidyid
            dyidzid = rcbyu*dphidzid + xcb*rcb/ru2
            dzidzid = rcbzu*dphidzid
c
c     get some second derivative chain rule terms by difference
c
            dxiaxib = -dxiaxia - dxiaxic - dxiaxid
            dxiayib = -dxiayia - dxiayic - dxiayid
            dxiazib = -dxiazia - dxiazic - dxiazid
            dyiayib = -dyiayia - dyiayic - dyiayid
            dyiazib = -dyiazia - dyiazic - dyiazid
            dziazib = -dziazia - dziazic - dziazid
            dxibxib = -dxiaxib - dxibxic - dxibxid
            dxibyib = -dyiaxib - dxibyic - dxibyid
            dxibzib = -dxiazib - dzibxic - dzibxid
            dxibzic = -dziaxib - dxibzib - dxibzid
            dyibyib = -dyiayib - dyibyic - dyibyid
            dyibzic = -dziayib - dyibzib - dyibzid
            dzibzib = -dziazib - dzibzic - dzibzid
            dzibyic = -dyiazib - dyibzib - dzibyid
            dxicxic = -dxiaxic - dxibxic - dxicxid
            dxicyic = -dyiaxic - dyibxic - dxicyid
            dxiczic = -dziaxic - dzibxic - dxiczid
            dyicyic = -dyiayic - dyibyic - dyicyid
            dyiczic = -dziayic - dzibyic - dyiczid
            dziczic = -dziazic - dzibzic - dziczid
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (i .eq. ia) then
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia
     &                          + d2edphi2*dphidxia*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia
     &                          + d2edphi2*dphidyia*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazia
     &                          + d2edphi2*dphidzia*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxia*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib
     &                          + d2edphi2*dphidyia*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib
     &                          + d2edphi2*dphidzia*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib
     &                          + d2edphi2*dphidxia*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib
     &                          + d2edphi2*dphidyia*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dziayib
     &                          + d2edphi2*dphidzia*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib
     &                          + d2edphi2*dphidxia*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib
     &                          + d2edphi2*dphidyia*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dziazib
     &                          + d2edphi2*dphidzia*dphidzib
               hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxia*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic
     &                          + d2edphi2*dphidyia*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic
     &                          + d2edphi2*dphidzia*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic
     &                          + d2edphi2*dphidxia*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic
     &                          + d2edphi2*dphidyia*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dziayic
     &                          + d2edphi2*dphidzia*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic
     &                          + d2edphi2*dphidxia*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic
     &                          + d2edphi2*dphidyia*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziazic
     &                          + d2edphi2*dphidzia*dphidzic
               hessx(1,id) = hessx(1,id) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxia*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyiaxid
     &                          + d2edphi2*dphidyia*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dziaxid
     &                          + d2edphi2*dphidzia*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxiayid
     &                          + d2edphi2*dphidxia*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyiayid
     &                          + d2edphi2*dphidyia*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dziayid
     &                          + d2edphi2*dphidzia*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiazid
     &                          + d2edphi2*dphidxia*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiazid
     &                          + d2edphi2*dphidyia*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dziazid
     &                          + d2edphi2*dphidzia*dphidzid
            else if (i .eq. ib) then
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib
     &                          + d2edphi2*dphidxib*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib
     &                          + d2edphi2*dphidyib*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib
     &                          + d2edphi2*dphidzib*dphidzib
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxib*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib
     &                          + d2edphi2*dphidyib*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib
     &                          + d2edphi2*dphidzib*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib
     &                          + d2edphi2*dphidxib*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib
     &                          + d2edphi2*dphidyib*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib
     &                          + d2edphi2*dphidzib*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib
     &                          + d2edphi2*dphidxib*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayib
     &                          + d2edphi2*dphidyib*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazib
     &                          + d2edphi2*dphidzib*dphidzia
               hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic
     &                          + d2edphi2*dphidxib*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic
     &                          + d2edphi2*dphidyib*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic
     &                          + d2edphi2*dphidzib*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic
     &                          + d2edphi2*dphidxib*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic
     &                          + d2edphi2*dphidyib*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic
     &                          + d2edphi2*dphidzib*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic
     &                          + d2edphi2*dphidxib*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic
     &                          + d2edphi2*dphidyib*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic
     &                          + d2edphi2*dphidzib*dphidzic
               hessx(1,id) = hessx(1,id) + dedphi*dxibxid
     &                          + d2edphi2*dphidxib*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyibxid
     &                          + d2edphi2*dphidyib*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dzibxid
     &                          + d2edphi2*dphidzib*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxibyid
     &                          + d2edphi2*dphidxib*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyibyid
     &                          + d2edphi2*dphidyib*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dzibyid
     &                          + d2edphi2*dphidzib*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxibzid
     &                          + d2edphi2*dphidxib*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyibzid
     &                          + d2edphi2*dphidyib*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzibzid
     &                          + d2edphi2*dphidzib*dphidzid
            else if (i .eq. ic) then
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic
     &                          + d2edphi2*dphidxic*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic
     &                          + d2edphi2*dphidyic*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczic
     &                          + d2edphi2*dphidzic*dphidzic
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxic*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic
     &                          + d2edphi2*dphidyic*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic
     &                          + d2edphi2*dphidzic*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic
     &                          + d2edphi2*dphidxic*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic
     &                          + d2edphi2*dphidyic*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic
     &                          + d2edphi2*dphidzic*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic
     &                          + d2edphi2*dphidxic*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayic
     &                          + d2edphi2*dphidyic*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazic
     &                          + d2edphi2*dphidzic*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic
     &                          + d2edphi2*dphidxic*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic
     &                          + d2edphi2*dphidyic*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic
     &                          + d2edphi2*dphidzic*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic
     &                          + d2edphi2*dphidxic*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic
     &                          + d2edphi2*dphidyic*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic
     &                          + d2edphi2*dphidzic*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic
     &                          + d2edphi2*dphidxic*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic
     &                          + d2edphi2*dphidyic*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic
     &                          + d2edphi2*dphidzic*dphidzib
               hessx(1,id) = hessx(1,id) + dedphi*dxicxid
     &                          + d2edphi2*dphidxic*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyicxid
     &                          + d2edphi2*dphidyic*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dzicxid
     &                          + d2edphi2*dphidzic*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxicyid
     &                          + d2edphi2*dphidxic*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyicyid
     &                          + d2edphi2*dphidyic*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dzicyid
     &                          + d2edphi2*dphidzic*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiczid
     &                          + d2edphi2*dphidxic*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiczid
     &                          + d2edphi2*dphidyic*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dziczid
     &                          + d2edphi2*dphidzic*dphidzid
            else if (i .eq. id) then
               hessx(1,id) = hessx(1,id) + dedphi*dxidxid
     &                          + d2edphi2*dphidxid*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessz(1,id) = hessz(1,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessx(2,id) = hessx(2,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyidyid
     &                          + d2edphi2*dphidyid*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessx(3,id) = hessx(3,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzidzid
     &                          + d2edphi2*dphidzid*dphidzid
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxid*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid
     &                          + d2edphi2*dphidyid*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid
     &                          + d2edphi2*dphidzid*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid
     &                          + d2edphi2*dphidxid*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid
     &                          + d2edphi2*dphidyid*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid
     &                          + d2edphi2*dphidzid*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid
     &                          + d2edphi2*dphidxid*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayid
     &                          + d2edphi2*dphidyid*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazid
     &                          + d2edphi2*dphidzid*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid
     &                          + d2edphi2*dphidxid*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid
     &                          + d2edphi2*dphidyid*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid
     &                          + d2edphi2*dphidzid*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid
     &                          + d2edphi2*dphidxid*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid
     &                          + d2edphi2*dphidyid*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid
     &                          + d2edphi2*dphidzid*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid
     &                          + d2edphi2*dphidxid*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid
     &                          + d2edphi2*dphidyid*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid
     &                          + d2edphi2*dphidzid*dphidzib
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid
     &                          + d2edphi2*dphidxid*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid
     &                          + d2edphi2*dphidyid*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid
     &                          + d2edphi2*dphidzid*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid
     &                          + d2edphi2*dphidxid*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid
     &                          + d2edphi2*dphidyid*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid
     &                          + d2edphi2*dphidzid*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid
     &                          + d2edphi2*dphidxid*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid
     &                          + d2edphi2*dphidyid*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczid
     &                          + d2edphi2*dphidzid*dphidzic
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eimptor3  --  impr. torsion energy & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "eimptor3" calculates the improper torsion potential energy;
c     also partitions the energy terms among the atoms
c
c
      subroutine eimptor3
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use energi
      use group
      use imptor
      use inform
      use iounit
      use math
      use torpot
      use usage
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps,rcb
      real*8 angle,fgrp
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 sine3,cosine3
      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
      real*8 xdc,ydc,zdc
      logical proceed
      logical header,huge
c
c
c     zero out the torsional energy and partitioning terms
c
      neit = 0
      eit = 0.0d0
      do i = 1, n
         aeit(i) = 0.0d0
      end do
      if (nitors .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nitors.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Improper Torsion Interactions :',
     &           //,' Type',25x,'Atom Names',21x,'Angle',
     &              6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nitors,iitors,use,x,y,z,
!$OMP& itors1,itors2,itors3,itorunit,eps,use_group,use_polymer,
!$OMP& name,verbose,debug,header,iout)
!$OMP& shared(eit,neit,aeit)
!$OMP DO reduction(+:eit,neit,aeit)
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,ia,ib,ic,id,0,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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
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)
c
c     calculate the improper torsional energy for this angle
c
            e = itorunit * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total torsional angle energy
c
            neit = neit + 1
            eit = eit + e
            aeit(ib) = aeit(ib) + 0.5d0*e
            aeit(ic) = aeit(ic) + 0.5d0*e
c
c     print a message if the energy of this interaction is large
c
            huge = (e .gt. 5.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Individual Improper Torsion',
     &                       ' Interactions :',
     &                    //,' Type',25x,'Atom Names',21x,'Angle',
     &                       6x,'Energy',/)
               end if
               write (iout,30)  ia,name(ia),ib,name(ib),ic,
     &                          name(ic),id,name(id),angle,e
   30          format (' Improper',2x,4(i7,'-',a3),f11.4,f12.4)
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine elj  --  Lennard-Jones van der Waals energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "elj" calculates the Lennard-Jones 6-12 van der Waals energy
c
c
      subroutine elj
      use energi
      use limits
      use vdwpot
      use warp
      implicit none
      real*8 elrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_stophat) then
         call elj0e
      else if (use_smooth) then
         call elj0d
      else if (use_vlist) then
         call elj0c
      else if (use_lights) then
         call elj0b
      else
         call elj0a
      end if
c
c     apply the long range van der Waals correction if used
c
      if (use_vcorr) then
         mode = 'VDW'
         call evcorr (mode,elrc)
         ev = ev + elrc
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine elj0a  --  double loop Lennard-Jones vdw energy  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "elj0a" calculates the Lennard-Jones 6-12 van der Waals energy
c     using a pairwise double loop
c
c
      subroutine elj0a
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use energi
      use group
      use mutant
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,p6,p12
      real*8 eps,sc,term
      real*8 rv,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     p6 = 2.0d0 * rik2**3 / rv**6
                     sc = p6 + 0.5d0*(1.0d0-vlambda)
                     term = 4.0d0 * vlambda * eps / (sc*sc)
                     e = term * (1.0d0-sc)
                  else
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     e = eps * (p12 - 2.0d0*p6)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component
c
                  ev = ev + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
c
c     set use of lambda scaling for decoupling or annihilation
c
                     mutik = .false.
                     if (muti .or. mutk) then
                        if (vcouple .eq. 1) then
                           mutik = .true.
                        else if (.not.muti .or. .not.mutk) then
                           mutik = .true.
                        end if
                     end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                     if (mutik) then
                        p6 = 2.0d0 * rik2**3 / rv**6
                        sc = p6 + 0.5d0*(1.0d0-vlambda)
                        term = 4.0d0 * vlambda * eps / (sc*sc)
                        e = term * (1.0d0-sc)
                     else
                        p6 = rv**6 / rik2**3
                        p12 = p6 * p6
                        e = eps * (p12 - 2.0d0*p6)
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik = sqrt(rik2)
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component;
c     interaction of an atom with its own image counts half
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ev = ev + e
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine elj0b  --  Lennard-Jones vdw energy via lights  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "elj0b" calculates the Lennard-Jones 6-12 van der Waals energy
c     using the method of lights
c
c
      subroutine elj0b
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use couple
      use energi
      use group
      use light
      use mutant
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer kgy,kgz
      integer start,stop
      integer, allocatable :: iv14(:)
      real*8 e,p6,p12
      real*8 eps,sc,term
      real*8 rv,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rv = radmin4(kt,it)
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     p6 = 2.0d0 * rik2**3 / rv**6
                     sc = p6 + 0.5d0*(1.0d0-vlambda)
                     term = 4.0d0 * vlambda * eps / (sc*sc)
                     e = term * (1.0d0-sc)
                  else
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     e = eps * (p12 - 2.0d0*p6)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component
c
                  ev = ev + e
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine elj0c  --  Lennard-Jones vdw energy via list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "elj0c" calculates the Lennard-Jones 6-12 van der Waals energy
c     using a pairwise neighbor list
c
c
      subroutine elj0c
      use atomid
      use atoms
      use bound
      use couple
      use energi
      use group
      use mutant
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,p6,p12
      real*8 eps,sc,term
      real*8 rv,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13,
!$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group,off2,
!$OMP& radmin,epsilon,radmin4,epsilon4,vcouple,vlambda,mut,
!$OMP& cut2,c0,c1,c2,c3,c4,c5) firstprivate(vscale,iv14)
!$OMP& shared(ev)
!$OMP DO reduction(+:ev)
c
c     find the van der Waals energy via neighbor list search
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     p6 = 2.0d0 * rik2**3 / rv**6
                     sc = p6 + 0.5d0*(1.0d0-vlambda)
                     term = 4.0d0 * vlambda * eps / (sc*sc)
                     e = term * (1.0d0-sc)
                  else
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     e = eps * (p12 - 2.0d0*p6)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine elj0d  --  Lennard-Jones energy for smoothing  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "elj0d" calculates the Lennard-Jones 6-12 van der Waals energy
c     via a Gaussian approximation for potential energy smoothing
c
c
      subroutine elj0d
      use math
      use vdwpot
      implicit none
c
c
c     set coefficients for a two-Gaussian fit to Lennard-Jones
c
      ngauss = 2
      igauss(1,1) = 14487.1d0
      igauss(2,1) = 9.05148d0 * twosix**2
      igauss(1,2) = -5.55338d0
      igauss(2,2) = 1.22536d0 * twosix**2
c
c     compute Gaussian approximation to Lennard-Jones potential
c
      call egauss
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine elj0e  --  Lennard-Jones energy for stophat  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "elj0e" calculates the Lennard-Jones 6-12 van der Waals energy
c     for use with stophat potential energy smoothing
c
c
      subroutine elj0e
      use atomid
      use atoms
      use couple
      use energi
      use group
      use usage
      use vdw
      use vdwpot
      use warp
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,rik2,rdn,p6
      real*8 eps,rv,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik3,rik4
      real*8 rik5,rik6
      real*8 width,width2
      real*8 width3,width4
      real*8 width5,width6
      real*8, allocatable :: vscale(:)
      logical proceed,usei
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the extent of smoothing to be performed
c
      width = deform * diffv
      width2 = width * width
      width3 = width2 * width
      width4 = width2 * width2
      width5 = width2 * width3
      width6 = width3 * width3
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               rik2 = xr*xr + yr*yr + zr*zr
               eps = epsilon(kt,it)
               rv = radmin(kt,it)
               if (iv14(k) .eq. i) then
                  eps = epsilon4(kt,it)
                  rv = radmin4(kt,it)
               end if
               eps = eps * vscale(k)
               p6 = rv**6
               rik = sqrt(rik2)
               rik3 = rik2 * rik
               rik4 = rik2 * rik2
               rik5 = rik2 * rik3
               rik6 = rik3 * rik3
c
c     transform the potential function via smoothing
c
               e = rik6 * (30.0d0*rik6 + 360.0d0*rik5*width
     &                + 1800.0d0*rik4*width2 + 4800.0d0*rik3*width3
     &                + 7200.0d0*rik2*width4 + 5760.0d0*rik*width5
     &                + 1920.0d0*width6)
               e = -e + p6 * (15.0d0*rik6 + 90.0d0*rik5*width
     &                + 288.0d0*rik4*width2 + 552.0d0*rik3*width3
     &                + 648.0d0*rik2*width4 + 432.0d0*rik*width5
     &                + 128.0d0*width6)
               e = e*eps*p6 / (15.0d0*(rik*(rik+2.0d0*width))**9)
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
               ev = ev + e
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine elj1  --  Lennard-Jones energy & derivatives  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "elj1" calculates the Lennard-Jones 6-12 van der Waals energy
c     and its first derivatives with respect to Cartesian coordinates
c
c
      subroutine elj1
      use energi
      use limits
      use vdwpot
      use virial
      use warp
      implicit none
      real*8 elrc,vlrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_stophat) then
         call elj1e
      else if (use_smooth) then
         call elj1d
      else if (use_vlist) then
         call elj1c
      else if (use_lights) then
         call elj1b
      else
         call elj1a
      end if
c
c     apply the long range van der Waals correction if used
c
      if (use_vcorr) then
         mode = 'VDW'
         call evcorr1 (mode,elrc,vlrc)
         ev = ev + elrc
         vir(1,1) = vir(1,1) + vlrc
         vir(2,2) = vir(2,2) + vlrc
         vir(3,3) = vir(3,3) + vlrc
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine elj1a  --  double loop Lennard-Jones vdw derivs  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "elj1a" calculates the Lennard-Jones 6-12 van der Waals energy
c     and its first derivatives using a pairwise double loop
c
c
      subroutine elj1a
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use deriv
      use energi
      use group
      use mutant
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,de,p6,p12
      real*8 eps,sc
      real*8 term,dterm
      real*8 rv,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 taper,dtaper
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find van der Waals energy and derivatives via double loop
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  rik = sqrt(rik2)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     p6 = 2.0d0 * rik2**3 / rv**6
                     sc = p6 + 0.5d0*(1.0d0-vlambda)
                     term = 4.0d0 * vlambda * eps / (sc*sc)
                     e = term * (1.0d0-sc)
                     dterm = -6.0d0 * p6 * term / rik
                     de = dterm * (1.0d0+2.0d0*(1.0d0-sc)/sc)
                  else
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     e = eps * (p12 - 2.0d0*p6)
                     de = eps * (p12-p6) * (-12.0d0/rik)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     rik = sqrt(rik2)
c
c     set use of lambda scaling for decoupling or annihilation
c
                     mutik = .false.
                     if (muti .or. mutk) then
                        if (vcouple .eq. 1) then
                           mutik = .true.
                        else if (.not.muti .or. .not.mutk) then
                           mutik = .true.
                        end if
                     end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                     if (mutik) then
                        p6 = 2.0d0 * rik2**3 / rv**6
                        sc = p6 + 0.5d0*(1.0d0-vlambda)
                         term = 4.0d0 * vlambda * eps / (sc*sc)
                        e = term * (1.0d0-sc)
                        dterm = -6.0d0 * p6 * term / rik
                        de = dterm * (1.0d0+2.0d0*(1.0d0-sc)/sc)
                     else
                        p6 = rv**6 / rik2**3
                        p12 = p6 * p6
                        e = eps * (p12 - 2.0d0*p6)
                        de = eps * (p12-p6) * (-12.0d0/rik)
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                              + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                        de = e*dtaper + de*taper
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        e = e * fgrp
                        de = de * fgrp
                     end if
c
c     find the chain rule terms for derivative components
c
                     de = de / rik
                     dedx = de * xr
                     dedy = de * yr
                     dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ev = ev + e
                     if (i .eq. iv) then
                        dev(1,i) = dev(1,i) + dedx
                        dev(2,i) = dev(2,i) + dedy
                        dev(3,i) = dev(3,i) + dedz
                     else
                        dev(1,i) = dev(1,i) + dedx*redi
                        dev(2,i) = dev(2,i) + dedy*redi
                        dev(3,i) = dev(3,i) + dedz*redi
                        dev(1,iv) = dev(1,iv) + dedx*rediv
                        dev(2,iv) = dev(2,iv) + dedy*rediv
                        dev(3,iv) = dev(3,iv) + dedz*rediv
                     end if
                     if (i .ne. k) then
                        if (k .eq. kv) then
                           dev(1,k) = dev(1,k) - dedx
                           dev(2,k) = dev(2,k) - dedy
                           dev(3,k) = dev(3,k) - dedz
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           dev(1,k) = dev(1,k) - dedx*redk
                           dev(2,k) = dev(2,k) - dedy*redk
                           dev(3,k) = dev(3,k) - dedz*redk
                           dev(1,kv) = dev(1,kv) - dedx*redkv
                           dev(2,kv) = dev(2,kv) - dedy*redkv
                           dev(3,kv) = dev(3,kv) - dedz*redkv
                        end if
                     end if
c
c     increment the internal virial tensor components
c
                     vxx = xr * dedx
                     vyx = yr * dedx
                     vzx = zr * dedx
                     vyy = yr * dedy
                     vzy = zr * dedy
                     vzz = zr * dedz
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine elj1b  --  Lennard-Jones vdw derivs via lights  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "elj1b" calculates the Lennard-Jones 6-12 van der Waals energy
c     and its first derivatives using the method of lights
c
c
      subroutine elj1b
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use couple
      use deriv
      use energi
      use group
      use light
      use mutant
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer kgy,kgz
      integer start,stop
      integer, allocatable :: iv14(:)
      real*8 e,de,p6,p12
      real*8 eps,sc
      real*8 term,dterm
      real*8 rv,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 taper,dtaper
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rv = radmin4(kt,it)
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
                  rik = sqrt(rik2)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     p6 = 2.0d0 * rik2**3 / rv**6
                     sc = p6 + 0.5d0*(1.0d0-vlambda)
                     term = 4.0d0 * vlambda * eps / (sc*sc)
                     e = term * (1.0d0-sc)
                     dterm = -6.0d0 * p6 * term / rik
                     de = dterm * (1.0d0+2.0d0*(1.0d0-sc)/sc)
                  else
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     e = eps * (p12 - 2.0d0*p6)
                     de = eps * (p12-p6) * (-12.0d0/rik)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine elj1c  --  Lennard-Jones vdw derivs via list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "elj1c" calculates the Lennard-Jones 12-6 van der Waals energy
c     and its first derivatives using a pairwise neighbor list
c
c
      subroutine elj1c
      use atomid
      use atoms
      use bound
      use couple
      use deriv
      use energi
      use group
      use mutant
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,de,p6,p12
      real*8 eps,sc
      real*8 term,dterm
      real*8 rv,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 taper,dtaper
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,kred,
!$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13,i14,
!$OMP& i15,v2scale,v3scale,v4scale,v5scale,use_group,off2,radmin,
!$OMP& epsilon,radmin4,epsilon4,vcouple,vlambda,mut,cut2,c0,c1,
!$OMP& c2,c3,c4,c5) firstprivate(vscale,iv14)
!$OMP& shared(ev,dev,vir)
!$OMP DO reduction(+:ev,dev,vir)
c
c     find van der Waals energy and derivatives via neighbor list
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  rik = sqrt(rik2)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     p6 = 2.0d0 * rik2**3 / rv**6
                     sc = p6 + 0.5d0*(1.0d0-vlambda)
                     term = 4.0d0 * vlambda * eps / (sc*sc)
                     e = term * (1.0d0-sc)
                     dterm = -6.0d0 * p6 * term / rik
                     de = dterm * (1.0d0+2.0d0*(1.0d0-sc)/sc)
                  else
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     e = eps * (p12 - 2.0d0*p6)
                     de = eps * (p12-p6) * (-12.0d0/rik)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine elj1d  --  Lennard-Jones derivs for smoothing  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "elj1d" calculates the Lennard-Jones 6-12 van der Waals energy
c      and its first derivatives via a Gaussian approximation for
c      potential energy smoothing
c
c
      subroutine elj1d
      use math
      use vdwpot
      implicit none
c
c
c     set coefficients for a two-Gaussian fit to Lennard-Jones
c
      ngauss = 2
      igauss(1,1) = 14487.1d0
      igauss(2,1) = 9.05148d0 * twosix**2
      igauss(1,2) = -5.55338d0
      igauss(2,2) = 1.22536d0 * twosix**2
c
c     compute Gaussian approximation to Lennard-Jones potential
c
      call egauss1
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine elj1e  --  Lennard-Jones derivs for stophat  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "elj1e" calculates the van der Waals interaction energy and its
c     first derivatives for use with stophat potential energy smoothing
c
c
      subroutine elj1e
      use atomid
      use atoms
      use couple
      use deriv
      use energi
      use group
      use usage
      use vdw
      use vdwpot
      use warp
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,de,rdn
      real*8 p6,denom
      real*8 eps,rv,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rik,rik2
      real*8 rik3,rik4
      real*8 rik5,rik6
      real*8 rik7,rik8
      real*8 width,width2
      real*8 width3,width4
      real*8 width5,width6
      real*8 width7
      real*8, allocatable :: vscale(:)
      logical proceed,usei
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         vscale(i) = 1.0d0
         iv14(i) = 0
      end do
c
c     set the extent of smoothing to be performed
c
      width = deform * diffv
      width2 = width * width
      width3 = width2 * width
      width4 = width2 * width2
      width5 = width2 * width3
      width6 = width3 * width3
      width7 = width3 * width4
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find van der Waals energy and derivatives via double loop
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               rik2 = xr*xr + yr*yr + zr*zr
               eps = epsilon(kt,it)
               rv = radmin(kt,it)
               if (iv14(k) .eq. i) then
                  eps = epsilon4(kt,it)
                  rv = radmin4(kt,it)
               end if
               eps = eps * vscale(k)
               p6 = rv**6
               rik = sqrt(rik2)
               rik3 = rik2 * rik
               rik4 = rik2 * rik2
               rik5 = rik2 * rik3
               rik6 = rik3 * rik3
               rik7 = rik3 * rik4
               rik8 = rik4 * rik4
               denom = rik*(rik+2.0d0*width)
               denom = denom**9
c
c     transform the potential function via smoothing
c
               e = rik5 * (30.0d0*rik7 + 360.0d0*rik6*width
     &                + 1800.0d0*rik5*width2 + 4800.0d0*rik4*width3
     &                + 7200.0d0*rik3*width4 + 5760.0d0*rik2*width5
     &                + 1920.0d0*rik*width6)
               e = -e + p6 * (15.0d0*rik6 + 90.0d0*rik5*width
     &                + 288.0d0*rik4*width2 + 552.0d0*rik3*width3
     &                + 648.0d0*rik2*width4 + 432.0d0*rik*width5
     &                + 128.0d0*width6)
               e = e*eps*p6 / (15.0d0*denom)
               de = rik5 * (5.0d0*rik8 + 65.0d0*rik7*width
     &                 + 360.0d0*rik6*width2 + 1100.0d0*rik5*width3
     &                 + 2000.0d0*rik4*width4 + 2160.0d0*rik3*width5
     &                 + 1280.0d0*rik2*width6 + 320.0d0*rik*width7)
               de = de - p6 * (5.0d0*rik7 + 35.0d0*rik6*width
     &                 + 132.0d0*rik5*width2 + 310.0d0*rik4*width3
     &                 + 472.0d0*rik3*width4 + 456.0d0*rik2*width5
     &                 + 256.0d0*rik*width6 + 64.0d0*width7)
               de = 12.0d0*de*eps*p6
     &                 / (5.0d0*denom*rik*(rik+2.0d0*width))
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  e = e * fgrp
                  de = de * fgrp
               end if
c
c     find the chain rule terms for derivative components
c
               de = de / rik
               dedx = de * xr
               dedy = de * yr
               dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
               ev = ev + e
               if (i .eq. iv) then
                  dev(1,i) = dev(1,i) + dedx
                  dev(2,i) = dev(2,i) + dedy
                  dev(3,i) = dev(3,i) + dedz
               else
                  dev(1,i) = dev(1,i) + dedx*redi
                  dev(2,i) = dev(2,i) + dedy*redi
                  dev(3,i) = dev(3,i) + dedz*redi
                  dev(1,iv) = dev(1,iv) + dedx*rediv
                  dev(2,iv) = dev(2,iv) + dedy*rediv
                  dev(3,iv) = dev(3,iv) + dedz*rediv
               end if
               if (k .eq. kv) then
                  dev(1,k) = dev(1,k) - dedx
                  dev(2,k) = dev(2,k) - dedy
                  dev(3,k) = dev(3,k) - dedz
               else
                  redk = kred(k)
                  redkv = 1.0d0 - redk
                  dev(1,k) = dev(1,k) - dedx*redk
                  dev(2,k) = dev(2,k) - dedy*redk
                  dev(3,k) = dev(3,k) - dedz*redk
                  dev(1,kv) = dev(1,kv) - dedx*redkv
                  dev(2,kv) = dev(2,kv) - dedy*redkv
                  dev(3,kv) = dev(3,kv) - dedz*redkv
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine elj2  --  atom-by-atom Lennard-Jones Hessian  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "elj2" calculates the Lennard-Jones 6-12 van der Waals second
c     derivatives for a single atom at a time
c
c
      subroutine elj2 (i)
      use warp
      implicit none
      integer i
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_stophat) then
         call elj2c (i)
      else if (use_smooth) then
         call elj2b (i)
      else
         call elj2a (i)
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine elj2a  --  double loop Lennard-Jones Hessian  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "elj2a" calculates the Lennard-Jones 6-12 van der Waals second
c     derivatives using a double loop over relevant atom pairs
c
c
      subroutine elj2a (iatom)
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use group
      use hessn
      use shunt
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer iatom,jcell
      integer nlist,list(5)
      integer, allocatable :: iv14(:)
      real*8 e,de,d2e
      real*8 fgrp,p6,p12
      real*8 eps,rv,rdn
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 redi2,rediv2
      real*8 rediiv
      real*8 redik,redivk
      real*8 redikv,redivkv
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 taper,dtaper
      real*8 d2taper
      real*8 d2edx,d2edy,d2edz
      real*8 term(3,3)
      real*8, allocatable :: vscale(:)
      logical proceed
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         vscale(i) = 1.0d0
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     check to see if the atom of interest is a vdw site
c
      nlist = 0
      do k = 1, nvdw
         if (ivdw(k) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = iatom
            goto 10
         end if
      end do
      return
   10 continue
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     determine the atoms involved via reduction factors
c
      nlist = 1
      list(nlist) = iatom
      do k = 1, n12(iatom)
         i = i12(k,iatom)
         if (ired(i) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = i
         end if
      end do
c
c     find van der Waals Hessian elements for involved atoms
c
      do ii = 1, nlist
         i = list(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         if (i .ne. iv) then
            rediv = 1.0d0 - redi
            redi2 = redi * redi
            rediv2 = rediv * rediv
            rediiv = redi * rediv
         end if
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (k .ne. i)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  rik = sqrt(rik2)
                  p6 = rv**6 / rik2**3
                  p12 = p6 * p6
                  de = eps * (p12-p6) * (-12.0d0/rik)
                  d2e = eps * (13.0d0*p12-7.0d0*p6) * (12.0d0/rik2)
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     e = eps * (p12-2.0d0*p6)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2
     &                            + 6.0d0*c3*rik + 2.0d0*c2
                     d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper
                     de = e*dtaper + de*taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     de = de * fgrp
                     d2e = d2e * fgrp
                  end if
c
c     get chain rule terms for van der Waals Hessian elements
c
                  de = de / rik
                  d2e = (d2e-de) / rik2
                  d2edx = d2e * xr
                  d2edy = d2e * yr
                  d2edz = d2e * zr
                  term(1,1) = d2edx*xr + de
                  term(1,2) = d2edx*yr
                  term(1,3) = d2edx*zr
                  term(2,1) = term(1,2)
                  term(2,2) = d2edy*yr + de
                  term(2,3) = d2edy*zr
                  term(3,1) = term(1,3)
                  term(3,2) = term(2,3)
                  term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                  if (i .eq. iatom) then
                     if (i.eq.iv .and. k.eq.kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)
                           hessy(j,i) = hessy(j,i) + term(2,j)
                           hessz(j,i) = hessz(j,i) + term(3,j)
                           hessx(j,k) = hessx(j,k) - term(1,j)
                           hessy(j,k) = hessy(j,k) - term(2,j)
                           hessz(j,k) = hessz(j,k) - term(3,j)
                        end do
                     else if (k .eq. kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                           hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                           hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                           hessx(j,k) = hessx(j,k) - term(1,j)*redi
                           hessy(j,k) = hessy(j,k) - term(2,j)*redi
                           hessz(j,k) = hessz(j,k) - term(3,j)*redi
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                        end do
                     else if (i .eq. iv) then
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)
                           hessy(j,i) = hessy(j,i) + term(2,j)
                           hessz(j,i) = hessz(j,i) + term(3,j)
                           hessx(j,k) = hessx(j,k) - term(1,j)*redk
                           hessy(j,k) = hessy(j,k) - term(2,j)*redk
                           hessz(j,k) = hessz(j,k) - term(3,j)*redk
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv
                        end do
                     else
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        redik = redi * redk
                        redikv = redi * redkv
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                           hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                           hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                           hessx(j,k) = hessx(j,k) - term(1,j)*redik
                           hessy(j,k) = hessy(j,k) - term(2,j)*redik
                           hessz(j,k) = hessz(j,k) - term(3,j)*redik
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv
                        end do
                     end if
                  else if (iv .eq. iatom) then
                     if (k .eq. kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                           hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                           hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                           hessx(j,k) = hessx(j,k) - term(1,j)*rediv
                           hessy(j,k) = hessy(j,k) - term(2,j)*rediv
                           hessz(j,k) = hessz(j,k) - term(3,j)*rediv
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                        end do
                     else
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        redivk = rediv * redk
                        redivkv = rediv * redkv
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                           hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                           hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                           hessx(j,k) = hessx(j,k) - term(1,j)*redivk
                           hessy(j,k) = hessy(j,k) - term(2,j)*redivk
                           hessz(j,k) = hessz(j,k) - term(3,j)*redivk
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv
                        end do
                     end if
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nlist
         i = list(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         if (i .ne. iv) then
            rediv = 1.0d0 - redi
            redi2 = redi * redi
            rediv2 = rediv * rediv
            rediiv = redi * rediv
         end if
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               do jcell = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,jcell)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     rik = sqrt(rik2)
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     de = eps * (p12-p6) * (-12.0d0/rik)
                     d2e = eps * (13.0d0*p12-7.0d0*p6) * (12.0d0/rik2)
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        e = eps * (p12-2.0d0*p6)
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                        d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2
     &                             + 6.0d0*c3*rik + 2.0d0*c2
                        d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper
                        de = e*dtaper + de*taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        de = de * fgrp
                        d2e = d2e * fgrp
                     end if
c
c     get chain rule terms for van der Waals Hessian elements
c
                     de = de / rik
                     d2e = (d2e-de) / rik2
                     d2edx = d2e * xr
                     d2edy = d2e * yr
                     d2edz = d2e * zr
                     term(1,1) = d2edx*xr + de
                     term(1,2) = d2edx*yr
                     term(1,3) = d2edx*zr
                     term(2,1) = term(1,2)
                     term(2,2) = d2edy*yr + de
                     term(2,3) = d2edy*zr
                     term(3,1) = term(1,3)
                     term(3,2) = term(2,3)
                     term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                     if (i .eq. iatom) then
                        if (i.eq.iv .and. k.eq.kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)
                              hessy(j,i) = hessy(j,i) + term(2,j)
                              hessz(j,i) = hessz(j,i) + term(3,j)
                              hessx(j,k) = hessx(j,k) - term(1,j)
                              hessy(j,k) = hessy(j,k) - term(2,j)
                              hessz(j,k) = hessz(j,k) - term(3,j)
                           end do
                        else if (k .eq. kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                              hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                              hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                              hessx(j,k) = hessx(j,k) - term(1,j)*redi
                              hessy(j,k) = hessy(j,k) - term(2,j)*redi
                              hessz(j,k) = hessz(j,k) - term(3,j)*redi
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediiv
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediiv
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediiv
                           end do
                        else if (i .eq. iv) then
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)
                              hessy(j,i) = hessy(j,i) + term(2,j)
                              hessz(j,i) = hessz(j,i) + term(3,j)
                              hessx(j,k) = hessx(j,k) - term(1,j)*redk
                              hessy(j,k) = hessy(j,k) - term(2,j)*redk
                              hessz(j,k) = hessz(j,k) - term(3,j)*redk
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redkv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redkv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redkv
                           end do
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           redik = redi * redk
                           redikv = redi * redkv
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                              hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                              hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                              hessx(j,k) = hessx(j,k) - term(1,j)*redik
                              hessy(j,k) = hessy(j,k) - term(2,j)*redik
                              hessz(j,k) = hessz(j,k) - term(3,j)*redik
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediiv
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediiv
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediiv
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redikv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redikv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redikv
                           end do
                        end if
                     else if (iv .eq. iatom) then
                        if (k .eq. kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                              hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                              hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                              hessx(j,k) = hessx(j,k) - term(1,j)*rediv
                              hessy(j,k) = hessy(j,k) - term(2,j)*rediv
                              hessz(j,k) = hessz(j,k) - term(3,j)*rediv
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediv2
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediv2
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediv2
                           end do
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           redivk = rediv * redk
                           redivkv = rediv * redkv
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                              hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                              hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                              hessx(j,k) = hessx(j,k) - term(1,j)*redivk
                              hessy(j,k) = hessy(j,k) - term(2,j)*redivk
                              hessz(j,k) = hessz(j,k) - term(3,j)*redivk
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediv2
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediv2
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediv2
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redivkv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redivkv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redivkv
                           end do
                        end if
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine elj2b  --  Lennard-Jones Hessian for smoothing  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "elj2b" calculates the Lennard-Jones 6-12 van der Waals second
c     derivatives via a Gaussian approximation for use with potential
c     energy smoothing
c
c
      subroutine elj2b (i)
      use math
      use vdwpot
      implicit none
      integer i
c
c
c     set coefficients for a two-Gaussian fit to Lennard-Jones
c
      ngauss = 2
      igauss(1,1) = 14487.1d0
      igauss(2,1) = 9.05148d0 * twosix**2
      igauss(1,2) = -5.55338d0
      igauss(2,2) = 1.22536d0 * twosix**2
c
c     compute Gaussian approximation to Lennard-Jones potential
c
      call egauss2 (i)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine elj2c  --  Lennard-Jones Hessian for stophat  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "elj2c" calculates the Lennard-Jones 6-12 van der Waals second
c     derivatives for use with stophat potential energy smoothing
c
c
      subroutine elj2c (iatom)
      use atomid
      use atoms
      use couple
      use group
      use hessn
      use vdw
      use vdwpot
      use warp
      implicit none
      integer i,j,k,iatom
      integer ii,it,iv
      integer kk,kt,kv
      integer nlist,list(5)
      integer, allocatable :: iv14(:)
      real*8 de,d2e
      real*8 fgrp,p6,denom
      real*8 eps,rv,rdn
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 redi2,rediv2
      real*8 rediiv
      real*8 redik,redivk
      real*8 redikv,redivkv
      real*8 rik,rik2
      real*8 rik3,rik4
      real*8 rik5,rik6
      real*8 rik7,rik8
      real*8 width,width2
      real*8 width3,width4
      real*8 width5,width6
      real*8 width7,width8
      real*8 d2edx,d2edy,d2edz
      real*8 term(3,3)
      real*8, allocatable :: vscale(:)
      logical proceed
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         vscale(i) = 1.0d0
         iv14(i) = 0
      end do
c
c     check to see if the atom of interest is a vdw site
c
      nlist = 0
      do k = 1, nvdw
         if (ivdw(k) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = iatom
            goto 10
         end if
      end do
      return
   10 continue
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     determine the atoms involved via reduction factors
c
      nlist = 1
      list(nlist) = iatom
      do k = 1, n12(iatom)
         i = i12(k,iatom)
         if (ired(i) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = i
         end if
      end do
c
c     set the extent of smoothing to be performed
c
      width = deform * diffv
      width2 = width * width
      width3 = width2 * width
      width4 = width2 * width2
      width5 = width2 * width3
      width6 = width3 * width3
      width7 = width3 * width4
      width8 = width4 * width4
c
c     find van der Waals Hessian elements for involved atoms
c
      do ii = 1, nlist
         i = list(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         if (i .ne. iv) then
            rediv = 1.0d0 - redi
            redi2 = redi * redi
            rediv2 = rediv * rediv
            rediiv = redi * rediv
         end if
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (k .ne. i)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               rik2 = xr*xr + yr*yr + zr*zr
               rv = radmin(kt,it)
               eps = epsilon(kt,it)
               if (iv14(k) .eq. i) then
                  rv = radmin4(kt,it)
                  eps = epsilon4(kt,it)
               end if
               eps = eps * vscale(k)
               p6 = rv**6
               rik = sqrt(rik2)
               rik3 = rik2 * rik
               rik4 = rik2 * rik2
               rik5 = rik2 * rik3
               rik6 = rik3 * rik3
               rik7 = rik3 * rik4
               rik8 = rik4 * rik4
               denom = rik * (rik+2.0d0*width)
               denom = denom**10
c
c     transform the potential function via smoothing
c
               de = rik5 * (5.0d0*rik8 + 65.0d0*rik7*width
     &                 + 360.0d0*rik6*width2 + 1100.0d0*rik5*width3
     &                 + 2000.0d0*rik4*width4 + 2160.0d0*rik3*width5
     &                 + 1280.0d0*rik2*width6 + 320.0d0*rik*width7)
               de = de - p6 * (5.0d0*rik7 + 35.0d0*rik6*width
     &                 + 132.0d0*rik5*width2 + 310.0d0*rik4*width3
     &                 + 472.0d0*rik3*width4 + 456.0d0*rik2*width5
     &                 + 256.0d0*rik*width6 + 64.0d0*width7)
               de = de*eps*p6*12.0d0 / (5.0d0*denom)
               d2e = rik6 * (35.0d0*rik8 +  490.0d0*rik7*width
     &                  + 2980.0d0*rik6*width2 + 10280.0d0*rik5*width3
     &                  + 22000.0d0*rik4*width4 + 29920.0d0*rik3*width5
     &                  + 25280.0d0*rik2*width6 + 12160.0d0*rik*width7
     &                  + 2560.0d0*width8)
               d2e = d2e - p6 * (65.0d0*rik8 + 520.0d0*rik7*width
     &                  + 2260.0d0*rik6*width2 + 6280.0d0*rik5*width3
     &                  + 11744.0d0*rik4*width4 + 14816.0d0*rik3*width5
     &                  + 12160.0d0*rik2*width6 + 5888.0d0*rik*width7
     &                  + 1280.0d0*width8)
               d2e = -12.0d0*p6*eps*d2e
     &                  / (5.0d0*denom*rik*(rik+2.0d0*width))
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  de = de * fgrp
                  d2e = d2e * fgrp
               end if
c
c     get chain rule terms for van der Waals Hessian elements
c
               de = de / rik
               d2e = (d2e-de) / rik2
               d2edx = d2e * xr
               d2edy = d2e * yr
               d2edz = d2e * zr
               term(1,1) = d2edx*xr + de
               term(1,2) = d2edx*yr
               term(1,3) = d2edx*zr
               term(2,1) = term(1,2)
               term(2,2) = d2edy*yr + de
               term(2,3) = d2edy*zr
               term(3,1) = term(1,3)
               term(3,2) = term(2,3)
               term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
               if (i .eq. iatom) then
                  if (i.eq.iv .and. k.eq.kv) then
                     do j = 1, 3
                        hessx(j,i) = hessx(j,i) + term(1,j)
                        hessy(j,i) = hessy(j,i) + term(2,j)
                        hessz(j,i) = hessz(j,i) + term(3,j)
                        hessx(j,k) = hessx(j,k) - term(1,j)
                        hessy(j,k) = hessy(j,k) - term(2,j)
                        hessz(j,k) = hessz(j,k) - term(3,j)
                     end do
                  else if (k .eq. kv) then
                     do j = 1, 3
                        hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                        hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                        hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                        hessx(j,k) = hessx(j,k) - term(1,j)*redi
                        hessy(j,k) = hessy(j,k) - term(2,j)*redi
                        hessz(j,k) = hessz(j,k) - term(3,j)*redi
                        hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                        hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                        hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                     end do
                  else if (i .eq. iv) then
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     do j = 1, 3
                        hessx(j,i) = hessx(j,i) + term(1,j)
                        hessy(j,i) = hessy(j,i) + term(2,j)
                        hessz(j,i) = hessz(j,i) + term(3,j)
                        hessx(j,k) = hessx(j,k) - term(1,j)*redk
                        hessy(j,k) = hessy(j,k) - term(2,j)*redk
                        hessz(j,k) = hessz(j,k) - term(3,j)*redk
                        hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv
                        hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv
                        hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv
                     end do
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     redik = redi * redk
                     redikv = redi * redkv
                     do j = 1, 3
                        hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                        hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                        hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                        hessx(j,k) = hessx(j,k) - term(1,j)*redik
                        hessy(j,k) = hessy(j,k) - term(2,j)*redik
                        hessz(j,k) = hessz(j,k) - term(3,j)*redik
                        hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                        hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                        hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                        hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv
                        hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv
                        hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv
                     end do
                  end if
               else if (iv .eq. iatom) then
                  if (k .eq. kv) then
                     do j = 1, 3
                        hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                        hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                        hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                        hessx(j,k) = hessx(j,k) - term(1,j)*rediv
                        hessy(j,k) = hessy(j,k) - term(2,j)*rediv
                        hessz(j,k) = hessz(j,k) - term(3,j)*rediv
                        hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                        hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                        hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                     end do
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     redivk = rediv * redk
                     redivkv = rediv * redkv
                     do j = 1, 3
                        hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                        hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                        hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                        hessx(j,k) = hessx(j,k) - term(1,j)*redivk
                        hessy(j,k) = hessy(j,k) - term(2,j)*redivk
                        hessz(j,k) = hessz(j,k) - term(3,j)*redivk
                        hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                        hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                        hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                        hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv
                        hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv
                        hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv
                     end do
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine elj3  --  Lennard-Jones vdw energy & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "elj3" calculates the Lennard-Jones 6-12 van der Waals energy
c     and also partitions the energy among the atoms
c
c
      subroutine elj3
      use analyz
      use atoms
      use energi
      use inform
      use iounit
      use limits
      use vdwpot
      use warp
      implicit none
      integer i
      real*8 elrc,aelrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_stophat) then
         call elj3e
      else if (use_smooth) then
         call elj3d
      else if (use_vlist) then
         call elj3c
      else if (use_lights) then
         call elj3b
      else
         call elj3a
      end if
c
c     apply the long range van der Waals correction if used
c
      if (use_vcorr) then
         mode = 'VDW'
         call evcorr (mode,elrc)
         ev = ev + elrc
         aelrc = elrc / dble(n)
         do i = 1, n
            aev(i) = aev(i) + aelrc
         end do
         if (verbose .and. elrc.ne.0.0d0) then
            if (digits .ge. 8) then
               write (iout,10)  elrc
   10          format (/,' Long-Range van der Waals :',6x,f16.8)
            else if (digits .ge. 6) then
               write (iout,20)  elrc
   20          format (/,' Long-Range van der Waals :',6x,f16.6)
            else
               write (iout,30)  elrc
   30          format (/,' Long-Range van der Waals :',6x,f16.4)
            end if
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine elj3a  --  double loop Lennard-Jones analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "elj3a" calculates the Lennard-Jones 6-12 van der Waals
c     energy and also partitions the energy among the atoms using
c     a pairwise double loop
c
c
      subroutine elj3a
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mutant
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,p6,p12
      real*8 eps,sc,term
      real*8 rv,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical header,huge
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     p6 = 2.0d0 * rik2**3 / rv**6
                     sc = p6 + 0.5d0*(1.0d0-vlambda)
                     term = 4.0d0 * vlambda * eps / (sc*sc)
                     e = term * (1.0d0-sc)
                  else
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     e = eps * (p12 - 2.0d0*p6)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   30                format (' VDW-LJ',4x,2(i7,'-',a3),
     &                          13x,2f10.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
c
c     set use of lambda scaling for decoupling or annihilation
c
                     mutik = .false.
                     if (muti .or. mutk) then
                        if (vcouple .eq. 1) then
                           mutik = .true.
                        else if (.not.muti .or. .not.mutk) then
                           mutik = .true.
                        end if
                     end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                     if (mutik) then
                        p6 = 2.0d0 * rik2**3 / rv**6
                        sc = p6 + 0.5d0*(1.0d0-vlambda)
                        term = 4.0d0 * vlambda * eps / (sc*sc)
                        e = term * (1.0d0-sc)
                     else
                        p6 = rv**6 / rik2**3
                        p12 = p6 * p6
                        e = eps * (p12 - 2.0d0*p6)
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik = sqrt(rik2)
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                                + c2*rik2 + c1*rik + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                     if (e .ne. 0.0d0) then
                        nev = nev + 1
                        if (i .eq. k) then
                           ev = ev + 0.5d0*e
                           aev(i) = aev(i) + 0.5d0*e
                        else
                           ev = ev + e
                           aev(i) = aev(i) + 0.5d0*e
                           aev(k) = aev(k) + 0.5d0*e
                        end if
                     end if
c
c     increment the total intermolecular energy
c
                     einter = einter + e
c
c     print a message if the energy of this interaction is large
c
                     huge = (e .gt. 10.0d0)
                     if ((debug.and.e.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual van der Waals',
     &                                ' Interactions :',
     &                             //,' Type',14x,'Atom Names',
     &                                20x,'Minimum',4x,'Actual',
     &                                6x,'Energy',/)
                        end if
                        write (iout,50)  i,name(i),k,name(k),
     &                                   rv,sqrt(rik2),e
   50                   format (' VDW-LJ',4x,2(i7,'-',a3),1x,
     &                             '(XTAL)',6x,2f10.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine elj3b  --  Lennard-Jones analysis via lights  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "elj3b" calculates the Lennard-Jones 6-12 van der Waals
c     energy and also partitions the energy among the atoms using
c     the method of lights
c
c
      subroutine elj3b
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use boxes
      use cell
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use light
      use molcul
      use mutant
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer kgy,kgz
      integer start,stop
      integer ikmin,ikmax
      integer, allocatable :: iv14(:)
      real*8 e,p6,p12
      real*8 eps,sc,term
      real*8 rv,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      logical header,huge
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   20    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 60
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 60
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 60
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 60
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rv = radmin4(kt,it)
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     p6 = 2.0d0 * rik2**3 / rv**6
                     sc = p6 + 0.5d0*(1.0d0-vlambda)
                     term = 4.0d0 * vlambda * eps / (sc*sc)
                     e = term * (1.0d0-sc)
                  else
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     e = eps * (p12 - 2.0d0*p6)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (.not.prime .or. molcule(i).ne.molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,30)
   30                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     ikmin = min(i,k)
                     ikmax = max(i,k)
                     if (prime) then
                        write (iout,40)  ikmin,name(ikmin),ikmax,
     &                                   name(ikmax),rv,sqrt(rik2),e
   40                   format (' VDW-LJ',4x,2(i7,'-',a3),
     &                             13x,2f10.4,f12.4)
                     else
                        write (iout,50)  ikmin,name(ikmin),ikmax,
     &                                   name(ikmax),rv,sqrt(rik2),e
   50                   format (' VDW-LJ',4x,2(i7,'-',a3),1x,
     &                             '(XTAL)',6x,2f10.4,f12.4)
                     end if
                  end if
               end if
            end if
   60       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 20
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine elj3c  --  Lennard-Jones analysis via list  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "elj3c" calculates the Lennard-Jones van der Waals energy
c     and also partitions the energy among the atoms using a
c     pairwise neighbor list
c
c
      subroutine elj3c
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mutant
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,p6,p12
      real*8 eps,sc,term
      real*8 rv,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical header,huge
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13,i14,
!$OMP& i15,v2scale,v3scale,v4scale,v5scale,use_group,off2,radmin,
!$OMP& epsilon,radmin4,epsilon4,vcouple,vlambda,mut,cut2,c0,c1,
!$OMP& c2,c3,c4,c5,molcule,name,verbose,debug,header,iout)
!$OMP& firstprivate(vscale,iv14) shared(ev,nev,aev,einter)
!$OMP DO reduction(+:ev,nev,aev,einter)
c
c     find the van der Waals energy via neighbor list search
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     p6 = 2.0d0 * rik2**3 / rv**6
                     sc = p6 + 0.5d0*(1.0d0-vlambda)
                     term = 4.0d0 * vlambda * eps / (sc*sc)
                     e = term * (1.0d0-sc)
                  else
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     e = eps * (p12 - 2.0d0*p6)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   30                format (' VDW-LJ',4x,2(i7,'-',a3),
     &                          13x,2f10.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine elj3d  --  Lennard-Jones analysis for smoothing  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "elj3d" calculates the Lennard-Jones 6-12 van der Waals energy
c     and also partitions the energy among the atoms via a Gaussian
c     approximation for potential energy smoothing
c
c
      subroutine elj3d
      use math
      use vdwpot
      implicit none
c
c
c     set coefficients for a two-Gaussian fit to Lennard-Jones
c
      ngauss = 2
      igauss(1,1) = 14487.1d0
      igauss(2,1) = 9.05148d0 * twosix**2
      igauss(1,2) = -5.55338d0
      igauss(2,2) = 1.22536d0 * twosix**2
c
c     compute Gaussian approximation to Lennard-Jones potential
c
      call egauss3
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine elj3e  --  Lennard-Jones analysis for stophat  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "elj3e" calculates the Lennard-Jones 6-12 van der Waals energy
c     and also partitions the energy among the atoms for use with
c     stophat potential energy smoothing
c
c
      subroutine elj3e
      use action
      use analyz
      use atomid
      use atoms
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use usage
      use vdw
      use vdwpot
      use warp
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer, allocatable :: iv14(:)
      real*8 e,rik2,rdn,p6
      real*8 eps,rv,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik3,rik4
      real*8 rik5,rik6
      real*8 width,width2
      real*8 width3,width4
      real*8 width5,width6
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical header,huge
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     set the extent of smoothing to be performed
c
      width = deform * diffv
      width2 = width * width
      width3 = width2 * width
      width4 = width2 * width2
      width5 = width2 * width3
      width6 = width3 * width3
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               rik2 = xr*xr + yr*yr + zr*zr
               eps = epsilon(kt,it)
               rv = radmin(kt,it)
               if (iv14(k) .eq. i) then
                  eps = epsilon4(kt,it)
                  rv = radmin4(kt,it)
               end if
               eps = eps * vscale(k)
               p6 = rv**6
               rik = sqrt(rik2)
               rik3 = rik2 * rik
               rik4 = rik2 * rik2
               rik5 = rik2 * rik3
               rik6 = rik3 * rik3
c
c     transform the potential function via smoothing
c
               e = rik6 * (30.0d0*rik6 + 360.0d0*rik5*width
     &                + 1800.0d0*rik4*width2 + 4800.0d0*rik3*width3
     &                + 7200.0d0*rik2*width4 + 5760.0d0*rik*width5
     &                + 1920.0d0*width6)
               e = -e + p6 * (15.0d0*rik6 + 90.0d0*rik5*width
     &                + 288.0d0*rik4*width2 + 552.0d0*rik3*width3
     &                + 648.0d0*rik2*width4 + 432.0d0*rik*width5
     &                + 128.0d0*width6)
               e = e*eps*p6 / (15.0d0*(rik*(rik+2.0d0*width))**9)
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
               if (e .ne. 0.0d0)  nev = nev + 1
               ev = ev + e
               aev(i) = aev(i) + 0.5d0*e
               aev(k) = aev(k) + 0.5d0*e
c
c     increment the total intermolecular energy
c
               if (molcule(i) .ne. molcule(k)) then
                  einter = einter + e
               end if
c
c     print a message if the energy of this interaction is large
c
               huge = (e .gt. 10.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual van der Waals',
     &                          ' Interactions :',
     &                       //,' Type',14x,'Atom Names',
     &                          20x,'Minimum',4x,'Actual',
     &                          6x,'Energy',/)
                  end if
                  write (iout,30)  i,name(i),k,name(k),
     &                             rv,sqrt(rik2),e
   30             format (' VDW-LJ',4x,2(i7,'-',a3),
     &                       13x,2f10.4,f12.4)
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine embed  --  structures via distance geometry  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "embed" is a distance geometry routine patterned after the
c     ideas of Gordon Crippen, Irwin Kuntz and Tim Havel; it takes
c     as input a set of upper and lower bounds on the interpoint
c     distances, chirality restraints and torsional restraints,
c     and attempts to generate a set of coordinates that satisfy
c     the input bounds and restraints
c
c     literature references:
c
c     G. M. Crippen and T. F. Havel, "Distance Geometry and Molecular
c     Conformation", Research Studies Press, Letchworth U.K., 1988,
c     John Wiley and Sons, U.S. distributor
c
c     T. F. Havel, "An Evaluation of Computational Strategies for
c     Use in the Determination of Protein Structure from Distance
c     Constraints obtained by Nuclear Magnetic Resonance", Progress
c     in Biophysics and Molecular Biology, 56, 43-78 (1991)
c
c
      subroutine embed
      use atoms
      use disgeo
      use files
      use inform
      use iounit
      use minima
      use refer
      implicit none
      integer maxeigen
      parameter (maxeigen=5)
      integer i,j,nvar,nstep
      integer lext,igeo,freeunit
      integer maxneg,nneg
      integer maxinner,ninner
      integer maxouter,nouter
      real*8 fctval,grdmin
      real*8 dt,wall,cpu
      real*8 temp_start
      real*8 temp_stop
      real*8 rg,rmsorig
      real*8 rmsflip,mass
      real*8 bounds,contact
      real*8 chiral,torsion
      real*8 local,locerr
      real*8 bnderr,vdwerr
      real*8 chirer,torser
      real*8 evl(maxeigen)
      real*8, allocatable :: v(:)
      real*8, allocatable :: a(:)
      real*8, allocatable :: evc(:,:)
      real*8, allocatable :: matrix(:,:)
      real*8, allocatable :: derivs(:,:)
      logical done,valid
      logical exist,info
      character*7 errtyp,ext
      character*240 title
      character*240 geofile
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (evc(n,maxeigen))
      allocate (matrix(n,n))
c
c     initialize any chirality restraints, then smooth the
c     bounds via triangle and inverse triangle inequalities;
c     currently these functions are performed by "distgeom"
c
c     call kchiral
c     if (verbose .and. n.le.130) then
c        title = 'Input Distance Bounds :'
c        call grafic (n,bnd,title)
c     end if
c     call geodesic
c     if (verbose .and. n.le.130)) then
c        title = 'Triangle Smoothed Bounds :'
c        call grafic (n,bnd,title)
c     end if
c
c     generate a distance matrix between the upper and
c     lower bounds, then convert to a metric matrix
c
      maxinner = 3
      maxouter = 3
      maxneg = 2
      nouter = 0
      valid = .false.
      do while (.not. valid)
         ninner = 0
         done = .false.
         do while (.not. done)
            ninner = ninner + 1
            call dstmat (matrix)
            call metric (matrix,nneg)
            if (nneg.le.maxneg .or. ninner.eq.maxinner)  done = .true.
            compact = 0.0d0
         end do
         if (verbose .and. nneg.gt.maxneg) then
            write (iout,10)  nneg
   10       format (/,' EMBED  --  Warning, Using Metric Matrix',
     &                  ' with',i4,' Negative Distances')
         end if
c
c     find the principle components of metric matrix, then
c     generate the trial Cartesian coordinates
c
         nouter = nouter + 1
         call eigen (evl,evc,matrix,valid)
         call coords (evl,evc)
         if (nouter.eq.maxouter .and. .not.valid) then
            valid = .true.
            if (verbose) then
               write (iout,20)
   20          format (/,' EMBED  --  Warning, Using Poor Initial',
     &                    ' Coordinates')
            end if
         end if
      end do
c
c     superimpose embedded structure and enantiomer on reference
c
      info = verbose
      verbose = .false.
      call impose (nref(1),xref,yref,zref,n,x,y,z,rmsorig)
      if (use_invert) then
         do i = 1, n
            x(i) = -x(i)
         end do
         call impose (nref(1),xref,yref,zref,n,x,y,z,rmsflip)
         if (rmsorig .lt. rmsflip) then
            do i = 1, n
               x(i) = -x(i)
            end do
            call impose (nref(1),xref,yref,zref,n,x,y,z,rmsorig)
         end if
         write (iout,30)  rmsorig,rmsflip
   30    format (/,' RMS Superposition for Original and',
     &              ' Enantiomer : ',2f12.4)
      end if
      verbose = info
c
c     compute an index of compaction for the embedded structure
c
      call chksize
c
c     write out the unrefined embedded atomic coordinate set
c
      if (debug) then
         i = 0
         exist = .true.
         do while (exist)
            i = i + 1
            lext = 3
            call numeral (i,ext,lext)
            geofile = filename(1:leng)//'-embed'//'.'//ext(1:lext)
            inquire (file=geofile,exist=exist)
         end do
         igeo = freeunit ()
         open (unit=igeo,file=geofile,status='new')
         call prtxyz (igeo)
         close (unit=igeo)
         title = 'after Embedding :'
         call fracdist (title)
      end if
c
c     use majorization to improve initial embedded coordinates
c
      do i = 1, n
         matrix(i,i) = 0.0d0
         do j = i+1, n
            matrix(j,i) = matrix(i,j)
         end do
      end do
      call majorize (matrix)
c
c     square the bounds for use during structure refinement
c
      do i = 1, n
         do j = 1, n
            dbnd(j,i) = dbnd(j,i)**2
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      if (use_anneal) then
         nvar = 3 * n
         allocate (v(nvar))
         allocate (a(nvar))
      end if
c
c     minimize the error function via simulated annealing
c
      if (verbose)  call settime
      if (use_anneal) then
         iprint = 0
         if (verbose)  iprint = 10
         grdmin = 1.0d0
         mass = 10000.0d0
         do i = 1, nvar
            v(i) = 0.0d0
            a(i) = 0.0d0
         end do
         errtyp = 'FINAL'
         call refine (errtyp,fctval,grdmin)
         nstep = 1000
         dt = 0.04d0
         temp_start = 200.0d0
         temp_stop = 200.0d0
         call explore (errtyp,nstep,dt,mass,temp_start,temp_stop,v,a)
         nstep = 10000
         dt = 0.2d0
         temp_start = 200.0d0
         temp_stop = 0.0d0
         call explore (errtyp,nstep,dt,mass,temp_start,temp_stop,v,a)
         grdmin = 0.01d0
         call refine (errtyp,fctval,grdmin)
c
c     minimize the error function via nonlinear optimization
c
      else
         iprint = 0
         if (verbose)  iprint = 10
         grdmin = 0.01d0
         errtyp = 'INITIAL'
         call refine (errtyp,fctval,grdmin)
         errtyp = 'MIDDLE'
         call refine (errtyp,fctval,grdmin)
         errtyp = 'FINAL'
         call refine (errtyp,fctval,grdmin)
      end if
      if (verbose) then
         call gettime (wall,cpu)
         write (iout,40)  wall
   40    format (/,' Time Required for Refinement :',10x,f12.2,
     &              ' seconds')
      end if
c
c     perform deallocation of some local arrays
c
      if (use_anneal) then
         deallocate (v)
         deallocate (a)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     print the final error function and its components
c
      bounds = bnderr (derivs)
      contact = vdwerr (derivs)
      local = locerr (derivs)
      chiral = chirer (derivs)
      torsion = torser (derivs)
      write (iout,50)  fctval,bounds,contact,local,chiral,torsion
   50 format (/,' Results of Distance Geometry Protocol :',
     &        //,' Final Error Function Value :',10x,f16.4,
     &        //,' Distance Restraint Error :',12x,f16.4,
     &        /,' Hard Sphere Contact Error :',11x,f16.4,
     &        /,' Local Geometry Error :',16x,f16.4,
     &        /,' Chirality-Planarity Error :',11x,f16.4,
     &        /,' Torsional Restraint Error :',11x,f16.4)
c
c     take the root of the currently squared distance bounds
c
      do i = 1, n
         do j = 1, n
            dbnd(j,i) = sqrt(dbnd(j,i))
         end do
      end do
c
c     print the final rms deviations and radius of gyration
c
      title = 'after Refinement :'
      call rmserror (title)
      call gyrate (rg)
      write (iout,60)  rg
   60 format (/,' Radius of Gyration after Refinement  :',6x,f16.4)
      if (verbose .and. n.le.130)  call dmdump (matrix)
c
c     print the normalized fractional distance distribution
c
      if (debug) then
         title = 'after Refinement :'
         call fracdist (title)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (evc)
      deallocate (matrix)
      deallocate (derivs)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine kchiral  --  chirality restraint assignment  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "kchiral" determines the target value for each chirality
c     and planarity restraint as the signed volume of the
c     parallelpiped spanned by vectors from a common atom to
c     each of three other atoms
c
c
      subroutine kchiral
      use atoms
      use inform
      use iounit
      use restrn
      implicit none
      integer i,j,ia,ib,ic,id
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 c1,c2,c3
c
c
c     compute the signed volume of each parallelpiped;
c     if the defining atoms almost lie in a plane, then
c     set the signed volume to exactly zero
c
      do i = 1, nchir
         ia = ichir(1,i)
         ib = ichir(2,i)
         ic = ichir(3,i)
         id = ichir(4,i)
         xad = x(ia) - x(id)
         yad = y(ia) - y(id)
         zad = z(ia) - z(id)
         xbd = x(ib) - x(id)
         ybd = y(ib) - y(id)
         zbd = z(ib) - z(id)
         xcd = x(ic) - x(id)
         ycd = y(ic) - y(id)
         zcd = z(ic) - z(id)
         c1 = ybd*zcd - zbd*ycd
         c2 = ycd*zad - zcd*yad
         c3 = yad*zbd - zad*ybd
         chir(1,i) = 0.1d0
         chir(2,i) = xad*c1 + xbd*c2 + xcd*c3
         if (abs(chir(2,i)) .lt. 1.0d0)  chir(2,i) = 0.0d0
         chir(3,i) = chir(2,i)
      end do
c
c     print out the results for each restraint
c
      if (verbose) then
         if (nchir .ne. 0) then
            write (iout,10)
   10       format (/,' Chirality and Planarity Constraints :')
            write (iout,20)
   20       format (/,18x,'Atom Numbers',12x,'Signed Volume',/)
         end if
         do i = 1, nchir
            write (iout,30)  i,(ichir(j,i),j=1,4),chir(2,i)
   30       format (i6,5x,4i6,5x,f12.4)
         end do
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine triangle  --  triangle inequality smoothing  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "triangle" smooths the upper and lower distance bounds via
c     the triangle inequality using a full-matrix variant of the
c     Floyd-Warshall shortest path algorithm; this routine is
c     usually much slower than the sparse matrix shortest path
c     methods in "geodesic" and "trifix", and should be used only
c     for comparison with answers generated by those routines
c
c     literature reference:
c
c     A. W. M. Dress and T. F. Havel, "Shortest-Path Problems and
c     Molecular Conformation", Discrete Applied Mathematics, 19,
c     129-144 (1988)
c
c
      subroutine triangle
      use atoms
      use disgeo
      use iounit
      implicit none
      integer i,j,k
      integer ik1,ik2
      integer jk1,jk2
      real*8 eps
      real*8 lij,lik,ljk
      real*8 uij,uik,ujk
c
c
c     use full-matrix algorithm to smooth upper and lower bounds
c
      eps = 1.0d-10
      do k = 1, n
         do i = 1, n-1
            ik1 = min(i,k)
            ik2 = max(i,k)
            lik = dbnd(ik2,ik1)
            uik = dbnd(ik1,ik2)
            do j = i+1, n
               lij = dbnd(j,i)
               uij = dbnd(i,j)
               jk1 = min(j,k)
               jk2 = max(j,k)
               ljk = dbnd(jk2,jk1)
               ujk = dbnd(jk1,jk2)
               lij = max(lij,lik-ujk,ljk-uik)
               uij = min(uij,uik+ujk)
               if (lij-uij .gt. eps) then
                  write (iout,10)
   10             format (/,' TRIANGLE  --  Inconsistent Bounds;',
     &                       ' Geometrically Impossible')
                  write (iout,20)  i,j,lij,uij
   20             format (/,' Error at :',6x,2i6,3x,2f9.4)
                  write (iout,30)  i,k,lik,uik,j,k,ljk,ujk
   30             format (/,' Traced to :',5x,2i6,3x,2f9.4,
     &                    /,17x,2i6,3x,2f9.4)
                  call fatal
               end if
               if (lij-dbnd(j,i) .gt. eps) then
                  write (iout,40)  i,j,dbnd(j,i),lij
   40             format (' TRIANGLE  --  Altered Lower Bound at',
     &                       2x,2i6,3x,f9.4,' -->',f9.4)
               end if
               if (dbnd(i,j)-uij .gt. eps) then
                  write (iout,50)  i,j,dbnd(i,j),uij
   50             format (' TRIANGLE  --  Altered Upper Bound at',
     &                       2x,2i6,3x,f9.4,' -->',f9.4)
               end if
               dbnd(j,i) = lij
               dbnd(i,j) = uij
            end do
         end do
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine geodesic  --  sparse matrix triangle smoothing  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "geodesic" smooths the upper and lower distance bounds via
c     the triangle inequality using a sparse matrix version of a
c     shortest path algorithm
c
c     literature reference:
c
c     G. M. Crippen and T. F. Havel, "Distance Geometry and Molecular
c     Conformation", Research Studies Press, Letchworth U.K., 1988,
c     John Wiley and Sons, U.S. distributor, see section 6-2
c
c
      subroutine geodesic
      use atoms
      use disgeo
      use restrn
      implicit none
      integer i,j,k,nlist
      integer, allocatable :: list(:)
      integer, allocatable :: key(:)
      integer, allocatable :: start(:)
      integer, allocatable :: stop(:)
      real*8, allocatable :: upper(:)
      real*8, allocatable :: lower(:)
c
c
c     perform dynamic allocation of some local arrays
c
      nlist = 2 * ndfix
      allocate (list(nlist))
      allocate (key(nlist))
      allocate (start(n))
      allocate (stop(n))
      allocate (upper(n))
      allocate (lower(n))
c
c     build an indexed list of atoms in distance restraints
c
      do i = 1, n
         start(i) = 0
         stop(i) = -1
      end do
      do i = 1, ndfix
         list(i) = idfix(1,i)
         list(i+ndfix) = idfix(2,i)
      end do
      call sort3 (nlist,list,key)
      j = -1
      do i = 1, nlist
         k = list(i)
         if (k .ne. j) then
            start(k) = i
            j = k
         end if
      end do
      j = -1
      do i = nlist, 1, -1
         k = list(i)
         if (k .ne. j) then
            stop(k) = i
            j = k
         end if
      end do
      do i = 1, nlist
         k = key(i)
         if (k .le. ndfix) then
            list(i) = idfix(2,k)
         else
            list(i) = idfix(1,k-ndfix)
         end if
      end do
c
c     triangle smooth bounds via sparse shortest path method
c
      do i = 1, n
         call minpath (i,upper,lower,start,stop,list)
         do j = i+1, n
            dbnd(i,j) = upper(j)
            dbnd(j,i) = max(lower(j),dbnd(j,i))
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (key)
      deallocate (start)
      deallocate (stop)
      deallocate (upper)
      deallocate (lower)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine minpath  --  triangle smoothed bounds to atom  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "minpath" is a routine for finding the triangle smoothed upper
c     and lower bounds of each atom to a specified root atom using a
c     sparse variant of the Bellman-Ford shortest path algorithm
c
c     literature reference:
c
c     D. P. Bertsekas, "A Simple and Fast Label Correcting Algorithm
c     for Shortest Paths", Networks, 23, 703-709 (1993)
c
c
      subroutine minpath (root,upper,lower,start,stop,list)
      use atoms
      use couple
      use disgeo
      implicit none
      integer i,j,k
      integer narc,root
      integer head,tail
      integer, allocatable :: iarc(:)
      integer, allocatable :: queue(:)
      integer start(*)
      integer stop(*)
      integer list(*)
      real*8 big,small
      real*8 upper(*)
      real*8 lower(*)
      logical enter
      logical, allocatable :: queued(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (iarc(n))
      allocate (queue(n))
      allocate (queued(n))
c
c     initialize candidate atom queue and the path lengths
c
      do i = 1, n
         queued(i) = .false.
         upper(i) = 1000000.0d0
         lower(i) = 0.0d0
      end do
c
c     put the root atom into the queue of candidate atoms
c
      head = root
      tail = root
      queue(root) = 0
      queued(root) = .true.
      upper(root) = 0.0d0
c
c     get the next candidate atom from head of queue
c
      do while (head .ne. 0)
         j = head
         queued(j) = .false.
         head = queue(head)
c
c     make a list of arcs to the current candidate atom
c
         narc = 0
         do i = 1, n12(j)
            k = i12(i,j)
            if (k .ne. root) then
               narc = narc + 1
               iarc(narc) = k
            end if
         end do
         do i = 1, n13(j)
            k = i13(i,j)
            if (k .ne. root) then
               narc = narc + 1
               iarc(narc) = k
            end if
         end do
         do i = 1, n14(j)
            k = i14(i,j)
            if (k .ne. root) then
               narc = narc + 1
               iarc(narc) = k
            end if
         end do
         do i = start(j), stop(j)
            k = list(i)
            if (k .ne. root) then
               narc = narc + 1
               iarc(narc) = k
            end if
         end do
c
c     check each arc for alteration of the path length bounds
c
         do i = 1, narc
            k = iarc(i)
            if (k .lt. j) then
               big = upper(j) + dbnd(k,j)
               small = max(dbnd(j,k)-upper(j),lower(j)-dbnd(k,j))
            else
               big = upper(j) + dbnd(j,k)
               small = max(dbnd(k,j)-upper(j),lower(j)-dbnd(j,k))
            end if
            enter = .false.
            if (upper(k) .gt. big) then
               upper(k) = big
               if (.not. queued(k))  enter = .true.
            end if
            if (lower(k) .lt. small) then
               lower(k) = small
               if (.not. queued(k))  enter = .true.
            end if
c
c     enter a new candidate atom at the tail of the queue
c
            if (enter) then
               queued(k) = .true.
               if (head .eq. 0) then
                  head = k
                  tail = k
                  queue(k) = 0
               else
                  queue(tail) = k
                  queue(k) = 0
                  tail = k
               end if
            end if
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iarc)
      deallocate (queue)
      deallocate (queued)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine trifix  --  update triangle inequality bounds  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "trifix" rebuilds both the upper and lower distance bound
c     matrices following tightening of one or both of the bounds
c     between a specified pair of atoms, "p" and "q", using a
c     modification of Murchland's shortest path update algorithm
c
c     literature references:
c
c     P. A. Steenbrink, "Optimization of Transport Networks", John
c     Wiley and Sons, Bristol, 1974; see section 7.7
c
c     R. Dionne, "Etude et Extension d'un Algorithme de Murchland",
c     Infor, 16, 132-146 (1978)
c
c
      subroutine trifix (p,q)
      use atoms
      use disgeo
      use inform
      use iounit
      implicit none
      integer i,k,p,q
      integer ip,iq,np,nq
      integer, allocatable :: pt(:)
      integer, allocatable :: qt(:)
      real*8 eps,ipmin,ipmax
      real*8 iqmin,iqmax
      real*8, allocatable :: pmin(:)
      real*8, allocatable :: pmax(:)
      real*8, allocatable :: qmin(:)
      real*8, allocatable :: qmax(:)
      logical, allocatable :: pun(:)
      logical, allocatable :: qun(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (pt(n))
      allocate (qt(n))
      allocate (pmin(n))
      allocate (pmax(n))
      allocate (qmin(n))
      allocate (qmax(n))
      allocate (pun(n))
      allocate (qun(n))
c
c     initialize the set of nodes that may have changed bounds
c
      eps = 1.0d-10
      np = 0
      nq = 0
      do i = 1, n
         pun(i) = .true.
         qun(i) = .true.
      end do
c
c     store the upper and lower bounds to "p" and "q"
c
      do i = 1, p
         pmin(i) = dbnd(p,i)
         pmax(i) = dbnd(i,p)
      end do
      do i = p+1, n
         pmin(i) = dbnd(i,p)
         pmax(i) = dbnd(p,i)
      end do
      do i = 1, q
         qmin(i) = dbnd(q,i)
         qmax(i) = dbnd(i,q)
      end do
      do i = q+1, n
         qmin(i) = dbnd(i,q)
         qmax(i) = dbnd(q,i)
      end do
c
c     check for changes in the upper bounds to "p" and "q"
c
      do i = 1, n
         ipmax = qmax(p) + qmax(i)
         if (pmax(i) .gt. ipmax+eps) then
            np = np + 1
            pt(np) = i
            pmax(i) = ipmax
            pun(i) = .false.
         end if
         iqmax = pmax(q) + pmax(i)
         if (qmax(i) .gt. iqmax+eps) then
            nq = nq + 1
            qt(nq) = i
            qmax(i) = iqmax
            qun(i) = .false.
         end if
      end do
c
c     for node pairs whose bounds to "p" and "q" have changed,
c     make any needed changes to upper bound of the pair
c
      do ip = 1, np
         i = pt(ip)
         ipmax = pmax(i)
         do iq = 1, nq
            k = qt(iq)
            if (i .lt. k) then
               dbnd(i,k) = min(dbnd(i,k),ipmax+pmax(k))
            else
               dbnd(k,i) = min(dbnd(k,i),ipmax+pmax(k))
            end if
         end do
      end do
c
c     check for changes in the lower bounds to "p" and "q"
c
      do i = 1, n
         ipmin = max(qmin(p)-qmax(i),qmin(i)-qmax(p))
         if (pmin(i) .lt. ipmin-eps) then
            if (pun(i)) then
               np = np + 1
               pt(np) = i
            end if
            pmin(i) = ipmin
         end if
         iqmin = max(pmin(q)-pmax(i),pmin(i)-pmax(q))
         if (qmin(i) .lt. iqmin-eps) then
            if (qun(i)) then
               nq = nq + 1
               qt(nq) = i
            end if
            qmin(i) = iqmin
         end if
      end do
c
c     for node pairs whose bounds to "p" and "q" have changed,
c     make any needed changes to lower bound of the pair
c
      do ip = 1, np
         i = pt(ip)
         ipmin = pmin(i)
         ipmax = pmax(i)
         do iq = 1, nq
            k = qt(iq)
            if (i .lt. k) then
               dbnd(k,i) = max(dbnd(k,i),ipmin-pmax(k),pmin(k)-ipmax)
            else
               dbnd(i,k) = max(dbnd(i,k),ipmin-pmax(k),pmin(k)-ipmax)
            end if
         end do
      end do
c
c     update the upper and lower bounds to "p" and "q"
c
      do i = 1, p
         dbnd(p,i) = pmin(i)
         dbnd(i,p) = pmax(i)
      end do
      do i = p+1, n
         dbnd(i,p) = pmin(i)
         dbnd(p,i) = pmax(i)
      end do
      do i = 1, q
         dbnd(q,i) = qmin(i)
         dbnd(i,q) = qmax(i)
      end do
      do i = q+1, n
         dbnd(i,q) = qmin(i)
         dbnd(q,i) = qmax(i)
      end do
c
c     output the atoms updated and amount of work required
c
c     if (debug) then
c        write (iout,10)  p,q,np*nq
c  10    format (' TRIFIX  --  Bounds Update for Atoms',2i6,
c    &              ' with',i8,' Searches')
c     end if
c
c     perform deallocation of some local arrays
c
      deallocate (pt)
      deallocate (qt)
      deallocate (pmin)
      deallocate (pmax)
      deallocate (qmin)
      deallocate (qmax)
      deallocate (pun)
      deallocate (qun)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine grafic  --  schematic graphical matrix output  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "grafic" outputs the upper & lower triangles and diagonal
c     of a square matrix in a schematic form for visual inspection
c
c
      subroutine grafic (n,a,title)
      use iounit
      implicit none
      integer i,j,k,m,n
      integer maxj,nrow,ndash
      integer minrow,maxrow
      integer trimtext
      real*8 big,v
      real*8 amin,dmin,bmin
      real*8 amax,dmax,bmax
      real*8 rcl,scl,tcl
      real*8 ca,cb,cc,cd
      real*8 cw,cx,cy,cz
      real*8 a(n,*)
      character*1 dash
      character*1 ta,tb,tc,td,te
      character*1 digit(0:9)
      character*1 symbol(130)
      character*240 title
      data dash   / '-' /
      data ta,tb,tc,td,te  / ' ','.','+','X','#' /
      data digit  / '0','1','2','3','4','5','6','7','8','9' /
c
c
c     set bounds of length of print row and write the header
c
      minrow = 54
      maxrow = 130
      ndash = min(max(n,minrow),maxrow)
      write (iout,10)  (dash,i=1,ndash)
   10 format (/,1x,130a1)
      write (iout,20)  title(1:trimtext(title))
   20 format (/,1x,a)
c
c     find the maximum and minimum elements of the matrix
c
      big = 1.0d6
      dmax = -big
      dmin = big
      amax = -big
      amin = big
      bmax = -big
      bmin = big
      do i = 1, n
         if (a(i,i) .gt. dmax)  dmax = a(i,i)
         if (a(i,i) .lt. dmin)  dmin = a(i,i)
         do j = 1, i-1
            if (a(j,i) .gt. amax)  amax = a(j,i)
            if (a(j,i) .lt. amin)  amin = a(j,i)
            if (a(i,j) .gt. bmax)  bmax = a(i,j)
            if (a(i,j) .lt. bmin)  bmin = a(i,j)
         end do
      end do
      write (iout,30)  amin,amax,dmin,dmax,bmin,bmax
   30 format (/,' Range of Above Diag Elements : ',f13.4,' to',f13.4,
     &        /,' Range of Diagonal Elements :   ',f13.4,' to',f13.4,
     &        /,' Range of Below Diag Elements : ',f13.4,' to',f13.4)
c
c     now, print out the graphical representation
c
      write (iout,40)
   40 format (/,' Symbol Magnitude Ordering :',14x,
     &          '# > X > + > . > '' ''',/)
      rcl = (bmax-bmin) / 5.0d0
      scl = (amax-amin) / 5.0d0
      tcl = (dmax-dmin) / 9.0d0
      if (rcl .eq. 0.0d0)  rcl = 1.0d0
      if (scl .eq. 0.0d0)  scl = 1.0d0
      if (tcl .eq. 0.0d0)  tcl = 1.0d0
      ca = amin + scl
      cb = ca + scl
      cc = cb + scl
      cd = cc + scl
      cw = bmin + rcl
      cx = cw + rcl
      cy = cx + rcl
      cz = cy + rcl
      do j = 1, n, maxrow
         maxj = j + maxrow - 1
         if (maxj .gt. n)  maxj = n
         nrow = maxj - j + 1
         do i = 1, n
            do k = j, maxj
               m = k - j + 1
               if (k .lt. i) then
                  v = abs(a(i,k))
                  if (v .le. cw) then
                     symbol(m) = ta
                  else if (v .le. cx) then
                     symbol(m) = tb
                  else if (v .le. cy) then
                     symbol(m) = tc
                  else if (v .le. cz) then
                     symbol(m) = td
                  else
                     symbol(m) = te
                  end if
               else if (k .eq. i) then
                  symbol(m) = digit(nint((a(i,i)-dmin)/tcl))
               else if (k .gt. i) then
                  v = abs(a(i,k))
                  if (v .le. ca) then
                     symbol(m) = ta
                  else if (v .le. cb) then
                     symbol(m) = tb
                  else if (v .le. cc) then
                     symbol(m) = tc
                  else if (v .le. cd) then
                     symbol(m) = td
                  else
                     symbol(m) = te
                  end if
               end if
            end do
            write (iout,50)  (symbol(k),k=1,nrow)
   50       format (1x,130a1)
         end do
         write (iout,60)  (dash,i=1,ndash)
   60    format (/,1x,130a1)
         if (maxj .lt. n) then
            write (iout,70)
   70       format ()
         end if
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine dstmat  --  choose values for distance matrix  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "dstmat" selects a distance matrix containing values between
c     the previously smoothed upper and lower bounds; the distance
c     values are chosen from uniform distributions, in a triangle
c     correlated fashion, or using random partial metrization
c
c
      subroutine dstmat (dmx)
      use atoms
      use disgeo
      use inform
      use iounit
      use keys
      implicit none
      integer i,j,k,m
      integer index,next
      integer npart,npair
      integer nmetrize
      integer mik,mjk,nik,njk
      integer, allocatable :: list(:)
      real*8 random,fraction
      real*8 invbeta,alpha,beta
      real*8 corr,mean,stdev
      real*8 denom,swap,delta
      real*8 percent,eps,gap
      real*8 wall,cpu
      real*8, allocatable :: value(:)
      real*8 dmx(n,*)
      logical first,uniform
      logical update
      character*8 method
      character*20 keyword
      character*240 record
      character*240 string
      external random,invbeta
      save first,method,update
      save npart,percent
      save mean,stdev
      save alpha,beta
      data first  / .true. /
c
c
c     initialize the method for distance element selection
c
      if (first) then
         first = .false.
         method = 'PAIRWISE'
         uniform = .false.
         update = .true.
         npart = 0
         percent = 0.0d0
         mean = 0.0d0
         compact = 0.0d0
         beta = 4.0d0
c
c     search each line of the keyword file for options
c
         do i = 1, nkey
            next = 1
            record = keyline(i)
            call gettext (record,keyword,next)
            call upcase (keyword)
c
c     get a distance selection method and extent of metrization
c
            if (keyword(1:15) .eq. 'TRIAL-DISTANCE ') then
               call gettext (record,method,next)
               call upcase (method)
               if (method .eq. 'HAVEL') then
                  call getnumb (record,npart,next)
               else if (method .eq. 'PARTIAL') then
                  call getnumb (record,npart,next)
               else if (method .eq. 'PAIRWISE') then
                  string = record(next:240)
                  read (string,*,err=10,end=10)  percent
   10             continue
               end if
c
c     get a choice of initial mean for the trial distribution
c
            else if (keyword(1:19) .eq. 'TRIAL-DISTRIBUTION ') then
               string = record(next:240)
               read (string,*,err=20,end=20)  mean
   20          continue
               update = .false.
            end if
         end do
c
c     set extent of partial metrization during distance selection
c
         if (method .eq. 'HAVEL') then
            if (npart.le.0 .or. npart.ge.n-1)  npart = n
         else if (method .eq. 'PARTIAL') then
            if (npart.le.0 .or. npart.ge.n-1)  npart = 4
         else if (method .eq. 'PAIRWISE') then
            if (percent.le.0.0d0 .or. percent.ge.100.0d0)
     &         percent = min(100.0d0,2000.0d0/dble(n))
         end if
c
c     set the initial distribution for selection of trial distances
c
         if (method .eq. 'CLASSIC')  uniform = .true.
         if (method .eq. 'TRICOR')  uniform = .true.
         if (method .eq. 'HAVEL')  uniform = .true.
         if (uniform)  update = .false.
         if (update) then
c           mean = 2.35d0 / log(pathmax)
            mean = 1.65d0 / (pathmax)**0.25d0
c           mean = 1.30d0 / (pathmax)**0.20d0
         end if
         alpha = beta*mean / (1.0d0-mean)
         stdev = sqrt(alpha*beta/(alpha+beta+1.0d0)) / (alpha+beta)
      end if
c
c     write out the final choice for distance matrix generation
c
      if (verbose) then
         call settime
         if (method .eq. 'CLASSIC') then
            write (iout,30)
   30       format (/,' Distance Matrix via Uniform Random',
     &                 ' Fractions without Metrization :')
         else if (method .eq. 'RANDOM') then
            write (iout,40)
   40       format (/,' Distance Matrix Generated via Normal',
     &                 ' Fractions without Metrization :')
         else if (method .eq. 'TRICOR') then
            write (iout,50)
   50       format (/,' Distance Matrix Generated via Triangle',
     &                 ' Correlated Fractions :')
         else if (method.eq.'HAVEL' .and. npart.lt.n) then
            write (iout,60)  npart
   60       format (/,' Distance Matrix Generated via',i4,'-Atom',
     &                 ' Partial Metrization :')
         else if (method .eq. 'HAVEL') then
            write (iout,70)
   70       format (/,' Distance Matrix Generated via Randomized',
     &                 ' Atom-Based Metrization :')
         else if (method .eq. 'PARTIAL') then
            write (iout,80)  npart
   80       format (/,' Distance Matrix Generated via',i4,'-Atom',
     &                 ' Partial Metrization :')
         else if (method.eq.'PAIRWISE' .and. percent.lt.100.0d0) then
            write (iout,90)  percent
   90       format (/,' Distance Matrix Generated via',f6.2,'%',
     &                 ' Random Pairwise Metrization :')
         else
            write (iout,100)
  100       format (/,' Distance Matrix Generated via Randomized',
     &                 ' Pairwise Metrization :')
         end if
      end if
c
c     adjust the distribution for selection of trial distances
c
      if (uniform) then
         write (iout,110)
  110    format (/,' Trial Distances Selected at Random from',
     &              ' Uniform Distribution')
      else
         if (update) then
            alpha = alpha - 0.2d0*sign(sqrt(abs(compact)),compact)
            mean = alpha / (alpha+beta)
            stdev = sqrt(alpha*beta/(alpha+beta+1.0d0)) / (alpha+beta)
         end if
         write (iout,120)  mean,stdev,alpha,beta
  120    format (/,' Trial Distance Beta Distribution :',
     &              4x,f5.2,' +/-',f5.2,3x,'Alpha-Beta',2f6.2)
      end if
c
c     perform dynamic allocation of some local arrays
c
      npair = n*(n-1) / 2
      allocate (list(npair))
      allocate (value(npair))
c
c     uniform or Gaussian distributed distances without metrization
c
      if (method.eq.'CLASSIC' .or. method.eq.'RANDOM') then
         do i = 1, n
            dmx(i,i) = 0.0d0
         end do
         do i = 1, n-1
            do j = i+1, n
               fraction = random ()
               if (method .eq. 'RANDOM') then
                  fraction = invbeta (alpha,beta,fraction)
               end if
               delta = dbnd(i,j) - dbnd(j,i)
               dmx(j,i) = dbnd(j,i) + delta*fraction
               dmx(i,j) = dmx(j,i)
            end do
         end do
c
c     Crippen's triangle correlated distance selection
c
      else if (method .eq. 'TRICOR') then
         do i = 1, n
            dmx(i,i) = 0.0d0
         end do
         do i = 1, n-1
            do j = i+1, n
               dmx(j,i) = random ()
               dmx(i,j) = dmx(j,i)
            end do
         end do
         do i = 1, n-1
            do j = i+1, n
               denom = 0.0d0
               dmx(i,j) = 0.0d0
               do k = 1, n
                  if (k .ne. i) then
                     mik = max(i,k)
                     mjk = max(j,k)
                     nik = min(i,k)
                     njk = min(j,k)
                     if (k .eq. j) then
                        dmx(i,j) = dmx(i,j) + dmx(j,i)
                        denom = denom + 1.0d0
                     else if (dbnd(njk,mjk) .le.
     &                        0.2d0*dbnd(nik,mik)) then
                        if (i .gt. k)  corr = 0.9d0 * dmx(i,k)
                        if (k .gt. i)  corr = 0.9d0 * dmx(k,i)
                        dmx(i,j) = dmx(i,j) + corr
                        denom = denom + 0.9d0
                     else if (dbnd(nik,mik) .le.
     &                        0.2d0*dbnd(njk,mjk)) then
                        if (j .gt. k)  corr = 0.9d0 * dmx(j,k)
                        if (k .gt. j)  corr = 0.9d0 * dmx(k,j)
                        dmx(i,j) = dmx(i,j) + corr
                        denom = denom + 0.9d0
                     else if (dbnd(mik,nik) .ge.
     &                        0.9d0*dbnd(njk,mjk)) then
                        if (j .gt. k)  corr = 0.5d0 * (1.0d0-dmx(j,k))
                        if (k .gt. j)  corr = 0.5d0 * (1.0d0-dmx(k,j))
                        dmx(i,j) = dmx(i,j) + corr
                        denom = denom + 0.5d0
                     else if (dbnd(mjk,njk) .ge.
     &                        0.9d0*dbnd(nik,mik)) then
                        if (i .gt. k)  corr = 0.5d0 * (1.0d0-dmx(i,k))
                        if (k .gt. i)  corr = 0.5d0 * (1.0d0-dmx(k,i))
                        dmx(i,j) = dmx(i,j) + corr
                        denom = denom + 0.5d0
                     end if
                  end if
               end do
               dmx(i,j) = dmx(i,j) / denom
            end do
         end do
         do i = 1, n-1
            do j = i+1, n
               delta = dbnd(i,j) - dbnd(j,i)
               dmx(i,j) = dbnd(j,i) + delta*dmx(i,j)
               dmx(j,i) = dmx(i,j)
            end do
         end do
c
c     Havel/XPLOR atom-based metrization over various distributions
c
      else if (method.eq.'HAVEL' .or. method.eq.'PARTIAL') then
         do i = 1, n
            do j = 1, n
               dmx(j,i) = dbnd(j,i)
            end do
         end do
         do i = 1, n
            value(i) = random ()
         end do
         call sort2 (n,value,list)
         gap = 0.0d0
         do i = 1, n-1
            k = list(i)
            do j = i+1, n
               m = list(j)
               fraction = random ()
               if (method .eq. 'PARTIAL') then
                  fraction = invbeta (alpha,beta,fraction)
               end if
               delta = abs(dbnd(k,m) - dbnd(m,k))
               if (k .lt. m) then
                  dbnd(k,m) = dbnd(m,k) + delta*fraction
                  dbnd(m,k) = dbnd(k,m)
               else
                  dbnd(k,m) = dbnd(k,m) + delta*fraction
                  dbnd(m,k) = dbnd(k,m)
               end if
               if (i .le. npart)  call trifix (k,m)
               if (i .gt. npart)  gap = gap + delta
            end do
         end do
         do i = 1, n
            do j = 1, n
               swap = dmx(j,i)
               dmx(j,i) = dbnd(j,i)
               dbnd(j,i) = swap
            end do
         end do
         if (verbose .and. npart.lt.n-1) then
            write (iout,130)  gap/dble((n-npart)*(n-npart-1)/2)
  130       format (/,' Average Bound Gap after Partial Metrization :',
     &                 3x,f12.4)
         end if
c
c     use partial randomized pairwise distance-based metrization
c
      else if (method.eq.'PAIRWISE' .and. percent.le.10.0d0) then
         npair = n*(n-1) / 2
         nmetrize = nint(0.01d0*percent*dble(npair))
         do i = 1, n
            do j = 1, n
               dmx(j,i) = dbnd(j,i)
            end do
         end do
         do i = 1, nmetrize
  140       continue
            k = int(dble(n)*random()) + 1
            m = int(dble(n)*random()) + 1
            if (dbnd(k,m) .eq. dbnd(m,k))  goto 140
            if (k .gt. m) then
               j = k
               k = m
               m = j
            end if
            fraction = random ()
            fraction = invbeta (alpha,beta,fraction)
            delta = dbnd(k,m) - dbnd(m,k)
            dbnd(k,m) = dbnd(m,k) + delta*fraction
            dbnd(m,k) = dbnd(k,m)
            call trifix (k,m)
         end do
         gap = 0.0d0
         do i = 1, n-1
            do j = i, n
               delta = dbnd(i,j) - dbnd(j,i)
               if (delta .ne. 0.0d0) then
                  gap = gap + delta
                  fraction = random ()
                  fraction = invbeta (alpha,beta,fraction)
                  dbnd(i,j) = dbnd(j,i) + delta*fraction
                  dbnd(j,i) = dbnd(i,j)
               end if
            end do
         end do
         do i = 1, n
            do j = 1, n
               swap = dmx(j,i)
               dmx(j,i) = dbnd(j,i)
               dbnd(j,i) = swap
            end do
         end do
         if (verbose .and. nmetrize.lt.npair) then
            write (iout,150)  gap/dble(npair-nmetrize)
  150       format (/,' Average Bound Gap after Partial Metrization :',
     &                 3x,f12.4)
         end if
c
c     use randomized pairwise distance-based metrization
c
      else if (method .eq. 'PAIRWISE') then
         npair = n*(n-1) / 2
         nmetrize = nint(0.01d0*percent*dble(npair))
         do i = 1, n
            do j = 1, n
               dmx(j,i) = dbnd(j,i)
            end do
         end do
         do i = 1, npair
            value(i) = random ()
         end do
         call sort2 (npair,value,list)
         eps = 1.0d-10
         gap = 0.0d0
         do i = 1, npair
            index = list(i)
            k = int(0.5d0 * (dble(2*n+1)
     &                 - sqrt(dble(4*n*(n-1)-8*index+9))) + eps)
            m = n*(1-k) + k*(k+1)/2 + index
            fraction = random ()
            fraction = invbeta (alpha,beta,fraction)
            delta = dbnd(k,m) - dbnd(m,k)
            dbnd(k,m) = dbnd(m,k) + delta*fraction
            dbnd(m,k) = dbnd(k,m)
            if (i .le. nmetrize)  call trifix (k,m)
            if (i .gt. nmetrize)  gap = gap + delta
         end do
         do i = 1, n
            do j = 1, n
               swap = dmx(j,i)
               dmx(j,i) = dbnd(j,i)
               dbnd(j,i) = swap
            end do
         end do
         if (verbose .and. nmetrize.lt.npair) then
            write (iout,160)  gap/dble(npair-nmetrize)
  160       format (/,' Average Bound Gap after Partial Metrization :',
     &                 3x,f12.4)
         end if
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (value)
c
c     get the time required for distance matrix generation
c
      if (verbose) then
         call gettime (wall,cpu)
         write (iout,170)  wall
  170    format (/,' Time Required for Distance Matrix :',5x,f12.2,
     &              ' seconds')
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine metric  --  computation of the metric matrix  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "metric" takes as input the trial distance matrix and computes
c     the metric matrix of all possible dot products between the atomic
c     vectors and the center of mass using the law of cosines and the
c     following formula for the distances to the center of mass:
c
c        dcm(i)**2 = (1/n) * sum(j=1,n)(dist(i,j)**2)
c                          - (1/n**2) * sum(j<k)(dist(j,k)**2)
c
c     upon output, the metric matrix is stored in the lower triangle
c     plus diagonal of the input trial distance matrix, the upper
c     triangle of the input matrix is unchanged
c
c     literature reference:
c
c     G. M. Crippen and T. F. Havel, "Stable Calculation of Coordinates
c     from Distance Information", Acta Cryst., A34, 282-284 (1978)
c
c
      subroutine metric (gmx,nneg)
      use atoms
      use disgeo
      use inform
      use iounit
      implicit none
      integer i,j,nneg
      real*8 total,sum,rg
      real*8 gmx(n,*)
      real*8, allocatable :: dsq(:)
      real*8, allocatable :: dcm(:)
c
c
c     square and sum trial distances to get radius of gyration
c
      total = 0.0d0
      do i = 1, n
         do j = i, n
            gmx(j,i) = gmx(j,i)**2
            total = total + gmx(j,i)
         end do
      end do
      total = total / dble(n**2)
      rg = sqrt(total)
      if (verbose) then
         write (iout,10)  rg
   10    format (/,' Radius of Gyration before Embedding :',7x,f16.4)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (dsq(n))
      allocate (dcm(n))
c
c     sum squared distances from each atom; the center
c     of mass is derived using the formula shown above
c
      nneg = 0
      do i = 1, n
         sum = 0.0d0
         do j = 1, i-1
            sum = sum + gmx(i,j)
         end do
         do j = i, n
            sum = sum + gmx(j,i)
         end do
         dsq(i) = sum/dble(n) - total
         dcm(i) = sqrt(abs(dsq(i)))
         if (dsq(i) .lt. 0.0d0) then
            nneg = nneg + 1
            dcm(i) = -dcm(i)
         end if
      end do
      if (verbose .and. n.le.130) then
         write (iout,20)
   20    format (/,' Atomic Distances to the Center of Mass :',/)
         write (iout,30)  (dcm(i),i=1,n)
   30    format (6f13.4)
      end if
c
c     calculate the metric matrix using the law of cosines, and
c     place into the lower triangle of the input distance matrix
c
      do i = 1, n
         do j = i, n
            gmx(j,i) = 0.5d0 * (dsq(i)+dsq(j)-gmx(j,i))
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (dsq)
      deallocate (dcm)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine eigen  --  largest eigenvalues of metric metrix  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "eigen" uses the power method to compute the largest eigenvalues
c     and eigenvectors of the metric matrix, "valid" is set true if the
c     first three eigenvalues are positive
c
c
      subroutine eigen (evl,evc,gmx,valid)
      use atoms
      use inform
      use iounit
      implicit none
      integer i,j,neigen
      real*8 wall,cpu
      real*8 evl(*)
      real*8 evc(n,*)
      real*8 gmx(n,*)
      logical valid
c
c
c     initialize number of eigenvalues and convergence criteria
c
      if (verbose)  call settime
      neigen = 3
c
c     compute largest eigenvalues via power method with deflation
c
      call deflate (n,neigen,gmx,evl,evc)
c
c     check to see if the first three eigenvalues are positive
c
      valid = .true.
      do i = 1, 3
         if (evl(i) .lt. 0.0d0)  valid = .false.
      end do
c
c     print out the eigenvalues and their eigenvectors
c
      if (verbose) then
         write (iout,10)
   10    format (/,' Eigenvalues from Metric Matrix :',/)
         write (iout,20)  (evl(i),i=1,neigen)
   20    format (5f15.4)
      end if
      if (debug) then
         write (iout,30)
   30    format (/,' Eigenvectors from Metric Matrix :',/)
         do i = 1, n
            write (iout,40)  (evc(i,j),j=1,neigen)
   40       format (5f15.4)
         end do
      end if
c
c     get the time required for partial matrix diagonalization
c
      if (verbose) then
         call gettime (wall,cpu)
         write (iout,50)  wall
   50    format (/,' Time Required for Eigenvalues :',9x,f12.2,
     &              ' seconds')
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine coords  --  converts eigenvalues to coordinates  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "coords" converts the three principal eigenvalues/vectors from
c     the metric matrix into atomic coordinates, and calls a routine
c     to compute the rms deviation from the bounds
c
c
      subroutine coords (evl,evc)
      use atoms
      use disgeo
      use inform
      use iounit
      implicit none
      integer i,j,neigen
      real*8 rg
      real*8 evl(*)
      real*8 evc(n,*)
      character*240 title
c
c
c     compute coordinates from the largest eigenvalues and vectors
c
      neigen = 3
      do j = 1, neigen
         evl(j) = sqrt(abs(evl(j)))
      end do
      do j = 1, neigen
         do i = 1, n
            evc(i,j) = evl(j) * evc(i,j)
         end do
      end do
c
c     transfer the final coordinates back to atomic vectors
c
      do i = 1, n
         x(i) = evc(i,1)
         y(i) = evc(i,2)
         z(i) = evc(i,3)
      end do
c
c     find the rms bounds deviations and radius of gyration
c
      if (verbose) then
         title = 'after Embedding :'
         call rmserror (title)
         call gyrate (rg)
         write (iout,10)  rg
   10    format (/,' Radius of Gyration after Embedding :',8x,f16.4)
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine chksize  --  estimate compaction or expansion  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "chksize" computes a measure of overall global structural
c     expansion or compaction from the number of excess upper
c     or lower bounds matrix violations
c
c
      subroutine chksize
      use atoms
      use couple
      use disgeo
      use inform
      use iounit
      implicit none
      integer i,k,npair,nskip
      integer nlarge,nsmall
      integer, allocatable :: skip(:)
      real*8 xi,yi,zi
      real*8 dstsq,bupsq,blosq
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (skip(n))
c
c     zero out the list of atoms locally connected to each atom
c
      nskip = 0
      do i = 1, n
         skip(i) = 0
      end do
c
c     initialize counters, total pair number, and cutoff distance
c
      nlarge = 0
      nsmall = 0
      npair = n*(n-1) / 2
c
c     count the number of excess upper or lower bound violations
c
      do i = 1, n-1
         xi = x(i)
         yi = y(i)
         zi = z(i)
c        do k = 1, n12(i)
c           skip(i12(k,i)) = i
c        end do
c        do k = 1, n13(i)
c           skip(i13(k,i)) = i
c        end do
c        do k = 1, n14(i)
c           skip(i14(k,i)) = i
c        end do
         do k = i+1, n
            if (skip(k) .eq. i) then
               nskip = nskip + 1
            else
               dstsq = (x(k)-xi)**2 + (y(k)-yi)**2 + (z(k)-zi)**2
               bupsq = dbnd(i,k)**2
               blosq = dbnd(k,i)**2
               if (dstsq .gt. bupsq) then
                  nlarge = nlarge + 1
               else if (blosq .gt. dstsq) then
                  nsmall = nsmall + 1
               end if
            end if
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (skip)
c
c     set the value for the overall index of compaction
c
      compact = 100.0d0 * dble(nlarge-nsmall)/dble(npair-nskip)
      if (verbose) then
         write (iout,10)  compact
   10    format (/,' Index of Structure Expansion/Compaction :',
     &              7x,f12.4)
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine majorize  --  Guttman transform majorization  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "majorize" refines the projected coordinates by attempting to
c     minimize the least square residual between the trial distance
c     matrix and the distances computed from the coordinates
c
c     literature reference:
c
c     T. F. Havel, "An Evaluation of Computational Strategies for
c     Use in the Determination of Protein Structure from Distance
c     Constraints obtained by Nuclear Magnetic Resonance", Progress
c     in Biophysics and Molecular Biology, 56, 43-78 (1991)
c
c
      subroutine majorize (dmx)
      use atoms
      use inform
      use iounit
      implicit none
      integer i,k,iter
      integer niter,period
      real*8 pairs,rg
      real*8 dn1,dn2
      real*8 wall,cpu
      real*8 target,dist,error
      real*8 rmserr,average
      real*8 xi,yi,zi
      real*8, allocatable :: b(:)
      real*8, allocatable :: xx(:)
      real*8, allocatable :: yy(:)
      real*8, allocatable :: zz(:)
      real*8 dmx(n,*)
      character*240 title
c
c
c     set number of iterations and some other needed values
c
      if (verbose)  call settime
      niter = 20
      period = 5
      pairs = dble(n*(n-1)/2)
      dn1 = dble(n-1)
      dn2 = dble(n*n)
c
c     find the average and rms error from trial distances
c
      iter = 0
      rmserr = 0.0d0
      average = 0.0d0
      do i = 1, n-1
         xi = x(i)
         yi = y(i)
         zi = z(i)
         do k = i+1, n
            target = dmx(k,i)
            dist = sqrt((x(k)-xi)**2+(y(k)-yi)**2+(z(k)-zi)**2)
            error = dist - target
            rmserr = rmserr + error**2
            average = average + error/target
         end do
      end do
      rmserr = sqrt(rmserr/pairs)
      average = 100.0d0 * average / pairs
c
c     write a header with the initial error values
c
      if (verbose) then
         write (iout,10)
   10    format (/,' Majorization to Trial Distances using',
     &              ' Constant Weights :',
     &           //,4x,'Iteration',6x,'RMS Error',5x,'Ave % Error',/)
         write (iout,20)  iter,rmserr,average
   20    format (5x,i5,2f16.4)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (b(n))
      allocate (xx(n))
      allocate (yy(n))
      allocate (zz(n))
c
c     initialize the transformed coordinates for each atom
c
      do iter = 1, niter
         do i = 1, n
            xi = x(i)
            yi = y(i)
            zi = z(i)
            b(i) = 0.0d0
            xx(i) = 0.0d0
            yy(i) = 0.0d0
            zz(i) = 0.0d0
c
c     form a single row of the B matrix assuming unity weights
c
            do k = 1, i-1
               dist = sqrt((x(k)-xi)**2+(y(k)-yi)**2+(z(k)-zi)**2)
               b(k) = -dmx(k,i) / dist
               b(i) = b(i) - b(k)
            end do
            do k = i+1, n
               dist = sqrt((x(k)-xi)**2+(y(k)-yi)**2+(z(k)-zi)**2)
               b(k) = -dmx(k,i) / dist
               b(i) = b(i) - b(k)
            end do
c
c     multiply the row of the B matrix by the atomic coordinates
c
            do k = 1, n
               xx(i) = xx(i) + b(k)*x(k)
               yy(i) = yy(i) + b(k)*y(k)
               zz(i) = zz(i) + b(k)*z(k)
            end do
         end do
c
c     move the intermediate values into the coordinate arrays
c
         do i = 1, n
            x(i) = xx(i)
            y(i) = yy(i)
            z(i) = zz(i)
         end do
c
c     multiply the inverse weight matrix S+ by the coordinates
c
         do i = 1, n
            xx(i) = (dn1/dn2) * x(i)
            yy(i) = (dn1/dn2) * y(i)
            zz(i) = (dn1/dn2) * z(i)
            do k = 1, i-1
               xx(i) = xx(i) - x(k)/dn2
               yy(i) = yy(i) - y(k)/dn2
               zz(i) = zz(i) - z(k)/dn2
            end do
            do k = i+1, n
               xx(i) = xx(i) - x(k)/dn2
               yy(i) = yy(i) - y(k)/dn2
               zz(i) = zz(i) - z(k)/dn2
            end do
         end do
c
c     copy the new coordinates into their permanent arrays
c
         do i = 1, n
            x(i) = xx(i)
            y(i) = yy(i)
            z(i) = zz(i)
         end do
c
c     find the average and rms error from trial distances
c
         rmserr = 0.0d0
         average = 0.0d0
         do i = 1, n-1
            xi = x(i)
            yi = y(i)
            zi = z(i)
            do k = i+1, n
               target = dmx(k,i)
               dist = sqrt((x(k)-xi)**2+(y(k)-yi)**2+(z(k)-zi)**2)
               error = dist - target
               rmserr = rmserr + error**2
               average = average + error/target
            end do
         end do
         rmserr = sqrt(rmserr/pairs)
         average = 100.0d0 * average / pairs
         if (verbose .and. mod(iter,period).eq.0) then
            write (iout,30)  iter,rmserr,average
   30       format (5x,i5,2f16.4)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (b)
      deallocate (xx)
      deallocate (yy)
      deallocate (zz)
c
c     find the rms bounds deviations and radius of gyration
c
      if (verbose) then
         title = 'after Majorization :'
         call rmserror (title)
         call gyrate (rg)
         write (iout,40)  rg
   40    format (/,' Radius of Gyration after Majorization :',5x,f16.4)
c
c     get the time required for the majorization procedure
c
         call gettime (wall,cpu)
         write (iout,50)  wall
   50    format (/,' Time Required for Majorization :',8x,f12.2,
     &              ' seconds')
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine refine  --  minimization of initial embedding  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "refine" performs minimization of the atomic coordinates
c     of an initial crude embedded distance geometry structure versus
c     the bound, chirality, planarity and torsional error functions
c
c
      subroutine refine (mode,fctval,grdmin)
      use atoms
      use disgeo
      use inform
      use iounit
      use minima
      use output
      implicit none
      integer i,nvar
      real*8 initerr,miderr,toterr
      real*8 fctval,grdmin
      real*8, allocatable :: xx(:)
      character*7 mode
      external initerr,miderr
      external toterr,optsave
c
c
c     perform dynamic allocation of some local arrays
c
      nvar = 3 * n
      allocate (xx(nvar))
c
c     convert atomic coordinates to optimization parameters
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         xx(nvar) = x(i)
         nvar = nvar + 1
         xx(nvar) = y(i)
         nvar = nvar + 1
         xx(nvar) = z(i)
      end do
c
c     set values of parameters needed for optimization
c
      coordtype = 'NONE'
      cyclesave = .true.
c     grdmin = 0.01d0
      maxiter = 2 * nvar
      iwrite = 0
c     iprint = 0
c     if (verbose)  iprint = 10
c
c     minimize initially only on the local geometry and torsions,
c     then on local geometry and chirality, torsions, and finally
c     minimize on all distance bounds, chirality and torsions
c
      if (mode .eq. 'INITIAL') then
         call lbfgs (nvar,xx,fctval,grdmin,initerr,optsave)
      else if (mode .eq. 'MIDDLE') then
         call lbfgs (nvar,xx,fctval,grdmin,miderr,optsave)
      else if (mode .eq. 'FINAL') then
         call lbfgs (nvar,xx,fctval,grdmin,toterr,optsave)
      end if
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine explore  --  simulated annealing refinement  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "explore" uses simulated annealing on an initial crude
c     embedded distance geoemtry structure to refine versus the
c     bound, chirality, planarity and torsional error functions
c
c
      subroutine explore (mode,nstep,dt,mass,temp_start,temp_stop,v,a)
      use atoms
      use inform
      use iounit
      use math
      use units
      implicit none
      integer i,istep,nstep
      integer nvar,period
      real*8 error,total
      real*8 prior,change
      real*8 dt,dt2,dt_2,dt2_2
      real*8 xbig,xrms,mass,kinetic
      real*8 temp_start,temp_stop
      real*8 tau_start,tau_stop
      real*8 ratio,sigmoid,scale
      real*8 target,temp,tautemp
      real*8 initerr,miderr,toterr
      real*8 v(*)
      real*8 a(*)
      real*8, allocatable :: xx(:)
      real*8, allocatable :: xmove(:)
      real*8, allocatable :: g(:)
      character*7 mode
c
c
c     set values of the basic simulated annealing parameters
c
c     nstep = 5000
c     dt = 0.1d0
c     temp_start = 200.0d0
c     temp_stop = 0.0d0
c     mass = 1000.0d0
c
c     perform dynamic allocation of some local arrays
c
      nvar = 3 * n
      allocate (xx(nvar))
      allocate (xmove(nvar))
      allocate (g(nvar))
c
c     convert atomic coordinates to annealing variables
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         xx(nvar) = x(i)
         nvar = nvar + 1
         xx(nvar) = y(i)
         nvar = nvar + 1
         xx(nvar) = z(i)
      end do
c
c     initialize the velocities, accelerations and other parameters
c
      dt2 = dt * dt
      dt_2 = dt / 2.0d0
      dt2_2 = dt2 / 2.0d0
      period = 100
      tau_start = 100.0d0 * dt
      tau_stop = 10.0d0 * dt
      tautemp = tau_start
c
c     print a header for the simulated annealing protocol
c
      write (iout,10)
   10 format (/,' Molecular Dynamics Simulated Annealing Refinement :')
      write (iout,20)  nstep,dt,log(mass)/logten,temp_start,temp_stop
   20 format (/,' Steps:',i6,3x,'Time/Step:',f6.3,' ps',3x,
     &           'LogMass:',f5.2,3x,'Temp:',f6.1,' to',f6.1)
c
c     get the total error and temperature at start of dynamics
c
      if (mode .eq. 'INITIAL') then
         error = initerr (xx,g)
      else if (mode .eq. 'MIDDLE') then
         error = miderr (xx,g)
      else if (mode .eq. 'FINAL') then
         error = toterr (xx,g)
      end if
      kinetic = 0.0d0
      do i = 1, nvar
         kinetic = kinetic + mass*v(i)**2
      end do
      kinetic = 0.5d0 * kinetic / ekcal
      temp = 2.0d0 * kinetic / (dble(nvar) * gasconst)
      total = error + kinetic
      prior = total
      if (verbose) then
         write (iout,30)
   30    format (/,' MD Step    E Total   E Potential   E Kinetic',
     &              '     Temp    MaxMove   RMS Move',/)
         write (iout,40)  0,total,error,kinetic,temp
   40    format (i6,2f13.4,f12.4,f11.2)
      end if
c
c     find new positions and half-step velocities via Verlet
c
      do istep = 1, nstep
         xbig = 0.0d0
         xrms = 0.0d0
         do i = 1, nvar
            xmove(i) = v(i)*dt + a(i)*dt2_2
            xx(i) = xx(i) + xmove(i)
            v(i) = v(i) + a(i)*dt_2
            if (abs(xmove(i)) .gt. xbig)  xbig = abs(xmove(i))
            xrms = xrms + xmove(i)**2
         end do
         xrms = sqrt(xrms/dble(nvar))
c
c     get the error function value and gradient
c
         if (mode .eq. 'INITIAL') then
            error = initerr (xx,g)
         else if (mode .eq. 'MIDDLE') then
            error = miderr (xx,g)
         else if (mode .eq. 'FINAL') then
            error = toterr (xx,g)
         end if
c
c     use Newton's second law to get the next accelerations;
c     find the full-step velocities using the Verlet recursion
c
         do i = 1, nvar
            a(i) = -ekcal * g(i) / mass
            v(i) = v(i) + a(i)*dt_2
         end do
c
c     find the total kinetic energy and system temperature
c
         kinetic = 0.0d0
         do i = 1, nvar
            kinetic = kinetic + mass*v(i)**2
         end do
         kinetic = 0.5d0 * kinetic / ekcal
         temp = 2.0d0 * kinetic / (dble(nvar) * gasconst)
         if (temp .eq. 0.0d0)  temp = 0.1d0
c
c     set target temperature and coupling via a sigmoidal cooling
c
         ratio = dble(istep) / dble(nstep)
         ratio = sigmoid (3.5d0,ratio)
         target = temp_start*(1.0d0-ratio) + temp_stop*ratio
         tautemp = tau_start*(1.0d0-ratio) + tau_stop*ratio
c
c     couple to external temperature bath via velocity scaling
c
         scale = sqrt(1.0d0 + (dt/tautemp)*(target/temp-1.0d0))
         do i = 1, nvar
            v(i) = scale * v(i)
         end do
c
c     write results for the current annealing step
c
         total = error + kinetic
         if (verbose .and. mod(istep,period).eq.0) then
            write (iout,50)  istep,total,error,kinetic,temp,xbig,xrms
   50       format (i6,2f13.4,f12.4,f11.2,2f10.4)
         end if
c
c     check the energy change for instability in the dynamics
c
         change = total - prior
         if (change .gt. dble(n)) then
            do i = 1, nvar
               xx(i) = xx(i) - xmove(i)
            end do
            if (verbose .and. mod(istep,period).ne.0) then
               write (iout,60)  istep,total,error,kinetic,temp,xbig,xrms
   60          format (i6,2f13.4,f12.4,f11.2,2f10.4)
            end if
            write (iout,70)
   70       format (/,' EXPLORE  --  Simulated Annealing Unstable;',
     &                 ' Switching to Minimization')
            goto 80
         end if
      end do
c
c     convert annealing variables to atomic coordinates
c
   80 continue
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      deallocate (xmove)
      deallocate (g)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine fracdist  --  fractional distance distribution  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "fracdist" computes a normalized distribution of the pairwise
c     fractional distances between the smoothed upper and lower bounds
c
c     literature reference:
c
c     C. M. Oshiro, J. Thomason and I. D. Kuntz, "Effects of Limited
c     Input Distance Constraints Upon the Distance Geometry Algorithm",
c     Biopolymers, 31, 1049-1064 (1991)
c
c
      subroutine fracdist (title)
      use atoms
      use disgeo
      use iounit
      implicit none
      integer start,stop
      parameter (start=-20)
      parameter (stop=120)
      integer i,j,k,sum
      integer trimtext
      integer bin(start:stop)
      integer bin2(start:stop)
      real*8 xi,yi,zi,size
      real*8 dist,range,fraction
      real*8 fdist(start:stop)
      real*8 fdist2(start:stop)
      character*240 title
c
c
c     set the bin size and zero out the individual bins
c
      size = 0.01d0
      do i = start, stop
         bin(i) = 0
         bin2(i) = 0
      end do
c
c     get distribution of fractional distances between bounds
c
      do i = 1, n-1
         xi = x(i)
         yi = y(i)
         zi = z(i)
         do j = i+1, n
            dist = sqrt((x(j)-xi)**2 + (y(j)-yi)**2 + (z(j)-zi)**2)
            range = dbnd(i,j) - dbnd(j,i)
            if (range .ge. 1.0d0) then
               fraction = (dist-dbnd(j,i)) / range
               k = nint(fraction / size)
               k = max(start,min(stop,k))
               bin(k) = bin(k) + 1
               if (range .ge. 0.8d0*pathmax)  bin2(k) = bin2(k) + 1
            end if
         end do
      end do
c
c     normalize the fractional distance frequency distribution
c
      sum = 0
      do i = start, stop
         sum = sum + bin(i)
      end do
      do i = start, stop
         fdist(i) = dble(bin(i)) / (size*dble(sum))
      end do
      sum = 0
      do i = start, stop
         sum = sum + bin2(i)
      end do
      do i = start, stop
         fdist2(i) = dble(bin2(i)) / (size*dble(sum))
      end do
c
c     print the normalized fractional distance probability
c
      write (iout,10)  title(1:trimtext(title))
   10 format (/,' Fractional Distance Distribution ',a,/)
      do i = start, stop
         write (iout,20)  size*dble(i),fdist(i),fdist2(i)
   20    format (8x,f8.4,8x,f8.4,8x,f8.4)
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine rmserror  --  rms bound and restraint error  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "rmserror" computes the maximum absolute deviation and the
c     rms deviation from the distance bounds, and the number and
c     rms value of the distance restraint violations
c
c
      subroutine rmserror (title)
      use atoms
      use disgeo
      use iounit
      use restrn
      implicit none
      integer i,j,k,npair
      integer nhierr,nloerr
      integer ihi,jhi,ilo,jlo
      integer trimtext
      real*8 rms,himax,lomax
      real*8 dist,hierr,loerr
      character*240 title
c
c
c     search all atom pairs for maximal bounds deviations
c
      npair = n*(n-1) / 2
      nloerr = 0
      nhierr = 0
      ilo = 0
      jlo = 0
      ihi = 0
      jhi = 0
      rms = 0.0d0
      lomax = 0.0d0
      himax = 0.0d0
      do i = 1, n-1
         do j = i+1, n
            dist = (x(i)-x(j))**2 + (y(i)-y(j))**2 + (z(i)-z(j))**2
            dist = sqrt(dist)
            hierr = dist - dbnd(i,j)
            if (hierr .gt. 0.0d0) then
               nhierr = nhierr + 1
               rms = rms + hierr**2
               if (hierr .gt. himax) then
                  himax = hierr
                  ihi = i
                  jhi = j
               end if
            end if
            loerr = dbnd(j,i) - dist
            if (loerr .gt. 0.0d0) then
               nloerr = nloerr + 1
               rms = rms + loerr**2
               if (loerr .gt. lomax) then
                  lomax = loerr
                  ilo = i
                  jlo = j
               end if
            end if
         end do
      end do
      rms = sqrt(rms/dble(n*(n-1)/2))
c
c     print the maximal and rms bound deviations
c
      write (iout,10)  title(1:trimtext(title))
   10 format (/,' Fit to Bounds ',a)
      write (iout,20)  nhierr,npair,nloerr,npair,himax,
     &                 ihi,jhi,lomax,ilo,jlo,rms
   20 format (/,' Num Upper Bound Violations :',4x,i11,'  of ',i12,
     &        /,' Num Lower Bound Violations :',4x,i11,'  of ',i12,
     &        /,' Max Upper Bound Violation :',4x,f12.4,'  at ',2i6,
     &        /,' Max Lower Bound Violation :',4x,f12.4,'  at ',2i6,
     &        /,' RMS Deviation from Bounds :',4x,f12.4)
c
c     search the list of distance restraints for violations
c
      if (ndfix .gt. 0) then
         nloerr = 0
         nhierr = 0
         ilo = 0
         jlo = 0
         ihi = 0
         jhi = 0
         rms = 0.0d0
         himax = 0.0d0
         lomax = 0.0d0
         do k = 1, ndfix
            i = idfix(1,k)
            j = idfix(2,k)
            dist = (x(i)-x(j))**2 + (y(i)-y(j))**2 + (z(i)-z(j))**2
            dist = sqrt(dist)
            if (dist .lt. dfix(2,k)) then
               nloerr = nloerr + 1
               loerr = dfix(2,k) - dist
               rms = rms + loerr**2
               if (loerr .gt. lomax) then
                  lomax = loerr
                  ilo = i
                  jlo = j
               end if
            else if (dist .gt. dfix(3,k)) then
               nhierr = nhierr + 1
               hierr = dist - dfix(3,k)
               rms = rms + hierr**2
               if (hierr .gt. himax) then
                  himax = hierr
                  ihi = i
                  jhi = j
               end if
            end if
         end do
         rms = sqrt(rms/dble(ndfix))
c
c     print total number and rms value of restraint violations
c
         write (iout,30)  nhierr,ndfix,nloerr,ndfix,himax,
     &                    ihi,jhi,lomax,ilo,jlo,rms
   30    format (/,' Num Upper Restraint Violations :',i11,'  of ',i12,
     &           /,' Num Lower Restraint Violations :',i11,'  of ',i12,
     &           /,' Max Upper Restraint Violation :',f12.4,'  at ',2i6,
     &           /,' Max Lower Restraint Violation :',f12.4,'  at ',2i6,
     &           /,' RMS Restraint Dist Violation : ',f12.4)
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine dmdump  --  final distance and error matrix  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "dmdump" puts the distance matrix of the final structure
c     into the upper half of a matrix, the distance of each atom
c     to the centroid on the diagonal, and the individual terms
c     of the bounds errors into the lower half of the matrix
c
c
      subroutine dmdump (dmd)
      use atoms
      use disgeo
      use iounit
      implicit none
      integer i,j
      real*8 sum,rgsq
      real*8 dist,dist2
      real*8 dmd(n,*)
      character*240 title
c
c
c     store the final distance matrix and bound violations
c
      do i = 1, n
         dmd(i,i) = 0.0d0
      end do
      sum = 0.0d0
      do i = 1, n-1
         do j = i+1, n
            dist2 = (x(i)-x(j))**2 + (y(i)-y(j))**2 + (z(i)-z(j))**2
            sum = sum + dist2
            dmd(i,i) = dmd(i,i) + dist2
            dmd(j,j) = dmd(j,j) + dist2
            dist = sqrt(dist2)
            dmd(i,j) = dist
            if (dist .gt. dbnd(i,j)) then
               dmd(j,i) = dist - dbnd(i,j)
            else if (dist .lt. dbnd(j,i)) then
               dmd(j,i) = dbnd(j,i) - dist
            else
               dmd(j,i) = 0.0d0
            end if
         end do
      end do
c
c     put the distance to the centroid on the diagonal
c
      rgsq = sum / dble(n**2)
      do i = 1, n
         dmd(i,i) = sqrt(dmd(i,i)/dble(n) - rgsq)
      end do
c
c     write out the interatomic distance and error matrices
c
      title = 'Final Dist Matrix Above; DCM on Diag; Error Below :'
      call grafic (n,dmd,title)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  function initerr  --  initial error function and gradient  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "initerr" is the initial error function and derivatives for
c     a distance geometry embedding; it includes components from
c     the local geometry and torsional restraint errors
c
c
      function initerr (xx,g)
      use atoms
      implicit none
      integer i,j,nvar
      real*8 initerr
      real*8 local,locerr
      real*8 torsion,torser
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     zero out the values of the atomic gradient components
c
      do i = 1, n
         do j = 1, 3
            derivs(j,i) = 0.0d0
         end do
      end do
c
c     compute the local geometry and the torsional
c     components of the error function and its gradient
c
      local = locerr (derivs)
      torsion = torser (derivs)
      initerr = local + torsion
c
c     store the atomic gradients as the optimization gradient
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         g(nvar) = derivs(1,i)
         nvar = nvar + 1
         g(nvar) = derivs(2,i)
         nvar = nvar + 1
         g(nvar) = derivs(3,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  function miderr  --  second error function and gradient  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "miderr" is the secondary error function and derivatives
c     for a distance geometry embedding; it includes components
c     from the distance bounds, local geometry, chirality and
c     torsional restraint errors
c
c
      function miderr (xx,g)
      use atoms
      implicit none
      integer i,j,nvar
      real*8 miderr
      real*8 bounds,bnderr
      real*8 local,locerr
      real*8 chiral,chirer
      real*8 torsion,torser
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     zero out the values of the atomic gradient components
c
      do i = 1, n
         do j = 1, 3
            derivs(j,i) = 0.0d0
         end do
      end do
c
c     compute the local geometry, chirality and torsional
c     components of the error function and its gradient
c
      bounds = bnderr (derivs)
      local = locerr (derivs)
      chiral = chirer (derivs)
      torsion = torser (derivs)
      miderr = bounds + local + chiral + torsion
c
c     store the atomic gradients as the optimization gradient
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         g(nvar) = derivs(1,i)
         nvar = nvar + 1
         g(nvar) = derivs(2,i)
         nvar = nvar + 1
         g(nvar) = derivs(3,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function toterr  --  total error function and gradient  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "toterr" is the error function and derivatives for a distance
c     geometry embedding; it includes components from the distance
c     bounds, hard sphere contacts, local geometry, chirality and
c     torsional restraint errors
c
c
      function toterr (xx,g)
      use atoms
      implicit none
      integer i,j,nvar
      real*8 toterr
      real*8 bounds,bnderr
      real*8 local,locerr
      real*8 chiral,chirer
      real*8 torsion,torser
      real*8 contact,vdwerr
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     zero out the values of the atomic gradient components
c
      do i = 1, n
         do j = 1, 3
            derivs(j,i) = 0.0d0
         end do
      end do
c
c     compute the distance bound, vdw, chirality and torsional
c     components of the error function and its gradient
c
      bounds = bnderr (derivs)
      contact = vdwerr (derivs)
      local = locerr (derivs)
      chiral = chirer (derivs)
      torsion = torser (derivs)
      toterr = bounds + contact + local + chiral + torsion
c
c     store the atomic gradients as the optimization gradient
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         g(nvar) = derivs(1,i)
         nvar = nvar + 1
         g(nvar) = derivs(2,i)
         nvar = nvar + 1
         g(nvar) = derivs(3,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function bnderr  --  computes total distance bound error  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "bnderr" is the distance bound error function and derivatives;
c     this version implements the original and Havel's normalized
c     lower bound penalty, the normalized version is preferred when
c     lower bounds are small (as with NMR NOE restraints), the
c     original penalty is needed if large lower bounds are present
c
c
      function bnderr (derivs)
      use atoms
      use restrn
      implicit none
      integer i,j,k
      real*8 bnderr,error,cutsq
      real*8 scale,chain,term
      real*8 gap,buffer,weigh
      real*8 dx,dy,dz,gx,gy,gz
      real*8 dstsq,bupsq,blosq
      real*8 derivs(3,*)
c
c
c     zero out the distance bounds error function
c
      bnderr = 0.0d0
      scale = 10.0d0
      cutsq = 40.0d0
c
c     calculate the pairwise distances between atoms
c
      do k = 1, ndfix
         i = idfix(1,k)
         j = idfix(2,k)
         dx = x(i) - x(j)
         dy = y(i) - y(j)
         dz = z(i) - z(j)
c
c     calculate squared actual distance and bound distances;
c     use of a small "buffer" cleans up the final error count
c
         dstsq = dx*dx + dy*dy + dz*dz
         gap = dfix(3,k) - dfix(2,k)
         buffer = 0.05d0 * min(1.0d0,gap)
         blosq = (dfix(2,k) + buffer)**2
         bupsq = (dfix(3,k) - buffer)**2
c
c     error and derivatives for upper bound violation
c
         if (dstsq .gt. bupsq) then
            weigh = scale * dfix(1,k)
            term = (dstsq-bupsq) / bupsq
            chain = 4.0d0 * weigh * term / bupsq
            error = weigh * term**2
            gx = dx * chain
            gy = dy * chain
            gz = dz * chain
            bnderr = bnderr + error
            derivs(1,i) = derivs(1,i) + gx
            derivs(2,i) = derivs(2,i) + gy
            derivs(3,i) = derivs(3,i) + gz
            derivs(1,j) = derivs(1,j) - gx
            derivs(2,j) = derivs(2,j) - gy
            derivs(3,j) = derivs(3,j) - gz
c
c     error and derivatives for lower bound violation
c
         else if (dstsq .lt. blosq) then
            weigh = scale * dfix(1,k)
            if (blosq .gt. cutsq) then
               term = (blosq-dstsq) / dstsq
               chain = -4.0d0 * weigh * term * (blosq/dstsq**2)
            else
               term = (blosq-dstsq) / (blosq+dstsq)
               chain = -8.0d0 * weigh * term * (blosq/(blosq+dstsq)**2)
            end if
            error = weigh * term**2
            gx = dx * chain
            gy = dy * chain
            gz = dz * chain
            bnderr = bnderr + error
            derivs(1,i) = derivs(1,i) + gx
            derivs(2,i) = derivs(2,i) + gy
            derivs(3,i) = derivs(3,i) + gz
            derivs(1,j) = derivs(1,j) - gx
            derivs(2,j) = derivs(2,j) - gy
            derivs(3,j) = derivs(3,j) - gz
         end if
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  function vdwerr  --  computes van der Waals bound error  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "vdwerr" is the hard sphere van der Waals bound error function
c     and derivatives that penalizes close nonbonded contacts,
c     pairwise neighbors are generated via the method of lights
c
c
      function vdwerr (derivs)
      use atoms
      use couple
      use disgeo
      use light
      implicit none
      integer i,j,k,kgy,kgz
      integer, allocatable :: skip(:)
      real*8 vdwerr,error
      real*8 scale,chain,term
      real*8 xi,yi,zi
      real*8 dx,dy,dz,gx,gy,gz
      real*8 dstsq,blosq
      real*8 radi,radsq
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      real*8 derivs(3,*)
      logical unique
c
c
c     zero out the distance van der Waals error function
c
      vdwerr = 0.0d0
      scale = 1.0d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (skip(n))
      allocate (xsort(n))
      allocate (ysort(n))
      allocate (zsort(n))
c
c     transfer coordinates and zero out atoms to be skipped
c
      do i = 1, n
         xsort(i) = x(i)
         ysort(i) = y(i)
         zsort(i) = z(i)
         skip(i) = 0
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (vdwmax,n,xsort,ysort,zsort,unique)
c
c     now, loop over all atoms computing the interactions
c
      do i = 1, n
         radi = georad(i)
         xi = xsort(rgx(i))
         yi = ysort(rgy(i))
         zi = zsort(rgz(i))
         do j = 1, n12(i)
            skip(i12(j,i)) = i
         end do
         do j = 1, n13(i)
            skip(i13(j,i)) = i
         end do
         do j = 1, n14(i)
            skip(i14(j,i)) = i
         end do
         do j = kbx(i)+1, kex(i)
            k = locx(j)
            if (skip(k) .eq. i)  goto 10
            kgy = rgy(k)
            if (kgy.lt.kby(i) .or. kgy.gt.key(i))  goto 10
            kgz = rgz(k)
            if (kgz.lt.kbz(i) .or. kgz.gt.kez(i))  goto 10
c
c     calculate squared distances and bounds
c
            dx = xi - xsort(j)
            dy = yi - ysort(kgy)
            dz = zi - zsort(kgz)
            dstsq = dx*dx + dy*dy + dz*dz
            radsq = (radi + georad(k))**2
            blosq = min(dbnd(k,i),dbnd(i,k),radsq)
c
c     error and derivatives for lower bound violation
c
            if (dstsq .lt. blosq) then
               term = (blosq-dstsq) / (blosq+dstsq)
               chain = -8.0d0 * scale * term * (blosq/(blosq+dstsq)**2)
               error = scale * term**2
               gx = dx * chain
               gy = dy * chain
               gz = dz * chain
               vdwerr = vdwerr + error
               derivs(1,i) = derivs(1,i) + gx
               derivs(2,i) = derivs(2,i) + gy
               derivs(3,i) = derivs(3,i) + gz
               derivs(1,k) = derivs(1,k) - gx
               derivs(2,k) = derivs(2,k) - gy
               derivs(3,k) = derivs(3,k) - gz
            end if
   10       continue
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (skip)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function locerr  --  computes local geometry error value  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "locerr" is the local geometry error function and derivatives
c     including the 1-2, 1-3 and 1-4 distance bound restraints
c
c
      function locerr (derivs)
      use angbnd
      use atoms
      use bndstr
      use disgeo
      use tors
      implicit none
      integer i,ia,ib,ic,id
      real*8 locerr,error
      real*8 scale,chain,term
      real*8 dx,dy,dz,gx,gy,gz
      real*8 dstsq,bupsq,blosq
      real*8 derivs(3,*)
c
c
c     zero out the local geometry error function
c
      locerr = 0.0d0
      scale = 10.0d0
c
c     calculate the bounds error for bond length distances
c
      do i = 1, nbond
         ia = min(ibnd(1,i),ibnd(2,i))
         ib = max(ibnd(1,i),ibnd(2,i))
         dx = x(ia) - x(ib)
         dy = y(ia) - y(ib)
         dz = z(ia) - z(ib)
         dstsq = dx*dx + dy*dy + dz*dz
         bupsq = dbnd(ia,ib)
         blosq = dbnd(ib,ia)
         if (dstsq .gt. bupsq) then
            term = (dstsq-bupsq) / bupsq
            chain = 4.0d0 * scale * term / bupsq
            error = scale * term**2
            gx = dx * chain
            gy = dy * chain
            gz = dz * chain
            locerr = locerr + error
            derivs(1,ia) = derivs(1,ia) + gx
            derivs(2,ia) = derivs(2,ia) + gy
            derivs(3,ia) = derivs(3,ia) + gz
            derivs(1,ib) = derivs(1,ib) - gx
            derivs(2,ib) = derivs(2,ib) - gy
            derivs(3,ib) = derivs(3,ib) - gz
         else if (dstsq .lt. blosq) then
            term = (blosq-dstsq) / (blosq+dstsq)
            chain = -8.0d0 * scale * term * (blosq/(blosq+dstsq)**2)
            error = scale * term**2
            gx = dx * chain
            gy = dy * chain
            gz = dz * chain
            locerr = locerr + error
            derivs(1,ia) = derivs(1,ia) + gx
            derivs(2,ia) = derivs(2,ia) + gy
            derivs(3,ia) = derivs(3,ia) + gz
            derivs(1,ib) = derivs(1,ib) - gx
            derivs(2,ib) = derivs(2,ib) - gy
            derivs(3,ib) = derivs(3,ib) - gz
         end if
      end do
c
c     calculate the bounds error for the bond angle distances
c
      do i = 1, nangle
         ia = min(iang(1,i),iang(3,i))
         ic = max(iang(1,i),iang(3,i))
         dx = x(ia) - x(ic)
         dy = y(ia) - y(ic)
         dz = z(ia) - z(ic)
         dstsq = dx*dx + dy*dy + dz*dz
         bupsq = dbnd(ia,ic)
         blosq = dbnd(ic,ia)
         if (dstsq .gt. bupsq) then
            term = (dstsq-bupsq) / bupsq
            chain = 4.0d0 * scale * term / bupsq
            error = scale * term**2
            gx = dx * chain
            gy = dy * chain
            gz = dz * chain
            locerr = locerr + error
            derivs(1,ia) = derivs(1,ia) + gx
            derivs(2,ia) = derivs(2,ia) + gy
            derivs(3,ia) = derivs(3,ia) + gz
            derivs(1,ic) = derivs(1,ic) - gx
            derivs(2,ic) = derivs(2,ic) - gy
            derivs(3,ic) = derivs(3,ic) - gz
         else if (dstsq .lt. blosq) then
            term = (blosq-dstsq) / (blosq+dstsq)
            chain = -8.0d0 * scale * term * (blosq/(blosq+dstsq)**2)
            error = scale * term**2
            gx = dx * chain
            gy = dy * chain
            gz = dz * chain
            locerr = locerr + error
            derivs(1,ia) = derivs(1,ia) + gx
            derivs(2,ia) = derivs(2,ia) + gy
            derivs(3,ia) = derivs(3,ia) + gz
            derivs(1,ic) = derivs(1,ic) - gx
            derivs(2,ic) = derivs(2,ic) - gy
            derivs(3,ic) = derivs(3,ic) - gz
         end if
      end do
c
c     calculate the bounds error for the torsion angle distances
c
      do i = 1, ntors
         ia = min(itors(1,i),itors(4,i))
         id = max(itors(1,i),itors(4,i))
         dx = x(ia) - x(id)
         dy = y(ia) - y(id)
         dz = z(ia) - z(id)
         dstsq = dx*dx + dy*dy + dz*dz
         bupsq = dbnd(ia,id)
         blosq = dbnd(id,ia)
         if (dstsq .gt. bupsq) then
            term = (dstsq-bupsq) / bupsq
            chain = 4.0d0 * scale * term / bupsq
            error = scale * term**2
            gx = dx * chain
            gy = dy * chain
            gz = dz * chain
            locerr = locerr + error
            derivs(1,ia) = derivs(1,ia) + gx
            derivs(2,ia) = derivs(2,ia) + gy
            derivs(3,ia) = derivs(3,ia) + gz
            derivs(1,id) = derivs(1,id) - gx
            derivs(2,id) = derivs(2,id) - gy
            derivs(3,id) = derivs(3,id) - gz
         else if (dstsq .lt. blosq) then
            term = (blosq-dstsq) / (blosq+dstsq)
            chain = -8.0d0 * scale * term * (blosq/(blosq+dstsq)**2)
            error = scale * term**2
            gx = dx * chain
            gy = dy * chain
            gz = dz * chain
            locerr = locerr + error
            derivs(1,ia) = derivs(1,ia) + gx
            derivs(2,ia) = derivs(2,ia) + gy
            derivs(3,ia) = derivs(3,ia) + gz
            derivs(1,id) = derivs(1,id) - gx
            derivs(2,id) = derivs(2,id) - gy
            derivs(3,id) = derivs(3,id) - gz
         end if
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function chirer  --  computes chirality error function  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "chirer" computes the chirality error and its derivatives
c     with respect to atomic Cartesian coordinates as a sum the
c     squares of deviations of chiral volumes from target values
c
c
      function chirer (derivs)
      use atoms
      use restrn
      implicit none
      integer i,ia,ib,ic,id
      real*8 chirer,error,scale
      real*8 vol,dt,dedt
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 c1,c2,c3
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 derivs(3,*)
c
c
c     zero the chirality restraint error function
c
      chirer = 0.0d0
      scale = 0.1d0
c
c     find signed volume value and compute chirality error
c
      do i = 1, nchir
         ia = ichir(1,i)
         ib = ichir(2,i)
         ic = ichir(3,i)
         id = ichir(4,i)
         xad = x(ia) - x(id)
         yad = y(ia) - y(id)
         zad = z(ia) - z(id)
         xbd = x(ib) - x(id)
         ybd = y(ib) - y(id)
         zbd = z(ib) - z(id)
         xcd = x(ic) - x(id)
         ycd = y(ic) - y(id)
         zcd = z(ic) - z(id)
         c1 = ybd*zcd - zbd*ycd
         c2 = ycd*zad - zcd*yad
         c3 = yad*zbd - zad*ybd
         vol = xad*c1 + xbd*c2 + xcd*c3
         dt = vol - chir(2,i)
         error = scale * dt**2
         dedt = 2.0d0 * scale * dt
c
c     compute derivative components for this interaction
c
         dedxia = dedt * (ybd*zcd - zbd*ycd)
         dedyia = dedt * (zbd*xcd - xbd*zcd)
         dedzia = dedt * (xbd*ycd - ybd*xcd)
         dedxib = dedt * (zad*ycd - yad*zcd)
         dedyib = dedt * (xad*zcd - zad*xcd)
         dedzib = dedt * (yad*xcd - xad*ycd)
         dedxic = dedt * (yad*zbd - zad*ybd)
         dedyic = dedt * (zad*xbd - xad*zbd)
         dedzic = dedt * (xad*ybd - yad*xbd)
         dedxid = -dedxia - dedxib - dedxic
         dedyid = -dedyia - dedyib - dedyic
         dedzid = -dedzia - dedzib - dedzic
c
c     increment the chirality restraint error and derivatives
c
         chirer = chirer + error
         derivs(1,ia) = derivs(1,ia) + dedxia
         derivs(2,ia) = derivs(2,ia) + dedyia
         derivs(3,ia) = derivs(3,ia) + dedzia
         derivs(1,ib) = derivs(1,ib) + dedxib
         derivs(2,ib) = derivs(2,ib) + dedyib
         derivs(3,ib) = derivs(3,ib) + dedzib
         derivs(1,ic) = derivs(1,ic) + dedxic
         derivs(2,ic) = derivs(2,ic) + dedyic
         derivs(3,ic) = derivs(3,ic) + dedzic
         derivs(1,id) = derivs(1,id) + dedxid
         derivs(2,id) = derivs(2,id) + dedyid
         derivs(3,id) = derivs(3,id) + dedzid
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function torser  --  computes torsional error function  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "torser" computes the torsional error function and its first
c     derivatives with respect to the atomic Cartesian coordinates
c     based on the deviation of specified torsional angles from
c     desired values, the contained bond angles are also restrained
c     to avoid a numerical instability
c
c
      function torser (derivs)
      use atoms
      use couple
      use disgeo
      use math
      use refer
      use restrn
      implicit none
      integer i,j,k,iref
      integer ia,ib,ic,id
      real*8 torser,error,force
      real*8 dt,deddt,dedphi
      real*8 angle,target,scale
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xria,yria,zria
      real*8 xrib,yrib,zrib
      real*8 xric,yric,zric
      real*8 xrid,yrid,zrid
      real*8 rba,rcb,rdc
      real*8 dot,cosine,sine
      real*8 rrba,rrcb,rrdc
      real*8 rrca,rrdb
      real*8 bndfac,angfac
      real*8 xp,yp,zp,rp
      real*8 terma,termb
      real*8 termc,termd
      real*8 angmax,angmin
      real*8 cosmax,cosmin
      real*8 bamax,bamin
      real*8 cbmax,cbmin
      real*8 dcmax,dcmin
      real*8 camax,camin
      real*8 dbmax,dbmin
      real*8 xba,yba,zba
      real*8 xcb,ycb,zcb
      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 tf1,tf2,t1,t2
      real*8 dedxt,dedyt,dedzt
      real*8 dedxu,dedyu,dedzu
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 derivs(3,*)
      logical bonded
c
c
c     zero the torsional restraint error function
c
      torser = 0.0d0
      scale = 0.01d0
c
c     compute error value and derivs for torsional restraints
c
      do i = 1, ntfix
         ia = itfix(1,i)
         ib = itfix(2,i)
         ic = itfix(3,i)
         id = itfix(4,i)
         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
c
c     find the actual distances between the four atoms
c
         rba = sqrt(xba*xba + yba*yba + zba*zba)
         rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
         rdc = sqrt(xdc*xdc + ydc*ydc + zdc*zdc)
c
c     see if the torsion involves four directly bonded atoms
c
         k = 0
         do j = 1, n12(ia)
            if (i12(j,ia) .eq. ib)  k = k + 1
         end do
         do j = 1, n12(ib)
            if (i12(j,ib) .eq. ic)  k = k + 1
         end do
         do j = 1, n12(ic)
            if (i12(j,ic) .eq. id)  k = k + 1
         end do
         if (k .eq. 3) then
            bonded = .true.
         else
            bonded = .false.
         end if
c
c     get maximum and minimum distances from distance matrix
c
         if (bonded) then
            bamax = sqrt(dbnd(min(ib,ia),max(ib,ia)))
            bamin = sqrt(dbnd(max(ib,ia),min(ib,ia)))
            cbmax = sqrt(dbnd(min(ic,ib),max(ic,ib)))
            cbmin = sqrt(dbnd(max(ic,ib),min(ic,ib)))
            dcmax = sqrt(dbnd(min(id,ic),max(id,ic)))
            dcmin = sqrt(dbnd(max(id,ic),min(id,ic)))
            camax = sqrt(dbnd(min(ic,ia),max(ic,ia)))
            camin = sqrt(dbnd(max(ic,ia),min(ic,ia)))
            dbmax = sqrt(dbnd(min(id,ib),max(id,ib)))
            dbmin = sqrt(dbnd(max(id,ib),min(id,ib)))
c
c     get maximum and minimum distances from input structure
c
         else
            iref = 1
            xria = xref(ia,iref)
            yria = yref(ia,iref)
            zria = zref(ia,iref)
            xrib = xref(ib,iref)
            yrib = yref(ib,iref)
            zrib = zref(ib,iref)
            xric = xref(ic,iref)
            yric = yref(ic,iref)
            zric = zref(ic,iref)
            xrid = xref(id,iref)
            yrid = yref(id,iref)
            zrid = zref(id,iref)
            rrba = sqrt((xrib-xria)**2+(yrib-yria)**2+(zrib-zria)**2)
            rrcb = sqrt((xric-xrib)**2+(yric-yrib)**2+(zric-zrib)**2)
            rrdc = sqrt((xrid-xric)**2+(yrid-yric)**2+(zrid-zric)**2)
            rrca = sqrt((xric-xria)**2+(yric-yria)**2+(zric-zria)**2)
            rrdb = sqrt((xrid-xrib)**2+(yrid-yrib)**2+(zrid-zrib)**2)
            bndfac = 0.05d0
            angfac = 0.05d0
            bamax = (1.0d0 + bndfac) * rrba
            bamin = (1.0d0 - bndfac) * rrba
            cbmax = (1.0d0 + bndfac) * rrcb
            cbmin = (1.0d0 - bndfac) * rrcb
            dcmax = (1.0d0 + bndfac) * rrdc
            dcmin = (1.0d0 - bndfac) * rrdc
            camax = (1.0d0 + angfac) * rrca
            camin = (1.0d0 - angfac) * rrca
            dbmax = (1.0d0 + angfac) * rrdb
            dbmin = (1.0d0 - angfac) * rrdb
         end if
c
c     compute the ia-ib-ic bond angle and any error
c
         dot = xba*xcb + yba*ycb + zba*zcb
         cosine = -dot / (rba*rcb)
         cosine = min(1.0d0,max(-1.0d0,cosine))
         angle = radian * acos(cosine)
         cosmax = (bamin**2+cbmin**2-camax**2) / (2.0d0*bamin*cbmin)
         cosmax = min(1.0d0,max(-1.0d0,cosmax))
         angmax = radian * acos(cosmax)
         cosmin = (bamax**2+cbmax**2-camin**2) / (2.0d0*bamax*cbmax)
         cosmin = min(1.0d0,max(-1.0d0,cosmin))
         angmin = radian * acos(cosmin)
         if (angle .gt. angmax) then
            dt = angle - angmax
         else if (angle .lt. angmin) then
            dt = angle - angmin
         else
            dt = 0.0d0
         end if
         error = scale * dt**2
         deddt = 2.0d0 * radian * scale * dt
c
c     compute derivative components for this interaction
c
         xp = zcb*yba - ycb*zba
         yp = xcb*zba - zcb*xba
         zp = ycb*xba - xcb*yba
         rp = sqrt(xp*xp + yp*yp + zp*zp)
         if (rp .ne. 0.0d0) then
            terma = -deddt / (rba*rba*rp)
            termc = deddt / (rcb*rcb*rp)
            dedxia = terma * (zba*yp-yba*zp)
            dedyia = terma * (xba*zp-zba*xp)
            dedzia = terma * (yba*xp-xba*yp)
            dedxic = termc * (ycb*zp-zcb*yp)
            dedyic = termc * (zcb*xp-xcb*zp)
            dedzic = termc * (xcb*yp-ycb*xp)
            dedxib = -dedxia - dedxic
            dedyib = -dedyia - dedyic
            dedzib = -dedzia - dedzic
c
c     increment the bond angle restraint error and derivatives
c
            torser = torser + error
            derivs(1,ia) = derivs(1,ia) + dedxia
            derivs(2,ia) = derivs(2,ia) + dedyia
            derivs(3,ia) = derivs(3,ia) + dedzia
            derivs(1,ib) = derivs(1,ib) + dedxib
            derivs(2,ib) = derivs(2,ib) + dedyib
            derivs(3,ib) = derivs(3,ib) + dedzib
            derivs(1,ic) = derivs(1,ic) + dedxic
            derivs(2,ic) = derivs(2,ic) + dedyic
            derivs(3,ic) = derivs(3,ic) + dedzic
         end if
c
c     compute the ib-ic-id bond angle and any error
c
         dot = xdc*xcb + ydc*ycb + zdc*zcb
         cosine = -dot / (rdc*rcb)
         cosine = min(1.0d0,max(-1.0d0,cosine))
         angle = radian * acos(cosine)
         cosmax = (dcmin**2+cbmin**2-dbmax**2) / (2.0d0*dcmin*cbmin)
         cosmax = min(1.0d0,max(-1.0d0,cosmax))
         angmax = radian * acos(cosmax)
         cosmin = (dcmax**2+cbmax**2-dbmin**2) / (2.0d0*dcmax*cbmax)
         cosmax = min(1.0d0,max(-1.0d0,cosmin))
         angmin = radian * acos(cosmin)
         if (angle .gt. angmax) then
            dt = angle - angmax
         else if (angle .lt. angmin) then
            dt = angle - angmin
         else
            dt = 0.0d0
         end if
         error = scale * dt**2
         deddt = 2.0d0 * radian * scale * dt
c
c     compute derivative components for this interaction
c
         xp = zdc*ycb - ydc*zcb
         yp = xdc*zcb - zdc*xcb
         zp = ydc*xcb - xdc*ycb
         rp = sqrt(xp*xp + yp*yp + zp*zp)
         if (rp .ne. 0.0d0) then
            termb = -deddt / (rcb*rcb*rp)
            termd = deddt / (rdc*rdc*rp)
            dedxib = termb * (zcb*yp-ycb*zp)
            dedyib = termb * (xcb*zp-zcb*xp)
            dedzib = termb * (ycb*xp-xcb*yp)
            dedxid = termd * (ydc*zp-zdc*yp)
            dedyid = termd * (zdc*xp-xdc*zp)
            dedzid = termd * (xdc*yp-ydc*xp)
            dedxic = -dedxib - dedxid
            dedyic = -dedyib - dedyid
            dedzic = -dedzib - dedzid
c
c     increment the bond angle restraint error and derivatives
c
            torser = torser + error
            derivs(1,ib) = derivs(1,ib) + dedxib
            derivs(2,ib) = derivs(2,ib) + dedyib
            derivs(3,ib) = derivs(3,ib) + dedzib
            derivs(1,ic) = derivs(1,ic) + dedxic
            derivs(2,ic) = derivs(2,ic) + dedyic
            derivs(3,ic) = derivs(3,ic) + dedzic
            derivs(1,id) = derivs(1,id) + dedxid
            derivs(2,id) = derivs(2,id) + dedyid
            derivs(3,id) = derivs(3,id) + dedzid
         end if
c
c     compute the value of the ia-ib-ic-id torsional angle
c
         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)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
c
c     calculate the torsional restraint error for this angle
c
            force = tfix(1,i)
            tf1 = tfix(2,i)
            tf2 = tfix(3,i)
            if (angle.gt.tf1 .and. angle.lt.tf2) then
               target = angle
            else if (angle.gt.tf1 .and. tf1.gt.tf2) then
               target = angle
            else if (angle.lt.tf2 .and. tf1.gt.tf2) then
               target = angle
            else
               t1 = angle - tf1
               t2 = angle - tf2
               if (t1 .gt. 180.0d0) then
                  t1 = t1 - 360.0d0
               else if (t1 .lt. -180.0d0) then
                  t1 = t1 + 360.0d0
               end if
               if (t2 .gt. 180.0d0) then
                  t2 = t2 - 360.0d0
               else if (t2 .lt. -180.0d0) then
                  t2 = t2 + 360.0d0
               end if
               if (abs(t1) .lt. abs(t2)) then
                  target = tf1
               else
                  target = tf2
               end if
            end if
            dt = angle - target
            if (dt .gt. 180.0d0) then
               dt = dt - 360.0d0
            else if (dt .lt. -180.0d0) then
               dt = dt + 360.0d0
            end if
            error = scale * force * dt**2
            dedphi = 2.0d0 * radian * scale * force * dt
c
c     chain rule terms for first derivative components
c
            xca = xic - xia
            yca = yic - yia
            zca = zic - zia
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            dedxt = dedphi * (yt*zcb - ycb*zt) / (rt2*rcb)
            dedyt = dedphi * (zt*xcb - zcb*xt) / (rt2*rcb)
            dedzt = dedphi * (xt*ycb - xcb*yt) / (rt2*rcb)
            dedxu = -dedphi * (yu*zcb - ycb*zu) / (ru2*rcb)
            dedyu = -dedphi * (zu*xcb - zcb*xu) / (ru2*rcb)
            dedzu = -dedphi * (xu*ycb - xcb*yu) / (ru2*rcb)
c
c     compute first derivative components for torsion angle
c
            dedxia = zcb*dedyt - ycb*dedzt
            dedyia = xcb*dedzt - zcb*dedxt
            dedzia = ycb*dedxt - xcb*dedyt
            dedxib = yca*dedzt - zca*dedyt + zdc*dedyu - ydc*dedzu
            dedyib = zca*dedxt - xca*dedzt + xdc*dedzu - zdc*dedxu
            dedzib = xca*dedyt - yca*dedxt + ydc*dedxu - xdc*dedyu
            dedxic = zba*dedyt - yba*dedzt + ydb*dedzu - zdb*dedyu
            dedyic = xba*dedzt - zba*dedxt + zdb*dedxu - xdb*dedzu
            dedzic = yba*dedxt - xba*dedyt + xdb*dedyu - ydb*dedxu
            dedxid = zcb*dedyu - ycb*dedzu
            dedyid = xcb*dedzu - zcb*dedxu
            dedzid = ycb*dedxu - xcb*dedyu
c
c     increment the torsional restraint error and derivatives
c
            torser = torser + error
            derivs(1,ia) = derivs(1,ia) + dedxia
            derivs(2,ia) = derivs(2,ia) + dedyia
            derivs(3,ia) = derivs(3,ia) + dedzia
            derivs(1,ib) = derivs(1,ib) + dedxib
            derivs(2,ib) = derivs(2,ib) + dedyib
            derivs(3,ib) = derivs(3,ib) + dedzib
            derivs(1,ic) = derivs(1,ic) + dedxic
            derivs(2,ic) = derivs(2,ic) + dedyic
            derivs(3,ic) = derivs(3,ic) + dedzic
            derivs(1,id) = derivs(1,id) + dedxid
            derivs(2,id) = derivs(2,id) + dedyid
            derivs(3,id) = derivs(3,id) + dedzid
         end if
      end do
      return
      end
c
c
c     ##################################################################
c     ##  COPYRIGHT (C) 2001 by Anders Carlsson & Jay William Ponder  ##
c     ##                     All Rights Reserved                      ##
c     ##################################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine emetal  --  metal ligand field potential energy  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "emetal" calculates the transition metal ligand field energy
c
c     literature reference:
c
c     A. E. Carlsson and S. Zapata, "The Functional Form of Angular
c     Forces around Transition Metal Ions in Biomolecules", Biophysical
c     Journal, 81, 1-10 (2001)
c
c
      subroutine emetal
      use atomid
      use atoms
      use couple
      use energi
      use kchrge
      implicit none
      integer maxneigh
      parameter (maxneigh=10)
      integer i,j,k,jj,k0
      integer nneigh,ineigh,jneigh
      integer neighnum(maxneigh)
      real*8 e,e0,elf0
      real*8 dot,cij
      real*8 rcut,r2
      real*8 argument
      real*8 rback2,esqtet
      real*8 xmet,ymet,zmet
      real*8 alpha,beta
      real*8 kappa,r0cu
      real*8 rback(3,maxneigh)
      real*8 facback(maxneigh)
      real*8 xneigh(maxneigh)
      real*8 yneigh(maxneigh)
      real*8 zneigh(maxneigh)
      real*8 rneigh(maxneigh)
      real*8 expfac(maxneigh)
      real*8 angfac(maxneigh,maxneigh)
      real*8 cosmat(maxneigh,maxneigh)
c
c
c     zero out the metal ligand field energy
c
      elf = 0.0d0
c
c     begin ligand field calculation; for now, only for Cu+2
c
      do i = 1, n
         if (atomic(i).ne.29 .or. chg(type(i)).ne.2.0d0)  goto 20
         nneigh = 0
         xmet = x(i)
         ymet = y(i)
         zmet = z(i)
         do j = 1, n
            if (j .eq. i)  goto 10
            if (atomic(j).ne.7 .and. atomic(j).ne.8)  goto 10
c
c     next are standard distance, decay factor and splitting energy
c
            r0cu = 2.06d0
            kappa = 1.0d0
            esqtet = 1.64d0
c
c     semiclassical method obtains only 65% of sq-tet difference
c
            elf0 = esqtet * 1.78d0/0.78d0
            elf0 = elf0 * 0.65d0
            e0 = elf0 * 23.05d0/2.608d0
            rcut = 2.50d0
            alpha = 0.0d0
            beta = -1.0d0
            r2 = (x(i)-x(j))**2 + (y(i)-y(j))**2 + (z(i)-z(j))**2
            if (r2 .gt. rcut**2)  goto 10
            nneigh = nneigh + 1
            xneigh(nneigh) = x(j)
            yneigh(nneigh) = y(j)
            zneigh(nneigh) = z(j)
            neighnum(nneigh) = j
            if (n12(j) .le. 0)  call fatal
c
c     set average of back neighbors relative to j,
c     notice that it is defined as a difference
c
            rback(1,nneigh) = 0.0d0
            rback(2,nneigh) = 0.0d0
            rback(3,nneigh) = 0.0d0
            do k0 = 1, n12(j)
               k = i12(k0,j)
               rback(1,nneigh) = rback(1,nneigh)
     &                              + (x(k)-x(j))/dble(n12(j))
               rback(2,nneigh) = rback(2,nneigh)
     &                              + (y(k)-y(j))/dble(n12(j))
               rback(3,nneigh) = rback(3,nneigh)
     &                              + (z(k)-z(j))/dble(n12(j))
            end do
            facback(nneigh) = 0.0d0
            dot = rback(1,nneigh)*(x(i)-x(j))
     &               + rback(2,nneigh)*(y(i)-y(j))
     &               + rback(3,nneigh)*(z(i)-z(j))
            rback2 = rback(1,nneigh)**2 + rback(2,nneigh)**2
     &                  + rback(3,nneigh)**2
            facback(nneigh) = (alpha*sqrt(rback2)*sqrt(r2)+beta*dot)**2
     &                                      / (rback2*r2)
   10       continue
         end do
c
c     calculate the energy for the current interaction
c
         do ineigh = 1, nneigh
            rneigh(ineigh) = (xneigh(ineigh)-xmet)**2
     &                          + (yneigh(ineigh)-ymet)**2
     &                          + (zneigh(ineigh)-zmet)**2
            rneigh(ineigh) = sqrt(rneigh(ineigh))
            expfac(ineigh) = exp(-kappa*(rneigh(ineigh)-r0cu))
            jj = neighnum(ineigh)
            if (atomic(jj) .eq. 8)
     &         expfac(ineigh) = 0.4d0 * expfac(ineigh)
         end do
         do ineigh = 1, nneigh
            jj = neighnum(ineigh)
         end do
         do ineigh = 1, nneigh
            do jneigh = 1, nneigh
               dot = (xneigh(ineigh)-xmet)*(xneigh(jneigh)-xmet)
     &                  + (yneigh(ineigh)-ymet)*(yneigh(jneigh)-ymet)
     &                  + (zneigh(ineigh)-zmet)*(zneigh(jneigh)-zmet)
               cij = dot / (rneigh(ineigh)*rneigh(jneigh))
               cosmat(ineigh,jneigh) = cij
               angfac(ineigh,jneigh) = 2.25d0*cij**4 - 1.5d0*cij**2
     &                                          + 0.005d0
            end do
         end do
         argument = 0.0d0
         do ineigh = 1, nneigh
            do jneigh = 1, nneigh
               argument = argument + expfac(ineigh)*expfac(jneigh)
     &                                  *angfac(ineigh,jneigh)
     &                              *facback(ineigh)*facback(jneigh)
            end do
         end do
c
c     increment the total metal ligand field energy
c
         e = 0.0d0
         if (argument .gt. 0) then
            e = -e0 * sqrt(argument)
            elf = elf + e
         end if
   20    continue
      end do
      return
      end
c
c
c     ##################################################################
c     ##  COPYRIGHT (C) 2001 by Anders Carlsson & Jay William Ponder  ##
c     ##                     All Rights Reserved                      ##
c     ##################################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine emetal1  --  ligand field energy & derivatives  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "emetal1" calculates the transition metal ligand field energy
c     and its first derivatives with respect to Cartesian coordinates
c
c
      subroutine emetal1
      use atomid
      use atoms
      use couple
      use deriv
      use energi
      use kchrge
      implicit none
      integer maxneigh
      parameter (maxneigh=10)
      integer i,j,k,jj,k0
      integer nneigh,ineigh,jneigh
      integer neighnum(maxneigh)
      real*8 e,e0,elf0,esqtet
      real*8 rcut,r2,rback2
      real*8 cij,argument,dot
      real*8 xmet,ymet,zmet
      real*8 alpha,beta
      real*8 kappa,r0cu
      real*8 demet(3)
      real*8 rback(3,maxneigh)
      real*8 dedrback(3,maxneigh)
      real*8 facback(maxneigh)
      real*8 dfacback(3,maxneigh)
      real*8 dftback(3,maxneigh)
      real*8 detback(3,maxneigh)
      real*8 de(3,maxneigh)
      real*8 delfdh(maxneigh)
      real*8 xneigh(maxneigh)
      real*8 yneigh(maxneigh)
      real*8 zneigh(maxneigh)
      real*8 rneigh(maxneigh)
      real*8 expfac(maxneigh)
      real*8 delfrad(maxneigh)
      real*8 angfac(maxneigh,maxneigh)
      real*8 dangfac(maxneigh,maxneigh)
      real*8 cosmat(maxneigh,maxneigh)
c
c
c     zero out metal ligand field energy and first derivatives
c
      elf = 0.0d0
      do i = 1, n
         delf(1,i) = 0.0d0
         delf(2,i) = 0.0d0
         delf(3,i) = 0.0d0
      end do
c
c     begin ligand field calculation; for now, only for Cu+2
c
      do i = 1, n
         if (atomic(i).ne.29 .or. chg(type(i)).ne.2.0d0)  goto 30
         nneigh = 0
         xmet = x(i)
         ymet = y(i)
         zmet = z(i)
         do j = 1, n
            if (j .eq. i)  goto 10
            if (atomic(j).ne.7 .and. atomic(j).ne.8)  goto 10
c
c     next are standard distance, decay factor and splitting energy
c
            r0cu = 2.06d0
            kappa = 1.0d0
            esqtet = 1.64d0
c
c     semiclassical method obtains only 65% of sq-tet difference
c
            elf0 = esqtet * 1.78d0/0.78d0
            elf0 = elf0 * 0.65d0
            e0 = elf0 * 23.05d0/2.608d0
            rcut = 2.50d0
            alpha = 0.0d0
            beta = -1.0d0
            r2 = (x(i)-x(j))**2 + (y(i)-y(j))**2 + (z(i)-z(j))**2
            if (r2 .gt. rcut**2)  goto 10
            nneigh = nneigh + 1
            xneigh(nneigh) = x(j)
            yneigh(nneigh) = y(j)
            zneigh(nneigh) = z(j)
            neighnum(nneigh) = j
            if (n12(j) .le. 0)  call fatal
c
c     set average of back neighbors relative to j,
c     notice that it is defined as a difference
c
            rback(1,nneigh) = 0.0d0
            rback(2,nneigh) = 0.0d0
            rback(3,nneigh) = 0.0d0
            do k0 = 1, n12(j)
               k = i12(k0,j)
               rback(1,nneigh) = rback(1,nneigh)
     &                              + (x(k)-x(j))/dble(n12(j))
               rback(2,nneigh) = rback(2,nneigh)
     &                              + (y(k)-y(j))/dble(n12(j))
               rback(3,nneigh) = rback(3,nneigh)
     &                              + (z(k)-z(j))/dble(n12(j))
            end do
            facback(nneigh) = 0.0d0
            dot = rback(1,nneigh)*(x(i)-x(j))
     &               + rback(2,nneigh)*(y(i)-y(j))
     &               + rback(3,nneigh)*(z(i)-z(j))
            rback2 = rback(1,nneigh)**2 + rback(2,nneigh)**2
     &                  + rback(3,nneigh)**2
            facback(nneigh) = (alpha*sqrt(rback2)*sqrt(r2)+beta*dot)**2
     &                                      / (rback2*r2)
c
c     dfacback is derivative of back factor with respect to center
c     of gravity of back atoms; detback is corresponding energy
c
            dfacback(1,nneigh) = 2.0d0*(alpha*sqrt(r2)*rback(1,nneigh)
     &                              /sqrt(rback2)+beta*(x(i)-x(j)))
     &                   *(alpha*sqrt(rback2*r2)+beta*dot)/(rback2*r2)
     &                   -2.0d0*facback(nneigh)*rback(1,nneigh)/rback2
            dfacback(2,nneigh) = 2.0d0*(alpha*sqrt(r2)*rback(2,nneigh)
     &                              /sqrt(rback2)+beta*(y(i)-y(j)))
     &                   *(alpha*sqrt(rback2*r2)+beta*dot)/(rback2*r2)
     &                   -2.0d0*facback(nneigh)*rback(2,nneigh)/rback2
            dfacback(3,nneigh) = 2.0d0*(alpha*sqrt(r2)*rback(3,nneigh)
     &                              /sqrt(rback2)+beta*(z(i)-z(j)))
     &                   *(alpha*sqrt(rback2*r2)+beta*dot)/(rback2*r2)
     &                   -2.0d0*facback(nneigh)*rback(3,nneigh)/rback2
            dftback(1,nneigh) = 2.0d0*(alpha*sqrt(rback2)*(x(i)-x(j))
     &                             /sqrt(r2)+beta*(rback(1,nneigh)))
     &                   *(alpha*sqrt(rback2*r2)+beta*dot)/(rback2*r2)
     &                          -2.0d0*facback(nneigh)*(x(i)-x(j))/r2
            dftback(2,nneigh) = 2.0d0*(alpha*sqrt(rback2)*(y(i)-y(j))
     &                             /sqrt(r2)+beta*(rback(2,nneigh)))
     &                   *(alpha*sqrt(rback2*r2)+beta*dot)/(rback2*r2)
     &                          -2.0d0*facback(nneigh)*(y(i)-y(j))/r2
            dftback(3,nneigh) = 2.0d0*(alpha*sqrt(rback2)*(z(i)-z(j))
     &                             /sqrt(r2)+beta*(rback(3,nneigh)))
     &                   *(alpha*sqrt(rback2*r2)+beta*dot)/(rback2*r2)
     &                          -2.0d0*facback(nneigh)*(z(i)-z(j))/r2
   10       continue
         end do
c
c     calculate the energy and derivatives for current interaction
c
         do ineigh = 1, nneigh
            rneigh(ineigh) = (xneigh(ineigh)-xmet)**2
     &                          + (yneigh(ineigh)-ymet)**2
     &                          + (zneigh(ineigh)-zmet)**2
            rneigh(ineigh) = sqrt(rneigh(ineigh))
            expfac(ineigh) = exp(-kappa*(rneigh(ineigh)-r0cu))
            jj = neighnum(ineigh)
            if (atomic(jj).eq.8)  expfac(ineigh) = 0.4d0*expfac(ineigh)
         end do
         do ineigh = 1, nneigh
            jj = neighnum(ineigh)
         end do
         do ineigh = 1, nneigh
            do jneigh = 1, nneigh
               dot = (xneigh(ineigh)-xmet)*(xneigh(jneigh)-xmet)
     &                  + (yneigh(ineigh)-ymet)*(yneigh(jneigh)-ymet)
     &                  + (zneigh(ineigh)-zmet)*(zneigh(jneigh)-zmet)
               cij = dot / (rneigh(ineigh)*rneigh(jneigh))
               cosmat(ineigh,jneigh) = cij
               angfac(ineigh,jneigh) = 2.25d0*cij**4 - 1.5d0*cij**2
     &                                          + 0.005d0
               dangfac(ineigh,jneigh) = 9.0d0*cij**3 - 3.0d0*cij
            end do
         end do
         argument = 0.0d0
         do ineigh = 1, nneigh
            do jneigh = 1, nneigh
               argument = argument + expfac(ineigh)*expfac(jneigh)
     &                                   *angfac(ineigh,jneigh)
     &                              *facback(ineigh)*facback(jneigh)
            end do
         end do
         e = 0.0d0
         do ineigh = 1, nneigh
            de(1,ineigh) = 0.0d0
            de(2,ineigh) = 0.0d0
            de(3,ineigh) = 0.0d0
         end do
         if (argument .le. 0)  goto 20
         if (argument .gt. 0)  e = -e0 * sqrt(argument)
c
c     set up radial derivatives of energy
c
         do ineigh = 1, nneigh
            delfrad(ineigh) = 0.0d0
            do jneigh = 1,nneigh
               delfrad(ineigh) = delfrad(ineigh) + expfac(jneigh)
     &                                         *angfac(ineigh,jneigh)
     &                                            *facback(jneigh)
            end do
            delfdh(ineigh) = delfrad(ineigh) * (e0/e)
c
c     note two minus signs above cancel
c
            delfrad(ineigh) = -delfrad(ineigh) * (e0**2/e)
     &                           * kappa*expfac(ineigh)*facback(ineigh)
c
c     note cancelling factors of two from square root and product
c
         end do
c
c     below does angular derivatives
c
         do ineigh = 1, nneigh
            de(1,ineigh) = 0.0d0
            de(2,ineigh) = 0.0d0
            de(3,ineigh) = 0.0d0
            do jneigh = 1, nneigh
               de(1,ineigh) = de(1,ineigh) +
     &    expfac(jneigh)*facback(jneigh)*dangfac(ineigh,jneigh)*
     &    ((xneigh(jneigh)-xmet)/(rneigh(ineigh)*rneigh(jneigh))-
     &    (xneigh(ineigh)-xmet)*cosmat(ineigh,jneigh)/rneigh(ineigh)**2)
               de(2,ineigh) = de(2,ineigh) +
     &    expfac(jneigh)*facback(jneigh)*dangfac(ineigh,jneigh)*
     &    ((yneigh(jneigh)-ymet)/(rneigh(ineigh)*rneigh(jneigh))-
     &    (yneigh(ineigh)-ymet)*cosmat(ineigh,jneigh)/rneigh(ineigh)**2)
               de(3,ineigh) = de(3,ineigh) +
     &    expfac(jneigh)*facback(jneigh)*dangfac(ineigh,jneigh)*
     &    ((zneigh(jneigh)-zmet)/(rneigh(ineigh)*rneigh(jneigh))-
     &    (zneigh(ineigh)-zmet)*cosmat(ineigh,jneigh)/rneigh(ineigh)**2)
            end do
            de(1,ineigh) = de(1,ineigh)*e0*e0*expfac(ineigh)
     &                            *facback(ineigh)/e
            de(2,ineigh) = de(2,ineigh)*e0*e0*expfac(ineigh)
     &                            *facback(ineigh)/e
            de(3,ineigh) = de(3,ineigh)*e0*e0*expfac(ineigh)
     &                            *facback(ineigh)/e
         end do
         do ineigh = 1, nneigh
            de(1,ineigh) = de(1,ineigh) + delfrad(ineigh)
     &                        *(xneigh(ineigh)-xmet)/rneigh(ineigh)
            de(2,ineigh) = de(2,ineigh) + delfrad(ineigh)
     &                        *(yneigh(ineigh)-ymet)/rneigh(ineigh)
            de(3,ineigh) = de(3,ineigh) + delfrad(ineigh)
     &                        *(zneigh(ineigh)-zmet)/rneigh(ineigh)
         end do
         do ineigh = 1, nneigh
            dedrback(1,ineigh) = dfacback(1,ineigh)*e0
     &                              *expfac(ineigh)*delfdh(ineigh)
            dedrback(2,ineigh) = dfacback(2,ineigh)*e0
     &                              *expfac(ineigh)*delfdh(ineigh)
            dedrback(3,ineigh) = dfacback(3,ineigh)*e0
     &                              *expfac(ineigh)*delfdh(ineigh)
            detback(1,ineigh) = dftback(1,ineigh)*e0
     &                             *expfac(ineigh)*delfdh(ineigh)
            detback(2,ineigh) = dftback(2,ineigh)*e0
     &                             *expfac(ineigh)*delfdh(ineigh)
            detback(3,ineigh) = dftback(3,ineigh)*e0
     &                             *expfac(ineigh)*delfdh(ineigh)
         end do
   20    continue
         demet(1) = 0.0d0
         demet(2) = 0.0d0
         demet(3) = 0.0d0
         do ineigh = 1, nneigh
            demet(1) = demet(1) - de(1,ineigh) + detback(1,ineigh)
            demet(2) = demet(2) - de(2,ineigh) + detback(2,ineigh)
            demet(3) = demet(3) - de(3,ineigh) + detback(3,ineigh)
         end do
         elf = elf + e
         delf(1,i) = delf(1,i) + demet(1)
         delf(2,i) = delf(2,i) + demet(2)
         delf(3,i) = delf(3,i) + demet(3)
         do ineigh = 1, nneigh
            j = neighnum(ineigh)
            delf(1,j) = delf(1,j) + de(1,ineigh) - dedrback(1,ineigh)
     &                     - detback(1,ineigh)
            delf(2,j) = delf(2,j) + de(2,ineigh) - dedrback(2,ineigh)
     &                     - detback(2,ineigh)
            delf(3,j) = delf(3,j) + de(3,ineigh) - dedrback(3,ineigh)
     &                     - detback(3,ineigh)
         end do
         do ineigh = 1, nneigh
            j = neighnum(ineigh)
            if (n12(j) .le. 0)  call fatal
            do k0 = 1, n12(j)
               k = i12(k0,j)
               delf(1,k) = delf(1,k) + dedrback(1,ineigh)/dble(n12(j))
               delf(2,k) = delf(2,k) + dedrback(2,ineigh)/dble(n12(j))
               delf(3,k) = delf(3,k) + dedrback(3,ineigh)/dble(n12(j))
            end do
         end do
   30    continue
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2000  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine emetal2  --  atom-by-atom ligand field Hessian  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "emetal2" calculates the transition metal ligand field second
c     derivatives for a single atom at a time
c
c
      subroutine emetal2 (i)
      implicit none
      integer i
c
c
c     compute the Hessian elements of the ligand field energy
c
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2000  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine emetal3  --  ligand field energy and analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "emetal3" calculates the transition metal ligand field energy
c     and also partitions the energy among the atoms
c
c
      subroutine emetal3
      use action
      use analyz
      use atomid
      use atoms
      use energi
      use kchrge
      implicit none
      integer i
c
c
c     zero out the ligand field energy and partitioning terms
c
      nelf = 0
      elf = 0.0d0
      do i = 1, n
         aelf(i) = 0.0d0
      end do
c
c     for now, just count the sites and call the energy code
c
      do i = 1, n
         if (atomic(i).eq.29 .and. chg(type(i)).eq.2.0d0) then
            nelf = nelf + 1
         end if
      end do
      call emetal
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine emm3hb  --  MM3 van der Waals and hbond energy  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "emm3hb" calculates the MM3 exp-6 van der Waals and directional
c     charge transfer hydrogen bonding energy
c
c     literature references:
c
c     J.-H. Lii and N. L. Allinger, "Directional Hydrogen Bonding in
c     the MM3 Force Field. I", Journal of Physical Organic Chemistry,
c     7, 591-609 (1994)
c
c     J.-H. Lii and N. L. Allinger, "Directional Hydrogen Bonding in
c     the MM3 Force Field. II", Journal of Computational Chemistry,
c     19, 1001-1016 (1998)
c
c
      subroutine emm3hb
      use energi
      use limits
      use vdwpot
      implicit none
      real*8 elrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_lights) then
         call emm3hb0b
      else if (use_vlist) then
         call emm3hb0c
      else
         call emm3hb0a
      end if
c
c     apply the long range van der Waals correction if used
c
      if (use_vcorr) then
         mode = 'VDW'
         call evcorr (mode,elrc)
         ev = ev + elrc
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine emm3hb0a  --  double loop MM3 vdw-hbond energy  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "emm3hb0a" calculates the MM3 exp-6 van der Waals and
c     directional charge transfer hydrogen bonding energy using
c     a pairwise double loop
c
c
      subroutine emm3hb0a
      use atmlst
      use atomid
      use atoms
      use bndstr
      use bound
      use cell
      use chgpot
      use couple
      use energi
      use group
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer ia,ib,ic
      integer, allocatable :: iv14(:)
      real*8 e,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmin2
      real*8 expmerge
      real*8 dot,cosine
      real*8 fterm,ideal
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rab,rcb2
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     special cutoffs for very short and very long range terms
c
      expmin2 = 0.01d0
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  fterm = 1.0d0
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  else if (radhbnd(kt,it) .ne. 0.0d0) then
                     rv = radhbnd(kt,it)
                     eps = epshbnd(kt,it) / dielec
                     if (atomic(i) .eq. 1) then
                        ia = i
                        ib = i12(1,i)
                        ic = k
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                     end if
                     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)
                     xab = xia - xib
                     yab = yia - yib
                     zab = zia - zib
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     call image (xcb,ycb,zcb)
                     rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                     rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     rab = sqrt(rab2)
                     ideal = bl(bndlist(1,ia))
                     fterm = cosine * (rab/ideal)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  if (p2 .le. expmin2) then
                     e = 0.0d0
                  else if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - fterm*cbuck*p6)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     fterm = 1.0d0
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (radhbnd(kt,it) .ne. 0.0d0) then
                        rv = radhbnd(kt,it)
                        eps = epshbnd(kt,it) / dielec
                        if (atomic(i) .eq. 1) then
                           ia = i
                           ib = i12(1,i)
                           ic = k
                        else
                           ia = k
                           ib = i12(1,k)
                           ic = i
                        end if
                        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)
                        xab = xia - xib
                        yab = yia - yib
                        zab = zia - zib
                        xcb = xic - xib
                        ycb = yic - yib
                        zcb = zic - zib
                        call imager (xcb,ycb,zcb,j)
                        rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                        rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                        dot = xab*xcb + yab*ycb + zab*zcb
                        cosine = dot / sqrt(rab2*rcb2)
                        rab = sqrt(rab2)
                        ideal = bl(bndlist(1,ia))
                        fterm = cosine * (rab/ideal)
                     end if
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              fterm = 1.0d0
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     p2 = (rv*rv) / rik2
                     p6 = p2 * p2 * p2
                     if (p2 .le. expmin2) then
                        e = 0.0d0
                     else if (p2 .le. expcut2) then
                        p = sqrt(p2)
                        expterm = abuck * exp(-bbuck/p)
                        e = eps * (expterm - fterm*cbuck*p6)
                     else
                        p12 = p6 * p6
                        e = expmerge * eps * p12
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik = sqrt(rik2)
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component;
c     interaction of an atom with its own image counts half
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ev = ev + e
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine emm3hb0b  --  MM3 vdw-hbond energy via lights  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "emm3hb0b" calculates the MM3 exp-6 van der Waals and
c     directional charge transfer hydrogen bonding energy using
c     the method of lights
c
c
      subroutine emm3hb0b
      use atmlst
      use atomid
      use atoms
      use bndstr
      use bound
      use boxes
      use cell
      use chgpot
      use couple
      use energi
      use group
      use light
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer ia,ib,ic
      integer kgy,kgz
      integer start,stop
      integer, allocatable :: iv14(:)
      real*8 e,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmin2
      real*8 expmerge
      real*8 dot,cosine
      real*8 fterm,ideal
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rab,rcb2
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     special cutoffs for very short and very long range terms
c
      expmin2 = 0.01d0
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  fterm = 1.0d0
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k).eq.i .and. prime) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  else if (radhbnd(kt,it) .ne. 0.0d0) then
                     rv = radhbnd(kt,it)
                     eps = epshbnd(kt,it) / dielec
                     if (atomic(i) .eq. 1) then
                        ia = i
                        ib = i12(1,i)
                        ic = k
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                     end if
                     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)
                     xab = xia - xib
                     yab = yia - yib
                     zab = zia - zib
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     if (use_bounds) then
                        if (abs(xcb) .gt. xcell2)
     &                     xcb = xcb - sign(xcell,xcb)
                        if (abs(ycb) .gt. ycell2)
     &                     ycb = ycb - sign(ycell,ycb)
                        if (abs(zcb) .gt. zcell2)
     &                     zcb = zcb - sign(zcell,zcb)
                        if (monoclinic) then
                           xcb = xcb + zcb*beta_cos
                           zcb = zcb * beta_sin
                        else if (triclinic) then
                           xcb = xcb + ycb*gamma_cos + zcb*beta_cos
                           ycb = ycb*gamma_sin + zcb*beta_term
                           zcb = zcb * gamma_term
                        end if
                     end if
                     rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                     rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     rab = sqrt(rab2)
                     ideal = bl(bndlist(1,ia))
                     fterm = cosine * (rab/ideal)
                  end if
                  if (prime)  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  if (p2 .le. expmin2) then
                     e = 0.0d0
                  else if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - fterm*cbuck*p6)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine emm3hb0c  --  MM3 vdw-hbond energy via list  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "emm3hb0c" calculates the MM3 exp-6 van der Waals and
c     directional charge transfer hydrogen bonding energy using
c     a pairwise neighbor list
c
c
      subroutine emm3hb0c
      use atmlst
      use atomid
      use atoms
      use bndstr
      use bound
      use chgpot
      use couple
      use energi
      use group
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer ia,ib,ic
      integer, allocatable :: iv14(:)
      real*8 e,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmin2
      real*8 expmerge
      real*8 dot,cosine
      real*8 fterm,ideal
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rab,rcb2
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     special cutoffs for very short and very long range terms
c
      expmin2 = 0.01d0
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13,
!$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group,
!$OMP& off2,radmin,epsilon,radmin4,epsilon4,radhbnd,epshbnd,
!$OMP& dielec,atomic,bl,bndlist,abuck,bbuck,cbuck,expmin2,
!$OMP& expcut2,expmerge,cut2,c0,c1,c2,c3,c4,c5)
!$OMP& firstprivate(vscale,iv14) shared(ev)
!$OMP DO reduction(+:ev)
c
c     find the van der Waals energy via neighbor list search
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  fterm = 1.0d0
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  else if (radhbnd(kt,it) .ne. 0.0d0) then
                     rv = radhbnd(kt,it)
                     eps = epshbnd(kt,it) / dielec
                     if (atomic(i) .eq. 1) then
                        ia = i
                        ib = i12(1,i)
                        ic = k
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                     end if
                     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)
                     xab = xia - xib
                     yab = yia - yib
                     zab = zia - zib
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     call image (xcb,ycb,zcb)
                     rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                     rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     rab = sqrt(rab2)
                     ideal = bl(bndlist(1,ia))
                     fterm = cosine * (rab/ideal)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  if (p2 .le. expmin2) then
                     e = 0.0d0
                  else if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - fterm*cbuck*p6)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine emm3hb1  --  MM3 vdw & hbond energy & derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "emm3hb1" calculates the MM3 exp-6 van der Waals and directional
c     charge transfer hydrogen bonding energy with respect to Cartesian
c     coordinates
c
c     literature references:
c
c     J.-H. Lii and N. L. Allinger, "Directional Hydrogen Bonding in
c     the MM3 Force Field. I", Journal of Physical Organic Chemistry,
c     7, 591-609 (1994)
c
c     J.-H. Lii and N. L. Allinger, "Directional Hydrogen Bonding in
c     the MM3 Force Field. II", Journal of Computational Chemistry,
c     19, 1001-1016 (1998)
c
c
      subroutine emm3hb1
      use energi
      use limits
      use vdwpot
      use virial
      implicit none
      real*8 elrc,vlrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_lights) then
         call emm3hb1b
      else if (use_vlist) then
         call emm3hb1c
      else
         call emm3hb1a
      end if
c
c     apply the long range van der Waals correction if used
c
      if (use_vcorr) then
         mode = 'VDW'
         call evcorr1 (mode,elrc,vlrc)
         ev = ev + elrc
         vir(1,1) = vir(1,1) + vlrc
         vir(2,2) = vir(2,2) + vlrc
         vir(3,3) = vir(3,3) + vlrc
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine emm3hb1a  --  double loop MM3 vdw-hbond derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "emm3hb1a" calculates the MM3 exp-6 van der Waals and directional
c     charge transfer hydrogen bonding energy with respect to Cartesian
c     coordinates using a pairwise double loop
c
c
      subroutine emm3hb1a
      use atmlst
      use atomid
      use atoms
      use bndstr
      use bound
      use cell
      use chgpot
      use couple
      use deriv
      use energi
      use group
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer ia,ib,ic
      integer, allocatable :: iv14(:)
      real*8 e,de,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rvterm
      real*8 taper,dtaper
      real*8 expcut,expcut2
      real*8 expterm,expmin2
      real*8 expmerge
      real*8 dot,cosine,sine
      real*8 fterm,fcbuck,term
      real*8 deddr,ideal,ratio
      real*8 deddt,terma,termc
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rab,rcb2
      real*8 xp,yp,zp,rp
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: vscale(:)
      logical proceed,usei,use_hb
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     special cutoffs for very short and very long range terms
c
      expmin2 = 0.01d0
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find van der Waals energy and derivatives via double loop
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  use_hb = .false.
                  fterm = 1.0d0
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  else if (radhbnd(kt,it) .ne. 0.0d0) then
                     use_hb = .true.
                     rv = radhbnd(kt,it)
                     eps = epshbnd(kt,it) / dielec
                     if (atomic(i) .eq. 1) then
                        ia = i
                        ib = i12(1,i)
                        ic = k
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                     end if
                     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)
                     xab = xia - xib
                     yab = yia - yib
                     zab = zia - zib
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     call image (xcb,ycb,zcb)
                     xp = ycb*zab - zcb*yab
                     yp = zcb*xab - xcb*zab
                     zp = xcb*yab - ycb*xab
                     rp = sqrt(xp*xp + yp*yp + zp*zp)
                     rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                     rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     sine = sqrt(abs(1.0d0-cosine**2))
                     rab = sqrt(rab2)
                     ideal = bl(bndlist(1,ia))
                     ratio = rab / ideal
                     fterm = cosine * ratio
                     deddt = -sine * ratio
                     deddr = cosine / (rab*ideal)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  rik = sqrt(rik2)
                  if (p2 .le. expmin2) then
                     e = 0.0d0
                     de = 0.0d0
                  else if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     rvterm = -bbuck / rv
                     expterm = abuck * exp(-bbuck/p)
                     fcbuck = fterm * cbuck * p6
                     e = eps * (expterm - fcbuck)
                     de = eps * (rvterm*expterm+6.0d0*fcbuck/rik)
                  else
                     use_hb = .false.
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                     de = -12.0d0 * e / rik
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                     if (use_hb) then
                        deddt = deddt * fgrp
                        deddr = deddr * fgrp
                     end if
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     find the chain rule terms for hydrogen bonding components
c
                  if (use_hb) then
                     term = eps * cbuck * p6
                     deddt = deddt * term
                     deddr = deddr * term
                     if (rik2 .gt. cut2) then
                        deddt = deddt * taper
                        deddr = deddr * taper
                     end if
                     terma = deddt / (rab2*max(rp,1.0d-6))
                     termc = -deddt / (rcb2*max(rp,1.0d-6))
                     dedxia = terma * (yab*zp-zab*yp) - deddr*xab
                     dedyia = terma * (zab*xp-xab*zp) - deddr*yab
                     dedzia = terma * (xab*yp-yab*xp) - deddr*zab
                     dedxic = termc * (ycb*zp-zcb*yp)
                     dedyic = termc * (zcb*xp-xcb*zp)
                     dedzic = termc * (xcb*yp-ycb*xp)
                     dedxib = -dedxia - dedxic
                     dedyib = -dedyia - dedyic
                     dedzib = -dedzia - dedzic
c
c     increment the derivatives for directional hydrogen bonding
c
                     dev(1,ia) = dev(1,ia) + dedxia
                     dev(2,ia) = dev(2,ia) + dedyia
                     dev(3,ia) = dev(3,ia) + dedzia
                     dev(1,ib) = dev(1,ib) + dedxib
                     dev(2,ib) = dev(2,ib) + dedyib
                     dev(3,ib) = dev(3,ib) + dedzib
                     dev(1,ic) = dev(1,ic) + dedxic
                     dev(2,ic) = dev(2,ic) + dedyic
                     dev(3,ic) = dev(3,ic) + dedzic
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  if (use_hb) then
                     vxx = xab*dedxia + xcb*dedxic
                     vyx = yab*dedxia + ycb*dedxic
                     vzx = zab*dedxia + zcb*dedxic
                     vyy = yab*dedyia + ycb*dedyic
                     vzy = zab*dedyia + zcb*dedyic
                     vzz = zab*dedzia + zcb*dedzic
                  end if
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     use_hb = .false.
                     fterm = 1.0d0
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (radhbnd(kt,it) .ne. 0.0d0) then
                        use_hb = .true.
                        rv = radhbnd(kt,it)
                        eps = epshbnd(kt,it) / dielec
                        if (atomic(i) .eq. 1) then
                           ia = i
                           ib = i12(1,i)
                           ic = k
                        else
                           ia = k
                           ib = i12(1,k)
                           ic = i
                        end if
                        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)
                        xab = xia - xib
                        yab = yia - yib
                        zab = zia - zib
                        xcb = xic - xib
                        ycb = yic - yib
                        zcb = zic - zib
                        call imager (xcb,ycb,zcb,j)
                        xp = ycb*zab - zcb*yab
                        yp = zcb*xab - xcb*zab
                        zp = xcb*yab - ycb*xab
                        rp = sqrt(xp*xp + yp*yp + zp*zp)
                        rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                        rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                        dot = xab*xcb + yab*ycb + zab*zcb
                        cosine = dot / sqrt(rab2*rcb2)
                        sine = sqrt(abs(1.0d0-cosine**2))
                        rab = sqrt(rab2)
                        ideal = bl(bndlist(1,ia))
                        ratio = rab / ideal
                        fterm = cosine * ratio
                        deddt = -sine * ratio
                        deddr = cosine / (rab*ideal)
                     end if
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              fterm = 1.0d0
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     p2 = (rv*rv) / rik2
                     p6 = p2 * p2 * p2
                     rik = sqrt(rik2)
                     if (p2 .le. expmin2) then
                        e = 0.0d0
                        de = 0.0d0
                     else if (p2 .le. expcut2) then
                        p = sqrt(p2)
                        rvterm = -bbuck / rv
                        expterm = abuck * exp(-bbuck/p)
                        fcbuck = fterm * cbuck * p6
                        e = eps * (expterm - fcbuck)
                        de = eps * (rvterm*expterm+6.0d0*fcbuck/rik)
                     else
                        use_hb = .false.
                        p12 = p6 * p6
                        e = expmerge * eps * p12
                        de = -12.0d0 * e / rik
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                              + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                        de = e*dtaper + de*taper
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        e = e * fgrp
                        de = de * fgrp
                        if (use_hb) then
                           deddt = deddt * fgrp
                           deddr = deddr * fgrp
                        end if
                     end if
c
c     find the chain rule terms for derivative components
c
                     de = de / rik
                     dedx = de * xr
                     dedy = de * yr
                     dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ev = ev + e
                     if (i .eq. iv) then
                        dev(1,i) = dev(1,i) + dedx
                        dev(2,i) = dev(2,i) + dedy
                        dev(3,i) = dev(3,i) + dedz
                     else
                        dev(1,i) = dev(1,i) + dedx*redi
                        dev(2,i) = dev(2,i) + dedy*redi
                        dev(3,i) = dev(3,i) + dedz*redi
                        dev(1,iv) = dev(1,iv) + dedx*rediv
                        dev(2,iv) = dev(2,iv) + dedy*rediv
                        dev(3,iv) = dev(3,iv) + dedz*rediv
                     end if
                     if (i .ne. k) then
                        if (k .eq. kv) then
                           dev(1,k) = dev(1,k) - dedx
                           dev(2,k) = dev(2,k) - dedy
                           dev(3,k) = dev(3,k) - dedz
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           dev(1,k) = dev(1,k) - dedx*redk
                           dev(2,k) = dev(2,k) - dedy*redk
                           dev(3,k) = dev(3,k) - dedz*redk
                           dev(1,kv) = dev(1,kv) - dedx*redkv
                           dev(2,kv) = dev(2,kv) - dedy*redkv
                           dev(3,kv) = dev(3,kv) - dedz*redkv
                        end if
                     end if
c
c     find the chain rule terms for hydrogen bonding components
c
                     if (use_hb) then
                        term = eps * cbuck * p6
                        deddt = deddt * term
                        deddr = deddr * term
                        if (rik2 .gt. cut2) then
                           deddt = deddt * taper
                           deddr = deddr * taper
                        end if
                        terma = deddt / (rab2*max(rp,1.0d-6))
                        termc = -deddt / (rcb2*max(rp,1.0d-6))
                        dedxia = terma * (yab*zp-zab*yp) - deddr*xab
                        dedyia = terma * (zab*xp-xab*zp) - deddr*yab
                        dedzia = terma * (xab*yp-yab*xp) - deddr*zab
                        dedxic = termc * (ycb*zp-zcb*yp)
                        dedyic = termc * (zcb*xp-xcb*zp)
                        dedzic = termc * (xcb*yp-ycb*xp)
                        dedxib = -dedxia - dedxic
                        dedyib = -dedyia - dedyic
                        dedzib = -dedzia - dedzic
c
c     increment the derivatives for directional hydrogen bonding
c
                        dev(1,ia) = dev(1,ia) + dedxia
                        dev(2,ia) = dev(2,ia) + dedyia
                        dev(3,ia) = dev(3,ia) + dedzia
                        dev(1,ib) = dev(1,ib) + dedxib
                        dev(2,ib) = dev(2,ib) + dedyib
                        dev(3,ib) = dev(3,ib) + dedzib
                        dev(1,ic) = dev(1,ic) + dedxic
                        dev(2,ic) = dev(2,ic) + dedyic
                        dev(3,ic) = dev(3,ic) + dedzic
                     end if
c
c     increment the internal virial tensor components
c
                     vxx = xr * dedx
                     vyx = yr * dedx
                     vzx = zr * dedx
                     vyy = yr * dedy
                     vzy = zr * dedy
                     vzz = zr * dedz
                     if (use_hb) then
                        vxx = xab*dedxia + xcb*dedxic
                        vyx = yab*dedxia + ycb*dedxic
                        vzx = zab*dedxia + zcb*dedxic
                        vyy = yab*dedyia + ycb*dedyic
                        vzy = zab*dedyia + zcb*dedyic
                        vzz = zab*dedzia + zcb*dedzic
                     end if
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine emm3hb1b  --  MM3 vdw-hbond derivs via lights  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "emm3hb1b" calculates the MM3 exp-6 van der Waals and directional
c     charge transfer hydrogen bonding energy with respect to Cartesian
c     coordinates using the method of lights
c
c
      subroutine emm3hb1b
      use atmlst
      use atomid
      use atoms
      use bndstr
      use bound
      use boxes
      use cell
      use chgpot
      use couple
      use deriv
      use energi
      use group
      use light
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer ia,ib,ic
      integer kgy,kgz
      integer start,stop
      integer, allocatable :: iv14(:)
      real*8 e,de,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rvterm
      real*8 taper,dtaper
      real*8 expcut,expcut2
      real*8 expterm,expmin2
      real*8 expmerge,fcbuck
      real*8 dot,cosine,sine
      real*8 term,terma,termc
      real*8 fterm,ideal,ratio
      real*8 deddr,deddt
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rab,rcb2
      real*8 xp,yp,zp,rp
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      logical use_hb
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     special cutoffs for very short and very long range terms
c
      expmin2 = 0.01d0
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
            if (proceed)  proceed = (vscale(k) .ne. 0.0d0)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  use_hb = .false.
                  fterm = 1.0d0
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k).eq.i .and. prime) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  else if (radhbnd(kt,it) .ne. 0.0d0) then
                     use_hb = .true.
                     rv = radhbnd(kt,it)
                     eps = epshbnd(kt,it) / dielec
                     if (atomic(i) .eq. 1) then
                        ia = i
                        ib = i12(1,i)
                        ic = k
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                     end if
                     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)
                     xab = xia - xib
                     yab = yia - yib
                     zab = zia - zib
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     if (use_bounds) then
                        if (abs(xcb) .gt. xcell2)
     &                     xcb = xcb - sign(xcell,xcb)
                        if (abs(ycb) .gt. ycell2)
     &                     ycb = ycb - sign(ycell,ycb)
                        if (abs(zcb) .gt. zcell2)
     &                     zcb = zcb - sign(zcell,zcb)
                        if (monoclinic) then
                           xcb = xcb + zcb*beta_cos
                           zcb = zcb * beta_sin
                        else if (triclinic) then
                           xcb = xcb + ycb*gamma_cos + zcb*beta_cos
                           ycb = ycb*gamma_sin + zcb*beta_term
                           zcb = zcb * gamma_term
                        end if
                     end if
                     xp = ycb*zab - zcb*yab
                     yp = zcb*xab - xcb*zab
                     zp = xcb*yab - ycb*xab
                     rp = sqrt(xp*xp + yp*yp + zp*zp)
                     rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                     rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     sine = sqrt(abs(1.0d0-cosine**2))
                     rab = sqrt(rab2)
                     ideal = bl(bndlist(1,ia))
                     ratio = rab / ideal
                     fterm = cosine * ratio
                     deddt = -sine * ratio
                     deddr = cosine / (rab*ideal)
                  end if
                  if (prime)  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  rik = sqrt(rik2)
                  if (p2 .le. expmin2) then
                     e = 0.0d0
                     de = 0.0d0
                  else if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     rvterm = -bbuck / rv
                     expterm = abuck * exp(-bbuck/p)
                     fcbuck = fterm * cbuck * p6
                     e = eps * (expterm - fcbuck)
                     de = eps * (rvterm*expterm+6.0d0*fcbuck/rik)
                  else
                     use_hb = .false.
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                     de = -12.0d0 * e / rik
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                     if (use_hb) then
                        deddt = deddt * fgrp
                        deddr = deddr * fgrp
                     end if
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     find the chain rule terms for hydrogen bonding components
c
                  if (use_hb) then
                     term = eps * cbuck * p6
                     deddt = deddt * term
                     deddr = deddr * term
                     if (rik2 .gt. cut2) then
                        deddt = deddt * taper
                        deddr = deddr * taper
                     end if
                     terma = deddt / (rab2*rp)
                     termc = -deddt / (rcb2*rp)
                     dedxia = terma * (yab*zp-zab*yp) - deddr*xab
                     dedyia = terma * (zab*xp-xab*zp) - deddr*yab
                     dedzia = terma * (xab*yp-yab*xp) - deddr*zab
                     dedxic = termc * (ycb*zp-zcb*yp)
                     dedyic = termc * (zcb*xp-xcb*zp)
                     dedzic = termc * (xcb*yp-ycb*xp)
                     dedxib = -dedxia - dedxic
                     dedyib = -dedyia - dedyic
                     dedzib = -dedzia - dedzic
c
c     increment the derivatives for directional hydrogen bonding
c
                     dev(1,ia) = dev(1,ia) + dedxia
                     dev(2,ia) = dev(2,ia) + dedyia
                     dev(3,ia) = dev(3,ia) + dedzia
                     dev(1,ib) = dev(1,ib) + dedxib
                     dev(2,ib) = dev(2,ib) + dedyib
                     dev(3,ib) = dev(3,ib) + dedzib
                     dev(1,ic) = dev(1,ic) + dedxic
                     dev(2,ic) = dev(2,ic) + dedyic
                     dev(3,ic) = dev(3,ic) + dedzic
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  if (use_hb) then
                     vxx = xab*dedxia + xcb*dedxic
                     vyx = yab*dedxia + ycb*dedxic
                     vzx = zab*dedxia + zcb*dedxic
                     vyy = yab*dedyia + ycb*dedyic
                     vzy = zab*dedyia + zcb*dedyic
                     vzz = zab*dedzia + zcb*dedzic
                  end if
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine emm3hb1c  --  MM3 vdw-hbond derivs via list  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "emm3hb1c" calculates the MM3 exp-6 van der Waals and directional
c     charge transfer hydrogen bonding energy with respect to Cartesian
c     coordinates using a pairwise neighbor list
c
c
      subroutine emm3hb1c
      use atmlst
      use atomid
      use atoms
      use bndstr
      use bound
      use chgpot
      use couple
      use deriv
      use energi
      use group
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      use virial
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer ia,ib,ic
      integer, allocatable :: iv14(:)
      real*8 e,de,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rvterm
      real*8 taper,dtaper
      real*8 expcut,expcut2
      real*8 expterm,expmin2
      real*8 expmerge
      real*8 dot,cosine,sine
      real*8 fterm,fcbuck,term
      real*8 deddr,ideal,ratio
      real*8 deddt,terma,termc
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rab,rcb2
      real*8 xp,yp,zp,rp
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8, allocatable :: vscale(:)
      logical proceed,usei,use_hb
      character*6 mode
c
c
c     zero out the van der Waals energy and first derivatives
c
      ev = 0.0d0
      do i = 1, n
         dev(1,i) = 0.0d0
         dev(2,i) = 0.0d0
         dev(3,i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     special cutoffs for very short and very long range terms
c
      expmin2 = 0.01d0
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& kred,xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,
!$OMP& i12,i13,i14,i15,v2scale,v3scale,v4scale,v5scale,
!$OMP& use_group,off2,radmin,epsilon,radmin4,epsilon4,
!$OMP& radhbnd,epshbnd,dielec,atomic,bl,bndlist,abuck,
!$OMP& bbuck,cbuck,cut2,c0,c1,c2,c3,c4,c5)
!$OMP& firstprivate(vscale,iv14) shared(ev,dev,vir)
!$OMP DO reduction(+:ev,dev,vir)
c
c     find van der Waals energy and derivatives via neighbor list
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  use_hb = .false.
                  fterm = 1.0d0
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  else if (radhbnd(kt,it) .ne. 0.0d0) then
                     use_hb = .true.
                     rv = radhbnd(kt,it)
                     eps = epshbnd(kt,it) / dielec
                     if (atomic(i) .eq. 1) then
                        ia = i
                        ib = i12(1,i)
                        ic = k
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                     end if
                     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)
                     xab = xia - xib
                     yab = yia - yib
                     zab = zia - zib
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     call image (xcb,ycb,zcb)
                     xp = ycb*zab - zcb*yab
                     yp = zcb*xab - xcb*zab
                     zp = xcb*yab - ycb*xab
                     rp = sqrt(xp*xp + yp*yp + zp*zp)
                     rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                     rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     sine = sqrt(abs(1.0d0-cosine**2))
                     rab = sqrt(rab2)
                     ideal = bl(bndlist(1,ia))
                     ratio = rab / ideal
                     fterm = cosine * ratio
                     deddt = -sine * ratio
                     deddr = cosine / (rab*ideal)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  rik = sqrt(rik2)
                  if (p2 .le. expmin2) then
                     e = 0.0d0
                     de = 0.0d0
                  else if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     rvterm = -bbuck / rv
                     expterm = abuck * exp(-bbuck/p)
                     fcbuck = fterm * cbuck * p6
                     e = eps * (expterm - fcbuck)
                     de = eps * (rvterm*expterm+6.0d0*fcbuck/rik)
                  else
                     use_hb = .false.
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                     de = -12.0d0 * e / rik
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     de = e*dtaper + de*taper
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                     if (use_hb) then
                        deddt = deddt * fgrp
                        deddr = deddr * fgrp
                     end if
                  end if
c
c     find the chain rule terms for derivative components
c
                  de = de / rik
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
c
c     increment the total van der Waals energy and derivatives
c
                  ev = ev + e
                  if (i .eq. iv) then
                     dev(1,i) = dev(1,i) + dedx
                     dev(2,i) = dev(2,i) + dedy
                     dev(3,i) = dev(3,i) + dedz
                  else
                     dev(1,i) = dev(1,i) + dedx*redi
                     dev(2,i) = dev(2,i) + dedy*redi
                     dev(3,i) = dev(3,i) + dedz*redi
                     dev(1,iv) = dev(1,iv) + dedx*rediv
                     dev(2,iv) = dev(2,iv) + dedy*rediv
                     dev(3,iv) = dev(3,iv) + dedz*rediv
                  end if
                  if (k .eq. kv) then
                     dev(1,k) = dev(1,k) - dedx
                     dev(2,k) = dev(2,k) - dedy
                     dev(3,k) = dev(3,k) - dedz
                  else
                     redk = kred(k)
                     redkv = 1.0d0 - redk
                     dev(1,k) = dev(1,k) - dedx*redk
                     dev(2,k) = dev(2,k) - dedy*redk
                     dev(3,k) = dev(3,k) - dedz*redk
                     dev(1,kv) = dev(1,kv) - dedx*redkv
                     dev(2,kv) = dev(2,kv) - dedy*redkv
                     dev(3,kv) = dev(3,kv) - dedz*redkv
                  end if
c
c     find the chain rule terms for hydrogen bonding components
c
                  if (use_hb) then
                     term = eps * cbuck * p6
                     deddt = deddt * term
                     deddr = deddr * term
                     if (rik2 .gt. cut2) then
                        deddt = deddt * taper
                        deddr = deddr * taper
                     end if
                     terma = deddt / (rab2*max(rp,1.0d-6))
                     termc = -deddt / (rcb2*max(rp,1.0d-6))
                     dedxia = terma * (yab*zp-zab*yp) - deddr*xab
                     dedyia = terma * (zab*xp-xab*zp) - deddr*yab
                     dedzia = terma * (xab*yp-yab*xp) - deddr*zab
                     dedxic = termc * (ycb*zp-zcb*yp)
                     dedyic = termc * (zcb*xp-xcb*zp)
                     dedzic = termc * (xcb*yp-ycb*xp)
                     dedxib = -dedxia - dedxic
                     dedyib = -dedyia - dedyic
                     dedzib = -dedzia - dedzic
c
c     increment the derivatives for directional hydrogen bonding
c
                     dev(1,ia) = dev(1,ia) + dedxia
                     dev(2,ia) = dev(2,ia) + dedyia
                     dev(3,ia) = dev(3,ia) + dedzia
                     dev(1,ib) = dev(1,ib) + dedxib
                     dev(2,ib) = dev(2,ib) + dedyib
                     dev(3,ib) = dev(3,ib) + dedzib
                     dev(1,ic) = dev(1,ic) + dedxic
                     dev(2,ic) = dev(2,ic) + dedyic
                     dev(3,ic) = dev(3,ic) + dedzic
                  end if
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  if (use_hb) then
                     vxx = xab*dedxia + xcb*dedxic
                     vyx = yab*dedxia + ycb*dedxic
                     vzx = zab*dedxia + zcb*dedxic
                     vyy = yab*dedyia + ycb*dedyic
                     vzy = zab*dedyia + zcb*dedyic
                     vzz = zab*dedzia + zcb*dedzic
                  end if
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine emm3hb2  --  atomwise MM3 vdw & hbond Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "emm3hb2" calculates the MM3 exp-6 van der Waals and directional
c     charge transfer hydrogen bonding second derivatives for a single
c     atom at a time
c
c     note this version only partially incorporates the directional
c     hydrogen bonding term into the Hessian calculation
c
c     literature references:
c
c     J.-H. Lii and N. L. Allinger, "Directional Hydrogen Bonding in
c     the MM3 Force Field. I", Journal of Physical Organic Chemistry,
c     7, 591-609 (1994)
c
c     J.-H. Lii and N. L. Allinger, "Directional Hydrogen Bonding in
c     the MM3 Force Field. II", Journal of Computational Chemistry,
c     19, 1001-1016 (1998)
c
c
      subroutine emm3hb2 (iatom)
      use atmlst
      use atomid
      use atoms
      use bndstr
      use bound
      use cell
      use chgpot
      use couple
      use group
      use hessn
      use shunt
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer iatom,jcell
      integer ia,ib,ic
      integer nlist,list(5)
      integer, allocatable :: iv14(:)
      real*8 e,de,d2e,fgrp
      real*8 eps,rv,rdn
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 redi2,rediv2,rediiv
      real*8 redik,redivk
      real*8 redikv,redivkv
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 taper,dtaper,d2taper
      real*8 d2edx,d2edy,d2edz
      real*8 expcut,expcut2
      real*8 expterm,expmin2
      real*8 expmerge
      real*8 rvterm,rvterm2
      real*8 dot,cosine,sine
      real*8 fterm,fcbuck
      real*8 ideal,ratio
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rab,rcb2
      real*8 xp,yp,zp,rp
      real*8 term(3,3)
      real*8, allocatable :: vscale(:)
      logical proceed
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     special cutoffs for very short and very long range terms
c
      expmin2 = 0.01d0
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     check to see if the atom of interest is a vdw site
c
      nlist = 0
      do k = 1, nvdw
         if (ivdw(k) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = iatom
            goto 10
         end if
      end do
      return
   10 continue
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     determine the atoms involved via reduction factors
c
      nlist = 1
      list(nlist) = iatom
      do k = 1, n12(iatom)
         i = i12(k,iatom)
         if (ired(i) .eq. iatom) then
            nlist = nlist + 1
            list(nlist) = i
         end if
      end do
c
c     find van der Waals Hessian elements for involved atoms
c
      do ii = 1, nlist
         i = list(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         if (i .ne. iv) then
            rediv = 1.0d0 - redi
            redi2 = redi * redi
            rediv2 = rediv * rediv
            rediiv = redi * rediv
         end if
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (k .ne. i)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  fterm = 1.0d0
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  else if (radhbnd(kt,it) .ne. 0.0d0) then
                     rv = radhbnd(kt,it)
                     eps = epshbnd(kt,it) / dielec
                     if (atomic(i) .eq. 1) then
                        ia = i
                        ib = i12(1,i)
                        ic = k
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                     end if
                     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)
                     xab = xia - xib
                     yab = yia - yib
                     zab = zia - zib
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     call image (xcb,ycb,zcb)
                     xp = ycb*zab - zcb*yab
                     yp = zcb*xab - xcb*zab
                     zp = xcb*yab - ycb*xab
                     rp = sqrt(xp*xp + yp*yp + zp*zp)
                     rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                     rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     sine = sqrt(abs(1.0d0-cosine**2))
                     rab = sqrt(rab2)
                     ideal = bl(bndlist(1,ia))
                     ratio = rab / ideal
                     fterm = cosine * ratio
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  rik = sqrt(rik2)
                  if (p2 .le. expmin2) then
                     e = 0.0d0
                     de = 0.0d0
                     d2e = 0.0d0
                  else if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     rvterm = -bbuck / rv
                     rvterm2 = rvterm * rvterm
                     expterm = abuck * exp(-bbuck/p)
                     fcbuck = fterm * cbuck * p6
                     e = eps * (expterm - fcbuck)
                     de = eps * (rvterm*expterm+6.0d0*fcbuck/rik)
                     d2e = eps * (rvterm2*expterm-42.0d0*fcbuck/rik2)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                     de = -12.0d0 * e / rik
                     d2e = 156.0d0 * e / rik2
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                     d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2
     &                            + 6.0d0*c3*rik + 2.0d0*c2
                     d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper
                     de = e*dtaper + de*taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     de = de * fgrp
                     d2e = d2e * fgrp
                  end if
c
c     get chain rule terms for van der Waals Hessian elements
c
                  de = de / rik
                  d2e = (d2e-de) / rik2
                  d2edx = d2e * xr
                  d2edy = d2e * yr
                  d2edz = d2e * zr
                  term(1,1) = d2edx*xr + de
                  term(1,2) = d2edx*yr
                  term(1,3) = d2edx*zr
                  term(2,1) = term(1,2)
                  term(2,2) = d2edy*yr + de
                  term(2,3) = d2edy*zr
                  term(3,1) = term(1,3)
                  term(3,2) = term(2,3)
                  term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                  if (i .eq. iatom) then
                     if (i.eq.iv .and. k.eq.kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)
                           hessy(j,i) = hessy(j,i) + term(2,j)
                           hessz(j,i) = hessz(j,i) + term(3,j)
                           hessx(j,k) = hessx(j,k) - term(1,j)
                           hessy(j,k) = hessy(j,k) - term(2,j)
                           hessz(j,k) = hessz(j,k) - term(3,j)
                        end do
                     else if (k .eq. kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                           hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                           hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                           hessx(j,k) = hessx(j,k) - term(1,j)*redi
                           hessy(j,k) = hessy(j,k) - term(2,j)*redi
                           hessz(j,k) = hessz(j,k) - term(3,j)*redi
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                        end do
                     else if (i .eq. iv) then
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)
                           hessy(j,i) = hessy(j,i) + term(2,j)
                           hessz(j,i) = hessz(j,i) + term(3,j)
                           hessx(j,k) = hessx(j,k) - term(1,j)*redk
                           hessy(j,k) = hessy(j,k) - term(2,j)*redk
                           hessz(j,k) = hessz(j,k) - term(3,j)*redk
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv
                        end do
                     else
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        redik = redi * redk
                        redikv = redi * redkv
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                           hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                           hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                           hessx(j,k) = hessx(j,k) - term(1,j)*redik
                           hessy(j,k) = hessy(j,k) - term(2,j)*redik
                           hessz(j,k) = hessz(j,k) - term(3,j)*redik
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv
                        end do
                     end if
                  else if (iv .eq. iatom) then
                     if (k .eq. kv) then
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                           hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                           hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                           hessx(j,k) = hessx(j,k) - term(1,j)*rediv
                           hessy(j,k) = hessy(j,k) - term(2,j)*rediv
                           hessz(j,k) = hessz(j,k) - term(3,j)*rediv
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                        end do
                     else
                        redk = kred(k)
                        redkv = 1.0d0 - redk
                        redivk = rediv * redk
                        redivkv = rediv * redkv
                        do j = 1, 3
                           hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                           hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                           hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                           hessx(j,k) = hessx(j,k) - term(1,j)*redivk
                           hessy(j,k) = hessy(j,k) - term(2,j)*redivk
                           hessz(j,k) = hessz(j,k) - term(3,j)*redivk
                           hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2
                           hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2
                           hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2
                           hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv
                           hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv
                           hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv
                        end do
                     end if
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nlist
         i = list(ii)
         it = jvdw(i)
         iv = ired(i)
         redi = kred(i)
         if (i .ne. iv) then
            rediv = 1.0d0 - redi
            redi2 = redi * redi
            rediv2 = rediv * rediv
            rediiv = redi * rediv
         end if
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               do jcell = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,jcell)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     fterm = 1.0d0
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (radhbnd(kt,it) .ne. 0.0d0) then
                        rv = radhbnd(kt,it)
                        eps = epshbnd(kt,it) / dielec
                        if (atomic(i) .eq. 1) then
                           ia = i
                           ib = i12(1,i)
                           ic = k
                        else
                           ia = k
                           ib = i12(1,k)
                           ic = i
                        end if
                        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)
                        xab = xia - xib
                        yab = yia - yib
                        zab = zia - zib
                        xcb = xic - xib
                        ycb = yic - yib
                        zcb = zic - zib
                        call imager (xcb,ycb,zcb,jcell)
                        xp = ycb*zab - zcb*yab
                        yp = zcb*xab - xcb*zab
                        zp = xcb*yab - ycb*xab
                        rp = sqrt(xp*xp + yp*yp + zp*zp)
                        rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                        rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                        dot = xab*xcb + yab*ycb + zab*zcb
                        cosine = dot / sqrt(rab2*rcb2)
                        sine = sqrt(abs(1.0d0-cosine**2))
                        rab = sqrt(rab2)
                        ideal = bl(bndlist(1,ia))
                        ratio = rab / ideal
                        fterm = cosine * ratio
                     end if
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              fterm = 1.0d0
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     p2 = (rv*rv) / rik2
                     p6 = p2 * p2 * p2
                     rik = sqrt(rik2)
                     if (p2 .le. expmin2) then
                        e = 0.0d0
                        de = 0.0d0
                        d2e = 0.0d0
                     else if (p2 .le. expcut2) then
                        p = sqrt(p2)
                        rvterm = -bbuck / rv
                        rvterm2 = rvterm * rvterm
                        expterm = abuck * exp(-bbuck/p)
                        fcbuck = fterm * cbuck * p6
                        e = eps * (expterm - fcbuck)
                        de = eps * (rvterm*expterm+6.0d0*fcbuck/rik)
                        d2e = eps * (rvterm2*expterm-42.0d0*fcbuck/rik2)
                     else
                        p12 = p6 * p6
                        e = expmerge * eps * p12
                        de = -12.0d0 * e / rik
                        d2e = 156.0d0 * e / rik2
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3
     &                           + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1
                        d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2
     &                             + 6.0d0*c3*rik + 2.0d0*c2
                        d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper
                        de = e*dtaper + de*taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        de = de * fgrp
                        d2e = d2e * fgrp
                     end if
c
c     get chain rule terms for van der Waals Hessian elements
c
                     de = de / rik
                     d2e = (d2e-de) / rik2
                     d2edx = d2e * xr
                     d2edy = d2e * yr
                     d2edz = d2e * zr
                     term(1,1) = d2edx*xr + de
                     term(1,2) = d2edx*yr
                     term(1,3) = d2edx*zr
                     term(2,1) = term(1,2)
                     term(2,2) = d2edy*yr + de
                     term(2,3) = d2edy*zr
                     term(3,1) = term(1,3)
                     term(3,2) = term(2,3)
                     term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
                     if (i .eq. iatom) then
                        if (i.eq.iv .and. k.eq.kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)
                              hessy(j,i) = hessy(j,i) + term(2,j)
                              hessz(j,i) = hessz(j,i) + term(3,j)
                              hessx(j,k) = hessx(j,k) - term(1,j)
                              hessy(j,k) = hessy(j,k) - term(2,j)
                              hessz(j,k) = hessz(j,k) - term(3,j)
                           end do
                        else if (k .eq. kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                              hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                              hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                              hessx(j,k) = hessx(j,k) - term(1,j)*redi
                              hessy(j,k) = hessy(j,k) - term(2,j)*redi
                              hessz(j,k) = hessz(j,k) - term(3,j)*redi
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediiv
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediiv
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediiv
                           end do
                        else if (i .eq. iv) then
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)
                              hessy(j,i) = hessy(j,i) + term(2,j)
                              hessz(j,i) = hessz(j,i) + term(3,j)
                              hessx(j,k) = hessx(j,k) - term(1,j)*redk
                              hessy(j,k) = hessy(j,k) - term(2,j)*redk
                              hessz(j,k) = hessz(j,k) - term(3,j)*redk
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redkv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redkv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redkv
                           end do
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           redik = redi * redk
                           redikv = redi * redkv
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*redi2
                              hessy(j,i) = hessy(j,i) + term(2,j)*redi2
                              hessz(j,i) = hessz(j,i) + term(3,j)*redi2
                              hessx(j,k) = hessx(j,k) - term(1,j)*redik
                              hessy(j,k) = hessy(j,k) - term(2,j)*redik
                              hessz(j,k) = hessz(j,k) - term(3,j)*redik
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediiv
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediiv
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediiv
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redikv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redikv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redikv
                           end do
                        end if
                     else if (iv .eq. iatom) then
                        if (k .eq. kv) then
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                              hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                              hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                              hessx(j,k) = hessx(j,k) - term(1,j)*rediv
                              hessy(j,k) = hessy(j,k) - term(2,j)*rediv
                              hessz(j,k) = hessz(j,k) - term(3,j)*rediv
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediv2
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediv2
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediv2
                           end do
                        else
                           redk = kred(k)
                           redkv = 1.0d0 - redk
                           redivk = rediv * redk
                           redivkv = rediv * redkv
                           do j = 1, 3
                              hessx(j,i) = hessx(j,i) + term(1,j)*rediiv
                              hessy(j,i) = hessy(j,i) + term(2,j)*rediiv
                              hessz(j,i) = hessz(j,i) + term(3,j)*rediiv
                              hessx(j,k) = hessx(j,k) - term(1,j)*redivk
                              hessy(j,k) = hessy(j,k) - term(2,j)*redivk
                              hessz(j,k) = hessz(j,k) - term(3,j)*redivk
                              hessx(j,iv) = hessx(j,iv)
     &                                         + term(1,j)*rediv2
                              hessy(j,iv) = hessy(j,iv)
     &                                         + term(2,j)*rediv2
                              hessz(j,iv) = hessz(j,iv)
     &                                         + term(3,j)*rediv2
                              hessx(j,kv) = hessx(j,kv)
     &                                         - term(1,j)*redivkv
                              hessy(j,kv) = hessy(j,kv)
     &                                         - term(2,j)*redivkv
                              hessz(j,kv) = hessz(j,kv)
     &                                         - term(3,j)*redivkv
                           end do
                        end if
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine emm3hb3  --  MM3 vdw & hbond energy & analysis  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "emm3hb3" calculates the MM3 exp-6 van der Waals and directional
c     charge transfer hydrogen bonding energy, and partitions the energy
c     among the atoms
c
c     literature references:
c
c     J.-H. Lii and N. L. Allinger, "Directional Hydrogen Bonding in
c     the MM3 Force Field. I", Journal of Physical Organic Chemistry,
c     7, 591-609 (1994)
c
c     J.-H. Lii and N. L. Allinger, "Directional Hydrogen Bonding in
c     the MM3 Force Field. II", Journal of Computational Chemistry,
c     19, 1001-1016 (1998)
c
c
      subroutine emm3hb3
      use analyz
      use atoms
      use energi
      use inform
      use iounit
      use limits
      use vdwpot
      implicit none
      integer i
      real*8 elrc,aelrc
      character*6 mode
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_lights) then
         call emm3hb3b
      else if (use_vlist) then
         call emm3hb3c
      else
         call emm3hb3a
      end if
c
c     apply the long range van der Waals correction if used
c
      if (use_vcorr) then
         mode = 'VDW'
         call evcorr (mode,elrc)
         ev = ev + elrc
         aelrc = elrc / dble(n)
         do i = 1, n
            aev(i) = aev(i) + aelrc
         end do
         if (verbose .and. elrc.ne.0.0d0) then
            if (digits .ge. 8) then
               write (iout,10)  elrc
   10          format (/,' Long-Range van der Waals :',6x,f16.8)
            else if (digits .ge. 6) then
               write (iout,20)  elrc
   20          format (/,' Long-Range van der Waals :',6x,f16.6)
            else
               write (iout,30)  elrc
   30          format (/,' Long-Range van der Waals :',6x,f16.4)
            end if
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine emm3hb3a  --  double loop MM3 vdw-hb analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "emm3hb3" calculates the MM3 exp-6 van der Waals and
c     directional charge transfer hydrogen bonding energy, and
c     partitions the energy among the atoms
c
c
      subroutine emm3hb3a
      use action
      use analyz
      use atmlst
      use atomid
      use atoms
      use bndstr
      use bound
      use cell
      use chgpot
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer ia,ib,ic
      integer, allocatable :: iv14(:)
      real*8 e,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmin2
      real*8 expmerge
      real*8 dot,cosine
      real*8 fterm,ideal
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rab,rcb2
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical header,huge
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     special cutoffs for very short and very long range terms
c
      expmin2 = 0.01d0
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  fterm = 1.0d0
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  else if (radhbnd(kt,it) .ne. 0.0d0) then
                     rv = radhbnd(kt,it)
                     eps = epshbnd(kt,it) / dielec
                     if (atomic(i) .eq. 1) then
                        ia = i
                        ib = i12(1,i)
                        ic = k
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                     end if
                     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)
                     xab = xia - xib
                     yab = yia - yib
                     zab = zia - zib
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     call image (xcb,ycb,zcb)
                     rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                     rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     rab = sqrt(rab2)
                     ideal = bl(bndlist(1,ia))
                     fterm = cosine * (rab/ideal)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  if (p2 .le. expmin2) then
                     e = 0.0d0
                  else if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - fterm*cbuck*p6)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   30                format (' VDW-MM3',3x,2(i7,'-',a3),
     &                          13x,2f10.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 2, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     fterm = 1.0d0
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (radhbnd(kt,it) .ne. 0.0d0) then
                        rv = radhbnd(kt,it)
                        eps = epshbnd(kt,it) / dielec
                        if (atomic(i) .eq. 1) then
                           ia = i
                           ib = i12(1,i)
                           ic = k
                        else
                           ia = k
                           ib = i12(1,k)
                           ic = i
                        end if
                        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)
                        xab = xia - xib
                        yab = yia - yib
                        zab = zia - zib
                        xcb = xic - xib
                        ycb = yic - yib
                        zcb = zic - zib
                        call imager (xcb,ycb,zcb,j)
                        rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                        rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                        dot = xab*xcb + yab*ycb + zab*zcb
                        cosine = dot / sqrt(rab2*rcb2)
                        rab = sqrt(rab2)
                        ideal = bl(bndlist(1,ia))
                        fterm = cosine * (rab/ideal)
                     end if
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              fterm = 1.0d0
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
                     p2 = (rv*rv) / rik2
                     p6 = p2 * p2 * p2
                     if (p2 .le. expmin2) then
                        e = 0.0d0
                     else if (p2 .le. expcut2) then
                        p = sqrt(p2)
                        expterm = abuck * exp(-bbuck/p)
                        e = eps * (expterm - fterm*cbuck*p6)
                     else
                        p12 = p6 * p6
                        e = expmerge * eps * p12
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik = sqrt(rik2)
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                                + c2*rik2 + c1*rik + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component
c
                     if (e .ne. 0.0d0) then
                        nev = nev + 1
                        if (i .eq. k) then
                           ev = ev + 0.5d0*e
                           aev(i) = aev(i) + 0.5d0*e
                        else
                           ev = ev + e
                           aev(i) = aev(i) + 0.5d0*e
                           aev(k) = aev(k) + 0.5d0*e
                        end if
                     end if
c
c     increment the total intermolecular energy
c
                     einter = einter + e
c
c     print a message if the energy of this interaction is large
c
                     huge = (e .gt. 10.0d0)
                     if ((debug.and.e.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual van der Waals',
     &                                ' Interactions :',
     &                             //,' Type',14x,'Atom Names',
     &                                20x,'Minimum',4x,'Actual',
     &                                6x,'Energy',/)
                        end if
                        write (iout,50)  i,name(i),k,name(k),
     &                                   rv,sqrt(rik2),e
   50                   format (' VDW-MM3',3x,2(i7,'-',a3),1x,
     &                             '(XTAL)',6x,2f10.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine emm3hb3b  --  MM3 vdw-hbond analysis via lights  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "emm3hb3b" calculates the MM3 exp-6 van der Waals and
c     directional charge transfer hydrogen bonding energy using
c     the method of lights
c
c
      subroutine emm3hb3b
      use action
      use analyz
      use atmlst
      use atomid
      use atoms
      use bndstr
      use bound
      use boxes
      use cell
      use chgpot
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use light
      use molcul
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer ia,ib,ic
      integer kgy,kgz
      integer start,stop
      integer ikmin,ikmax
      integer, allocatable :: iv14(:)
      real*8 e,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmin2
      real*8 expmerge
      real*8 dot,cosine
      real*8 fterm,ideal
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rab,rcb2
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei,prime
      logical unique,repeat
      logical header,huge
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     special cutoffs for very short and very long range terms
c
      expmin2 = 0.01d0
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .true.
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   20    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 60
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 60
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 60
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 60
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kt = jvdw(k)
            kv = ired(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  fterm = 1.0d0
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k).eq.i .and. prime) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  else if (radhbnd(kt,it) .ne. 0.0d0) then
                     rv = radhbnd(kt,it)
                     eps = epshbnd(kt,it) / dielec
                     if (atomic(i) .eq. 1) then
                        ia = i
                        ib = i12(1,i)
                        ic = k
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                     end if
                     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)
                     xab = xia - xib
                     yab = yia - yib
                     zab = zia - zib
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     if (use_bounds) then
                        if (abs(xcb) .gt. xcell2)
     &                     xcb = xcb - sign(xcell,xcb)
                        if (abs(ycb) .gt. ycell2)
     &                     ycb = ycb - sign(ycell,ycb)
                        if (abs(zcb) .gt. zcell2)
     &                     zcb = zcb - sign(zcell,zcb)
                        if (monoclinic) then
                           xcb = xcb + zcb*beta_cos
                           zcb = zcb * beta_sin
                        else if (triclinic) then
                           xcb = xcb + ycb*gamma_cos + zcb*beta_cos
                           ycb = ycb*gamma_sin + zcb*beta_term
                           zcb = zcb * gamma_term
                        end if
                     end if
                     rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                     rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     rab = sqrt(rab2)
                     ideal = bl(bndlist(1,ia))
                     fterm = cosine * (rab/ideal)
                  end if
                  if (prime)  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  if (p2 .le. expmin2) then
                     e = 0.0d0
                  else if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - fterm*cbuck*p6)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (.not.prime .or. molcule(i).ne.molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,30)
   30                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     ikmin = min(i,k)
                     ikmax = max(i,k)
                     if (prime) then
                        write (iout,40)  ikmin,name(ikmin),ikmax,
     &                                   name(ikmax),rv,sqrt(rik2),e
   40                   format (' VDW-MM3',3x,2(i7,'-',a3),
     &                             13x,2f10.4,f12.4)
                     else
                        write (iout,50)  ikmin,name(ikmin),ikmax,
     &                                   name(ikmax),rv,sqrt(rik2),e
   50                   format (' VDW-MM3',3x,2(i7,'-',a3),1x,
     &                             '(XTAL)',6x,2f10.4,f12.4)
                     end if
                  end if
               end if
            end if
   60       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 20
         end if
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine emm3hb3c  --  MM3 vdw-hbond analysis via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "emm3hb3c" calculates the MM3 exp-6 van der Waals and
c     directional charge transfer hydrogen bonding energy using
c     a pairwise neighbor list
c
c
      subroutine emm3hb3c
      use action
      use analyz
      use atmlst
      use atomid
      use atoms
      use bndstr
      use bound
      use chgpot
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use neigh
      use shunt
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,it,iv
      integer kk,kt,kv
      integer ia,ib,ic
      integer, allocatable :: iv14(:)
      real*8 e,rv,eps
      real*8 rdn,fgrp
      real*8 p,p2,p6,p12
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmin2
      real*8 expmerge
      real*8 dot,cosine
      real*8 fterm,ideal
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rab,rcb2
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical header,huge
      character*6 mode
c
c
c     zero out the van der Waals energy and partitioning terms
c
      nev = 0
      ev = 0.0d0
      do i = 1, n
         aev(i) = 0.0d0
      end do
      if (nvdw .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         iv14(i) = 0
         vscale(i) = 1.0d0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nvdw.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual van der Waals Interactions :',
     &           //,' Type',14x,'Atom Names',20x,'Minimum',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     special cutoffs for very short and very long range terms
c
      expmin2 = 0.01d0
      expcut = 2.0d0
      expcut2 = expcut * expcut
      expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6))
     &                               / (expcut**12)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,
!$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13,
!$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group,off2,
!$OMP& radmin,epsilon,radmin4,epsilon4,radhbnd,epshbnd,dielec,
!$OMP& atomic,bl,bndlist,abuck,bbuck,cbuck,cut2,c0,c1,c2,c3,
!$OMP& c4,c5,molcule,name,verbose,debug,header,iout)
!$OMP& firstprivate(vscale,iv14) shared(ev,nev,aev,einter)
!$OMP DO reduction(+:ev,nev,aev,einter)
c
c     find the van der Waals energy via neighbor list search
c
      do ii = 1, nvdw
         i = ivdw(ii)
         it = jvdw(i)
         iv = ired(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(i)
            k = vlst(kk,i)
            kt = jvdw(k)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  fterm = 1.0d0
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  else if (radhbnd(kt,it) .ne. 0.0d0) then
                     rv = radhbnd(kt,it)
                     eps = epshbnd(kt,it) / dielec
                     if (atomic(i) .eq. 1) then
                        ia = i
                        ib = i12(1,i)
                        ic = k
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                     end if
                     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)
                     xab = xia - xib
                     yab = yia - yib
                     zab = zia - zib
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     call image (xcb,ycb,zcb)
                     rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
                     rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     rab = sqrt(rab2)
                     ideal = bl(bndlist(1,ia))
                     fterm = cosine * (rab/ideal)
                  end if
                  eps = eps * vscale(k)
                  p2 = (rv*rv) / rik2
                  p6 = p2 * p2 * p2
                  if (p2 .le. expmin2) then
                     e = 0.0d0
                  else if (p2 .le. expcut2) then
                     p = sqrt(p2)
                     expterm = abuck * exp(-bbuck/p)
                     e = eps * (expterm - fterm*cbuck*p6)
                  else
                     p12 = p6 * p6
                     e = expmerge * eps * p12
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik = sqrt(rik2)
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  if (e .ne. 0.0d0) then
                     nev = nev + 1
                     ev = ev + e
                     aev(i) = aev(i) + 0.5d0*e
                     aev(k) = aev(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 10.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             20x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   30                format (' VDW-MM3',3x,2(i7,'-',a3),
     &                          13x,2f10.4,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (vscale)
      return
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 1999 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine empole  --  atomic multipole moment energy  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "empole" calculates the electrostatic energy due to atomic
c     multipole interactions
c
c
      subroutine empole
      use energi
      use extfld
      use limits
      implicit none
      real*8 exf
      character*6 mode
c
c
c     choose the method to sum over multipole interactions
c
      if (use_ewald) then
         if (use_mlist) then
            call empole0d
         else
            call empole0c
         end if
      else
         if (use_mlist) then
            call empole0b
         else
            call empole0a
         end if
      end if
c
c     get contribution from external electric field if used
c
      if (use_exfld) then
         mode = 'MPOLE'
         call exfield (mode,exf)
         em = em + exf
      end if
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine empole0a  --  double loop multipole energy  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "empole0a" calculates the atomic multipole interaction energy
c     using a double loop
c
c
      subroutine empole0a
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use energi
      use group
      use math
      use mplpot
      use mpole
      use polpot
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer ix,iy,iz
      integer kx,ky,kz
      real*8 e,f,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 rr1i,rr3i,rr5i
      real*8 rr1k,rr3k,rr5k
      real*8 rr1ik,rr3ik,rr5ik
      real*8 rr7ik,rr9ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9)
      real*8, allocatable :: mscale(:)
      logical proceed,usei,usek
      character*6 mode
c
c
c     zero out the total atomic multipole energy
c
      em = 0.0d0
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     calculate the multipole interaction energy term
c
      do ii = 1, npole-1
         i = ipole(ii)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  ck = rpole(1,k)
                  dkx = rpole(2,k)
                  dky = rpole(3,k)
                  dkz = rpole(4,k)
                  qkxx = rpole(5,k)
                  qkxy = rpole(6,k)
                  qkxz = rpole(7,k)
                  qkyy = rpole(9,k)
                  qkyz = rpole(10,k)
                  qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
                  dir = dix*xr + diy*yr + diz*zr
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qir = qix*xr + qiy*yr + qiz*zr
                  dkr = dkx*xr + dky*yr + dkz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
                  qkr = qkx*xr + qky*yr + qkz*zr
                  dik = dix*dkx + diy*dky + diz*dkz
                  qik = qix*qkx + qiy*qky + qiz*qkz
                  diqk = dix*qkx + diy*qky + diz*qkz
                  dkqi = dkx*qix + dky*qiy + dkz*qiz
                  qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                      + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                  rr1 = f * mscale(k) / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
c
c     find damped multipole intermediates and energy value
c
                  if (use_chgpen) then
                     corek = pcore(k)
                     valk = pval(k)
                     alphak = palpha(k)
                     term1 = corei*corek
                     term1i = corek*vali
                     term2i = corek*dir
                     term3i = corek*qir
                     term1k = corei*valk
                     term2k = -corei*dkr
                     term3k = corei*qkr
                     term1ik = vali*valk
                     term2ik = valk*dir - vali*dkr + dik
                     term3ik = vali*qkr + valk*qir - dir*dkr
     &                            + 2.0d0*(dkqi-diqk+qiqk)
                     term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                     term5ik = qir*qkr
                     call damppole (r,9,alphai,alphak,
     &                               dmpi,dmpk,dmpik)
                     rr1i = dmpi(1)*rr1
                     rr3i = dmpi(3)*rr3
                     rr5i = dmpi(5)*rr5
                     rr1k = dmpk(1)*rr1
                     rr3k = dmpk(3)*rr3
                     rr5k = dmpk(5)*rr5
                     rr1ik = dmpik(1)*rr1
                     rr3ik = dmpik(3)*rr3
                     rr5ik = dmpik(5)*rr5
                     rr7ik = dmpik(7)*rr7
                     rr9ik = dmpik(9)*rr9
                     e = term1*rr1 + term1i*rr1i
     &                      + term1k*rr1k + term1ik*rr1ik
     &                      + term2i*rr3i + term2k*rr3k
     &                      + term2ik*rr3ik + term3i*rr5i
     &                      + term3k*rr5k + term3ik*rr5ik
     &                      + term4ik*rr7ik + term5ik*rr9ik
c
c     find standard multipole intermediates and energy value
c
                  else
                     term1 = ci*ck
                     term2 = ck*dir - ci*dkr + dik
                     term3 = ci*qkr + ck*qir - dir*dkr
     &                          + 2.0d0*(dkqi-diqk+qiqk)
                     term4 = dir*qkr - dkr*qir - 4.0d0*qik
                     term5 = qir*qkr
                     e = term1*rr1 + term2*rr3 + term3*rr5
     &                      + term4*rr7 + term5*rr9
                  end if
c
c     compute the energy contribution for this interaction
c
                  if (use_group)  e = e * fgrp
                  em = em + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction energy with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            iz = zaxis(i)
            ix = xaxis(i)
            iy = abs(yaxis(i))
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ci = rpole(1,i)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            qixx = rpole(5,i)
            qixy = rpole(6,i)
            qixz = rpole(7,i)
            qiyy = rpole(9,i)
            qiyz = rpole(10,i)
            qizz = rpole(13,i)
            if (use_chgpen) then
               corei = pcore(i)
               vali = pval(i)
               alphai = palpha(i)
            end if
            usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = m2scale
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = m3scale
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = m4scale
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = m5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               kz = zaxis(k)
               kx = xaxis(k)
               ky = abs(yaxis(k))
               usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               proceed = .true.
               if (proceed)  proceed = (usei .or. usek)
               if (proceed) then
                  do j = 2, ncell
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     call imager (xr,yr,zr,j)
                     r2 = xr*xr + yr* yr + zr*zr
                     if (.not. (use_polymer .and. r2.le.polycut2))
     &                  mscale(k) = 1.0d0
                     if (r2 .le. off2) then
                        r = sqrt(r2)
                        ck = rpole(1,k)
                        dkx = rpole(2,k)
                        dky = rpole(3,k)
                        dkz = rpole(4,k)
                        qkxx = rpole(5,k)
                        qkxy = rpole(6,k)
                        qkxz = rpole(7,k)
                        qkyy = rpole(9,k)
                        qkyz = rpole(10,k)
                        qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
                        dir = dix*xr + diy*yr + diz*zr
                        qix = qixx*xr + qixy*yr + qixz*zr
                        qiy = qixy*xr + qiyy*yr + qiyz*zr
                        qiz = qixz*xr + qiyz*yr + qizz*zr
                        qir = qix*xr + qiy*yr + qiz*zr
                        dkr = dkx*xr + dky*yr + dkz*zr
                        qkx = qkxx*xr + qkxy*yr + qkxz*zr
                        qky = qkxy*xr + qkyy*yr + qkyz*zr
                        qkz = qkxz*xr + qkyz*yr + qkzz*zr
                        qkr = qkx*xr + qky*yr + qkz*zr
                        dik = dix*dkx + diy*dky + diz*dkz
                        qik = qix*qkx + qiy*qky + qiz*qkz
                        diqk = dix*qkx + diy*qky + diz*qkz
                        dkqi = dkx*qix + dky*qiy + dkz*qiz
                        qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                            + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                        rr1 = f * mscale(k) / r
                        rr3 = rr1 / r2
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr9 = 7.0d0 * rr7 / r2
c
c     find damped multipole intermediates and energy value
c
                        if (use_chgpen) then
                           corek = pcore(k)
                           valk = pval(k)
                           alphak = palpha(k)
                           term1 = corei*corek
                           term1i = corek*vali
                           term2i = corek*dir
                           term3i = corek*qir
                           term1k = corei*valk
                           term2k = -corei*dkr
                           term3k = corei*qkr
                           term1ik = vali*valk
                           term2ik = valk*dir - vali*dkr + dik
                           term3ik = vali*qkr + valk*qir - dir*dkr
     &                                  + 2.0d0*(dkqi-diqk+qiqk)
                           term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                           term5ik = qir*qkr
                           call damppole (r,9,alphai,alphak,
     &                                     dmpi,dmpk,dmpik)
                           rr1i = dmpi(1)*rr1
                           rr3i = dmpi(3)*rr3
                           rr5i = dmpi(5)*rr5
                           rr1k = dmpk(1)*rr1
                           rr3k = dmpk(3)*rr3
                           rr5k = dmpk(5)*rr5
                           rr1ik = dmpik(1)*rr1
                           rr3ik = dmpik(3)*rr3
                           rr5ik = dmpik(5)*rr5
                           rr7ik = dmpik(7)*rr7
                           rr9ik = dmpik(9)*rr9
                           e = term1*rr1 + term1i*rr1i
     &                            + term1k*rr1k + term1ik*rr1ik
     &                            + term2i*rr3i + term2k*rr3k
     &                            + term2ik*rr3ik + term3i*rr5i
     &                            + term3k*rr5k + term3ik*rr5ik
     &                            + term4ik*rr7ik + term5ik*rr9ik
c
c     find standard multipole intermediates and energy value
c
                        else
                           term1 = ci*ck
                           term2 = ck*dir - ci*dkr + dik
                           term3 = ci*qkr + ck*qir - dir*dkr
     &                                + 2.0d0*(dkqi-diqk+qiqk)
                           term4 = dir*qkr - dkr*qir - 4.0d0*qik
                           term5 = qir*qkr
                           e = term1*rr1 + term2*rr3 + term3*rr5
     &                            + term4*rr7 + term5*rr9
                        end if
c
c     compute the energy contribution for this interaction
c
                        if (use_group)  e = e * fgrp
                        if (i .eq. k)  e = 0.5d0 * e
                        em = em + e
                     end if
                  end do
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine empole0b  --  neighbor list multipole energy  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "empole0b" calculates the atomic multipole interaction energy
c     using a neighbor list
c
c
      subroutine empole0b
      use atoms
      use bound
      use chgpen
      use chgpot
      use couple
      use energi
      use group
      use math
      use mplpot
      use mpole
      use neigh
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer ix,iy,iz
      integer kx,ky,kz
      real*8 e,f,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 rr1i,rr3i,rr5i
      real*8 rr1k,rr3k,rr5k
      real*8 rr1ik,rr3ik,rr5ik
      real*8 rr7ik,rr9ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9)
      real*8, allocatable :: mscale(:)
      logical proceed,usei,usek
      character*6 mode
c
c
c     zero out the total atomic multipole energy
c
      em = 0.0d0
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,x,y,z,xaxis,yaxis,zaxis,rpole,pcore,pval,
!$OMP& palpha,use,n12,i12,n13,i13,n14,i14,n15,i15,m2scale,m3scale,
!$OMP& m4scale,m5scale,f,nelst,elst,use_chgpen,use_group,use_intra,
!$OMP& use_bounds,off2)
!$OMP& firstprivate(mscale) shared (em)
!$OMP DO reduction(+:em)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, npole
         i = ipole(ii)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  ck = rpole(1,k)
                  dkx = rpole(2,k)
                  dky = rpole(3,k)
                  dkz = rpole(4,k)
                  qkxx = rpole(5,k)
                  qkxy = rpole(6,k)
                  qkxz = rpole(7,k)
                  qkyy = rpole(9,k)
                  qkyz = rpole(10,k)
                  qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
                  dir = dix*xr + diy*yr + diz*zr
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qir = qix*xr + qiy*yr + qiz*zr
                  dkr = dkx*xr + dky*yr + dkz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
                  qkr = qkx*xr + qky*yr + qkz*zr
                  dik = dix*dkx + diy*dky + diz*dkz
                  qik = qix*qkx + qiy*qky + qiz*qkz
                  diqk = dix*qkx + diy*qky + diz*qkz
                  dkqi = dkx*qix + dky*qiy + dkz*qiz
                  qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                      + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                  rr1 = f * mscale(k) / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
c
c     find damped multipole intermediates and energy value
c
                  if (use_chgpen) then
                     corek = pcore(k)
                     valk = pval(k)
                     alphak = palpha(k)
                     term1 = corei*corek
                     term1i = corek*vali
                     term2i = corek*dir
                     term3i = corek*qir
                     term1k = corei*valk
                     term2k = -corei*dkr
                     term3k = corei*qkr
                     term1ik = vali*valk
                     term2ik = valk*dir - vali*dkr + dik
                     term3ik = vali*qkr + valk*qir - dir*dkr
     &                            + 2.0d0*(dkqi-diqk+qiqk)
                     term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                     term5ik = qir*qkr
                     call damppole (r,9,alphai,alphak,
     &                               dmpi,dmpk,dmpik)
                     rr1i = dmpi(1)*rr1
                     rr3i = dmpi(3)*rr3
                     rr5i = dmpi(5)*rr5
                     rr1k = dmpk(1)*rr1
                     rr3k = dmpk(3)*rr3
                     rr5k = dmpk(5)*rr5
                     rr1ik = dmpik(1)*rr1
                     rr3ik = dmpik(3)*rr3
                     rr5ik = dmpik(5)*rr5
                     rr7ik = dmpik(7)*rr7
                     rr9ik = dmpik(9)*rr9
                     e = term1*rr1 + term1i*rr1i
     &                      + term1k*rr1k + term1ik*rr1ik
     &                      + term2i*rr3i + term2k*rr3k
     &                      + term2ik*rr3ik + term3i*rr5i
     &                      + term3k*rr5k + term3ik*rr5ik
     &                      + term4ik*rr7ik + term5ik*rr9ik
c
c     find standard multipole intermediates and energy value
c
                  else
                     term1 = ci*ck
                     term2 = ck*dir - ci*dkr + dik
                     term3 = ci*qkr + ck*qir - dir*dkr
     &                          + 2.0d0*(dkqi-diqk+qiqk)
                     term4 = dir*qkr - dkr*qir - 4.0d0*qik
                     term5 = qir*qkr
                     e = term1*rr1 + term2*rr3 + term3*rr5
     &                      + term4*rr7 + term5*rr9
                  end if
c
c     compute the energy contribution for this interaction
c
                  if (use_group)  e = e * fgrp
                  em = em + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine empole0c  --  Ewald multipole energy via loop  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "empole0c" calculates the atomic multipole interaction energy
c     using particle mesh Ewald summation and a double loop
c
c
      subroutine empole0c
      use atoms
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use mpole
      use pme
      implicit none
      integer i,ii
      real*8 e,f,sum
      real*8 term,fterm
      real*8 cii,dii,qii
      real*8 xd,yd,zd
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
c
c
c     zero out the total atomic multipole energy
c
      em = 0.0d0
      if (npole .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     compute the real space portion of the Ewald summation
c
      call emreal0c
c
c     compute the reciprocal space part of the Ewald summation
c
      call emrecip
c
c     compute the self-energy portion of the Ewald summation
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / rootpi
      do ii = 1, npole
         i = ipole(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         cii = ci*ci
         dii = dix*dix + diy*diy + diz*diz
         qii = 2.0d0*(qixy*qixy+qixz*qixz+qiyz*qiyz)
     &            + qixx*qixx + qiyy*qiyy + qizz*qizz
         e = fterm * (cii + term*(dii/3.0d0+2.0d0*term*qii/5.0d0))
         em = em + e
      end do
c
c     compute the uniform background charge correction term
c
      fterm = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         sum = sum + rpole(1,i)
      end do
      e = fterm * sum**2
      em = em + e
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            xd = xd + dix + rpole(1,i)*x(i)
            yd = yd + diy + rpole(1,i)*y(i)
            zd = zd + diz + rpole(1,i)*z(i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         e = term * (xd*xd+yd*yd+zd*zd)
         em = em + e
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine emreal0c  --  real space mpole energy via loop  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "emreal0c" evaluates the real space portion of the Ewald sum
c     energy due to atomic multipoles using a double loop
c
c     literature reference:
c
c     W. Smith, "Point Multipoles in the Ewald Summation (Revisited)",
c     CCP5 Newsletter, 46, 18-30, 1998  [newsletters are available at
c     https://www.ccp5.ac.uk/infoweb/newsletters]
c
c
      subroutine emreal0c
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use energi
      use math
      use mplpot
      use mpole
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 e,f,scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 rr1i,rr3i,rr5i
      real*8 rr1k,rr3k,rr5k
      real*8 rr1ik,rr3ik,rr5ik
      real*8 rr7ik,rr9ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9),dmpe(9)
      real*8, allocatable :: mscale(:)
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               dik = dix*dkx + diy*dky + diz*dkz
               qik = qix*qkx + qiy*qky + qiz*qkz
               diqk = dix*qkx + diy*qky + diz*qkz
               dkqi = dkx*qix + dky*qiy + dkz*qiz
               qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                   + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
c
c     calculate real space Ewald error function damping
c
               call dampewald (9,r,r2,f,dmpe)
c
c     find damped multipole intermediates and energy value
c
               if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  term1 = corei*corek
                  term1i = corek*vali
                  term2i = corek*dir
                  term3i = corek*qir
                  term1k = corei*valk
                  term2k = -corei*dkr
                  term3k = corei*qkr
                  term1ik = vali*valk
                  term2ik = valk*dir - vali*dkr + dik
                  term3ik = vali*qkr + valk*qir - dir*dkr
     &                         + 2.0d0*(dkqi-diqk+qiqk)
                  term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                  term5ik = qir*qkr
                  call damppole (r,9,alphai,alphak,
     &                            dmpi,dmpk,dmpik)
                  scalek = mscale(k)
                  scalek = mscale(k)
                  rr1i = dmpe(1) - (1.0d0-scalek*dmpi(1))*rr1
                  rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                  rr1k = dmpe(1) - (1.0d0-scalek*dmpk(1))*rr1
                  rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                  rr1ik = dmpe(1) - (1.0d0-scalek*dmpik(1))*rr1
                  rr3ik = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                  rr5ik = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                  rr7ik = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                  rr9ik = dmpe(9) - (1.0d0-scalek*dmpik(9))*rr9
                  rr1 = dmpe(1) - (1.0d0-scalek)*rr1
                  e = term1*rr1 + term4ik*rr7ik + term5ik*rr9ik
     &                   + term1i*rr1i + term1k*rr1k + term1ik*rr1ik
     &                   + term2i*rr3i + term2k*rr3k + term2ik*rr3ik
     &                   + term3i*rr5i + term3k*rr5k + term3ik*rr5ik
c
c     find standard multipole intermediates and energy value
c
               else
                  term1 = ci*ck
                  term2 = ck*dir - ci*dkr + dik
                  term3 = ci*qkr + ck*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  scalek = 1.0d0 - mscale(k)
                  rr1 = dmpe(1) - scalek*rr1
                  rr3 = dmpe(3) - scalek*rr3
                  rr5 = dmpe(5) - scalek*rr5
                  rr7 = dmpe(7) - scalek*rr7
                  rr9 = dmpe(9) - scalek*rr9
                  e = term1*rr1 + term2*rr3 + term3*rr5
     &                   + term4*rr7 + term5*rr9
               end if
c
c     increment the overall multipole energy component
c
               em = em + e
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction energy with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ci = rpole(1,i)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            qixx = rpole(5,i)
            qixy = rpole(6,i)
            qixz = rpole(7,i)
            qiyy = rpole(9,i)
            qiyz = rpole(10,i)
            qizz = rpole(13,i)
            if (use_chgpen) then
               corei = pcore(i)
               vali = pval(i)
               alphai = palpha(i)
            end if
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = m2scale
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = m3scale
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = m4scale
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = m5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               do jcell = 2, ncell
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr* yr + zr*zr
                  if (.not. (use_polymer .and. r2.le.polycut2))
     &               mscale(k) = 1.0d0
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     ck = rpole(1,k)
                     dkx = rpole(2,k)
                     dky = rpole(3,k)
                     dkz = rpole(4,k)
                     qkxx = rpole(5,k)
                     qkxy = rpole(6,k)
                     qkxz = rpole(7,k)
                     qkyy = rpole(9,k)
                     qkyz = rpole(10,k)
                     qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
                     dir = dix*xr + diy*yr + diz*zr
                     qix = qixx*xr + qixy*yr + qixz*zr
                     qiy = qixy*xr + qiyy*yr + qiyz*zr
                     qiz = qixz*xr + qiyz*yr + qizz*zr
                     qir = qix*xr + qiy*yr + qiz*zr
                     dkr = dkx*xr + dky*yr + dkz*zr
                     qkx = qkxx*xr + qkxy*yr + qkxz*zr
                     qky = qkxy*xr + qkyy*yr + qkyz*zr
                     qkz = qkxz*xr + qkyz*yr + qkzz*zr
                     qkr = qkx*xr + qky*yr + qkz*zr
                     dik = dix*dkx + diy*dky + diz*dkz
                     qik = qix*qkx + qiy*qky + qiz*qkz
                     diqk = dix*qkx + diy*qky + diz*qkz
                     dkqi = dkx*qix + dky*qiy + dkz*qiz
                     qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                         + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                     rr1 = f / r
                     rr3 = rr1 / r2
                     rr5 = 3.0d0 * rr3 / r2
                     rr7 = 5.0d0 * rr5 / r2
                     rr9 = 7.0d0 * rr7 / r2
c
c     calculate real space Ewald error function damping
c
                     call dampewald (9,r,r2,f,dmpe)
c
c     find damped multipole intermediates and energy value
c
                     if (use_chgpen) then
                        corek = pcore(k)
                        valk = pval(k)
                        alphak = palpha(k)
                        term1 = corei*corek
                        term1i = corek*vali
                        term2i = corek*dir
                        term3i = corek*qir
                        term1k = corei*valk
                        term2k = -corei*dkr
                        term3k = corei*qkr
                        term1ik = vali*valk
                        term2ik = valk*dir - vali*dkr + dik
                        term3ik = vali*qkr + valk*qir - dir*dkr
     &                               + 2.0d0*(dkqi-diqk+qiqk)
                        term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                        term5ik = qir*qkr
                        call damppole (r,9,alphai,alphak,
     &                                  dmpi,dmpk,dmpik)
                        scalek = mscale(k)
                        rr1i = dmpe(1) - (1.0d0-scalek*dmpi(1))*rr1
                        rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                        rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                        rr1k = dmpe(1) - (1.0d0-scalek*dmpk(1))*rr1
                        rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                        rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                        rr1ik = dmpe(1) - (1.0d0-scalek*dmpik(1))*rr1
                        rr3ik = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                        rr5ik = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                        rr7ik = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                        rr9ik = dmpe(9) - (1.0d0-scalek*dmpik(9))*rr9
                        rr1 = dmpe(1) - (1.0d0-scalek)*rr1
                        e = term1*rr1 + term1i*rr1i
     &                         + term1k*rr1k + term1ik*rr1ik
     &                         + term2i*rr3i + term2k*rr3k
     &                         + term2ik*rr3ik + term3i*rr5i
     &                         + term3k*rr5k + term3ik*rr5ik
     &                         + term4ik*rr7ik + term5ik*rr9ik
c
c     find standard multipole intermediates and energy value
c
                     else
                        term1 = ci*ck
                        term2 = ck*dir - ci*dkr + dik
                        term3 = ci*qkr + ck*qir - dir*dkr
     &                             + 2.0d0*(dkqi-diqk+qiqk)
                        term4 = dir*qkr - dkr*qir - 4.0d0*qik
                        term5 = qir*qkr
                        scalek = 1.0d0 - mscale(k)
                        rr1 = dmpe(1) - scalek*rr1
                        rr3 = dmpe(3) - scalek*rr3
                        rr5 = dmpe(5) - scalek*rr5
                        rr7 = dmpe(7) - scalek*rr7
                        rr9 = dmpe(9) - scalek*rr9
                        e = term1*rr1 + term2*rr3 + term3*rr5
     &                         + term4*rr7 + term5*rr9
                     end if
c
c     increment the overall multipole energy component
c
                     if (i .eq. k)  e = 0.5d0 * e
                     em = em + e
                  end if
               end do
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine empole0d  --  Ewald multipole energy via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "empole0d" calculates the atomic multipole interaction energy
c     using particle mesh Ewald summation and a neighbor list
c
c
      subroutine empole0d
      use atoms
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use mpole
      use pme
      implicit none
      integer i,ii
      real*8 e,f,sum
      real*8 term,fterm
      real*8 cii,dii,qii
      real*8 xd,yd,zd
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
c
c
c     zero out the total atomic multipole energy
c
      em = 0.0d0
      if (npole .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     compute the real space portion of the Ewald summation
c
      call emreal0d
c
c     compute the reciprocal space part of the Ewald summation
c
      call emrecip
c
c     compute the self-energy portion of the Ewald summation
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / rootpi
      do ii = 1, npole
         i = ipole(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         cii = ci*ci
         dii = dix*dix + diy*diy + diz*diz
         qii = 2.0d0*(qixy*qixy+qixz*qixz+qiyz*qiyz)
     &            + qixx*qixx + qiyy*qiyy + qizz*qizz
         e = fterm * (cii + term*(dii/3.0d0+2.0d0*term*qii/5.0d0))
         em = em + e
      end do
c
c     compute the uniform background charge correction term
c
      fterm = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         sum = sum + rpole(1,i)
      end do
      e = fterm * sum**2
      em = em + e
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            xd = xd + dix + rpole(1,i)*x(i)
            yd = yd + diy + rpole(1,i)*y(i)
            zd = zd + diz + rpole(1,i)*z(i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         e = term * (xd*xd+yd*yd+zd*zd)
         em = em + e
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine emreal0d  --  real space mpole energy via list  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "emreal0d" evaluates the real space portion of the Ewald sum
c     energy due to atomic multipoles using a neighbor list
c
c     literature reference:
c
c     W. Smith, "Point Multipoles in the Ewald Summation (Revisited)",
c     CCP5 Newsletter, 46, 18-30, 1998  [newsletters are available at
c     https://www.ccp5.ac.uk/infoweb/newsletters]
c
c
      subroutine emreal0d
      use atoms
      use bound
      use chgpen
      use chgpot
      use couple
      use energi
      use math
      use mplpot
      use mpole
      use neigh
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 e,f,scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 rr1i,rr3i,rr5i
      real*8 rr1k,rr3k,rr5k
      real*8 rr1ik,rr3ik,rr5ik
      real*8 rr7ik,rr9ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9),dmpe(9)
      real*8, allocatable :: mscale(:)
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,x,y,z,rpole,pcore,pval,palpha,n12,i12,
!$OMP& n13,i13,n14,i14,n15,i15,m2scale,m3scale,m4scale,m5scale,
!$OMP& f,nelst,elst,use_bounds,use_chgpen,off2)
!$OMP& firstprivate(mscale) shared (em)
!$OMP DO reduction(+:em)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               dik = dix*dkx + diy*dky + diz*dkz
               qik = qix*qkx + qiy*qky + qiz*qkz
               diqk = dix*qkx + diy*qky + diz*qkz
               dkqi = dkx*qix + dky*qiy + dkz*qiz
               qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                   + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
c
c     calculate real space Ewald error function damping
c
               call dampewald (9,r,r2,f,dmpe)
c
c     find damped multipole intermediates and energy value
c
               if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  term1 = corei*corek
                  term1i = corek*vali
                  term2i = corek*dir
                  term3i = corek*qir
                  term1k = corei*valk
                  term2k = -corei*dkr
                  term3k = corei*qkr
                  term1ik = vali*valk
                  term2ik = valk*dir - vali*dkr + dik
                  term3ik = vali*qkr + valk*qir - dir*dkr
     &                         + 2.0d0*(dkqi-diqk+qiqk)
                  term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                  term5ik = qir*qkr
                  call damppole (r,9,alphai,alphak,
     &                            dmpi,dmpk,dmpik)
                  scalek = mscale(k)
                  rr1i = dmpe(1) - (1.0d0-scalek*dmpi(1))*rr1
                  rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                  rr1k = dmpe(1) - (1.0d0-scalek*dmpk(1))*rr1
                  rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                  rr1ik = dmpe(1) - (1.0d0-scalek*dmpik(1))*rr1
                  rr3ik = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                  rr5ik = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                  rr7ik = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                  rr9ik = dmpe(9) - (1.0d0-scalek*dmpik(9))*rr9
                  rr1 = dmpe(1) - (1.0d0-scalek)*rr1
                  e = term1*rr1 + term4ik*rr7ik + term5ik*rr9ik
     &                   + term1i*rr1i + term1k*rr1k + term1ik*rr1ik
     &                   + term2i*rr3i + term2k*rr3k + term2ik*rr3ik
     &                   + term3i*rr5i + term3k*rr5k + term3ik*rr5ik
c
c     find standard multipole intermediates and energy value
c
               else
                  term1 = ci*ck
                  term2 = ck*dir - ci*dkr + dik
                  term3 = ci*qkr + ck*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  scalek = 1.0d0 - mscale(k)
                  rr1 = dmpe(1) - scalek*rr1
                  rr3 = dmpe(3) - scalek*rr3
                  rr5 = dmpe(5) - scalek*rr5
                  rr7 = dmpe(7) - scalek*rr7
                  rr9 = dmpe(9) - scalek*rr9
                  e = term1*rr1 + term2*rr3 + term3*rr5
     &                   + term4*rr7 + term5*rr9
               end if
c
c     increment the overall multipole energy component
c
               em = em + e
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine emrecip  --  PME recip space multipole energy  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "emrecip" evaluates the reciprocal space portion of the particle
c     mesh Ewald energy due to atomic multipole interactions
c
c     literature references:
c
c     C. Sagui, L. G. Pedersen and T. A. Darden, "Towards an Accurate
c     Representation of Electrostatics in Classical Force Fields:
c     Efficient Implementation of Multipolar Interactions in
c     Biomolecular Simulations", Journal of Chemical Physics, 120,
c     73-87 (2004)
c
c     W. Smith and D. Fincham, "The Ewald Sum in Truncated Octahedral
c     and Rhombic Dodecahedral Boundary Conditions", Molecular
c     Simulation, 10, 67-71 (1993)
c
c     modifications for nonperiodic systems suggested by Tom Darden
c     during May 2007
c
c
      subroutine emrecip
      use atoms
      use bound
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use mpole
      use mrecip
      use pme
      implicit none
      integer i,j,k,ii
      integer k1,k2,k3
      integer m1,m2,m3
      integer ntot,nff
      integer nf1,nf2,nf3
      real*8 e,r1,r2,r3
      real*8 f,h1,h2,h3
      real*8 volterm,denom
      real*8 hsq,expterm
      real*8 term,pterm
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      f = 0.5d0 * electric / dielec
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(cmp)) then
         if (size(cmp) .lt. 10*n)  deallocate (cmp)
      end if
      if (allocated(fmp)) then
         if (size(fmp) .lt. 10*n)  deallocate (fmp)
      end if
      if (allocated(fphi)) then
         if (size(fphi) .lt. 20*n)  deallocate (fphi)
      end if
      if (.not. allocated(cmp))  allocate (cmp(10,n))
      if (.not. allocated(fmp))  allocate (fmp(10,n))
      if (.not. allocated(fphi))  allocate (fphi(20,n))
c
c     perform dynamic allocation of some global arrays
c
      ntot = nfft1 * nfft2 * nfft3
      if (allocated(qgrid)) then
         if (size(qgrid) .ne. 2*ntot)  call fftclose
      end if
      if (.not. allocated(qgrid))  call fftsetup
c
c     setup spatial decomposition and B-spline coefficients
c
      call getchunk
      call moduli
      call bspline_fill
      call table_fill
c
c     copy the multipole moments into local storage areas
c
      do ii = 1, npole
         i = ipole(ii)
         cmp(1,i) = rpole(1,i)
         cmp(2,i) = rpole(2,i)
         cmp(3,i) = rpole(3,i)
         cmp(4,i) = rpole(4,i)
         cmp(5,i) = rpole(5,i)
         cmp(6,i) = rpole(9,i)
         cmp(7,i) = rpole(13,i)
         cmp(8,i) = 2.0d0 * rpole(6,i)
         cmp(9,i) = 2.0d0 * rpole(7,i)
         cmp(10,i) = 2.0d0 * rpole(10,i)
      end do
c
c     convert Cartesian multipoles to fractional coordinates
c
      call cmp_to_fmp (cmp,fmp)
c
c     assign PME grid and perform 3-D FFT forward transform
c
      call grid_mpole (fmp)
      call fftfront
c
c     make the scalar summation over reciprocal lattice
c
      pterm = (pi/aewald)**2
      volterm = pi * volbox
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      nff = nfft1 * nfft2
      ntot = nff * nfft3
      do i = 1, ntot-1
         k3 = i/nff + 1
         j = i - (k3-1)*nff
         k2 = j/nfft1 + 1
         k1 = j - (k2-1)*nfft1 + 1
         m1 = k1 - 1
         m2 = k2 - 1
         m3 = k3 - 1
         if (k1 .gt. nf1)  m1 = m1 - nfft1
         if (k2 .gt. nf2)  m2 = m2 - nfft2
         if (k3 .gt. nf3)  m3 = m3 - nfft3
         r1 = dble(m1)
         r2 = dble(m2)
         r3 = dble(m3)
         h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
         h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
         h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
         hsq = h1*h1 + h2*h2 + h3*h3
         term = -pterm * hsq
         expterm = 0.0d0
         if (term .gt. -50.0d0) then
            denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
            expterm = exp(term) / denom
            if (.not. use_bounds) then
               expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
            else if (nonprism) then
               if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
            end if
         end if
         qgrid(1,k1,k2,k3) = expterm * qgrid(1,k1,k2,k3)
         qgrid(2,k1,k2,k3) = expterm * qgrid(2,k1,k2,k3)
      end do
c
c     account for zeroth grid point for nonperiodic system
c
      qgrid(1,1,1,1) = 0.0d0
      qgrid(2,1,1,1) = 0.0d0
      if (.not. use_bounds) then
         expterm = 0.5d0 * pi / xbox
         qgrid(1,1,1,1) = expterm * qgrid(1,1,1,1)
         qgrid(2,1,1,1) = expterm * qgrid(2,1,1,1)
      end if
c
c     perform 3-D FFT backward transform and get potential
c
      call fftback
      call fphi_mpole (fphi)
c
c     increment the total permanent atomic multipole energy
c
      e = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         do k = 1, 10
            term = f * fmp(k,i) * fphi(k,i)
            e = e + term
         end do
      end do
      em = em + e
      return
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 1999 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine empole1  --  multipole energy & derivatives  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "empole1" calculates the atomic multipole energy and first
c     derivatives with respect to Cartesian coordinates
c
c
      subroutine empole1
      use energi
      use extfld
      use limits
      implicit none
      real*8 exf
      character*6 mode
c
c
c     choose the method to sum over multipole interactions
c
      if (use_ewald) then
         if (use_mlist) then
            call empole1d
         else
            call empole1c
         end if
      else
         if (use_mlist) then
            call empole1b
         else
            call empole1a
         end if
      end if
c
c     get contribution from external electric field if used
c
      if (use_exfld) then
         mode = 'MPOLE'
         call exfield1 (mode,exf)
         em = em + exf
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine empole1a  --  double loop multipole derivatives  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "empole1a" calculates the multipole energy and derivatives with 
c     respect to Cartesian coordinates using a pairwise double loop
c
c
      subroutine empole1a
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use deriv
      use energi
      use group
      use mplpot
      use mpole
      use potent
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,kk,jcell
      integer ix,iy,iz
      integer kx,ky,kz
      real*8 e,de,f,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9,rr11
      real*8 rr1i,rr3i,rr5i,rr7i
      real*8 rr1k,rr3k,rr5k,rr7k
      real*8 rr1ik,rr3ik,rr5ik
      real*8 rr7ik,rr9ik,rr11ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 dirx,diry,dirz
      real*8 dkrx,dkry,dkrz
      real*8 dikx,diky,dikz
      real*8 qirx,qiry,qirz
      real*8 qkrx,qkry,qkrz
      real*8 qikx,qiky,qikz
      real*8 qixk,qiyk,qizk
      real*8 qkxi,qkyi,qkzi
      real*8 qikrx,qikry,qikrz
      real*8 qkirx,qkiry,qkirz
      real*8 diqkx,diqky,diqkz
      real*8 dkqix,dkqiy,dkqiz
      real*8 diqkrx,diqkry,diqkrz
      real*8 dkqirx,dkqiry,dkqirz
      real*8 dqikx,dqiky,dqikz
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5,term6
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 poti,potk
      real*8 frcx,frcy,frcz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 ttmi(3),ttmk(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(11)
      real*8, allocatable :: mscale(:)
      real*8, allocatable :: tem(:,:)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
      logical proceed,usei,usek
      character*6 mode
c
c
c     zero out the atomic multipole energy and derivatives
c
      em = 0.0d0
      do i = 1, n
         do j = 1, 3
            dem(j,i) = 0.0d0
         end do
      end do
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
      allocate (tem(3,n))
      allocate (pot(n))
      allocate (decfx(n))
      allocate (decfy(n))
      allocate (decfz(n))
c
c     initialize scaling, torque and potential arrays
c
      do i = 1, n
         mscale(i) = 1.0d0
         do j = 1, 3
            tem(j,i) = 0.0d0
         end do
         pot(i) = 0.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     compute the multipole interaction energy and gradient
c
      do ii = 1, npole-1
         i = ipole(ii)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
            if (.not. proceed)  goto 10
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               dik = dix*dkx + diy*dky + diz*dkz
               qik = qix*qkx + qiy*qky + qiz*qkz
               diqk = dix*qkx + diy*qky + diz*qkz
               dkqi = dkx*qix + dky*qiy + dkz*qiz
               qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                   + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
               dirx = diy*zr - diz*yr
               diry = diz*xr - dix*zr
               dirz = dix*yr - diy*xr
               dkrx = dky*zr - dkz*yr
               dkry = dkz*xr - dkx*zr
               dkrz = dkx*yr - dky*xr
               dikx = diy*dkz - diz*dky
               diky = diz*dkx - dix*dkz
               dikz = dix*dky - diy*dkx
               qirx = qiz*yr - qiy*zr
               qiry = qix*zr - qiz*xr
               qirz = qiy*xr - qix*yr
               qkrx = qkz*yr - qky*zr
               qkry = qkx*zr - qkz*xr
               qkrz = qky*xr - qkx*yr
               qikx = qky*qiz - qkz*qiy
               qiky = qkz*qix - qkx*qiz
               qikz = qkx*qiy - qky*qix
               qixk = qixx*qkx + qixy*qky + qixz*qkz
               qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
               qizk = qixz*qkx + qiyz*qky + qizz*qkz
               qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
               qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
               qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
               qikrx = qizk*yr - qiyk*zr
               qikry = qixk*zr - qizk*xr
               qikrz = qiyk*xr - qixk*yr
               qkirx = qkzi*yr - qkyi*zr
               qkiry = qkxi*zr - qkzi*xr
               qkirz = qkyi*xr - qkxi*yr
               diqkx = dix*qkxx + diy*qkxy + diz*qkxz
               diqky = dix*qkxy + diy*qkyy + diz*qkyz
               diqkz = dix*qkxz + diy*qkyz + diz*qkzz
               dkqix = dkx*qixx + dky*qixy + dkz*qixz
               dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
               dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
               diqkrx = diqkz*yr - diqky*zr
               diqkry = diqkx*zr - diqkz*xr
               diqkrz = diqky*xr - diqkx*yr
               dkqirx = dkqiz*yr - dkqiy*zr
               dkqiry = dkqix*zr - dkqiz*xr
               dkqirz = dkqiy*xr - dkqix*yr
               dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                 - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                         -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
               dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                 - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                         -qixx*qkxz-qixy*qkyz-qixz*qkzz)
               dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                 - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                         -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f * mscale(k) / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
               rr11 = 9.0d0 * rr9 / r2
c
c     find damped multipole intermediates and energy value
c
               if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  term1 = corei*corek
                  term1i = corek*vali
                  term2i = corek*dir
                  term3i = corek*qir
                  term1k = corei*valk
                  term2k = -corei*dkr
                  term3k = corei*qkr
                  term1ik = vali*valk
                  term2ik = valk*dir - vali*dkr + dik
                  term3ik = vali*qkr + valk*qir - dir*dkr
     &                         + 2.0d0*(dkqi-diqk+qiqk)
                  term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                  term5ik = qir*qkr
                  call damppole (r,11,alphai,alphak,
     &                            dmpi,dmpk,dmpik)
                  rr1i = dmpi(1)*rr1
                  rr3i = dmpi(3)*rr3
                  rr5i = dmpi(5)*rr5
                  rr7i = dmpi(7)*rr7
                  rr1k = dmpk(1)*rr1
                  rr3k = dmpk(3)*rr3
                  rr5k = dmpk(5)*rr5
                  rr7k = dmpk(7)*rr7
                  rr1ik = dmpik(1)*rr1
                  rr3ik = dmpik(3)*rr3
                  rr5ik = dmpik(5)*rr5
                  rr7ik = dmpik(7)*rr7
                  rr9ik = dmpik(9)*rr9
                  rr11ik = dmpik(11)*rr11
                  e = term1*rr1 + term4ik*rr7ik + term5ik*rr9ik
     &                   + term1i*rr1i + term1k*rr1k + term1ik*rr1ik
     &                   + term2i*rr3i + term2k*rr3k + term2ik*rr3ik
     &                   + term3i*rr5i + term3k*rr5k + term3ik*rr5ik
c
c     find damped multipole intermediates for force and torque
c
                  de = term1*rr3 + term4ik*rr9ik + term5ik*rr11ik
     &                    + term1i*rr3i + term1k*rr3k + term1ik*rr3ik
     &                    + term2i*rr5i + term2k*rr5k + term2ik*rr5ik
     &                    + term3i*rr7i + term3k*rr7k + term3ik*rr7ik
                  term1 = -corek*rr3i - valk*rr3ik
     &                       + dkr*rr5ik - qkr*rr7ik
                  term2 = corei*rr3k + vali*rr3ik
     &                       + dir*rr5ik + qir*rr7ik
                  term3 = 2.0d0 * rr5ik
                  term4 = -2.0d0 * (corek*rr5i+valk*rr5ik
     &                                -dkr*rr7ik+qkr*rr9ik)
                  term5 = -2.0d0 * (corei*rr5k+vali*rr5ik
     &                                +dir*rr7ik+qir*rr9ik)
                  term6 = 4.0d0 * rr7ik
c
c     find standard multipole intermediates and energy value
c
               else
                  term1 = ci*ck
                  term2 = ck*dir - ci*dkr + dik
                  term3 = ci*qkr + ck*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  e = term1*rr1 + term2*rr3 + term3*rr5
     &                   + term4*rr7 + term5*rr9
c
c     find standard multipole intermediates for force and torque
c
                  de = term1*rr3 + term2*rr5 + term3*rr7
     &                    + term4*rr9 + term5*rr11
                  term1 = -ck*rr3 + dkr*rr5 - qkr*rr7
                  term2 = ci*rr3 + dir*rr5 + qir*rr7
                  term3 = 2.0d0 * rr5
                  term4 = -2.0d0 * (ck*rr5-dkr*rr7+qkr*rr9)
                  term5 = -2.0d0 * (ci*rr5+dir*rr7+qir*rr9)
                  term6 = 4.0d0 * rr7
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_chgpen) then
                     term1i = corek*dmpi(1) + valk*dmpik(1) 
                     term1k = corei*dmpk(1) + vali*dmpik(1) 
                     term2i = -dkr * dmpik(3)
                     term2k = dir * dmpik(3)
                     term3i = qkr * dmpik(5)
                     term3k = qir * dmpik(5)
                     poti = term1i*rr1 + term2i*rr3 + term3i*rr5
                     potk = term1k*rr1 + term2k*rr3 + term3k*rr5
                  else
                     poti = ck*rr1 - dkr*rr3 + qkr*rr5
                     potk = ci*rr1 + dir*rr3 + qir*rr5
                  end if
                  pot(i) = pot(i) + poti
                  pot(k) = pot(k) + potk
               end if 
c
c     compute the force components for this interaction
c
               frcx = de*xr + term1*dix + term2*dkx
     &                   + term3*(diqkx-dkqix) + term4*qix
     &                   + term5*qkx + term6*(qixk+qkxi)
               frcy = de*yr + term1*diy + term2*dky
     &                   + term3*(diqky-dkqiy) + term4*qiy
     &                   + term5*qky + term6*(qiyk+qkyi)
               frcz = de*zr + term1*diz + term2*dkz
     &                   + term3*(diqkz-dkqiz) + term4*qiz
     &                   + term5*qkz + term6*(qizk+qkzi)
c
c     compute the torque components for this interaction
c
               if (use_chgpen)  rr3 = rr3ik
               ttmi(1) = -rr3*dikx + term1*dirx
     &                      + term3*(dqikx+dkqirx)
     &                      - term4*qirx - term6*(qikrx+qikx)
               ttmi(2) = -rr3*diky + term1*diry
     &                      + term3*(dqiky+dkqiry)
     &                      - term4*qiry - term6*(qikry+qiky)
               ttmi(3) = -rr3*dikz + term1*dirz
     &                      + term3*(dqikz+dkqirz)
     &                      - term4*qirz - term6*(qikrz+qikz)
               ttmk(1) = rr3*dikx + term2*dkrx
     &                      - term3*(dqikx+diqkrx)
     &                      - term5*qkrx - term6*(qkirx-qikx)
               ttmk(2) = rr3*diky + term2*dkry
     &                      - term3*(dqiky+diqkry)
     &                      - term5*qkry - term6*(qkiry-qiky)
               ttmk(3) = rr3*dikz + term2*dkrz
     &                      - term3*(dqikz+diqkrz)
     &                      - term5*qkrz - term6*(qkirz-qikz)
c
c     energy, force and torque scaled by group membership
c
               if (use_group) then
                  e = fgrp * e
                  frcx = fgrp * frcx
                  frcy = fgrp * frcy
                  frcz = fgrp * frcz
                  do j = 1, 3
                     ttmi(j) = fgrp * ttmi(j)
                     ttmk(j) = fgrp * ttmk(j)
                  end do
               end if
c
c     increment the overall atomic multipole energy component
c
               em = em + e
c
c     increment force-based gradient and torque on first site
c
               dem(1,i) = dem(1,i) + frcx
               dem(2,i) = dem(2,i) + frcy
               dem(3,i) = dem(3,i) + frcz
               tem(1,i) = tem(1,i) + ttmi(1)
               tem(2,i) = tem(2,i) + ttmi(2)
               tem(3,i) = tem(3,i) + ttmi(3)
c
c     increment force-based gradient and torque on second site
c
               dem(1,k) = dem(1,k) - frcx
               dem(2,k) = dem(2,k) - frcy
               dem(3,k) = dem(3,k) - frcz
               tem(1,k) = tem(1,k) + ttmk(1)
               tem(2,k) = tem(2,k) + ttmk(2)
               tem(3,k) = tem(3,k) + ttmk(3)
c
c     increment the virial due to pairwise Cartesian forces
c
               vxx = -xr * frcx
               vxy = -0.5d0 * (yr*frcx+xr*frcy)
               vxz = -0.5d0 * (zr*frcx+xr*frcz)
               vyy = -yr * frcy
               vyz = -0.5d0 * (zr*frcy+yr*frcz)
               vzz = -zr * frcz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
   10       continue
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction with other unit cells
c
      do ii = 1, npole
         i = ipole(ii)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii, npole
            k = ipole(kk)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
            if (.not. proceed)  goto 20
            do jcell = 2, ncell
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            call imager (xr,yr,zr,jcell)
            r2 = xr*xr + yr*yr + zr*zr
            if (.not. (use_polymer .and. r2.le.polycut2)) then
               mscale(k) = 1.0d0
            end if
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               dik = dix*dkx + diy*dky + diz*dkz
               qik = qix*qkx + qiy*qky + qiz*qkz
               diqk = dix*qkx + diy*qky + diz*qkz
               dkqi = dkx*qix + dky*qiy + dkz*qiz
               qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                   + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
               dirx = diy*zr - diz*yr
               diry = diz*xr - dix*zr
               dirz = dix*yr - diy*xr
               dkrx = dky*zr - dkz*yr
               dkry = dkz*xr - dkx*zr
               dkrz = dkx*yr - dky*xr
               dikx = diy*dkz - diz*dky
               diky = diz*dkx - dix*dkz
               dikz = dix*dky - diy*dkx
               qirx = qiz*yr - qiy*zr
               qiry = qix*zr - qiz*xr
               qirz = qiy*xr - qix*yr
               qkrx = qkz*yr - qky*zr
               qkry = qkx*zr - qkz*xr
               qkrz = qky*xr - qkx*yr
               qikx = qky*qiz - qkz*qiy
               qiky = qkz*qix - qkx*qiz
               qikz = qkx*qiy - qky*qix
               qixk = qixx*qkx + qixy*qky + qixz*qkz
               qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
               qizk = qixz*qkx + qiyz*qky + qizz*qkz
               qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
               qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
               qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
               qikrx = qizk*yr - qiyk*zr
               qikry = qixk*zr - qizk*xr
               qikrz = qiyk*xr - qixk*yr
               qkirx = qkzi*yr - qkyi*zr
               qkiry = qkxi*zr - qkzi*xr
               qkirz = qkyi*xr - qkxi*yr
               diqkx = dix*qkxx + diy*qkxy + diz*qkxz
               diqky = dix*qkxy + diy*qkyy + diz*qkyz
               diqkz = dix*qkxz + diy*qkyz + diz*qkzz
               dkqix = dkx*qixx + dky*qixy + dkz*qixz
               dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
               dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
               diqkrx = diqkz*yr - diqky*zr
               diqkry = diqkx*zr - diqkz*xr
               diqkrz = diqky*xr - diqkx*yr
               dkqirx = dkqiz*yr - dkqiy*zr
               dkqiry = dkqix*zr - dkqiz*xr
               dkqirz = dkqiy*xr - dkqix*yr
               dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                 - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                         -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
               dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                 - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                         -qixx*qkxz-qixy*qkyz-qixz*qkzz)
               dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                 - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                         -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f * mscale(k) / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
               rr11 = 9.0d0 * rr9 / r2
c
c     find damped multipole intermediates and energy value
c
               if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  term1 = corei*corek
                  term1i = corek*vali
                  term2i = corek*dir
                  term3i = corek*qir
                  term1k = corei*valk
                  term2k = -corei*dkr
                  term3k = corei*qkr
                  term1ik = vali*valk
                  term2ik = valk*dir - vali*dkr + dik
                  term3ik = vali*qkr + valk*qir - dir*dkr
     &                         + 2.0d0*(dkqi-diqk+qiqk)
                  term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                  term5ik = qir*qkr
                  call damppole (r,11,alphai,alphak,
     &                            dmpi,dmpk,dmpik)
                  rr1i = dmpi(1)*rr1
                  rr3i = dmpi(3)*rr3
                  rr5i = dmpi(5)*rr5
                  rr7i = dmpi(7)*rr7
                  rr1k = dmpk(1)*rr1
                  rr3k = dmpk(3)*rr3
                  rr5k = dmpk(5)*rr5
                  rr7k = dmpk(7)*rr7
                  rr1ik = dmpik(1)*rr1
                  rr3ik = dmpik(3)*rr3
                  rr5ik = dmpik(5)*rr5
                  rr7ik = dmpik(7)*rr7
                  rr9ik = dmpik(9)*rr9
                  rr11ik = dmpik(11)*rr11
                  e = term1*rr1 + term4ik*rr7ik + term5ik*rr9ik
     &                   + term1i*rr1i + term1k*rr1k + term1ik*rr1ik
     &                   + term2i*rr3i + term2k*rr3k + term2ik*rr3ik
     &                   + term3i*rr5i + term3k*rr5k + term3ik*rr5ik
c
c     find damped multipole intermediates for force and torque
c
                  de = term1*rr3 + term4ik*rr9ik + term5ik*rr11ik
     &                    + term1i*rr3i + term1k*rr3k + term1ik*rr3ik
     &                    + term2i*rr5i + term2k*rr5k + term2ik*rr5ik
     &                    + term3i*rr7i + term3k*rr7k + term3ik*rr7ik
                  term1 = -corek*rr3i - valk*rr3ik
     &                       + dkr*rr5ik - qkr*rr7ik
                  term2 = corei*rr3k + vali*rr3ik
     &                       + dir*rr5ik + qir*rr7ik
                  term3 = 2.0d0 * rr5ik
                  term4 = -2.0d0 * (corek*rr5i+valk*rr5ik
     &                                -dkr*rr7ik+qkr*rr9ik)
                  term5 = -2.0d0 * (corei*rr5k+vali*rr5ik
     &                                +dir*rr7ik+qir*rr9ik)
                  term6 = 4.0d0 * rr7ik
c
c     find standard multipole intermediates and energy value
c
               else
                  term1 = ci*ck
                  term2 = ck*dir - ci*dkr + dik
                  term3 = ci*qkr + ck*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  e = term1*rr1 + term2*rr3 + term3*rr5
     &                   + term4*rr7 + term5*rr9
c
c     find standard multipole intermediates for force and torque
c
                  de = term1*rr3 + term2*rr5 + term3*rr7
     &                    + term4*rr9 + term5*rr11
                  term1 = -ck*rr3 + dkr*rr5 - qkr*rr7
                  term2 = ci*rr3 + dir*rr5 + qir*rr7
                  term3 = 2.0d0 * rr5
                  term4 = -2.0d0 * (ck*rr5-dkr*rr7+qkr*rr9)
                  term5 = -2.0d0 * (ci*rr5+dir*rr7+qir*rr9)
                  term6 = 4.0d0 * rr7
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_chgpen) then
                     term1i = corek*dmpi(1) + valk*dmpik(1) 
                     term1k = corei*dmpk(1) + vali*dmpik(1) 
                     term2i = -dkr * dmpik(3)
                     term2k = dir * dmpik(3)
                     term3i = qkr * dmpik(5)
                     term3k = qir * dmpik(5)
                     poti = term1i*rr1 + term2i*rr3 + term3i*rr5
                     potk = term1k*rr1 + term2k*rr3 + term3k*rr5
                  else
                     poti = ck*rr1 - dkr*rr3 + qkr*rr5
                     potk = ci*rr1 + dir*rr3 + qir*rr5
                  end if
                  pot(i) = pot(i) + poti
                  pot(k) = pot(k) + potk
               end if 
c
c     compute the force components for this interaction
c
               frcx = de*xr + term1*dix + term2*dkx
     &                   + term3*(diqkx-dkqix) + term4*qix
     &                   + term5*qkx + term6*(qixk+qkxi)
               frcy = de*yr + term1*diy + term2*dky
     &                   + term3*(diqky-dkqiy) + term4*qiy
     &                   + term5*qky + term6*(qiyk+qkyi)
               frcz = de*zr + term1*diz + term2*dkz
     &                   + term3*(diqkz-dkqiz) + term4*qiz
     &                   + term5*qkz + term6*(qizk+qkzi)
c
c     compute the torque components for this interaction
c
               if (use_chgpen)  rr3 = rr3ik
               ttmi(1) = -rr3*dikx + term1*dirx
     &                      + term3*(dqikx+dkqirx)
     &                      - term4*qirx - term6*(qikrx+qikx)
               ttmi(2) = -rr3*diky + term1*diry
     &                      + term3*(dqiky+dkqiry)
     &                      - term4*qiry - term6*(qikry+qiky)
               ttmi(3) = -rr3*dikz + term1*dirz
     &                      + term3*(dqikz+dkqirz)
     &                      - term4*qirz - term6*(qikrz+qikz)
               ttmk(1) = rr3*dikx + term2*dkrx
     &                      - term3*(dqikx+diqkrx)
     &                      - term5*qkrx - term6*(qkirx-qikx)
               ttmk(2) = rr3*diky + term2*dkry
     &                      - term3*(dqiky+diqkry)
     &                      - term5*qkry - term6*(qkiry-qiky)
               ttmk(3) = rr3*dikz + term2*dkrz
     &                      - term3*(dqikz+diqkrz)
     &                      - term5*qkrz - term6*(qkirz-qikz)
c
c     energy, force and torque scaled by group membership
c
               if (i .eq. k) then
                  e = 0.5d0 * e
                  frcx = 0.5d0 * frcx
                  frcy = 0.5d0 * frcy
                  frcz = 0.5d0 * frcz
                  do j = 1, 3
                     ttmi(j) = 0.5d0 * ttmi(j)
                     ttmk(j) = 0.5d0 * ttmk(j)
                  end do
               end if
               if (use_group) then
                  e = fgrp * e
                  frcx = fgrp * frcx
                  frcy = fgrp * frcy
                  frcz = fgrp * frcz
                  do j = 1, 3
                     ttmi(j) = fgrp * ttmi(j)
                     ttmk(j) = fgrp * ttmk(j)
                  end do
               end if
c
c     increment the overall atomic multipole energy component
c
               em = em + e
c
c     increment force-based gradient and torque on first site
c
               dem(1,i) = dem(1,i) + frcx
               dem(2,i) = dem(2,i) + frcy
               dem(3,i) = dem(3,i) + frcz
               tem(1,i) = tem(1,i) + ttmi(1)
               tem(2,i) = tem(2,i) + ttmi(2)
               tem(3,i) = tem(3,i) + ttmi(3)
c
c     increment force-based gradient and torque on second site
c
               dem(1,k) = dem(1,k) - frcx
               dem(2,k) = dem(2,k) - frcy
               dem(3,k) = dem(3,k) - frcz
               tem(1,k) = tem(1,k) + ttmk(1)
               tem(2,k) = tem(2,k) + ttmk(2)
               tem(3,k) = tem(3,k) + ttmk(3)
c
c     increment the virial due to pairwise Cartesian forces
c
               vxx = -xr * frcx
               vxy = -0.5d0 * (yr*frcx+xr*frcy)
               vxz = -0.5d0 * (zr*frcx+xr*frcz)
               vyy = -yr * frcy
               vyz = -0.5d0 * (zr*frcy+yr*frcz)
               vzz = -zr * frcz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
            end do
   20       continue
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
      end if
c
c     resolve site torques then increment forces and virial
c
      do ii = 1, npole
         i = ipole(ii)
         call torque (i,tem(1,i),fix,fiy,fiz,dem)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     modify the gradient and virial for charge flux
c
      if (use_chgflx) then
         call dcflux (pot,decfx,decfy,decfz)
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            frcx = decfx(i)
            frcy = decfy(i)
            frcz = decfz(i)
            dem(1,i) = dem(1,i) + frcx
            dem(2,i) = dem(2,i) + frcy
            dem(3,i) = dem(3,i) + frcz
            vxx = xi * frcx
            vxy = yi * frcx
            vxz = zi * frcx
            vyy = yi * frcy
            vyz = zi * frcy
            vzz = zi * frcz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vxy
            vir(3,1) = vir(3,1) + vxz
            vir(1,2) = vir(1,2) + vxy
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vyz
            vir(1,3) = vir(1,3) + vxz
            vir(2,3) = vir(2,3) + vyz
            vir(3,3) = vir(3,3) + vzz
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      deallocate (tem)
      deallocate (pot)
      deallocate (decfx)
      deallocate (decfy)
      deallocate (decfz)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine empole1b  --  neighbor list multipole derivs  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "empole1b" calculates the multipole energy and derivatives
c     with respect to Cartesian coordinates using a neighbor list
c
c
      subroutine empole1b
      use atoms
      use bound
      use chgpen
      use chgpot
      use couple
      use deriv
      use energi
      use group
      use mplpot
      use mpole
      use neigh
      use potent
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      integer ix,iy,iz
      integer kx,ky,kz
      real*8 e,de,f,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9,rr11
      real*8 rr1i,rr3i,rr5i,rr7i
      real*8 rr1k,rr3k,rr5k,rr7k
      real*8 rr1ik,rr3ik,rr5ik
      real*8 rr7ik,rr9ik,rr11ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 dirx,diry,dirz
      real*8 dkrx,dkry,dkrz
      real*8 dikx,diky,dikz
      real*8 qirx,qiry,qirz
      real*8 qkrx,qkry,qkrz
      real*8 qikx,qiky,qikz
      real*8 qixk,qiyk,qizk
      real*8 qkxi,qkyi,qkzi
      real*8 qikrx,qikry,qikrz
      real*8 qkirx,qkiry,qkirz
      real*8 diqkx,diqky,diqkz
      real*8 dkqix,dkqiy,dkqiz
      real*8 diqkrx,diqkry,diqkrz
      real*8 dkqirx,dkqiry,dkqirz
      real*8 dqikx,dqiky,dqikz
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5,term6
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 poti,potk
      real*8 frcx,frcy,frcz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 ttmi(3),ttmk(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(11)
      real*8, allocatable :: mscale(:)
      real*8, allocatable :: tem(:,:)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
      logical proceed,usei,usek
      character*6 mode
c
c
c     zero out the atomic multipole energy and derivatives
c
      em = 0.0d0
      do i = 1, n
         do j = 1, 3
            dem(j,i) = 0.0d0
         end do
      end do
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
      allocate (tem(3,n))
      allocate (pot(n))
      allocate (decfx(n))
      allocate (decfy(n))
      allocate (decfz(n))
c
c     initialize scaling, torque and potential arrays
c
      do i = 1, n
         mscale(i) = 1.0d0
         do j = 1, 3
            tem(j,i) = 0.0d0
         end do
         pot(i) = 0.0d0
      end do
c
c     set conversion factor, cutoff and scaling coefficients
c
      f = electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,x,y,z,xaxis,yaxis,zaxis,rpole,pcore,
!$OMP& pval,palpha,use,n12,i12,n13,i13,n14,i14,n15,i15,m2scale,
!$OMP& m3scale,m4scale,m5scale,nelst,elst,use_chgpen,use_chgflx,
!$OMP& use_group,use_intra,use_bounds,off2,f)
!$OMP& firstprivate(mscale) shared (em,dem,tem,pot,vir)
!$OMP DO reduction(+:em,dem,tem,pot,vir)
c
c     compute the multipole interaction energy and gradient
c
      do ii = 1, npole
         i = ipole(ii)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
            if (.not. proceed)  goto 10
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               dik = dix*dkx + diy*dky + diz*dkz
               qik = qix*qkx + qiy*qky + qiz*qkz
               diqk = dix*qkx + diy*qky + diz*qkz
               dkqi = dkx*qix + dky*qiy + dkz*qiz
               qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                   + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
               dirx = diy*zr - diz*yr
               diry = diz*xr - dix*zr
               dirz = dix*yr - diy*xr
               dkrx = dky*zr - dkz*yr
               dkry = dkz*xr - dkx*zr
               dkrz = dkx*yr - dky*xr
               dikx = diy*dkz - diz*dky
               diky = diz*dkx - dix*dkz
               dikz = dix*dky - diy*dkx
               qirx = qiz*yr - qiy*zr
               qiry = qix*zr - qiz*xr
               qirz = qiy*xr - qix*yr
               qkrx = qkz*yr - qky*zr
               qkry = qkx*zr - qkz*xr
               qkrz = qky*xr - qkx*yr
               qikx = qky*qiz - qkz*qiy
               qiky = qkz*qix - qkx*qiz
               qikz = qkx*qiy - qky*qix
               qixk = qixx*qkx + qixy*qky + qixz*qkz
               qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
               qizk = qixz*qkx + qiyz*qky + qizz*qkz
               qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
               qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
               qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
               qikrx = qizk*yr - qiyk*zr
               qikry = qixk*zr - qizk*xr
               qikrz = qiyk*xr - qixk*yr
               qkirx = qkzi*yr - qkyi*zr
               qkiry = qkxi*zr - qkzi*xr
               qkirz = qkyi*xr - qkxi*yr
               diqkx = dix*qkxx + diy*qkxy + diz*qkxz
               diqky = dix*qkxy + diy*qkyy + diz*qkyz
               diqkz = dix*qkxz + diy*qkyz + diz*qkzz
               dkqix = dkx*qixx + dky*qixy + dkz*qixz
               dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
               dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
               diqkrx = diqkz*yr - diqky*zr
               diqkry = diqkx*zr - diqkz*xr
               diqkrz = diqky*xr - diqkx*yr
               dkqirx = dkqiz*yr - dkqiy*zr
               dkqiry = dkqix*zr - dkqiz*xr
               dkqirz = dkqiy*xr - dkqix*yr
               dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                 - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                         -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
               dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                 - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                         -qixx*qkxz-qixy*qkyz-qixz*qkzz)
               dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                 - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                         -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f * mscale(k) / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
               rr11 = 9.0d0 * rr9 / r2
c
c     find damped multipole intermediates and energy value
c
               if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  term1 = corei*corek
                  term1i = corek*vali
                  term2i = corek*dir
                  term3i = corek*qir
                  term1k = corei*valk
                  term2k = -corei*dkr
                  term3k = corei*qkr
                  term1ik = vali*valk
                  term2ik = valk*dir - vali*dkr + dik
                  term3ik = vali*qkr + valk*qir - dir*dkr
     &                         + 2.0d0*(dkqi-diqk+qiqk)
                  term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                  term5ik = qir*qkr
                  call damppole (r,11,alphai,alphak,
     &                            dmpi,dmpk,dmpik)
                  rr1i = dmpi(1)*rr1
                  rr3i = dmpi(3)*rr3
                  rr5i = dmpi(5)*rr5
                  rr7i = dmpi(7)*rr7
                  rr1k = dmpk(1)*rr1
                  rr3k = dmpk(3)*rr3
                  rr5k = dmpk(5)*rr5
                  rr7k = dmpk(7)*rr7
                  rr1ik = dmpik(1)*rr1
                  rr3ik = dmpik(3)*rr3
                  rr5ik = dmpik(5)*rr5
                  rr7ik = dmpik(7)*rr7
                  rr9ik = dmpik(9)*rr9
                  rr11ik = dmpik(11)*rr11
                  e = term1*rr1 + term4ik*rr7ik + term5ik*rr9ik
     &                   + term1i*rr1i + term1k*rr1k + term1ik*rr1ik
     &                   + term2i*rr3i + term2k*rr3k + term2ik*rr3ik
     &                   + term3i*rr5i + term3k*rr5k + term3ik*rr5ik
c
c     find damped multipole intermediates for force and torque
c
                  de = term1*rr3 + term4ik*rr9ik + term5ik*rr11ik
     &                    + term1i*rr3i + term1k*rr3k + term1ik*rr3ik
     &                    + term2i*rr5i + term2k*rr5k + term2ik*rr5ik
     &                    + term3i*rr7i + term3k*rr7k + term3ik*rr7ik
                  term1 = -corek*rr3i - valk*rr3ik
     &                       + dkr*rr5ik - qkr*rr7ik
                  term2 = corei*rr3k + vali*rr3ik
     &                       + dir*rr5ik + qir*rr7ik
                  term3 = 2.0d0 * rr5ik
                  term4 = -2.0d0 * (corek*rr5i+valk*rr5ik
     &                                -dkr*rr7ik+qkr*rr9ik)
                  term5 = -2.0d0 * (corei*rr5k+vali*rr5ik
     &                                +dir*rr7ik+qir*rr9ik)
                  term6 = 4.0d0 * rr7ik
c
c     find standard multipole intermediates and energy value
c
               else
                  term1 = ci*ck
                  term2 = ck*dir - ci*dkr + dik
                  term3 = ci*qkr + ck*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  e = term1*rr1 + term2*rr3 + term3*rr5
     &                   + term4*rr7 + term5*rr9
c
c     find standard multipole intermediates for force and torque
c
                  de = term1*rr3 + term2*rr5 + term3*rr7
     &                    + term4*rr9 + term5*rr11
                  term1 = -ck*rr3 + dkr*rr5 - qkr*rr7
                  term2 = ci*rr3 + dir*rr5 + qir*rr7
                  term3 = 2.0d0 * rr5
                  term4 = -2.0d0 * (ck*rr5-dkr*rr7+qkr*rr9)
                  term5 = -2.0d0 * (ci*rr5+dir*rr7+qir*rr9)
                  term6 = 4.0d0 * rr7
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_chgpen) then
                     term1i = corek*dmpi(1) + valk*dmpik(1) 
                     term1k = corei*dmpk(1) + vali*dmpik(1) 
                     term2i = -dkr * dmpik(3)
                     term2k = dir * dmpik(3)
                     term3i = qkr * dmpik(5)
                     term3k = qir * dmpik(5)
                     poti = term1i*rr1 + term2i*rr3 + term3i*rr5
                     potk = term1k*rr1 + term2k*rr3 + term3k*rr5
                  else
                     poti = ck*rr1 - dkr*rr3 + qkr*rr5
                     potk = ci*rr1 + dir*rr3 + qir*rr5
                  end if
                  pot(i) = pot(i) + poti
                  pot(k) = pot(k) + potk
               end if 
c
c     compute the force components for this interaction
c
               frcx = de*xr + term1*dix + term2*dkx
     &                   + term3*(diqkx-dkqix) + term4*qix
     &                   + term5*qkx + term6*(qixk+qkxi)
               frcy = de*yr + term1*diy + term2*dky
     &                   + term3*(diqky-dkqiy) + term4*qiy
     &                   + term5*qky + term6*(qiyk+qkyi)
               frcz = de*zr + term1*diz + term2*dkz
     &                   + term3*(diqkz-dkqiz) + term4*qiz
     &                   + term5*qkz + term6*(qizk+qkzi)
c
c     compute the torque components for this interaction
c
               if (use_chgpen)  rr3 = rr3ik
               ttmi(1) = -rr3*dikx + term1*dirx
     &                      + term3*(dqikx+dkqirx)
     &                      - term4*qirx - term6*(qikrx+qikx)
               ttmi(2) = -rr3*diky + term1*diry
     &                      + term3*(dqiky+dkqiry)
     &                      - term4*qiry - term6*(qikry+qiky)
               ttmi(3) = -rr3*dikz + term1*dirz
     &                      + term3*(dqikz+dkqirz)
     &                      - term4*qirz - term6*(qikrz+qikz)
               ttmk(1) = rr3*dikx + term2*dkrx
     &                      - term3*(dqikx+diqkrx)
     &                      - term5*qkrx - term6*(qkirx-qikx)
               ttmk(2) = rr3*diky + term2*dkry
     &                      - term3*(dqiky+diqkry)
     &                      - term5*qkry - term6*(qkiry-qiky)
               ttmk(3) = rr3*dikz + term2*dkrz
     &                      - term3*(dqikz+diqkrz)
     &                      - term5*qkrz - term6*(qkirz-qikz)
c
c     energy, force and torque scaled by group membership
c
               if (use_group) then
                  e = fgrp * e
                  frcx = fgrp * frcx
                  frcy = fgrp * frcy
                  frcz = fgrp * frcz
                  do j = 1, 3
                     ttmi(j) = fgrp * ttmi(j)
                     ttmk(j) = fgrp * ttmk(j)
                  end do
               end if
c
c     increment the overall atomic multipole energy component
c
               em = em + e
c
c     increment force-based gradient and torque on first site
c
               dem(1,i) = dem(1,i) + frcx
               dem(2,i) = dem(2,i) + frcy
               dem(3,i) = dem(3,i) + frcz
               tem(1,i) = tem(1,i) + ttmi(1)
               tem(2,i) = tem(2,i) + ttmi(2)
               tem(3,i) = tem(3,i) + ttmi(3)
c
c     increment force-based gradient and torque on second site
c
               dem(1,k) = dem(1,k) - frcx
               dem(2,k) = dem(2,k) - frcy
               dem(3,k) = dem(3,k) - frcz
               tem(1,k) = tem(1,k) + ttmk(1)
               tem(2,k) = tem(2,k) + ttmk(2)
               tem(3,k) = tem(3,k) + ttmk(3)
c
c     increment the virial due to pairwise Cartesian forces
c
               vxx = -xr * frcx
               vxy = -0.5d0 * (yr*frcx+xr*frcy)
               vxz = -0.5d0 * (zr*frcx+xr*frcz)
               vyy = -yr * frcy
               vyz = -0.5d0 * (zr*frcy+yr*frcz)
               vzz = -zr * frcz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
   10       continue
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP DO reduction(+:dem,vir)
c
c     resolve site torques then increment forces and virial
c
      do ii = 1, npole
         i = ipole(ii)
         call torque (i,tem(1,i),fix,fiy,fiz,dem)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
c
c     modify the gradient and virial for charge flux
c
      if (use_chgflx) then
         call dcflux (pot,decfx,decfy,decfz)
!$OMP    DO reduction(+:dem,vir)
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            frcx = decfx(i)
            frcy = decfy(i)
            frcz = decfz(i)
            dem(1,i) = dem(1,i) + frcx
            dem(2,i) = dem(2,i) + frcy
            dem(3,i) = dem(3,i) + frcz
            vxx = xi * frcx
            vxy = yi * frcx
            vxz = zi * frcx
            vyy = yi * frcy
            vyz = zi * frcy
            vzz = zi * frcz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vxy
            vir(3,1) = vir(3,1) + vxz
            vir(1,2) = vir(1,2) + vxy
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vyz
            vir(1,3) = vir(1,3) + vxz
            vir(2,3) = vir(2,3) + vyz
            vir(3,3) = vir(3,3) + vzz
         end do
!$OMP    END DO
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      deallocate (tem)
      deallocate (pot)
      deallocate (decfx)
      deallocate (decfy)
      deallocate (decfz)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine empole1c  --  Ewald multipole derivs via loop  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "empole1c" calculates the multipole energy and derivatives
c     with respect to Cartesian coordinates using particle mesh
c     Ewald summation and a double loop
c
c
      subroutine empole1c
      use atoms
      use boxes
      use chgpot
      use deriv
      use energi
      use ewald
      use math
      use mpole
      use pme
      use potent
      use virial
      implicit none
      integer i,j,ii
      real*8 e,f,sum
      real*8 term,fterm
      real*8 cii,dii,qii
      real*8 xi,yi,zi
      real*8 xd,yd,zd
      real*8 xq,yq,zq
      real*8 xv,yv,zv,vterm
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 xdfield,ydfield
      real*8 zdfield
      real*8 fx,fy,fz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 tem(3),frcx(3)
      real*8 frcy(3),frcz(3)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
c
c
c     zero out the atomic multipole energy and derivatives
c
      em = 0.0d0
      do i = 1, n
         do j = 1, 3
            dem(j,i) = 0.0d0
         end do
      end do
      if (npole .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     compute the real space part of the Ewald summation
c
      call emreal1c
c
c     compute the reciprocal space part of the Ewald summation
c
      call emrecip1
c
c     perform dynamic allocation of some local arrays
c
      allocate (pot(n))
      allocate (decfx(n))
      allocate (decfy(n))
      allocate (decfz(n))
c
c     initialize Ewald self-energy potential array
c
      do i = 1, n
         pot(i) = 0.0d0
      end do
c
c     compute the Ewald self-energy term over all the atoms
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / rootpi
      do ii = 1, npole
         i = ipole(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         cii = ci*ci
         dii = dix*dix + diy*diy + diz*diz
         qii = 2.0d0*(qixy*qixy+qixz*qixz+qiyz*qiyz)
     &            + qixx*qixx + qiyy*qiyy + qizz*qizz
         e = fterm * (cii + term*(dii/3.0d0+2.0d0*term*qii/5.0d0))
         em = em + e
         pot(i) = 2.0d0 * fterm * ci
      end do
c
c     modify gradient and virial for charge flux self-energy
c
      if (use_chgflx) then
         call dcflux (pot,decfx,decfy,decfz)
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            fx = decfx(i)
            fy = decfy(i)
            fz = decfz(i)
            dem(1,i) = dem(1,i) + fx
            dem(2,i) = dem(2,i) + fy
            dem(3,i) = dem(3,i) + fz
            vxx = xi * fx
            vxy = yi * fx
            vxz = zi * fx
            vyy = yi * fy
            vyz = zi * fy
            vzz = zi * fz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vxy
            vir(3,1) = vir(3,1) + vxz
            vir(1,2) = vir(1,2) + vxy
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vyz
            vir(1,3) = vir(1,3) + vxz
            vir(2,3) = vir(2,3) + vyz
            vir(3,3) = vir(3,3) + vzz
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (pot)
      deallocate (decfx)
      deallocate (decfy)
      deallocate (decfz)
c
c     compute the uniform background charge correction term
c
      fterm = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         sum = sum + rpole(1,i)
      end do
      e = fterm * sum**2
      em = em + e
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            xd = xd + rpole(2,i) + rpole(1,i)*x(i)
            yd = yd + rpole(3,i) + rpole(1,i)*y(i)
            zd = zd + rpole(4,i) + rpole(1,i)*z(i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         em = em + term*(xd*xd+yd*yd+zd*zd)
         do ii = 1, npole
            i = ipole(ii)
            dem(1,i) = dem(1,i) + 2.0d0*term*rpole(1,i)*xd
            dem(2,i) = dem(2,i) + 2.0d0*term*rpole(1,i)*yd
            dem(3,i) = dem(3,i) + 2.0d0*term*rpole(1,i)*zd
         end do
         xdfield = -2.0d0 * term * xd
         ydfield = -2.0d0 * term * yd
         zdfield = -2.0d0 * term * zd
         do ii = 1, npole
            i = ipole(ii)
            tem(1) = rpole(3,i)*zdfield - rpole(4,i)*ydfield
            tem(2) = rpole(4,i)*xdfield - rpole(2,i)*zdfield
            tem(3) = rpole(2,i)*ydfield - rpole(3,i)*xdfield
            call torque (i,tem,frcx,frcy,frcz,dem)
         end do
c
c     boundary correction to virial due to overall cell dipole
c
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         xq = 0.0d0
         yq = 0.0d0
         zq = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            xd = xd + rpole(2,i)
            yd = yd + rpole(3,i)
            zd = zd + rpole(4,i)
            xq = xq + rpole(1,i)*x(i)
            yq = yq + rpole(1,i)*y(i)
            zq = zq + rpole(1,i)*z(i)
         end do
         xv = xd * xq
         yv = yd * yq
         zv = zd * zq
         vterm = term * (xd*xd + yd*yd + zd*zd + 2.0d0*(xv+yv+zv)
     &                      + xq*xq + yq*yq + zq*zq)
         vxx = 2.0d0*term*(xq*xq+xv) + vterm
         vxy = 2.0d0*term*(xq*yq+xv)
         vxz = 2.0d0*term*(xq*zq+xv)
         vyy = 2.0d0*term*(yq*yq+yv) + vterm
         vyz = 2.0d0*term*(yq*zq+yv)
         vzz = 2.0d0*term*(zq*zq+zv) + vterm
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine emreal1c  --  Ewald real mpole derivs via loop  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "emreal1c" evaluates the real space portion of the Ewald
c     summation energy and gradient due to multipole interactions
c     via a double loop
c
c
      subroutine emreal1c
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use deriv
      use energi
      use math
      use mplpot
      use mpole
      use potent
      use shunt
      use virial
      implicit none
      integer i,j,k
      integer ii,kk,jcell
      integer ix,iy,iz
      real*8 e,de,f
      real*8 scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9,rr11
      real*8 rr1i,rr3i,rr5i,rr7i
      real*8 rr1k,rr3k,rr5k,rr7k
      real*8 rr1ik,rr3ik,rr5ik
      real*8 rr7ik,rr9ik,rr11ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 dirx,diry,dirz
      real*8 dkrx,dkry,dkrz
      real*8 dikx,diky,dikz
      real*8 qirx,qiry,qirz
      real*8 qkrx,qkry,qkrz
      real*8 qikx,qiky,qikz
      real*8 qixk,qiyk,qizk
      real*8 qkxi,qkyi,qkzi
      real*8 qikrx,qikry,qikrz
      real*8 qkirx,qkiry,qkirz
      real*8 diqkx,diqky,diqkz
      real*8 dkqix,dkqiy,dkqiz
      real*8 diqkrx,diqkry,diqkrz
      real*8 dkqirx,dkqiry,dkqirz
      real*8 dqikx,dqiky,dqikz
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5,term6
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 poti,potk
      real*8 frcx,frcy,frcz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 ttmi(3),ttmk(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(11),dmpe(11)
      real*8, allocatable :: mscale(:)
      real*8, allocatable :: tem(:,:)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
      allocate (tem(3,n))
      allocate (pot(n))
      allocate (decfx(n))
      allocate (decfy(n))
      allocate (decfz(n))
c
c     initialize scaling, torque and potential arrays
c
      do i = 1, n
         mscale(i) = 1.0d0
         do j = 1, 3
            tem(j,i) = 0.0d0
         end do
         pot(i) = 0.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               dik = dix*dkx + diy*dky + diz*dkz
               qik = qix*qkx + qiy*qky + qiz*qkz
               diqk = dix*qkx + diy*qky + diz*qkz
               dkqi = dkx*qix + dky*qiy + dkz*qiz
               qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                   + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
               dirx = diy*zr - diz*yr
               diry = diz*xr - dix*zr
               dirz = dix*yr - diy*xr
               dkrx = dky*zr - dkz*yr
               dkry = dkz*xr - dkx*zr
               dkrz = dkx*yr - dky*xr
               dikx = diy*dkz - diz*dky
               diky = diz*dkx - dix*dkz
               dikz = dix*dky - diy*dkx
               qirx = qiz*yr - qiy*zr
               qiry = qix*zr - qiz*xr
               qirz = qiy*xr - qix*yr
               qkrx = qkz*yr - qky*zr
               qkry = qkx*zr - qkz*xr
               qkrz = qky*xr - qkx*yr
               qikx = qky*qiz - qkz*qiy
               qiky = qkz*qix - qkx*qiz
               qikz = qkx*qiy - qky*qix
               qixk = qixx*qkx + qixy*qky + qixz*qkz
               qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
               qizk = qixz*qkx + qiyz*qky + qizz*qkz
               qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
               qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
               qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
               qikrx = qizk*yr - qiyk*zr
               qikry = qixk*zr - qizk*xr
               qikrz = qiyk*xr - qixk*yr
               qkirx = qkzi*yr - qkyi*zr
               qkiry = qkxi*zr - qkzi*xr
               qkirz = qkyi*xr - qkxi*yr
               diqkx = dix*qkxx + diy*qkxy + diz*qkxz
               diqky = dix*qkxy + diy*qkyy + diz*qkyz
               diqkz = dix*qkxz + diy*qkyz + diz*qkzz
               dkqix = dkx*qixx + dky*qixy + dkz*qixz
               dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
               dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
               diqkrx = diqkz*yr - diqky*zr
               diqkry = diqkx*zr - diqkz*xr
               diqkrz = diqky*xr - diqkx*yr
               dkqirx = dkqiz*yr - dkqiy*zr
               dkqiry = dkqix*zr - dkqiz*xr
               dkqirz = dkqiy*xr - dkqix*yr
               dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                 - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                         -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
               dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                 - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                         -qixx*qkxz-qixy*qkyz-qixz*qkzz)
               dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                 - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                         -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
               rr11 = 9.0d0 * rr9 / r2
c
c     calculate real space Ewald error function damping
c
               call dampewald (11,r,r2,f,dmpe)
c
c     find damped multipole intermediates and energy value
c
               if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  term1 = corei*corek
                  term1i = corek*vali
                  term2i = corek*dir
                  term3i = corek*qir
                  term1k = corei*valk
                  term2k = -corei*dkr
                  term3k = corei*qkr
                  term1ik = vali*valk
                  term2ik = valk*dir - vali*dkr + dik
                  term3ik = vali*qkr + valk*qir - dir*dkr
     &                         + 2.0d0*(dkqi-diqk+qiqk)
                  term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                  term5ik = qir*qkr
                  call damppole (r,11,alphai,alphak,
     &                            dmpi,dmpk,dmpik)
                  scalek = mscale(k)
                  rr1i = dmpe(1) - (1.0d0-scalek*dmpi(1))*rr1
                  rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                  rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7
                  rr1k = dmpe(1) - (1.0d0-scalek*dmpk(1))*rr1
                  rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                  rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7
                  rr1ik = dmpe(1) - (1.0d0-scalek*dmpik(1))*rr1
                  rr3ik = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                  rr5ik = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                  rr7ik = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                  rr9ik = dmpe(9) - (1.0d0-scalek*dmpik(9))*rr9
                  rr11ik = dmpe(11) - (1.0d0-scalek*dmpik(11))*rr11
                  rr1 = dmpe(1) - (1.0d0-scalek)*rr1
                  rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                  e = term1*rr1 + term4ik*rr7ik + term5ik*rr9ik
     &                   + term1i*rr1i + term1k*rr1k + term1ik*rr1ik
     &                   + term2i*rr3i + term2k*rr3k + term2ik*rr3ik
     &                   + term3i*rr5i + term3k*rr5k + term3ik*rr5ik
c
c     find damped multipole intermediates for force and torque
c
                  de = term1*rr3 + term4ik*rr9ik + term5ik*rr11ik
     &                    + term1i*rr3i + term1k*rr3k + term1ik*rr3ik
     &                    + term2i*rr5i + term2k*rr5k + term2ik*rr5ik
     &                    + term3i*rr7i + term3k*rr7k + term3ik*rr7ik
                  term1 = -corek*rr3i - valk*rr3ik
     &                       + dkr*rr5ik - qkr*rr7ik
                  term2 = corei*rr3k + vali*rr3ik
     &                       + dir*rr5ik + qir*rr7ik
                  term3 = 2.0d0 * rr5ik
                  term4 = -2.0d0 * (corek*rr5i+valk*rr5ik
     &                                -dkr*rr7ik+qkr*rr9ik)
                  term5 = -2.0d0 * (corei*rr5k+vali*rr5ik
     &                                +dir*rr7ik+qir*rr9ik)
                  term6 = 4.0d0 * rr7ik
c
c     find standard multipole intermediates and energy value
c
               else
                  term1 = ci*ck
                  term2 = ck*dir - ci*dkr + dik
                  term3 = ci*qkr + ck*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  scalek = 1.0d0 - mscale(k)
                  rr1 = dmpe(1) - scalek*rr1
                  rr3 = dmpe(3) - scalek*rr3
                  rr5 = dmpe(5) - scalek*rr5
                  rr7 = dmpe(7) - scalek*rr7
                  rr9 = dmpe(9) - scalek*rr9
                  rr11 = dmpe(11) - scalek*rr11
                  e = term1*rr1 + term2*rr3 + term3*rr5
     &                   + term4*rr7 + term5*rr9
c
c     find standard multipole intermediates for force and torque
c
                  de = term1*rr3 + term2*rr5 + term3*rr7
     &                    + term4*rr9 + term5*rr11
                  term1 = -ck*rr3 + dkr*rr5 - qkr*rr7
                  term2 = ci*rr3 + dir*rr5 + qir*rr7
                  term3 = 2.0d0 * rr5
                  term4 = -2.0d0 * (ck*rr5-dkr*rr7+qkr*rr9)
                  term5 = -2.0d0 * (ci*rr5+dir*rr7+qir*rr9)
                  term6 = 4.0d0 * rr7
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_chgpen) then
                     term1i = corek*rr1i + valk*rr1ik
                     term1k = corei*rr1k + vali*rr1ik
                     term2i = -dkr * rr3ik
                     term2k = dir * rr3ik
                     term3i = qkr * rr5ik
                     term3k = qir * rr5ik
                     poti = term1i + term2i + term3i
                     potk = term1k + term2k + term3k
                  else
                     poti = ck*rr1 - dkr*rr3 + qkr*rr5
                     potk = ci*rr1 + dir*rr3 + qir*rr5
                  end if
                  pot(i) = pot(i) + poti
                  pot(k) = pot(k) + potk
               end if 
c
c     compute the force components for this interaction
c
               frcx = de*xr + term1*dix + term2*dkx
     &                   + term3*(diqkx-dkqix) + term4*qix
     &                   + term5*qkx + term6*(qixk+qkxi)
               frcy = de*yr + term1*diy + term2*dky
     &                   + term3*(diqky-dkqiy) + term4*qiy
     &                   + term5*qky + term6*(qiyk+qkyi)
               frcz = de*zr + term1*diz + term2*dkz
     &                   + term3*(diqkz-dkqiz) + term4*qiz
     &                   + term5*qkz + term6*(qizk+qkzi)
c
c     compute the torque components for this interaction
c
               if (use_chgpen)  rr3 = rr3ik
               ttmi(1) = -rr3*dikx + term1*dirx
     &                      + term3*(dqikx+dkqirx)
     &                      - term4*qirx - term6*(qikrx+qikx)
               ttmi(2) = -rr3*diky + term1*diry
     &                      + term3*(dqiky+dkqiry)
     &                      - term4*qiry - term6*(qikry+qiky)
               ttmi(3) = -rr3*dikz + term1*dirz
     &                      + term3*(dqikz+dkqirz)
     &                      - term4*qirz - term6*(qikrz+qikz)
               ttmk(1) = rr3*dikx + term2*dkrx
     &                      - term3*(dqikx+diqkrx)
     &                      - term5*qkrx - term6*(qkirx-qikx)
               ttmk(2) = rr3*diky + term2*dkry
     &                      - term3*(dqiky+diqkry)
     &                      - term5*qkry - term6*(qkiry-qiky)
               ttmk(3) = rr3*dikz + term2*dkrz
     &                      - term3*(dqikz+diqkrz)
     &                      - term5*qkrz - term6*(qkirz-qikz)
c
c     increment the overall atomic multipole energy component
c
               em = em + e
c
c     increment force-based gradient and torque on first site
c
               dem(1,i) = dem(1,i) + frcx
               dem(2,i) = dem(2,i) + frcy
               dem(3,i) = dem(3,i) + frcz
               tem(1,i) = tem(1,i) + ttmi(1)
               tem(2,i) = tem(2,i) + ttmi(2)
               tem(3,i) = tem(3,i) + ttmi(3)
c
c     increment force-based gradient and torque on second site
c
               dem(1,k) = dem(1,k) - frcx
               dem(2,k) = dem(2,k) - frcy
               dem(3,k) = dem(3,k) - frcz
               tem(1,k) = tem(1,k) + ttmk(1)
               tem(2,k) = tem(2,k) + ttmk(2)
               tem(3,k) = tem(3,k) + ttmk(3)
c
c     increment the virial due to pairwise Cartesian forces
c
               vxx = -xr * frcx
               vxy = -0.5d0 * (yr*frcx+xr*frcy)
               vxz = -0.5d0 * (zr*frcx+xr*frcz)
               vyy = -yr * frcy
               vyz = -0.5d0 * (zr*frcy+yr*frcz)
               vzz = -zr * frcz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction with other unit cells
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii, npole
            k = ipole(kk)
            do jcell = 2, ncell
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            call imager (xr,yr,zr,jcell)
            r2 = xr*xr + yr*yr + zr*zr
            if (.not. (use_polymer .and. r2.le.polycut2)) then
               mscale(k) = 1.0d0
            end if
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               dik = dix*dkx + diy*dky + diz*dkz
               qik = qix*qkx + qiy*qky + qiz*qkz
               diqk = dix*qkx + diy*qky + diz*qkz
               dkqi = dkx*qix + dky*qiy + dkz*qiz
               qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                   + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
               dirx = diy*zr - diz*yr
               diry = diz*xr - dix*zr
               dirz = dix*yr - diy*xr
               dkrx = dky*zr - dkz*yr
               dkry = dkz*xr - dkx*zr
               dkrz = dkx*yr - dky*xr
               dikx = diy*dkz - diz*dky
               diky = diz*dkx - dix*dkz
               dikz = dix*dky - diy*dkx
               qirx = qiz*yr - qiy*zr
               qiry = qix*zr - qiz*xr
               qirz = qiy*xr - qix*yr
               qkrx = qkz*yr - qky*zr
               qkry = qkx*zr - qkz*xr
               qkrz = qky*xr - qkx*yr
               qikx = qky*qiz - qkz*qiy
               qiky = qkz*qix - qkx*qiz
               qikz = qkx*qiy - qky*qix
               qixk = qixx*qkx + qixy*qky + qixz*qkz
               qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
               qizk = qixz*qkx + qiyz*qky + qizz*qkz
               qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
               qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
               qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
               qikrx = qizk*yr - qiyk*zr
               qikry = qixk*zr - qizk*xr
               qikrz = qiyk*xr - qixk*yr
               qkirx = qkzi*yr - qkyi*zr
               qkiry = qkxi*zr - qkzi*xr
               qkirz = qkyi*xr - qkxi*yr
               diqkx = dix*qkxx + diy*qkxy + diz*qkxz
               diqky = dix*qkxy + diy*qkyy + diz*qkyz
               diqkz = dix*qkxz + diy*qkyz + diz*qkzz
               dkqix = dkx*qixx + dky*qixy + dkz*qixz
               dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
               dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
               diqkrx = diqkz*yr - diqky*zr
               diqkry = diqkx*zr - diqkz*xr
               diqkrz = diqky*xr - diqkx*yr
               dkqirx = dkqiz*yr - dkqiy*zr
               dkqiry = dkqix*zr - dkqiz*xr
               dkqirz = dkqiy*xr - dkqix*yr
               dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                 - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                         -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
               dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                 - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                         -qixx*qkxz-qixy*qkyz-qixz*qkzz)
               dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                 - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                         -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
               rr11 = 9.0d0 * rr9 / r2
c
c     calculate real space Ewald error function damping
c
               call dampewald (11,r,r2,f,dmpe)
c
c     find damped multipole intermediates and energy value
c
               if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  term1 = corei*corek
                  term1i = corek*vali
                  term2i = corek*dir
                  term3i = corek*qir
                  term1k = corei*valk
                  term2k = -corei*dkr
                  term3k = corei*qkr
                  term1ik = vali*valk
                  term2ik = valk*dir - vali*dkr + dik
                  term3ik = vali*qkr + valk*qir - dir*dkr
     &                         + 2.0d0*(dkqi-diqk+qiqk)
                  term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                  term5ik = qir*qkr
                  call damppole (r,11,alphai,alphak,
     &                            dmpi,dmpk,dmpik)
                  scalek = mscale(k)
                  rr1i = dmpe(1) - (1.0d0-scalek*dmpi(1))*rr1
                  rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                  rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7
                  rr1k = dmpe(1) - (1.0d0-scalek*dmpk(1))*rr1
                  rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                  rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7
                  rr1ik = dmpe(1) - (1.0d0-scalek*dmpik(1))*rr1
                  rr3ik = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                  rr5ik = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                  rr7ik = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                  rr9ik = dmpe(9) - (1.0d0-scalek*dmpik(9))*rr9
                  rr11ik = dmpe(11) - (1.0d0-scalek*dmpik(11))*rr11
                  rr1 = dmpe(1) - (1.0d0-scalek)*rr1
                  rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                  e = term1*rr1 + term4ik*rr7ik + term5ik*rr9ik
     &                   + term1i*rr1i + term1k*rr1k + term1ik*rr1ik
     &                   + term2i*rr3i + term2k*rr3k + term2ik*rr3ik
     &                   + term3i*rr5i + term3k*rr5k + term3ik*rr5ik
c
c     find damped multipole intermediates for force and torque
c
                  de = term1*rr3 + term4ik*rr9ik + term5ik*rr11ik
     &                    + term1i*rr3i + term1k*rr3k + term1ik*rr3ik
     &                    + term2i*rr5i + term2k*rr5k + term2ik*rr5ik
     &                    + term3i*rr7i + term3k*rr7k + term3ik*rr7ik
                  term1 = -corek*rr3i - valk*rr3ik
     &                       + dkr*rr5ik - qkr*rr7ik
                  term2 = corei*rr3k + vali*rr3ik
     &                       + dir*rr5ik + qir*rr7ik
                  term3 = 2.0d0 * rr5ik
                  term4 = -2.0d0 * (corek*rr5i+valk*rr5ik
     &                                -dkr*rr7ik+qkr*rr9ik)
                  term5 = -2.0d0 * (corei*rr5k+vali*rr5ik
     &                                +dir*rr7ik+qir*rr9ik)
                  term6 = 4.0d0 * rr7ik
c
c     find standard multipole intermediates and energy value
c
               else
                  term1 = ci*ck
                  term2 = ck*dir - ci*dkr + dik
                  term3 = ci*qkr + ck*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  scalek = 1.0d0 - mscale(k)
                  rr1 = dmpe(1) - scalek*rr1
                  rr3 = dmpe(3) - scalek*rr3
                  rr5 = dmpe(5) - scalek*rr5
                  rr7 = dmpe(7) - scalek*rr7
                  rr9 = dmpe(9) - scalek*rr9
                  rr11 = dmpe(11) - scalek*rr11
                  e = term1*rr1 + term2*rr3 + term3*rr5
     &                   + term4*rr7 + term5*rr9
c
c     find standard multipole intermediates for force and torque
c
                  de = term1*rr3 + term2*rr5 + term3*rr7
     &                    + term4*rr9 + term5*rr11
                  term1 = -ck*rr3 + dkr*rr5 - qkr*rr7
                  term2 = ci*rr3 + dir*rr5 + qir*rr7
                  term3 = 2.0d0 * rr5
                  term4 = -2.0d0 * (ck*rr5-dkr*rr7+qkr*rr9)
                  term5 = -2.0d0 * (ci*rr5+dir*rr7+qir*rr9)
                  term6 = 4.0d0 * rr7
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_chgpen) then
                     term1i = corek*rr1i + valk*rr1ik
                     term1k = corei*rr1k + vali*rr1ik
                     term2i = -dkr * rr3ik
                     term2k = dir * rr3ik
                     term3i = qkr * rr5ik
                     term3k = qir * rr5ik
                     poti = term1i + term2i + term3i
                     potk = term1k + term2k + term3k
                  else
                     poti = ck*rr1 - dkr*rr3 + qkr*rr5
                     potk = ci*rr1 + dir*rr3 + qir*rr5
                  end if
                  pot(i) = pot(i) + poti
                  pot(k) = pot(k) + potk
               end if 
c
c     compute the force components for this interaction
c
               frcx = de*xr + term1*dix + term2*dkx
     &                   + term3*(diqkx-dkqix) + term4*qix
     &                   + term5*qkx + term6*(qixk+qkxi)
               frcy = de*yr + term1*diy + term2*dky
     &                   + term3*(diqky-dkqiy) + term4*qiy
     &                   + term5*qky + term6*(qiyk+qkyi)
               frcz = de*zr + term1*diz + term2*dkz
     &                   + term3*(diqkz-dkqiz) + term4*qiz
     &                   + term5*qkz + term6*(qizk+qkzi)
c
c     compute the torque components for this interaction
c
               if (use_chgpen)  rr3 = rr3ik
               ttmi(1) = -rr3*dikx + term1*dirx
     &                      + term3*(dqikx+dkqirx)
     &                      - term4*qirx - term6*(qikrx+qikx)
               ttmi(2) = -rr3*diky + term1*diry
     &                      + term3*(dqiky+dkqiry)
     &                      - term4*qiry - term6*(qikry+qiky)
               ttmi(3) = -rr3*dikz + term1*dirz
     &                      + term3*(dqikz+dkqirz)
     &                      - term4*qirz - term6*(qikrz+qikz)
               ttmk(1) = rr3*dikx + term2*dkrx
     &                      - term3*(dqikx+diqkrx)
     &                      - term5*qkrx - term6*(qkirx-qikx)
               ttmk(2) = rr3*diky + term2*dkry
     &                      - term3*(dqiky+diqkry)
     &                      - term5*qkry - term6*(qkiry-qiky)
               ttmk(3) = rr3*dikz + term2*dkrz
     &                      - term3*(dqikz+diqkrz)
     &                      - term5*qkrz - term6*(qkirz-qikz)
c
c     energy, force and torque scaled for self-interactions
c
               if (i .eq. k) then
                  e = 0.5d0 * e
                  frcx = 0.5d0 * frcx
                  frcy = 0.5d0 * frcy
                  frcz = 0.5d0 * frcz
                  do j = 1, 3
                     ttmi(j) = 0.5d0 * ttmi(j)
                     ttmk(j) = 0.5d0 * ttmk(j)
                  end do
               end if
c
c     increment the overall atomic multipole energy component
c
               em = em + e
c
c     increment force-based gradient and torque on first site
c
               dem(1,i) = dem(1,i) + frcx
               dem(2,i) = dem(2,i) + frcy
               dem(3,i) = dem(3,i) + frcz
               tem(1,i) = tem(1,i) + ttmi(1)
               tem(2,i) = tem(2,i) + ttmi(2)
               tem(3,i) = tem(3,i) + ttmi(3)
c
c     increment force-based gradient and torque on second site
c
               dem(1,k) = dem(1,k) - frcx
               dem(2,k) = dem(2,k) - frcy
               dem(3,k) = dem(3,k) - frcz
               tem(1,k) = tem(1,k) + ttmk(1)
               tem(2,k) = tem(2,k) + ttmk(2)
               tem(3,k) = tem(3,k) + ttmk(3)
c
c     increment the virial due to pairwise Cartesian forces
c
               vxx = -xr * frcx
               vxy = -0.5d0 * (yr*frcx+xr*frcy)
               vxz = -0.5d0 * (zr*frcx+xr*frcz)
               vyy = -yr * frcy
               vyz = -0.5d0 * (zr*frcy+yr*frcz)
               vzz = -zr * frcz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
            end do
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
      end if
c
c     resolve site torques then increment forces and virial
c
      do ii = 1, npole
         i = ipole(ii)
         call torque (i,tem(1,i),fix,fiy,fiz,dem)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     modify the gradient and virial for charge flux
c
      if (use_chgflx) then
         call dcflux (pot,decfx,decfy,decfz)
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            frcx = decfx(i)
            frcy = decfy(i)
            frcz = decfz(i)
            dem(1,i) = dem(1,i) + frcx
            dem(2,i) = dem(2,i) + frcy
            dem(3,i) = dem(3,i) + frcz
            vxx = xi * frcx
            vxy = yi * frcx
            vxz = zi * frcx
            vyy = yi * frcy
            vyz = zi * frcy
            vzz = zi * frcz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vxy
            vir(3,1) = vir(3,1) + vxz
            vir(1,2) = vir(1,2) + vxy
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vyz
            vir(1,3) = vir(1,3) + vxz
            vir(2,3) = vir(2,3) + vyz
            vir(3,3) = vir(3,3) + vzz
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      deallocate (tem)
      deallocate (pot)
      deallocate (decfx)
      deallocate (decfy)
      deallocate (decfz)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine empole1d  --  Ewald multipole derivs via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "empole1d" calculates the multipole energy and derivatives
c     with respect to Cartesian coordinates using particle mesh Ewald
c     summation and a neighbor list
c
c
      subroutine empole1d
      use atoms
      use boxes
      use chgpot
      use deriv
      use energi
      use ewald
      use math
      use mpole
      use pme
      use potent
      use virial
      implicit none
      integer i,j,ii
      real*8 e,f,sum
      real*8 term,fterm
      real*8 cii,dii,qii
      real*8 xi,yi,zi
      real*8 xd,yd,zd
      real*8 xq,yq,zq
      real*8 xv,yv,zv,vterm
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 xdfield,ydfield
      real*8 zdfield
      real*8 fx,fy,fz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 tem(3),frcx(3)
      real*8 frcy(3),frcz(3)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
c
c
c     zero out the atomic multipole energy and derivatives
c
      em = 0.0d0
      do i = 1, n
         do j = 1, 3
            dem(j,i) = 0.0d0
         end do
      end do
      if (npole .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     compute the real space part of the Ewald summation
c
      call emreal1d
c
c     compute the reciprocal space part of the Ewald summation
c
      call emrecip1
c
c     perform dynamic allocation of some local arrays
c
      allocate (pot(n))
      allocate (decfx(n))
      allocate (decfy(n))
      allocate (decfz(n))
c
c     initialize Ewald self-energy potential array
c
      do i = 1, n
         pot(i) = 0.0d0
      end do
c
c     compute the Ewald self-energy term over all the atoms
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / rootpi
      do ii = 1, npole
         i = ipole(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         cii = ci*ci
         dii = dix*dix + diy*diy + diz*diz
         qii = 2.0d0*(qixy*qixy+qixz*qixz+qiyz*qiyz)
     &            + qixx*qixx + qiyy*qiyy + qizz*qizz
         e = fterm * (cii + term*(dii/3.0d0+2.0d0*term*qii/5.0d0))
         em = em + e
         pot(i) = 2.0d0 * fterm * ci
      end do
c
c     modify gradient and virial for charge flux self-energy
c
      if (use_chgflx) then
         call dcflux (pot,decfx,decfy,decfz)
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            fx = decfx(i)
            fy = decfy(i)
            fz = decfz(i)
            dem(1,i) = dem(1,i) + fx
            dem(2,i) = dem(2,i) + fy
            dem(3,i) = dem(3,i) + fz
            vxx = xi * fx
            vxy = yi * fx
            vxz = zi * fx
            vyy = yi * fy
            vyz = zi * fy
            vzz = zi * fz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vxy
            vir(3,1) = vir(3,1) + vxz
            vir(1,2) = vir(1,2) + vxy
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vyz
            vir(1,3) = vir(1,3) + vxz
            vir(2,3) = vir(2,3) + vyz
            vir(3,3) = vir(3,3) + vzz
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (pot)
      deallocate (decfx)
      deallocate (decfy)
      deallocate (decfz)
c
c     compute the uniform background charge correction term
c
      fterm = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         sum = sum + rpole(1,i)
      end do
      e = fterm * sum**2
      em = em + e
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            xd = xd + rpole(2,i) + rpole(1,i)*x(i)
            yd = yd + rpole(3,i) + rpole(1,i)*y(i)
            zd = zd + rpole(4,i) + rpole(1,i)*z(i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         em = em + term*(xd*xd+yd*yd+zd*zd)
         do ii = 1, npole
            i = ipole(ii)
            dem(1,i) = dem(1,i) + 2.0d0*term*rpole(1,i)*xd
            dem(2,i) = dem(2,i) + 2.0d0*term*rpole(1,i)*yd
            dem(3,i) = dem(3,i) + 2.0d0*term*rpole(1,i)*zd
         end do
         xdfield = -2.0d0 * term * xd
         ydfield = -2.0d0 * term * yd
         zdfield = -2.0d0 * term * zd
         do ii = 1, npole
            i = ipole(ii)
            tem(1) = rpole(3,i)*zdfield - rpole(4,i)*ydfield
            tem(2) = rpole(4,i)*xdfield - rpole(2,i)*zdfield
            tem(3) = rpole(2,i)*ydfield - rpole(3,i)*xdfield
            call torque (i,tem,frcx,frcy,frcz,dem)
         end do
c
c     boundary correction to virial due to overall cell dipole
c
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         xq = 0.0d0
         yq = 0.0d0
         zq = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            xd = xd + rpole(2,i)
            yd = yd + rpole(3,i)
            zd = zd + rpole(4,i)
            xq = xq + rpole(1,i)*x(i)
            yq = yq + rpole(1,i)*y(i)
            zq = zq + rpole(1,i)*z(i)
         end do
         xv = xd * xq
         yv = yd * yq
         zv = zd * zq
         vterm = term * (xd*xd + yd*yd + zd*zd + 2.0d0*(xv+yv+zv)
     &                      + xq*xq + yq*yq + zq*zq)
         vxx = 2.0d0*term*(xq*xq+xv) + vterm
         vxy = 2.0d0*term*(xq*yq+xv)
         vxz = 2.0d0*term*(xq*zq+xv)
         vyy = 2.0d0*term*(yq*yq+yv) + vterm
         vyz = 2.0d0*term*(yq*zq+yv)
         vzz = 2.0d0*term*(zq*zq+zv) + vterm
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine emreal1d  --  Ewald real mpole derivs via list  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "emreal1d" evaluates the real space portion of the Ewald
c     summation energy and gradient due to multipole interactions
c     via a neighbor list
c
c
      subroutine emreal1d
      use atoms
      use bound
      use chgpen
      use chgpot
      use couple
      use deriv
      use energi
      use math
      use mplpot
      use mpole
      use neigh
      use potent
      use shunt
      use virial
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      integer ix,iy,iz
      real*8 e,de,f
      real*8 scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9,rr11
      real*8 rr1i,rr3i,rr5i,rr7i
      real*8 rr1k,rr3k,rr5k,rr7k
      real*8 rr1ik,rr3ik,rr5ik
      real*8 rr7ik,rr9ik,rr11ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 dirx,diry,dirz
      real*8 dkrx,dkry,dkrz
      real*8 dikx,diky,dikz
      real*8 qirx,qiry,qirz
      real*8 qkrx,qkry,qkrz
      real*8 qikx,qiky,qikz
      real*8 qixk,qiyk,qizk
      real*8 qkxi,qkyi,qkzi
      real*8 qikrx,qikry,qikrz
      real*8 qkirx,qkiry,qkirz
      real*8 diqkx,diqky,diqkz
      real*8 dkqix,dkqiy,dkqiz
      real*8 diqkrx,diqkry,diqkrz
      real*8 dkqirx,dkqiry,dkqirz
      real*8 dqikx,dqiky,dqikz
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5,term6
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 poti,potk
      real*8 frcx,frcy,frcz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 ttmi(3),ttmk(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(11),dmpe(11)
      real*8, allocatable :: mscale(:)
      real*8, allocatable :: tem(:,:)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
      allocate (tem(3,n))
      allocate (pot(n))
      allocate (decfx(n))
      allocate (decfy(n))
      allocate (decfz(n))
c
c     initialize scaling, torque and potential arrays
c
      do i = 1, n
         mscale(i) = 1.0d0
         do j = 1, 3
            tem(j,i) = 0.0d0
         end do
         pot(i) = 0.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,x,y,z,rpole,pcore,pval,palpha,n12,i12,
!$OMP& n13,i13,n14,i14,n15,i15,m2scale,m3scale,m4scale,m5scale,
!$OMP& nelst,elst,use_chgpen,use_chgflx,use_bounds,f,off2,xaxis,
!$OMP& yaxis,zaxis)
!$OMP& firstprivate(mscale) shared (em,dem,tem,pot,vir)
!$OMP DO reduction(+:em,dem,tem,pot,vir)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               dik = dix*dkx + diy*dky + diz*dkz
               qik = qix*qkx + qiy*qky + qiz*qkz
               diqk = dix*qkx + diy*qky + diz*qkz
               dkqi = dkx*qix + dky*qiy + dkz*qiz
               qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                   + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
               dirx = diy*zr - diz*yr
               diry = diz*xr - dix*zr
               dirz = dix*yr - diy*xr
               dkrx = dky*zr - dkz*yr
               dkry = dkz*xr - dkx*zr
               dkrz = dkx*yr - dky*xr
               dikx = diy*dkz - diz*dky
               diky = diz*dkx - dix*dkz
               dikz = dix*dky - diy*dkx
               qirx = qiz*yr - qiy*zr
               qiry = qix*zr - qiz*xr
               qirz = qiy*xr - qix*yr
               qkrx = qkz*yr - qky*zr
               qkry = qkx*zr - qkz*xr
               qkrz = qky*xr - qkx*yr
               qikx = qky*qiz - qkz*qiy
               qiky = qkz*qix - qkx*qiz
               qikz = qkx*qiy - qky*qix
               qixk = qixx*qkx + qixy*qky + qixz*qkz
               qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
               qizk = qixz*qkx + qiyz*qky + qizz*qkz
               qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
               qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
               qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
               qikrx = qizk*yr - qiyk*zr
               qikry = qixk*zr - qizk*xr
               qikrz = qiyk*xr - qixk*yr
               qkirx = qkzi*yr - qkyi*zr
               qkiry = qkxi*zr - qkzi*xr
               qkirz = qkyi*xr - qkxi*yr
               diqkx = dix*qkxx + diy*qkxy + diz*qkxz
               diqky = dix*qkxy + diy*qkyy + diz*qkyz
               diqkz = dix*qkxz + diy*qkyz + diz*qkzz
               dkqix = dkx*qixx + dky*qixy + dkz*qixz
               dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
               dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
               diqkrx = diqkz*yr - diqky*zr
               diqkry = diqkx*zr - diqkz*xr
               diqkrz = diqky*xr - diqkx*yr
               dkqirx = dkqiz*yr - dkqiy*zr
               dkqiry = dkqix*zr - dkqiz*xr
               dkqirz = dkqiy*xr - dkqix*yr
               dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                 - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                         -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
               dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                 - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                         -qixx*qkxz-qixy*qkyz-qixz*qkzz)
               dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                 - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                         -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
               rr11 = 9.0d0 * rr9 / r2
c
c     calculate real space Ewald error function damping
c
               call dampewald (11,r,r2,f,dmpe)
c
c     find damped multipole intermediates and energy value
c
               if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  term1 = corei*corek
                  term1i = corek*vali
                  term2i = corek*dir
                  term3i = corek*qir
                  term1k = corei*valk
                  term2k = -corei*dkr
                  term3k = corei*qkr
                  term1ik = vali*valk
                  term2ik = valk*dir - vali*dkr + dik
                  term3ik = vali*qkr + valk*qir - dir*dkr
     &                         + 2.0d0*(dkqi-diqk+qiqk)
                  term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                  term5ik = qir*qkr
                  call damppole (r,11,alphai,alphak,
     &                            dmpi,dmpk,dmpik)
                  scalek = mscale(k)
                  rr1i = dmpe(1) - (1.0d0-scalek*dmpi(1))*rr1
                  rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                  rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7
                  rr1k = dmpe(1) - (1.0d0-scalek*dmpk(1))*rr1
                  rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                  rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7
                  rr1ik = dmpe(1) - (1.0d0-scalek*dmpik(1))*rr1
                  rr3ik = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                  rr5ik = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                  rr7ik = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                  rr9ik = dmpe(9) - (1.0d0-scalek*dmpik(9))*rr9
                  rr11ik = dmpe(11) - (1.0d0-scalek*dmpik(11))*rr11
                  rr1 = dmpe(1) - (1.0d0-scalek)*rr1
                  rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                  e = term1*rr1 + term4ik*rr7ik + term5ik*rr9ik
     &                   + term1i*rr1i + term1k*rr1k + term1ik*rr1ik
     &                   + term2i*rr3i + term2k*rr3k + term2ik*rr3ik
     &                   + term3i*rr5i + term3k*rr5k + term3ik*rr5ik
c
c     find damped multipole intermediates for force and torque
c
                  de = term1*rr3 + term4ik*rr9ik + term5ik*rr11ik
     &                    + term1i*rr3i + term1k*rr3k + term1ik*rr3ik
     &                    + term2i*rr5i + term2k*rr5k + term2ik*rr5ik
     &                    + term3i*rr7i + term3k*rr7k + term3ik*rr7ik
                  term1 = -corek*rr3i - valk*rr3ik
     &                       + dkr*rr5ik - qkr*rr7ik
                  term2 = corei*rr3k + vali*rr3ik
     &                       + dir*rr5ik + qir*rr7ik
                  term3 = 2.0d0 * rr5ik
                  term4 = -2.0d0 * (corek*rr5i+valk*rr5ik
     &                                -dkr*rr7ik+qkr*rr9ik)
                  term5 = -2.0d0 * (corei*rr5k+vali*rr5ik
     &                                +dir*rr7ik+qir*rr9ik)
                  term6 = 4.0d0 * rr7ik
c
c     find standard multipole intermediates and energy value
c
               else
                  term1 = ci*ck
                  term2 = ck*dir - ci*dkr + dik
                  term3 = ci*qkr + ck*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  scalek = 1.0d0 - mscale(k)
                  rr1 = dmpe(1) - scalek*rr1
                  rr3 = dmpe(3) - scalek*rr3
                  rr5 = dmpe(5) - scalek*rr5
                  rr7 = dmpe(7) - scalek*rr7
                  rr9 = dmpe(9) - scalek*rr9
                  rr11 = dmpe(11) - scalek*rr11
                  e = term1*rr1 + term2*rr3 + term3*rr5
     &                   + term4*rr7 + term5*rr9
c
c     find standard multipole intermediates for force and torque
c
                  de = term1*rr3 + term2*rr5 + term3*rr7
     &                    + term4*rr9 + term5*rr11
                  term1 = -ck*rr3 + dkr*rr5 - qkr*rr7
                  term2 = ci*rr3 + dir*rr5 + qir*rr7
                  term3 = 2.0d0 * rr5
                  term4 = -2.0d0 * (ck*rr5-dkr*rr7+qkr*rr9)
                  term5 = -2.0d0 * (ci*rr5+dir*rr7+qir*rr9)
                  term6 = 4.0d0 * rr7
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_chgpen) then
                     term1i = corek*rr1i + valk*rr1ik
                     term1k = corei*rr1k + vali*rr1ik
                     term2i = -dkr * rr3ik
                     term2k = dir * rr3ik
                     term3i = qkr * rr5ik
                     term3k = qir * rr5ik
                     poti = term1i + term2i + term3i
                     potk = term1k + term2k + term3k
                  else
                     poti = ck*rr1 - dkr*rr3 + qkr*rr5
                     potk = ci*rr1 + dir*rr3 + qir*rr5
                  end if
                  pot(i) = pot(i) + poti
                  pot(k) = pot(k) + potk
               end if 
c
c     compute the force components for this interaction
c
               frcx = de*xr + term1*dix + term2*dkx
     &                   + term3*(diqkx-dkqix) + term4*qix
     &                   + term5*qkx + term6*(qixk+qkxi)
               frcy = de*yr + term1*diy + term2*dky
     &                   + term3*(diqky-dkqiy) + term4*qiy
     &                   + term5*qky + term6*(qiyk+qkyi)
               frcz = de*zr + term1*diz + term2*dkz
     &                   + term3*(diqkz-dkqiz) + term4*qiz
     &                   + term5*qkz + term6*(qizk+qkzi)
c
c     compute the torque components for this interaction
c
               if (use_chgpen)  rr3 = rr3ik
               ttmi(1) = -rr3*dikx + term1*dirx
     &                      + term3*(dqikx+dkqirx)
     &                      - term4*qirx - term6*(qikrx+qikx)
               ttmi(2) = -rr3*diky + term1*diry
     &                      + term3*(dqiky+dkqiry)
     &                      - term4*qiry - term6*(qikry+qiky)
               ttmi(3) = -rr3*dikz + term1*dirz
     &                      + term3*(dqikz+dkqirz)
     &                      - term4*qirz - term6*(qikrz+qikz)
               ttmk(1) = rr3*dikx + term2*dkrx
     &                      - term3*(dqikx+diqkrx)
     &                      - term5*qkrx - term6*(qkirx-qikx)
               ttmk(2) = rr3*diky + term2*dkry
     &                      - term3*(dqiky+diqkry)
     &                      - term5*qkry - term6*(qkiry-qiky)
               ttmk(3) = rr3*dikz + term2*dkrz
     &                      - term3*(dqikz+diqkrz)
     &                      - term5*qkrz - term6*(qkirz-qikz)
c
c     increment the overall atomic multipole energy component
c
               em = em + e
c
c     increment force-based gradient and torque on first site
c
               dem(1,i) = dem(1,i) + frcx
               dem(2,i) = dem(2,i) + frcy
               dem(3,i) = dem(3,i) + frcz
               tem(1,i) = tem(1,i) + ttmi(1)
               tem(2,i) = tem(2,i) + ttmi(2)
               tem(3,i) = tem(3,i) + ttmi(3)
c
c     increment force-based gradient and torque on second site
c
               dem(1,k) = dem(1,k) - frcx
               dem(2,k) = dem(2,k) - frcy
               dem(3,k) = dem(3,k) - frcz
               tem(1,k) = tem(1,k) + ttmk(1)
               tem(2,k) = tem(2,k) + ttmk(2)
               tem(3,k) = tem(3,k) + ttmk(3)
c
c     increment the virial due to pairwise Cartesian forces
c
               vxx = -xr * frcx
               vxy = -0.5d0 * (yr*frcx+xr*frcy)
               vxz = -0.5d0 * (zr*frcx+xr*frcz)
               vyy = -yr * frcy
               vyz = -0.5d0 * (zr*frcy+yr*frcz)
               vzz = -zr * frcz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP DO reduction(+:dem,vir)
c
c     resolve site torques then increment forces and virial
c
      do ii = 1, npole
         i = ipole(ii)
         call torque (i,tem(1,i),fix,fiy,fiz,dem)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
c
c     modify the gradient and virial for charge flux
c
      if (use_chgflx) then
         call dcflux (pot,decfx,decfy,decfz)
!$OMP    DO reduction(+:dem,vir)
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            frcx = decfx(i)
            frcy = decfy(i)
            frcz = decfz(i)
            dem(1,i) = dem(1,i) + frcx
            dem(2,i) = dem(2,i) + frcy
            dem(3,i) = dem(3,i) + frcz
            vxx = xi * frcx
            vxy = yi * frcx
            vxz = zi * frcx
            vyy = yi * frcy
            vyz = zi * frcy
            vzz = zi * frcz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vxy
            vir(3,1) = vir(3,1) + vxz
            vir(1,2) = vir(1,2) + vxy
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vyz
            vir(1,3) = vir(1,3) + vxz
            vir(2,3) = vir(2,3) + vyz
            vir(3,3) = vir(3,3) + vzz
         end do
!$OMP    END DO
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      deallocate (tem)
      deallocate (pot)
      deallocate (decfx)
      deallocate (decfy)
      deallocate (decfz)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine emrecip1  --  PME recip mpole energy & derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "emrecip1" evaluates the reciprocal space portion of particle
c     mesh Ewald summation energy and gradient due to multipoles
c
c     literature references:
c
c     C. Sagui, L. G. Pedersen and T. A. Darden, "Towards an Accurate
c     Representation of Electrostatics in Classical Force Fields:
c     Efficient Implementation of Multipolar Interactions in
c     Biomolecular Simulations", Journal of Chemical Physics, 120,
c     73-87 (2004)
c
c     W. Smith and D. Fincham, "The Ewald Sum in Truncated Octahedral
c     and Rhombic Dodecahedral Boundary Conditions", Molecular
c     Simulation, 10, 67-71 (1993)
c
c     modifications for nonperiodic systems suggested by Tom Darden
c     during May 2007
c
c
      subroutine emrecip1
      use atoms
      use bound
      use boxes
      use chgpot
      use deriv
      use energi
      use ewald
      use math
      use mpole
      use mrecip
      use pme
      use potent
      use virial
      implicit none
      integer i,j,k,ii
      integer k1,k2,k3
      integer m1,m2,m3
      integer ix,iy,iz
      integer ntot,nff
      integer nf1,nf2,nf3
      integer deriv1(10)
      integer deriv2(10)
      integer deriv3(10)
      real*8 e,eterm,f
      real*8 r1,r2,r3
      real*8 h1,h2,h3
      real*8 f1,f2,f3
      real*8 xi,yi,zi
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 frcx,frcy,frcz
      real*8 volterm,denom
      real*8 hsq,expterm
      real*8 term,pterm
      real*8 vterm,struc2
      real*8 tem(3),fix(3)
      real*8 fiy(3),fiz(3)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
c
c     indices into the electrostatic field array
c
      data deriv1  / 2, 5,  8,  9, 11, 16, 18, 14, 15, 20 /
      data deriv2  / 3, 8,  6, 10, 14, 12, 19, 16, 20, 17 /
      data deriv3  / 4, 9, 10,  7, 15, 17, 13, 20, 18, 19 /
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      f = electric / dielec
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(cmp)) then
         if (size(cmp) .lt. 10*n)  deallocate (cmp)
      end if
      if (allocated(fmp)) then
         if (size(fmp) .lt. 10*n)  deallocate (fmp)
      end if
      if (allocated(cphi)) then
         if (size(cphi) .lt. 10*n)  deallocate (cphi)
      end if
      if (allocated(fphi)) then
         if (size(fphi) .lt. 20*n)  deallocate (fphi)
      end if
      if (.not. allocated(cmp))  allocate (cmp(10,n))
      if (.not. allocated(fmp))  allocate (fmp(10,n))
      if (.not. allocated(cphi))  allocate (cphi(10,n))
      if (.not. allocated(fphi))  allocate (fphi(20,n))
c
c     perform dynamic allocation of some global arrays
c
      ntot = nfft1 * nfft2 * nfft3
      if (allocated(qgrid)) then
         if (size(qgrid) .ne. 2*ntot)  call fftclose
      end if
      if (.not. allocated(qgrid))  call fftsetup
c
c     setup spatial decomposition and B-spline coefficients
c
      call getchunk
      call moduli
      call bspline_fill
      call table_fill
c
c     copy multipole moments and coordinates to local storage
c
      do ii = 1, npole
         i = ipole(ii)
         cmp(1,i) = rpole(1,i)
         cmp(2,i) = rpole(2,i)
         cmp(3,i) = rpole(3,i)
         cmp(4,i) = rpole(4,i)
         cmp(5,i) = rpole(5,i)
         cmp(6,i) = rpole(9,i)
         cmp(7,i) = rpole(13,i)
         cmp(8,i) = 2.0d0 * rpole(6,i)
         cmp(9,i) = 2.0d0 * rpole(7,i)
         cmp(10,i) = 2.0d0 * rpole(10,i)
      end do
c
c     convert Cartesian multipoles to fractional coordinates
c
      call cmp_to_fmp (cmp,fmp)
c
c     assign PME grid and perform 3-D FFT forward transform
c
      call grid_mpole (fmp)
      call fftfront
c
c     zero out the temporary virial accumulation variables
c
      vxx = 0.0d0
      vxy = 0.0d0
      vxz = 0.0d0
      vyy = 0.0d0
      vyz = 0.0d0
      vzz = 0.0d0
c
c     make the scalar summation over reciprocal lattice
c
      pterm = (pi/aewald)**2
      volterm = pi * volbox
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      nff = nfft1 * nfft2
      ntot = nff * nfft3
      do i = 1, ntot-1
         k3 = i/nff + 1
         j = i - (k3-1)*nff
         k2 = j/nfft1 + 1
         k1 = j - (k2-1)*nfft1 + 1
         m1 = k1 - 1
         m2 = k2 - 1
         m3 = k3 - 1
         if (k1 .gt. nf1)  m1 = m1 - nfft1
         if (k2 .gt. nf2)  m2 = m2 - nfft2
         if (k3 .gt. nf3)  m3 = m3 - nfft3
         r1 = dble(m1)
         r2 = dble(m2)
         r3 = dble(m3)
         h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
         h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
         h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
         hsq = h1*h1 + h2*h2 + h3*h3
         term = -pterm * hsq
         expterm = 0.0d0
         if (term .gt. -50.0d0) then
            denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
            expterm = exp(term) / denom
            if (.not. use_bounds) then
               expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
            else if (nonprism) then
               if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
            end if
            struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2
            eterm = 0.5d0 * f * expterm * struc2
            vterm = (2.0d0/hsq) * (1.0d0-term) * eterm
            vxx = vxx + h1*h1*vterm - eterm
            vxy = vxy + h1*h2*vterm
            vxz = vxz + h1*h3*vterm
            vyy = vyy + h2*h2*vterm - eterm
            vyz = vyz + h2*h3*vterm
            vzz = vzz + h3*h3*vterm - eterm
         end if
         qgrid(1,k1,k2,k3) = expterm * qgrid(1,k1,k2,k3)
         qgrid(2,k1,k2,k3) = expterm * qgrid(2,k1,k2,k3)
      end do
c
c     save the partial virial for the polarization computation
c
      vmxx = vxx
      vmxy = vxy
      vmxz = vxz
      vmyy = vyy
      vmyz = vyz
      vmzz = vzz
c
c     account for zeroth grid point for nonperiodic system
c
      qgrid(1,1,1,1) = 0.0d0
      qgrid(2,1,1,1) = 0.0d0
      if (.not. use_bounds) then
         expterm = 0.5d0 * pi / xbox
         qgrid(1,1,1,1) = expterm * qgrid(1,1,1,1)
         qgrid(2,1,1,1) = expterm * qgrid(2,1,1,1)
      end if
c
c     perform 3-D FFT backward transform and get potential
c
      call fftback
      call fphi_mpole (fphi)
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 20
            fphi(j,i) = f * fphi(j,i)
         end do
      end do
      call fphi_to_cphi (fphi,cphi)
c
c     increment the permanent multipole energy and gradient
c
      e = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         f1 = 0.0d0
         f2 = 0.0d0
         f3 = 0.0d0
         do k = 1, 10
            e = e + fmp(k,i)*fphi(k,i)
            f1 = f1 + fmp(k,i)*fphi(deriv1(k),i)
            f2 = f2 + fmp(k,i)*fphi(deriv2(k),i)
            f3 = f3 + fmp(k,i)*fphi(deriv3(k),i)
         end do
         f1 = dble(nfft1) * f1
         f2 = dble(nfft2) * f2
         f3 = dble(nfft3) * f3
         h1 = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3
         h2 = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3
         h3 = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3
         dem(1,i) = dem(1,i) + h1
         dem(2,i) = dem(2,i) + h2
         dem(3,i) = dem(3,i) + h3
      end do
      e = 0.5d0 * e
      em = em + e
c
c     increment the permanent multipole virial contributions
c
      do ii = 1, npole
         i = ipole(ii)
         vxx = vxx - cmp(2,i)*cphi(2,i) - 2.0d0*cmp(5,i)*cphi(5,i)
     &            - cmp(8,i)*cphi(8,i) - cmp(9,i)*cphi(9,i)
         vxy = vxy - 0.5d0*(cmp(3,i)*cphi(2,i)+cmp(2,i)*cphi(3,i))
     &            - (cmp(5,i)+cmp(6,i))*cphi(8,i)
     &            - 0.5d0*cmp(8,i)*(cphi(5,i)+cphi(6,i))
     &            - 0.5d0*(cmp(9,i)*cphi(10,i)+cmp(10,i)*cphi(9,i))
         vxz = vxz - 0.5d0*(cmp(4,i)*cphi(2,i)+cmp(2,i)*cphi(4,i))
     &            - (cmp(5,i)+cmp(7,i))*cphi(9,i)
     &            - 0.5d0*cmp(9,i)*(cphi(5,i)+cphi(7,i))
     &            - 0.5d0*(cmp(8,i)*cphi(10,i)+cmp(10,i)*cphi(8,i))
         vyy = vyy - cmp(3,i)*cphi(3,i) - 2.0d0*cmp(6,i)*cphi(6,i)
     &            - cmp(8,i)*cphi(8,i) - cmp(10,i)*cphi(10,i)
         vyz = vyz - 0.5d0*(cmp(4,i)*cphi(3,i)+cmp(3,i)*cphi(4,i))
     &            - (cmp(6,i)+cmp(7,i))*cphi(10,i)
     &            - 0.5d0*cmp(10,i)*(cphi(6,i)+cphi(7,i))
     &            - 0.5d0*(cmp(8,i)*cphi(9,i)+cmp(9,i)*cphi(8,i))
         vzz = vzz - cmp(4,i)*cphi(4,i) - 2.0d0*cmp(7,i)*cphi(7,i)
     &            - cmp(9,i)*cphi(9,i) - cmp(10,i)*cphi(10,i)
      end do
c
c     resolve site torques then increment forces and virial
c
      do ii = 1, npole
         i = ipole(ii)
         tem(1) = cmp(4,i)*cphi(3,i) - cmp(3,i)*cphi(4,i)
     &               + 2.0d0*(cmp(7,i)-cmp(6,i))*cphi(10,i)
     &               + cmp(9,i)*cphi(8,i) + cmp(10,i)*cphi(6,i)
     &               - cmp(8,i)*cphi(9,i) - cmp(10,i)*cphi(7,i)
         tem(2) = cmp(2,i)*cphi(4,i) - cmp(4,i)*cphi(2,i)
     &               + 2.0d0*(cmp(5,i)-cmp(7,i))*cphi(9,i)
     &               + cmp(8,i)*cphi(10,i) + cmp(9,i)*cphi(7,i)
     &               - cmp(9,i)*cphi(5,i) - cmp(10,i)*cphi(8,i)
         tem(3) = cmp(3,i)*cphi(2,i) - cmp(2,i)*cphi(3,i)
     &               + 2.0d0*(cmp(6,i)-cmp(5,i))*cphi(8,i)
     &               + cmp(8,i)*cphi(5,i) + cmp(10,i)*cphi(9,i)
     &               - cmp(8,i)*cphi(6,i) - cmp(9,i)*cphi(10,i)
         call torque (i,tem,fix,fiy,fiz,dem)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = ii
         if (ix .eq. 0)  ix = ii
         if (iy .eq. 0)  iy = ii
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = vxx + xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = vxy + 0.5d0*(yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                        + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = vxz + 0.5d0*(zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                        + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 
         vyy = vyy + yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = vyz + 0.5d0*(zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                        + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = vzz + zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
      end do
c
c     perform dynamic allocation of some local arrays
c
      if (use_chgflx) then
         allocate (pot(n))
         allocate (decfx(n))
         allocate (decfy(n))
         allocate (decfz(n))
c
c     modify the gradient and virial for charge flux
c
         do i = 1, n
            pot(i) = 0.0d0
         end do
         do ii = 1, npole
            i = ipole(ii)
            pot(i) = cphi(1,i)
         end do
         call dcflux (pot,decfx,decfy,decfz)
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            frcx = decfx(i)
            frcy = decfy(i)
            frcz = decfz(i)
            dem(1,i) = dem(1,i) + frcx
            dem(2,i) = dem(2,i) + frcy
            dem(3,i) = dem(3,i) + frcz
            vxx = vxx + xi*frcx
            vxy = vxy + yi*frcx
            vxz = vxz + zi*frcx
            vyy = vyy + yi*frcy
            vyz = vyz + zi*frcy
            vzz = vzz + zi*frcz
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (pot)
         deallocate (decfx)
         deallocate (decfy)
         deallocate (decfz)
      end if
c
c     increment the total internal virial tensor components
c
      vir(1,1) = vir(1,1) + vxx
      vir(2,1) = vir(2,1) + vxy
      vir(3,1) = vir(3,1) + vxz
      vir(1,2) = vir(1,2) + vxy
      vir(2,2) = vir(2,2) + vyy
      vir(3,2) = vir(3,2) + vyz
      vir(1,3) = vir(1,3) + vxz
      vir(2,3) = vir(2,3) + vyz
      vir(3,3) = vir(3,3) + vzz
      return
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 1999 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine empole2  --  atomic multipole Hessian elements  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "empole2" calculates second derivatives of the multipole energy
c     for a single atom at a time
c
c
      subroutine empole2 (i)
      use atoms
      use deriv
      use energi
      use hessn
      use mpole
      use potent
      implicit none
      integer i,j,k,kk
      integer nlist
      integer, allocatable :: list(:)
      real*8 eps,old
      real*8, allocatable :: d0(:,:)
      logical prior
      logical twosided
c
c
c     set the default stepsize and accuracy control flags
c
      eps = 1.0d-5
      twosided = .false.
      if (n .le. 300)  twosided = .true.
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
      allocate (d0(3,n))
c
c     perform dynamic allocation of some global arrays
c
      prior = .false.
      if (allocated(dem)) then
         prior = .true.
         if (size(dem) .lt. 3*n)  deallocate (dem)
      end if
      if (.not. allocated(dem))  allocate (dem(3,n))
c
c     find the multipole definitions involving the current atom
c
      nlist = 0
      do kk = 1, npole
         k = ipole(kk)
         if (k.eq.i .or. zaxis(k).eq.i .or. xaxis(k).eq.i
     &          .or. abs(yaxis(k)).eq.i) then
            nlist = nlist + 1
            list(nlist) = k
         end if
      end do
c
c     get multipole first derivatives for the base structure
c
      if (.not. twosided) then
         call empole2a (nlist,list)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = dem(j,k)
            end do
         end do
      end if
c
c     find numerical x-components via perturbed structures
c
      old = x(i)
      if (twosided) then
         x(i) = x(i) - 0.5d0*eps
         call empole2a (nlist,list)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = dem(j,k)
            end do
         end do
      end if
      x(i) = x(i) + eps
      call empole2a (nlist,list)
      x(i) = old
      do k = 1, n
         do j = 1, 3
            hessx(j,k) = hessx(j,k) + (dem(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical y-components via perturbed structures
c
      old = y(i)
      if (twosided) then
         y(i) = y(i) - 0.5d0*eps
         call empole2a (nlist,list)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = dem(j,k)
            end do
         end do
      end if
      y(i) = y(i) + eps
      call empole2a (nlist,list)
      y(i) = old
      do k = 1, n
         do j = 1, 3
            hessy(j,k) = hessy(j,k) + (dem(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical z-components via perturbed structures
c
      old = z(i)
      if (twosided) then
         z(i) = z(i) - 0.5d0*eps
         call empole2a (nlist,list)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = dem(j,k)
            end do
         end do
      end if
      z(i) = z(i) + eps
      call empole2a (nlist,list)
      z(i) = old
      do k = 1, n
         do j = 1, 3
            hessz(j,k) = hessz(j,k) + (dem(j,k)-d0(j,k))/eps
         end do
      end do
c
c     perform deallocation of some global arrays
c
      if (.not. prior)  deallocate (dem)
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (d0)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine empole2a  --  multipole derivatives utility  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "empole2a" computes multipole first derivatives for a single
c     atom; used to get finite difference second derivatives
c
c
      subroutine empole2a (nlist,list)
      use atoms
      use bound
      use boxes
      use cell
      use chgpen
      use chgpot
      use couple
      use deriv
      use group
      use limits
      use molcul
      use mplpot
      use mpole
      use potent
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk,iii
      integer nlist,jcell
      integer ix,iy,iz
      integer kx,ky,kz
      integer list(*)
      real*8 de,f,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9,rr11
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 rr3ik,rr5ik,rr7ik
      real*8 rr9ik,rr11ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 dirx,diry,dirz
      real*8 dkrx,dkry,dkrz
      real*8 dikx,diky,dikz
      real*8 qirx,qiry,qirz
      real*8 qkrx,qkry,qkrz
      real*8 qikx,qiky,qikz
      real*8 qixk,qiyk,qizk
      real*8 qkxi,qkyi,qkzi
      real*8 qikrx,qikry,qikrz
      real*8 qkirx,qkiry,qkirz
      real*8 diqkx,diqky,diqkz
      real*8 dkqix,dkqiy,dkqiz
      real*8 diqkrx,diqkry,diqkrz
      real*8 dkqirx,dkqiry,dkqirz
      real*8 dqikx,dqiky,dqikz
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5,term6
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 poti,potk
      real*8 frcx,frcy,frcz
      real*8 ttmi(3),ttmk(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(11)
      real*8, allocatable :: mscale(:)
      real*8, allocatable :: tem(:,:)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
      logical proceed
      logical usei,usek
      character*6 mode
c
c
c     zero out the multipole first derivative components
c
      do i = 1, n
         do j = 1, 3
            dem(j,i) = 0.0d0
         end do
      end do
      if (nlist .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
      allocate (tem(3,n))
      allocate (pot(n))
      allocate (decfx(n))
      allocate (decfy(n))
      allocate (decfz(n))
c
c     initialize scaling, torque and potential arrays
c
      do i = 1, n
         mscale(i) = 1.0d0
         do j = 1, 3
            tem(j,i) = 0.0d0
         end do
         pot(i) = 0.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     alter partial charges and multipoles for charge flux
c
      if (use_chgflx)  call alterchg
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     compute components of the multipole interaction gradient
c
      do iii = 1, nlist
         ii = list(iii)
         i = ipole(ii)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, npole
            if (kk .eq. ii)  goto 10
            k = ipole(kk)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
            if (.not. proceed)  goto 10
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               dik = dix*dkx + diy*dky + diz*dkz
               qik = qix*qkx + qiy*qky + qiz*qkz
               diqk = dix*qkx + diy*qky + diz*qkz
               dkqi = dkx*qix + dky*qiy + dkz*qiz
               qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                   + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
               dirx = diy*zr - diz*yr
               diry = diz*xr - dix*zr
               dirz = dix*yr - diy*xr
               dkrx = dky*zr - dkz*yr
               dkry = dkz*xr - dkx*zr
               dkrz = dkx*yr - dky*xr
               dikx = diy*dkz - diz*dky
               diky = diz*dkx - dix*dkz
               dikz = dix*dky - diy*dkx
               qirx = qiz*yr - qiy*zr
               qiry = qix*zr - qiz*xr
               qirz = qiy*xr - qix*yr
               qkrx = qkz*yr - qky*zr
               qkry = qkx*zr - qkz*xr
               qkrz = qky*xr - qkx*yr
               qikx = qky*qiz - qkz*qiy
               qiky = qkz*qix - qkx*qiz
               qikz = qkx*qiy - qky*qix
               qixk = qixx*qkx + qixy*qky + qixz*qkz
               qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
               qizk = qixz*qkx + qiyz*qky + qizz*qkz
               qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
               qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
               qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
               qikrx = qizk*yr - qiyk*zr
               qikry = qixk*zr - qizk*xr
               qikrz = qiyk*xr - qixk*yr
               qkirx = qkzi*yr - qkyi*zr
               qkiry = qkxi*zr - qkzi*xr
               qkirz = qkyi*xr - qkxi*yr
               diqkx = dix*qkxx + diy*qkxy + diz*qkxz
               diqky = dix*qkxy + diy*qkyy + diz*qkyz
               diqkz = dix*qkxz + diy*qkyz + diz*qkzz
               dkqix = dkx*qixx + dky*qixy + dkz*qixz
               dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
               dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
               diqkrx = diqkz*yr - diqky*zr
               diqkry = diqkx*zr - diqkz*xr
               diqkrz = diqky*xr - diqkx*yr
               dkqirx = dkqiz*yr - dkqiy*zr
               dkqiry = dkqix*zr - dkqiz*xr
               dkqirz = dkqiy*xr - dkqix*yr
               dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                 - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                         -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
               dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                 - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                         -qixx*qkxz-qixy*qkyz-qixz*qkzz)
               dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                 - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                         -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f * mscale(k) / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
               rr11 = 9.0d0 * rr9 / r2
c
c     find damped multipole intermediates for force and torque
c
               if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  term1 = corei*corek
                  term1i = corek*vali
                  term2i = corek*dir
                  term3i = corek*qir
                  term1k = corei*valk
                  term2k = -corei*dkr
                  term3k = corei*qkr
                  term1ik = vali*valk
                  term2ik = valk*dir - vali*dkr + dik
                  term3ik = vali*qkr + valk*qir - dir*dkr
     &                         + 2.0d0*(dkqi-diqk+qiqk)
                  term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                  term5ik = qir*qkr
                  call damppole (r,11,alphai,alphak,
     &                            dmpi,dmpk,dmpik)
                  rr3i = dmpi(3)*rr3
                  rr5i = dmpi(5)*rr5
                  rr7i = dmpi(7)*rr7
                  rr3k = dmpk(3)*rr3
                  rr5k = dmpk(5)*rr5
                  rr7k = dmpk(7)*rr7
                  rr3ik = dmpik(3)*rr3
                  rr5ik = dmpik(5)*rr5
                  rr7ik = dmpik(7)*rr7
                  rr9ik = dmpik(9)*rr9
                  rr11ik = dmpik(11)*rr11
                  de = term1*rr3 + term4ik*rr9ik + term5ik*rr11ik
     &                    + term1i*rr3i + term1k*rr3k + term1ik*rr3ik
     &                    + term2i*rr5i + term2k*rr5k + term2ik*rr5ik
     &                    + term3i*rr7i + term3k*rr7k + term3ik*rr7ik
                  term1 = -corek*rr3i - valk*rr3ik
     &                       + dkr*rr5ik - qkr*rr7ik
                  term2 = corei*rr3k + vali*rr3ik
     &                       + dir*rr5ik + qir*rr7ik
                  term3 = 2.0d0 * rr5ik
                  term4 = -2.0d0 * (corek*rr5i+valk*rr5ik
     &                                -dkr*rr7ik+qkr*rr9ik)
                  term5 = -2.0d0 * (corei*rr5k+vali*rr5ik
     &                                +dir*rr7ik+qir*rr9ik)
                  term6 = 4.0d0 * rr7ik
c
c     find standard multipole intermediates for force and torque
c
               else
                  term1 = ci*ck
                  term2 = ck*dir - ci*dkr + dik
                  term3 = ci*qkr + ck*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  de = term1*rr3 + term2*rr5 + term3*rr7
     &                    + term4*rr9 + term5*rr11
                  term1 = -ck*rr3 + dkr*rr5 - qkr*rr7
                  term2 = ci*rr3 + dir*rr5 + qir*rr7
                  term3 = 2.0d0 * rr5
                  term4 = 2.0d0 * (-ck*rr5+dkr*rr7-qkr*rr9)
                  term5 = 2.0d0 * (-ci*rr5-dir*rr7-qir*rr9)
                  term6 = 4.0d0 * rr7
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_chgpen) then
                     term1i = corek*dmpi(1) + valk*dmpik(1) 
                     term1k = corei*dmpk(1) + vali*dmpik(1) 
                     term2i = -dkr * dmpik(3)
                     term2k = dir * dmpik(3)
                     term3i = qkr * dmpik(5)
                     term3k = qir * dmpik(5)
                     poti = term1i*rr1 + term2i*rr3 + term3i*rr5
                     potk = term1k*rr1 + term2k*rr3 + term3k*rr5
                  else
                     poti = ck*rr1 - dkr*rr3 + qkr*rr5
                     potk = ci*rr1 + dir*rr3 + qir*rr5
                  end if
                  pot(i) = pot(i) + poti
                  pot(k) = pot(k) + potk
               end if 
c
c     compute the force components for this interaction
c
               frcx = de*xr + term1*dix + term2*dkx
     &                   + term3*(diqkx-dkqix) + term4*qix
     &                   + term5*qkx + term6*(qixk+qkxi)
               frcy = de*yr + term1*diy + term2*dky
     &                   + term3*(diqky-dkqiy) + term4*qiy
     &                   + term5*qky + term6*(qiyk+qkyi)
               frcz = de*zr + term1*diz + term2*dkz
     &                   + term3*(diqkz-dkqiz) + term4*qiz
     &                   + term5*qkz + term6*(qizk+qkzi)
c
c     compute the torque components for this interaction
c
               if (use_chgpen)  rr3 = rr3ik
               ttmi(1) = -rr3*dikx + term1*dirx
     &                      + term3*(dqikx+dkqirx)
     &                      - term4*qirx - term6*(qikrx+qikx)
               ttmi(2) = -rr3*diky + term1*diry
     &                      + term3*(dqiky+dkqiry)
     &                      - term4*qiry - term6*(qikry+qiky)
               ttmi(3) = -rr3*dikz + term1*dirz
     &                      + term3*(dqikz+dkqirz)
     &                      - term4*qirz - term6*(qikrz+qikz)
               ttmk(1) = rr3*dikx + term2*dkrx
     &                      - term3*(dqikx+diqkrx)
     &                      - term5*qkrx - term6*(qkirx-qikx)
               ttmk(2) = rr3*diky + term2*dkry
     &                      - term3*(dqiky+diqkry)
     &                      - term5*qkry - term6*(qkiry-qiky)
               ttmk(3) = rr3*dikz + term2*dkrz
     &                      - term3*(dqikz+diqkrz)
     &                      - term5*qkrz - term6*(qkirz-qikz)
c
c     force and torque components scaled by group membership
c
               if (use_group) then
                  frcx = fgrp * frcx
                  frcy = fgrp * frcy
                  frcz = fgrp * frcz
                  do j = 1, 3
                     ttmi(j) = fgrp * ttmi(j)
                     ttmk(j) = fgrp * ttmk(j)
                  end do
               end if
c
c     increment force-based gradient and torque on first site
c
               dem(1,i) = dem(1,i) + frcx
               dem(2,i) = dem(2,i) + frcy
               dem(3,i) = dem(3,i) + frcz
               tem(1,i) = tem(1,i) + ttmi(1)
               tem(2,i) = tem(2,i) + ttmi(2)
               tem(3,i) = tem(3,i) + ttmi(3)
c
c     increment force-based gradient and torque on second site
c
               dem(1,k) = dem(1,k) - frcx
               dem(2,k) = dem(2,k) - frcy
               dem(3,k) = dem(3,k) - frcz
               tem(1,k) = tem(1,k) + ttmk(1)
               tem(2,k) = tem(2,k) + ttmk(2)
               tem(3,k) = tem(3,k) + ttmk(3)
            end if
   10       continue
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction with other unit cells
c
      do iii = 1, nlist
         ii = list(iii)
         i = ipole(ii)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, npole
            k = ipole(kk)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
            if (.not. proceed)  goto 20
            do jcell = 2, ncell
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            call imager (xr,yr,zr,jcell)
            r2 = xr*xr + yr*yr + zr*zr
            if (.not. (use_polymer .and. r2.le.polycut2)) then
               mscale(k) = 1.0d0
            end if
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               dik = dix*dkx + diy*dky + diz*dkz
               qik = qix*qkx + qiy*qky + qiz*qkz
               diqk = dix*qkx + diy*qky + diz*qkz
               dkqi = dkx*qix + dky*qiy + dkz*qiz
               qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                   + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
               dirx = diy*zr - diz*yr
               diry = diz*xr - dix*zr
               dirz = dix*yr - diy*xr
               dkrx = dky*zr - dkz*yr
               dkry = dkz*xr - dkx*zr
               dkrz = dkx*yr - dky*xr
               dikx = diy*dkz - diz*dky
               diky = diz*dkx - dix*dkz
               dikz = dix*dky - diy*dkx
               qirx = qiz*yr - qiy*zr
               qiry = qix*zr - qiz*xr
               qirz = qiy*xr - qix*yr
               qkrx = qkz*yr - qky*zr
               qkry = qkx*zr - qkz*xr
               qkrz = qky*xr - qkx*yr
               qikx = qky*qiz - qkz*qiy
               qiky = qkz*qix - qkx*qiz
               qikz = qkx*qiy - qky*qix
               qixk = qixx*qkx + qixy*qky + qixz*qkz
               qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
               qizk = qixz*qkx + qiyz*qky + qizz*qkz
               qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
               qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
               qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
               qikrx = qizk*yr - qiyk*zr
               qikry = qixk*zr - qizk*xr
               qikrz = qiyk*xr - qixk*yr
               qkirx = qkzi*yr - qkyi*zr
               qkiry = qkxi*zr - qkzi*xr
               qkirz = qkyi*xr - qkxi*yr
               diqkx = dix*qkxx + diy*qkxy + diz*qkxz
               diqky = dix*qkxy + diy*qkyy + diz*qkyz
               diqkz = dix*qkxz + diy*qkyz + diz*qkzz
               dkqix = dkx*qixx + dky*qixy + dkz*qixz
               dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
               dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
               diqkrx = diqkz*yr - diqky*zr
               diqkry = diqkx*zr - diqkz*xr
               diqkrz = diqky*xr - diqkx*yr
               dkqirx = dkqiz*yr - dkqiy*zr
               dkqiry = dkqix*zr - dkqiz*xr
               dkqirz = dkqiy*xr - dkqix*yr
               dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                 - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                         -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
               dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                 - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                         -qixx*qkxz-qixy*qkyz-qixz*qkzz)
               dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                 - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                         -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f * mscale(k) / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
               rr11 = 9.0d0 * rr9 / r2
c
c     find damped multipole intermediates for force and torque
c
               if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  term1 = corei*corek
                  term1i = corek*vali
                  term2i = corek*dir
                  term3i = corek*qir
                  term1k = corei*valk
                  term2k = -corei*dkr
                  term3k = corei*qkr
                  term1ik = vali*valk
                  term2ik = valk*dir - vali*dkr + dik
                  term3ik = vali*qkr + valk*qir - dir*dkr
     &                         + 2.0d0*(dkqi-diqk+qiqk)
                  term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                  term5ik = qir*qkr
                  call damppole (r,11,alphai,alphak,
     &                            dmpi,dmpk,dmpik)
                  rr3i = dmpi(3)*rr3
                  rr5i = dmpi(5)*rr5
                  rr7i = dmpi(7)*rr7
                  rr3k = dmpk(3)*rr3
                  rr5k = dmpk(5)*rr5
                  rr7k = dmpk(7)*rr7
                  rr3ik = dmpik(3)*rr3
                  rr5ik = dmpik(5)*rr5
                  rr7ik = dmpik(7)*rr7
                  rr9ik = dmpik(9)*rr9
                  rr11ik = dmpik(11)*rr11
                  de = term1*rr3 + term4ik*rr9ik + term5ik*rr11ik
     &                    + term1i*rr3i + term1k*rr3k + term1ik*rr3ik
     &                    + term2i*rr5i + term2k*rr5k + term2ik*rr5ik
     &                    + term3i*rr7i + term3k*rr7k + term3ik*rr7ik
                  term1 = -corek*rr3i - valk*rr3ik
     &                       + dkr*rr5ik - qkr*rr7ik
                  term2 = corei*rr3k + vali*rr3ik
     &                       + dir*rr5ik + qir*rr7ik
                  term3 = 2.0d0 * rr5ik
                  term4 = -2.0d0 * (corek*rr5i+valk*rr5ik
     &                                -dkr*rr7ik+qkr*rr9ik)
                  term5 = -2.0d0 * (corei*rr5k+vali*rr5ik
     &                                +dir*rr7ik+qir*rr9ik)
                  term6 = 4.0d0 * rr7ik
                  rr3 = rr3ik
c
c     find standard multipole intermediates for force and torque
c
               else
                  term1 = ci*ck
                  term2 = ck*dir - ci*dkr + dik
                  term3 = ci*qkr + ck*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  de = term1*rr3 + term2*rr5 + term3*rr7
     &                    + term4*rr9 + term5*rr11
                  term1 = -ck*rr3 + dkr*rr5 - qkr*rr7
                  term2 = ci*rr3 + dir*rr5 + qir*rr7
                  term3 = 2.0d0 * rr5
                  term4 = 2.0d0 * (-ck*rr5+dkr*rr7-qkr*rr9)
                  term5 = 2.0d0 * (-ci*rr5-dir*rr7-qir*rr9)
                  term6 = 4.0d0 * rr7
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_chgpen) then
                     term1i = corek*dmpi(1) + valk*dmpik(1) 
                     term1k = corei*dmpk(1) + vali*dmpik(1) 
                     term2i = -dkr * dmpik(3)
                     term2k = dir * dmpik(3)
                     term3i = qkr * dmpik(5)
                     term3k = qir * dmpik(5)
                     poti = term1i*rr1 + term2i*rr3 + term3i*rr5
                     potk = term1k*rr1 + term2k*rr3 + term3k*rr5
                  else
                     poti = ck*rr1 - dkr*rr3 + qkr*rr5
                     potk = ci*rr1 + dir*rr3 + qir*rr5
                  end if
                  pot(i) = pot(i) + poti
                  pot(k) = pot(k) + potk
               end if 
c
c     compute the force components for this interaction
c
               frcx = de*xr + term1*dix + term2*dkx
     &                   + term3*(diqkx-dkqix) + term4*qix
     &                   + term5*qkx + term6*(qixk+qkxi)
               frcy = de*yr + term1*diy + term2*dky
     &                   + term3*(diqky-dkqiy) + term4*qiy
     &                   + term5*qky + term6*(qiyk+qkyi)
               frcz = de*zr + term1*diz + term2*dkz
     &                   + term3*(diqkz-dkqiz) + term4*qiz
     &                   + term5*qkz + term6*(qizk+qkzi)
c
c     compute the torque components for this interaction
c
               ttmi(1) = -rr3*dikx + term1*dirx
     &                      + term3*(dqikx+dkqirx)
     &                      - term4*qirx - term6*(qikrx+qikx)
               ttmi(2) = -rr3*diky + term1*diry
     &                      + term3*(dqiky+dkqiry)
     &                      - term4*qiry - term6*(qikry+qiky)
               ttmi(3) = -rr3*dikz + term1*dirz
     &                      + term3*(dqikz+dkqirz)
     &                      - term4*qirz - term6*(qikrz+qikz)
               ttmk(1) = rr3*dikx + term2*dkrx
     &                      - term3*(dqikx+diqkrx)
     &                      - term5*qkrx - term6*(qkirx-qikx)
               ttmk(2) = rr3*diky + term2*dkry
     &                      - term3*(dqiky+diqkry)
     &                      - term5*qkry - term6*(qkiry-qiky)
               ttmk(3) = rr3*dikz + term2*dkrz
     &                      - term3*(dqikz+diqkrz)
     &                      - term5*qkrz - term6*(qkirz-qikz)
c
c     force and torque scaled for self-interactions and groups
c
               if (i .eq. k) then
                  frcx = 0.5d0 * frcx
                  frcy = 0.5d0 * frcy
                  frcz = 0.5d0 * frcz
                  do j = 1, 3
                     ttmi(j) = 0.5d0 * ttmi(j)
                     ttmk(j) = 0.5d0 * ttmk(j)
                  end do
               end if
               if (use_group) then
                  frcx = fgrp * frcx
                  frcy = fgrp * frcy
                  frcz = fgrp * frcz
                  do j = 1, 3
                     ttmi(j) = fgrp * ttmi(j)
                     ttmk(j) = fgrp * ttmk(j)
                  end do
               end if
c
c     increment force-based gradient and torque on first site
c
               dem(1,i) = dem(1,i) + frcx
               dem(2,i) = dem(2,i) + frcy
               dem(3,i) = dem(3,i) + frcz
               tem(1,i) = tem(1,i) + ttmi(1)
               tem(2,i) = tem(2,i) + ttmi(2)
               tem(3,i) = tem(3,i) + ttmi(3)
c
c     increment force-based gradient and torque on second site
c
               dem(1,k) = dem(1,k) - frcx
               dem(2,k) = dem(2,k) - frcy
               dem(3,k) = dem(3,k) - frcz
               tem(1,k) = tem(1,k) + ttmk(1)
               tem(2,k) = tem(2,k) + ttmk(2)
               tem(3,k) = tem(3,k) + ttmk(3)
            end if
            end do
   20       continue
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
      end if
c
c     resolve site torques then increment multipole forces
c
      do ii = 1, npole
         i = ipole(ii)
         call torque (i,tem(1,i),fix,fiy,fiz,dem)
      end do
c
c     modify the gradient and virial for charge flux
c
      if (use_chgflx) then
         call dcflux (pot,decfx,decfy,decfz)
         do ii = 1, npole
            i = ipole(ii)
            frcx = decfx(i)
            frcy = decfy(i)
            frcz = decfz(i)
            dem(1,i) = dem(1,i) + frcx
            dem(2,i) = dem(2,i) + frcy
            dem(3,i) = dem(3,i) + frcz
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      deallocate (tem)
      deallocate (pot)
      deallocate (decfx)
      deallocate (decfy)
      deallocate (decfz)
      return
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 1999 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine empole3  --  atomic multipole energy & analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "empole3" calculates the electrostatic energy due to atomic
c     multipole interactions, and partitions the energy among atoms
c
c
      subroutine empole3
      use energi
      use extfld
      use inform
      use iounit
      use limits
      implicit none
      real*8 exf
      character*6 mode
c
c
c     choose the method to sum over multipole interactions
c
      if (use_ewald) then
         if (use_mlist) then
            call empole3d
         else
            call empole3c
         end if
      else
         if (use_mlist) then
            call empole3b
         else
            call empole3a
         end if
      end if
c
c     get contribution from external electric field if used
c
      if (use_exfld) then
         mode = 'MPOLE'
         call exfield3 (mode,exf)
         em = em + exf
         if (verbose .and. exf.ne.0.0d0) then
            if (digits .ge. 8) then
               write (iout,10)  exf
   10          format (/,' External Electric Field :',7x,f16.8)
            else if (digits .ge. 6) then
               write (iout,20)  exf
   20          format (/,' External Electric Field :',7x,f16.6)
            else
               write (iout,30)  exf
   30          format (/,' External Electric Field :',7x,f16.4)
            end if
         end if
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine empole3a  --  double loop multipole analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "empole3a" calculates the atomic multipole interaction energy
c     using a double loop, and partitions the energy among atoms
c
c
      subroutine empole3a
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use math
      use molcul
      use mplpot
      use mpole
      use potent
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer ix,iy,iz
      integer kx,ky,kz
      real*8 e,f,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 rr1i,rr3i,rr5i
      real*8 rr1k,rr3k,rr5k
      real*8 rr1ik,rr3ik,rr5ik
      real*8 rr7ik,rr9ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9)
      real*8, allocatable :: mscale(:)
      logical proceed
      logical header,huge
      logical usei,usek
      character*6 mode
c
c
c     zero out total atomic multipole energy and partitioning
c
      nem = 0
      em = 0.0d0
      do i = 1, n
         aem(i) = 0.0d0
      end do
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. npole.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Atomic Multipole Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     calculate the multipole interaction energy term
c
      do ii = 1, npole-1
         i = ipole(ii)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  ck = rpole(1,k)
                  dkx = rpole(2,k)
                  dky = rpole(3,k)
                  dkz = rpole(4,k)
                  qkxx = rpole(5,k)
                  qkxy = rpole(6,k)
                  qkxz = rpole(7,k)
                  qkyy = rpole(9,k)
                  qkyz = rpole(10,k)
                  qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
                  dir = dix*xr + diy*yr + diz*zr
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qir = qix*xr + qiy*yr + qiz*zr
                  dkr = dkx*xr + dky*yr + dkz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
                  qkr = qkx*xr + qky*yr + qkz*zr
                  dik = dix*dkx + diy*dky + diz*dkz
                  qik = qix*qkx + qiy*qky + qiz*qkz
                  diqk = dix*qkx + diy*qky + diz*qkz
                  dkqi = dkx*qix + dky*qiy + dkz*qiz
                  qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                      + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                  rr1 = f * mscale(k) / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
c
c     find damped multipole intermediates and energy value
c
                  if (use_chgpen) then
                     corek = pcore(k)
                     valk = pval(k)
                     alphak = palpha(k)
                     term1 = corei*corek
                     term1i = corek*vali
                     term2i = corek*dir
                     term3i = corek*qir
                     term1k = corei*valk
                     term2k = -corei*dkr
                     term3k = corei*qkr
                     term1ik = vali*valk
                     term2ik = valk*dir - vali*dkr + dik
                     term3ik = vali*qkr + valk*qir - dir*dkr
     &                            + 2.0d0*(dkqi-diqk+qiqk)
                     term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                     term5ik = qir*qkr
                     call damppole (r,9,alphai,alphak,
     &                               dmpi,dmpk,dmpik)
                     rr1i = dmpi(1)*rr1
                     rr3i = dmpi(3)*rr3
                     rr5i = dmpi(5)*rr5
                     rr1k = dmpk(1)*rr1
                     rr3k = dmpk(3)*rr3
                     rr5k = dmpk(5)*rr5
                     rr1ik = dmpik(1)*rr1
                     rr3ik = dmpik(3)*rr3
                     rr5ik = dmpik(5)*rr5
                     rr7ik = dmpik(7)*rr7
                     rr9ik = dmpik(9)*rr9
                     e = term1*rr1 + term1i*rr1i
     &                      + term1k*rr1k + term1ik*rr1ik
     &                      + term2i*rr3i + term2k*rr3k
     &                      + term2ik*rr3ik + term3i*rr5i
     &                      + term3k*rr5k + term3ik*rr5ik
     &                      + term4ik*rr7ik + term5ik*rr9ik
c
c     find standard multipole intermediates and energy value
c
                  else
                     term1 = ci*ck
                     term2 = ck*dir - ci*dkr + dik
                     term3 = ci*qkr + ck*qir - dir*dkr
     &                          + 2.0d0*(dkqi-diqk+qiqk)
                     term4 = dir*qkr - dkr*qir - 4.0d0*qik
                     term5 = qir*qkr
                     e = term1*rr1 + term2*rr3 + term3*rr5
     &                      + term4*rr7 + term5*rr9
                  end if
c
c     increment the overall multipole energy components
c
                  if (use_group)  e = e * fgrp
                  if (e .ne. 0.0d0) then
                     nem = nem + 1
                     em = em + e
                     aem(i) = aem(i) + 0.5d0*e
                     aem(k) = aem(k) + 0.5d0*e
                     if (molcule(i) .ne. molcule(k)) then
                        einter = einter + e
                     end if
                  end if
c
c     print message if the energy of this interaction is large
c
                  huge = (abs(e) .gt. 100.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Atomic Multipole',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             15x,'Distance',8x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),r,e
   30                format (' Mpole',5x,2(i7,'-',a3),9x,
     &                          f10.4,2x,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction energy with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            iz = zaxis(i)
            ix = xaxis(i)
            iy = abs(yaxis(i))
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ci = rpole(1,i)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            qixx = rpole(5,i)
            qixy = rpole(6,i)
            qixz = rpole(7,i)
            qiyy = rpole(9,i)
            qiyz = rpole(10,i)
            qizz = rpole(13,i)
            if (use_chgpen) then
               corei = pcore(i)
               vali = pval(i)
               alphai = palpha(i)
            end if
            usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = m2scale
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = m3scale
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = m4scale
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = m5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               kz = zaxis(k)
               kx = xaxis(k)
               ky = abs(yaxis(k))
               usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               proceed = .true.
               if (proceed)  proceed = (usei .or. usek)
               if (proceed) then
                  do j = 2, ncell
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     call imager (xr,yr,zr,j)
                     r2 = xr*xr + yr* yr + zr*zr
                     if (.not. (use_polymer .and. r2.le.polycut2))
     &                  mscale(k) = 1.0d0
                     if (r2 .le. off2) then
                        r = sqrt(r2)
                        ck = rpole(1,k)
                        dkx = rpole(2,k)
                        dky = rpole(3,k)
                        dkz = rpole(4,k)
                        qkxx = rpole(5,k)
                        qkxy = rpole(6,k)
                        qkxz = rpole(7,k)
                        qkyy = rpole(9,k)
                        qkyz = rpole(10,k)
                        qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
                        dir = dix*xr + diy*yr + diz*zr
                        qix = qixx*xr + qixy*yr + qixz*zr
                        qiy = qixy*xr + qiyy*yr + qiyz*zr
                        qiz = qixz*xr + qiyz*yr + qizz*zr
                        qir = qix*xr + qiy*yr + qiz*zr
                        dkr = dkx*xr + dky*yr + dkz*zr
                        qkx = qkxx*xr + qkxy*yr + qkxz*zr
                        qky = qkxy*xr + qkyy*yr + qkyz*zr
                        qkz = qkxz*xr + qkyz*yr + qkzz*zr
                        qkr = qkx*xr + qky*yr + qkz*zr
                        dik = dix*dkx + diy*dky + diz*dkz
                        qik = qix*qkx + qiy*qky + qiz*qkz
                        diqk = dix*qkx + diy*qky + diz*qkz
                        dkqi = dkx*qix + dky*qiy + dkz*qiz
                        qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                            + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                        rr1 = f * mscale(k) / r
                        rr3 = rr1 / r2
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr9 = 7.0d0 * rr7 / r2
c
c     find damped multipole intermediates and energy value
c
                        if (use_chgpen) then
                           corek = pcore(k)
                           valk = pval(k)
                           alphak = palpha(k)
                           term1 = corei*corek
                           term1i = corek*vali
                           term2i = corek*dir
                           term3i = corek*qir
                           term1k = corei*valk
                           term2k = -corei*dkr
                           term3k = corei*qkr
                           term1ik = vali*valk
                           term2ik = valk*dir - vali*dkr + dik
                           term3ik = vali*qkr + valk*qir - dir*dkr
     &                                  + 2.0d0*(dkqi-diqk+qiqk)
                           term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                           term5ik = qir*qkr
                           call damppole (r,9,alphai,alphak,
     &                                     dmpi,dmpk,dmpik)
                           rr1i = dmpi(1)*rr1
                           rr3i = dmpi(3)*rr3
                           rr5i = dmpi(5)*rr5
                           rr1k = dmpk(1)*rr1
                           rr3k = dmpk(3)*rr3
                           rr5k = dmpk(5)*rr5
                           rr1ik = dmpik(1)*rr1
                           rr3ik = dmpik(3)*rr3
                           rr5ik = dmpik(5)*rr5
                           rr7ik = dmpik(7)*rr7
                           rr9ik = dmpik(9)*rr9
                           e = term1*rr1 + term1i*rr1i
     &                            + term1k*rr1k + term1ik*rr1ik
     &                            + term2i*rr3i + term2k*rr3k
     &                            + term2ik*rr3ik + term3i*rr5i
     &                            + term3k*rr5k + term3ik*rr5ik
     &                            + term4ik*rr7ik + term5ik*rr9ik
c
c     find standard multipole intermediates and energy value
c
                        else
                           term1 = ci*ck
                           term2 = ck*dir - ci*dkr + dik
                           term3 = ci*qkr + ck*qir - dir*dkr
     &                                + 2.0d0*(dkqi-diqk+qiqk)
                           term4 = dir*qkr - dkr*qir - 4.0d0*qik
                           term5 = qir*qkr
                           e = term1*rr1 + term2*rr3 + term3*rr5
     &                            + term4*rr7 + term5*rr9
                        end if
c
c     increment the overall multipole energy components
c
                        if (use_group)  e = e * fgrp
                        if (i .eq. k)  e = 0.5d0 * e
                        if (e .ne. 0.0d0) then
                           nem = nem + 1
                           em = em + e
                           aem(i) = aem(i) + 0.5d0*e
                           aem(k) = aem(k) + 0.5d0*e
                           einter = einter + e
                        end if
c
c     print message if the energy of this interaction is large
c
                        huge = (abs(e) .gt. 100.0d0)
                        if ((debug.and.e.ne.0.0d0)
     &                        .or. (verbose.and.huge)) then
                           if (header) then
                              header = .false.
                              write (iout,40)
   40                         format (/,' Individual Atomic Multipole',
     &                                   ' Interactions :',
     &                                //,' Type',14x,'Atom Names',
     &                                   15x,'Distance',8x,'Energy',/)
                           end if
                           write (iout,50)  i,name(i),k,name(k),r,e
   50                      format (' Mpole',5x,2(i7,'-',a3),1x,
     &                                '(XTAL)',2x,f10.4,2x,f12.4)
                        end if
                     end if
                  end do
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine empole3b  --  neighbor list multipole analysis  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "empole3b" calculates the atomic multipole interaction energy
c     using a neighbor list, and partitions the energy among the atoms
c
c
      subroutine empole3b
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use chgpen
      use chgpot
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use math
      use molcul
      use mplpot
      use mpole
      use neigh
      use potent
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer ix,iy,iz
      integer kx,ky,kz
      real*8 e,f,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 rr1i,rr3i,rr5i
      real*8 rr1k,rr3k,rr5k
      real*8 rr1ik,rr3ik,rr5ik
      real*8 rr7ik,rr9ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9)
      real*8, allocatable :: mscale(:)
      logical proceed
      logical header,huge
      logical usei,usek
      character*6 mode
c
c
c     zero out total atomic multipole energy and partitioning
c
      nem = 0
      em = 0.0d0
      do i = 1, n
         aem(i) = 0.0d0
      end do
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. npole.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Atomic Multipole Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,x,y,z,xaxis,yaxis,zaxis,rpole,pcore,pval,
!$OMP& palpha,use,n12,i12,n13,i13,n14,i14,n15,i15,m2scale,m3scale,
!$OMP& m4scale,m5scale,f,nelst,elst,use_chgpen,use_group,use_intra,
!$OMP& use_bounds,off2,molcule,name,verbose,debug,header,iout)
!$OMP& firstprivate(mscale) shared (em,nem,aem,einter)
!$OMP DO reduction(+:em,nem,aem,einter)
c
c     calculate the multipole interaction energy term
c
      do ii = 1, npole
         i = ipole(ii)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  ck = rpole(1,k)
                  dkx = rpole(2,k)
                  dky = rpole(3,k)
                  dkz = rpole(4,k)
                  qkxx = rpole(5,k)
                  qkxy = rpole(6,k)
                  qkxz = rpole(7,k)
                  qkyy = rpole(9,k)
                  qkyz = rpole(10,k)
                  qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
                  dir = dix*xr + diy*yr + diz*zr
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qir = qix*xr + qiy*yr + qiz*zr
                  dkr = dkx*xr + dky*yr + dkz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
                  qkr = qkx*xr + qky*yr + qkz*zr
                  dik = dix*dkx + diy*dky + diz*dkz
                  qik = qix*qkx + qiy*qky + qiz*qkz
                  diqk = dix*qkx + diy*qky + diz*qkz
                  dkqi = dkx*qix + dky*qiy + dkz*qiz
                  qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                      + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                  rr1 = f * mscale(k) / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
c
c     find damped multipole intermediates and energy value
c
                  if (use_chgpen) then
                     corek = pcore(k)
                     valk = pval(k)
                     alphak = palpha(k)
                     term1 = corei*corek
                     term1i = corek*vali
                     term2i = corek*dir
                     term3i = corek*qir
                     term1k = corei*valk
                     term2k = -corei*dkr
                     term3k = corei*qkr
                     term1ik = vali*valk
                     term2ik = valk*dir - vali*dkr + dik
                     term3ik = vali*qkr + valk*qir - dir*dkr
     &                            + 2.0d0*(dkqi-diqk+qiqk)
                     term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                     term5ik = qir*qkr
                     call damppole (r,9,alphai,alphak,
     &                               dmpi,dmpk,dmpik)
                     rr1i = dmpi(1)*rr1
                     rr3i = dmpi(3)*rr3
                     rr5i = dmpi(5)*rr5
                     rr1k = dmpk(1)*rr1
                     rr3k = dmpk(3)*rr3
                     rr5k = dmpk(5)*rr5
                     rr1ik = dmpik(1)*rr1
                     rr3ik = dmpik(3)*rr3
                     rr5ik = dmpik(5)*rr5
                     rr7ik = dmpik(7)*rr7
                     rr9ik = dmpik(9)*rr9
                     e = term1*rr1 + term1i*rr1i
     &                      + term1k*rr1k + term1ik*rr1ik
     &                      + term2i*rr3i + term2k*rr3k
     &                      + term2ik*rr3ik + term3i*rr5i
     &                      + term3k*rr5k + term3ik*rr5ik
     &                      + term4ik*rr7ik + term5ik*rr9ik
c
c     find standard multipole intermediates and energy value
c
                  else
                     term1 = ci*ck
                     term2 = ck*dir - ci*dkr + dik
                     term3 = ci*qkr + ck*qir - dir*dkr
     &                          + 2.0d0*(dkqi-diqk+qiqk)
                     term4 = dir*qkr - dkr*qir - 4.0d0*qik
                     term5 = qir*qkr
                     e = term1*rr1 + term2*rr3 + term3*rr5
     &                      + term4*rr7 + term5*rr9
                  end if
c
c     increment the overall multipole energy components
c
                  if (use_group)  e = e * fgrp
                  if (e .ne. 0.0d0) then
                     nem = nem + 1
                     em = em + e
                     aem(i) = aem(i) + 0.5d0*e
                     aem(k) = aem(k) + 0.5d0*e
                     if (molcule(i) .ne. molcule(k)) then
                        einter = einter + e
                     end if
                  end if
c
c     print message if the energy of this interaction is large
c
                  huge = (abs(e) .gt. 100.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Atomic Multipole',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             15x,'Distance',8x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),r,e
   30                format (' Mpole',5x,2(i7,'-',a3),9x,
     &                          f10.4,2x,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine empole3c  --  Ewald multipole analysis via loop  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "empole3c" calculates the atomic multipole interaction energy
c     using a particle mesh Ewald summation and double loop, and
c     partitions the energy among the atoms
c
c
      subroutine empole3c
      use action
      use analyz
      use atoms
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use mpole
      use pme
      implicit none
      integer i,ii
      real*8 e,f,sum
      real*8 term,fterm
      real*8 cii,dii,qii
      real*8 xd,yd,zd
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
c
c
c     zero out the multipole and polarization energies
c
      nem = 0
      em = 0.0d0
      do i = 1, n
         aem(i) = 0.0d0
      end do
      if (npole .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     compute the real space part of the Ewald summation
c
      call emreal3c
c
c     compute the reciprocal space part of the Ewald summation
c
      call emrecip3
c
c     compute the self-energy part of the Ewald summation
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / rootpi
      do ii = 1, npole
         i = ipole(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         cii = ci*ci
         dii = dix*dix + diy*diy + diz*diz
         qii = 2.0d0*(qixy*qixy+qixz*qixz+qiyz*qiyz)
     &            + qixx*qixx + qiyy*qiyy + qizz*qizz
         e = fterm * (cii + term*(dii/3.0d0+2.0d0*term*qii/5.0d0))
         em = em + e
         nem = nem + 1
         aem(i) = aem(i) + e
      end do
c
c     compute the uniform background charge correction term
c
      fterm = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         sum = sum + rpole(1,i)
      end do
      if (sum .ne. 0.0d0) then
         e = fterm * sum**2
         em = em + e
         nem = nem + 1
         do ii = 1, npole
            i = ipole(ii)
            aem(i) = aem(i) + e/dble(npole)
         end do
      end if
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            xd = xd + dix + rpole(1,i)*x(i)
            yd = yd + diy + rpole(1,i)*y(i)
            zd = zd + diz + rpole(1,i)*z(i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         e = term * (xd*xd+yd*yd+zd*zd)
         em = em + e
         nem = nem + 1
         do ii = 1, npole
            i = ipole(ii)
            aem(i) = aem(i) + e/dble(npole)
         end do
      end if
      return
      end
c
c
c     ###################################################################
c     ##                                                               ##
c     ##  subroutine emreal3c  --  real space mpole analysis via loop  ##
c     ##                                                               ##
c     ###################################################################
c
c
c     "emreal3c" evaluates the real space portion of the Ewald sum
c     energy due to atomic multipole interactions and partitions
c     the energy among the atoms
c
c     literature reference:
c
c     W. Smith, "Point Multipoles in the Ewald Summation (Revisited)",
c     CCP5 Newsletter, 46, 18-30, 1998  [newsletters are available at
c     https://www.ccp5.ac.uk/infoweb/newsletters]
c
c
      subroutine emreal3c
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use energi
      use inform
      use inter
      use iounit
      use math
      use molcul
      use mplpot
      use mpole
      use potent
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 e,efull,f
      real*8 scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 rr1i,rr3i,rr5i
      real*8 rr1k,rr3k,rr5k
      real*8 rr1ik,rr3ik,rr5ik
      real*8 rr7ik,rr9ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9),dmpe(9)
      real*8, allocatable :: mscale(:)
      logical header,huge
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. npole.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Atomic Multipole Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               dik = dix*dkx + diy*dky + diz*dkz
               qik = qix*qkx + qiy*qky + qiz*qkz
               diqk = dix*qkx + diy*qky + diz*qkz
               dkqi = dkx*qix + dky*qiy + dkz*qiz
               qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                   + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
c
c     calculate real space Ewald error function damping
c
               call dampewald (9,r,r2,f,dmpe)
c
c     find damped multipole intermediates and energy value
c
               if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  term1 = corei*corek
                  term1i = corek*vali
                  term2i = corek*dir
                  term3i = corek*qir
                  term1k = corei*valk
                  term2k = -corei*dkr
                  term3k = corei*qkr
                  term1ik = vali*valk
                  term2ik = valk*dir - vali*dkr + dik
                  term3ik = vali*qkr + valk*qir - dir*dkr
     &                         + 2.0d0*(dkqi-diqk+qiqk)
                  term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                  term5ik = qir*qkr
                  call damppole (r,9,alphai,alphak,
     &                            dmpi,dmpk,dmpik)
                  rr1i = dmpi(1)*rr1
                  rr3i = dmpi(3)*rr3
                  rr5i = dmpi(5)*rr5
                  rr1k = dmpk(1)*rr1
                  rr3k = dmpk(3)*rr3
                  rr5k = dmpk(5)*rr5
                  rr1ik = dmpik(1)*rr1
                  rr3ik = dmpik(3)*rr3
                  rr5ik = dmpik(5)*rr5
                  rr7ik = dmpik(7)*rr7
                  rr9ik = dmpik(9)*rr9
                  e = term1*rr1 + term4ik*rr7ik + term5ik*rr9ik
     &                   + term1i*rr1i + term1k*rr1k + term1ik*rr1ik
     &                   + term2i*rr3i + term2k*rr3k + term2ik*rr3ik
     &                   + term3i*rr5i + term3k*rr5k + term3ik*rr5ik
c
c     find standard multipole intermediates and energy value
c
               else
                  term1 = ci*ck
                  term2 = ck*dir - ci*dkr + dik
                  term3 = ci*qkr + ck*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  e = term1*rr1 + term2*rr3 + term3*rr5
     &                   + term4*rr7 + term5*rr9
               end if
c
c     compute the full undamped energy for this interaction
c
               efull = mscale(k) * e
               if (efull .ne. 0.0d0) then
                  nem = nem + 1
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + efull
                  end if
               end if
c
c     compute the energy contribution for this interaction
c
               if (use_chgpen) then
                  scalek = mscale(k)
                  rr1i = dmpe(1) - (1.0d0-scalek*dmpi(1))*rr1
                  rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                  rr1k = dmpe(1) - (1.0d0-scalek*dmpk(1))*rr1
                  rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                  rr1ik = dmpe(1) - (1.0d0-scalek*dmpik(1))*rr1
                  rr3ik = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                  rr5ik = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                  rr7ik = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                  rr9ik = dmpe(9) - (1.0d0-scalek*dmpik(9))*rr9
                  rr1 = dmpe(1) - (1.0d0-scalek)*rr1
                  e = term1*rr1 + term4ik*rr7ik + term5ik*rr9ik
     &                   + term1i*rr1i + term1k*rr1k + term1ik*rr1ik
     &                   + term2i*rr3i + term2k*rr3k + term2ik*rr3ik
     &                   + term3i*rr5i + term3k*rr5k + term3ik*rr5ik
               else
                  scalek = 1.0d0 - mscale(k)
                  rr1 = dmpe(1) - scalek*rr1
                  rr3 = dmpe(3) - scalek*rr3
                  rr5 = dmpe(5) - scalek*rr5
                  rr7 = dmpe(7) - scalek*rr7
                  rr9 = dmpe(9) - scalek*rr9
                  e = term1*rr1 + term2*rr3 + term3*rr5
     &                   + term4*rr7 + term5*rr9
               end if
c
c     increment the overall multipole energy component
c
               em = em + e
               aem(i) = aem(i) + 0.5d0*e
               aem(k) = aem(k) + 0.5d0*e
c
c     print a message if the energy of this interaction is large
c
               huge = (abs(efull) .gt. 100.0d0)
               if ((debug.and.efull.ne.0.0d0)
     &               .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual Atomic Multipole',
     &                          ' Interactions :',
     &                       //,' Type',14x,'Atom Names',
     &                          15x,'Distance',8x,'Energy',/)
                  end if
                  write (iout,30)  i,name(i),k,name(k),r,efull
   30             format (' Mpole',5x,2(i7,'-',a3),9x,
     &                       f10.4,2x,f12.4)
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction energy with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ci = rpole(1,i)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            qixx = rpole(5,i)
            qixy = rpole(6,i)
            qixz = rpole(7,i)
            qiyy = rpole(9,i)
            qiyz = rpole(10,i)
            qizz = rpole(13,i)
            if (use_chgpen) then
               corei = pcore(i)
               vali = pval(i)
               alphai = palpha(i)
            end if
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = m2scale
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = m3scale
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = m4scale
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = m5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               do jcell = 2, ncell
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr* yr + zr*zr
                  if (.not. (use_polymer .and. r2.le.polycut2))
     &               mscale(k) = 1.0d0
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     ck = rpole(1,k)
                     dkx = rpole(2,k)
                     dky = rpole(3,k)
                     dkz = rpole(4,k)
                     qkxx = rpole(5,k)
                     qkxy = rpole(6,k)
                     qkxz = rpole(7,k)
                     qkyy = rpole(9,k)
                     qkyz = rpole(10,k)
                     qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
                     dir = dix*xr + diy*yr + diz*zr
                     qix = qixx*xr + qixy*yr + qixz*zr
                     qiy = qixy*xr + qiyy*yr + qiyz*zr
                     qiz = qixz*xr + qiyz*yr + qizz*zr
                     qir = qix*xr + qiy*yr + qiz*zr
                     dkr = dkx*xr + dky*yr + dkz*zr
                     qkx = qkxx*xr + qkxy*yr + qkxz*zr
                     qky = qkxy*xr + qkyy*yr + qkyz*zr
                     qkz = qkxz*xr + qkyz*yr + qkzz*zr
                     qkr = qkx*xr + qky*yr + qkz*zr
                     dik = dix*dkx + diy*dky + diz*dkz
                     qik = qix*qkx + qiy*qky + qiz*qkz
                     diqk = dix*qkx + diy*qky + diz*qkz
                     dkqi = dkx*qix + dky*qiy + dkz*qiz
                     qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                         + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                     rr1 = f / r
                     rr3 = rr1 / r2
                     rr5 = 3.0d0 * rr3 / r2
                     rr7 = 5.0d0 * rr5 / r2
                     rr9 = 7.0d0 * rr7 / r2
c
c     calculate real space Ewald error function damping
c
                     call dampewald (9,r,r2,f,dmpe)
c
c     find damped multipole intermediates and energy value
c
                     if (use_chgpen) then
                        corek = pcore(k)
                        valk = pval(k)
                        alphak = palpha(k)
                        term1 = corei*corek
                        term1i = corek*vali
                        term2i = corek*dir
                        term3i = corek*qir
                        term1k = corei*valk
                        term2k = -corei*dkr
                        term3k = corei*qkr
                        term1ik = vali*valk
                        term2ik = valk*dir - vali*dkr + dik
                        term3ik = vali*qkr + valk*qir - dir*dkr
     &                               + 2.0d0*(dkqi-diqk+qiqk)
                        term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                        term5ik = qir*qkr
                        call damppole (r,9,alphai,alphak,
     &                                  dmpi,dmpk,dmpik)
                        rr1i = dmpi(1)*rr1
                        rr3i = dmpi(3)*rr3
                        rr5i = dmpi(5)*rr5
                        rr1k = dmpk(1)*rr1
                        rr3k = dmpk(3)*rr3
                        rr5k = dmpk(5)*rr5
                        rr1ik = dmpik(1)*rr1
                        rr3ik = dmpik(3)*rr3
                        rr5ik = dmpik(5)*rr5
                        rr7ik = dmpik(7)*rr7
                        rr9ik = dmpik(9)*rr9
                        e = term1*rr1 + term1i*rr1i
     &                         + term1k*rr1k + term1ik*rr1ik
     &                         + term2i*rr3i + term2k*rr3k
     &                         + term2ik*rr3ik + term3i*rr5i
     &                         + term3k*rr5k + term3ik*rr5ik
     &                         + term4ik*rr7ik + term5ik*rr9ik
c
c     find standard multipole intermediates and energy value
c
                     else
                        term1 = ci*ck
                        term2 = ck*dir - ci*dkr + dik
                        term3 = ci*qkr + ck*qir - dir*dkr
     &                             + 2.0d0*(dkqi-diqk+qiqk)
                        term4 = dir*qkr - dkr*qir - 4.0d0*qik
                        term5 = qir*qkr
                        e = term1*rr1 + term2*rr3 + term3*rr5
     &                         + term4*rr7 + term5*rr9
                     end if
c
c     compute the full undamped energy for this interaction
c
                     efull = mscale(k) * e
                     if (efull .ne. 0.0d0) then
                        nem = nem + 1
                        einter = einter + efull
                     end if
c
c     compute the energy contribution for this interaction
c
                     if (use_chgpen) then
                        scalek = mscale(k)
                        rr1i = dmpe(1) - (1.0d0-scalek*dmpi(1))*rr1
                        rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                        rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                        rr1k = dmpe(1) - (1.0d0-scalek*dmpk(1))*rr1
                        rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                        rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                        rr1ik = dmpe(1) - (1.0d0-scalek*dmpik(1))*rr1
                        rr3ik = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                        rr5ik = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                        rr7ik = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                        rr9ik = dmpe(9) - (1.0d0-scalek*dmpik(9))*rr9
                        rr1 = dmpe(1) - (1.0d0-scalek)*rr1
                        e = term1*rr1 + term1i*rr1i
     &                         + term1k*rr1k + term1ik*rr1ik
     &                         + term2i*rr3i + term2k*rr3k
     &                         + term2ik*rr3ik + term3i*rr5i
     &                         + term3k*rr5k + term3ik*rr5ik
     &                         + term4ik*rr7ik + term5ik*rr9ik
                     else
                        scalek = 1.0d0 - mscale(k)
                        rr1 = dmpe(1) - scalek*rr1
                        rr3 = dmpe(3) - scalek*rr3
                        rr5 = dmpe(5) - scalek*rr5
                        rr7 = dmpe(7) - scalek*rr7
                        rr9 = dmpe(9) - scalek*rr9
                        e = term1*rr1 + term2*rr3 + term3*rr5
     &                               + term4*rr7 + term5*rr9
                     end if
c
c     increment the overall multipole energy component
c
                     if (i .eq. k)  e = 0.5d0 * e
                     em = em + e
                     aem(i) = aem(i) + 0.5d0*e
                     aem(k) = aem(k) + 0.5d0*e
c
c     print message if the energy of this interaction is large
c
                     huge = (abs(efull) .gt. 100.0d0)
                     if ((debug .and. efull.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual Atomic Multipole',
     &                                ' Interactions :',
     &                             //,' Type',14x,'Atom Names',
     &                                15x,'Distance',8x,'Energy',/)
                        end if
                        write (iout,50)  i,name(i),k,name(k),r,efull
   50                   format (' Mpole',5x,2(i7,'-',a3),1x,
     &                             '(XTAL)',2x,f10.4,2x,f12.4)
                     end if
                  end if
               end do
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               mscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               mscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               mscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               mscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine empole3d  --  Ewald multipole analysis via list  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "empole3d" calculates the atomic multipole interaction energy
c     using particle mesh Ewald summation and a neighbor list, and
c     partitions the energy among the atoms
c
c
      subroutine empole3d
      use action
      use analyz
      use atoms
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use mpole
      use pme
      implicit none
      integer i,ii
      real*8 e,f,sum
      real*8 term,fterm
      real*8 cii,dii,qii
      real*8 xd,yd,zd
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
c
c
c     zero out the multipole and polarization energies
c
      nem = 0
      em = 0.0d0
      do i = 1, n
         aem(i) = 0.0d0
      end do
      if (npole .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bseorder
      aewald = aeewald
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     compute the real space part of the Ewald summation
c
      call emreal3d
c
c     compute the reciprocal space part of the Ewald summation
c
      call emrecip3
c
c     compute the self-energy part of the Ewald summation
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / rootpi
      do ii = 1, npole
         i = ipole(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         cii = ci*ci
         dii = dix*dix + diy*diy + diz*diz
         qii = 2.0d0*(qixy*qixy+qixz*qixz+qiyz*qiyz)
     &            + qixx*qixx + qiyy*qiyy + qizz*qizz
         e = fterm * (cii + term*(dii/3.0d0+2.0d0*term*qii/5.0d0))
         em = em + e
         nem = nem + 1
         aem(i) = aem(i) + e
      end do
c
c     compute the uniform background charge correction term
c
      fterm = -0.5d0 * f * pi / (volbox*aewald**2)
      sum = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         sum = sum + rpole(1,i)
      end do
      if (sum .ne. 0.0d0) then
         e = fterm * sum**2
         em = em + e
         nem = nem + 1
         do ii = 1, npole
            i = ipole(ii)
            aem(i) = aem(i) + e/dble(npole)
         end do
      end if
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            xd = xd + dix + rpole(1,i)*x(i)
            yd = yd + diy + rpole(1,i)*y(i)
            zd = zd + diz + rpole(1,i)*z(i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         e = term * (xd*xd+yd*yd+zd*zd)
         em = em + e
         nem = nem + 1
         do ii = 1, npole
            i = ipole(ii)
            aem(i) = aem(i) + e/dble(npole)
         end do
      end if
      return
      end
c
c
c     ###################################################################
c     ##                                                               ##
c     ##  subroutine emreal3d  --  real space mpole analysis via list  ##
c     ##                                                               ##
c     ###################################################################
c
c
c     "emreal3d" evaluates the real space portion of the Ewald sum
c     energy due to atomic multipole interactions, and partitions
c     the energy among the atoms using a pairwise neighbor list
c
c     literature reference:
c
c     W. Smith, "Point Multipoles in the Ewald Summation (Revisited)",
c     CCP5 Newsletter, 46, 18-30, 1998  [newsletters are available at
c     https://www.ccp5.ac.uk/infoweb/newsletters]
c
c
      subroutine emreal3d
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use chgpen
      use chgpot
      use couple
      use energi
      use inform
      use inter
      use iounit
      use math
      use molcul
      use mplpot
      use mpole
      use neigh
      use potent
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 e,efull,f
      real*8 scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 rr1i,rr3i,rr5i
      real*8 rr1k,rr3k,rr5k
      real*8 rr1ik,rr3ik,rr5ik
      real*8 rr7ik,rr9ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 term1i,term2i,term3i
      real*8 term1k,term2k,term3k
      real*8 term1ik,term2ik,term3ik
      real*8 term4ik,term5ik
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9),dmpe(9)
      real*8, allocatable :: mscale(:)
      logical header,huge
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (mscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         mscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. npole.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Atomic Multipole Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,x,y,z,rpole,pcore,pval,palpha,n12,i12,
!$OMP& n13,i13,n14,i14,n15,i15,m2scale,m3scale,m4scale,m5scale,
!$OMP& nelst,elst,use_chgpen,use_bounds,f,off2,molcule,name,
!$OMP& verbose,debug,header,iout)
!$OMP& firstprivate(mscale) shared (em,nem,aem,einter)
!$OMP DO reduction(+:em,nem,aem,einter)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = m2scale
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = m3scale
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = m4scale
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = m5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               dik = dix*dkx + diy*dky + diz*dkz
               qik = qix*qkx + qiy*qky + qiz*qkz
               diqk = dix*qkx + diy*qky + diz*qkz
               dkqi = dkx*qix + dky*qiy + dkz*qiz
               qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                   + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
c
c     calculate real space Ewald error function damping
c
               call dampewald (9,r,r2,f,dmpe)
c
c     find damped multipole intermediates and energy value
c
               if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  term1 = corei*corek
                  term1i = corek*vali
                  term2i = corek*dir
                  term3i = corek*qir
                  term1k = corei*valk
                  term2k = -corei*dkr
                  term3k = corei*qkr
                  term1ik = vali*valk
                  term2ik = valk*dir - vali*dkr + dik
                  term3ik = vali*qkr + valk*qir - dir*dkr
     &                         + 2.0d0*(dkqi-diqk+qiqk)
                  term4ik = dir*qkr - dkr*qir - 4.0d0*qik
                  term5ik = qir*qkr
                  call damppole (r,9,alphai,alphak,
     &                            dmpi,dmpk,dmpik)
                  rr1i = dmpi(1)*rr1
                  rr3i = dmpi(3)*rr3
                  rr5i = dmpi(5)*rr5
                  rr1k = dmpk(1)*rr1
                  rr3k = dmpk(3)*rr3
                  rr5k = dmpk(5)*rr5
                  rr1ik = dmpik(1)*rr1
                  rr3ik = dmpik(3)*rr3
                  rr5ik = dmpik(5)*rr5
                  rr7ik = dmpik(7)*rr7
                  rr9ik = dmpik(9)*rr9
                  e = term1*rr1 + term4ik*rr7ik + term5ik*rr9ik
     &                   + term1i*rr1i + term1k*rr1k + term1ik*rr1ik
     &                   + term2i*rr3i + term2k*rr3k + term2ik*rr3ik
     &                   + term3i*rr5i + term3k*rr5k + term3ik*rr5ik
c
c     find standard multipole intermediates and energy value
c
               else
                  term1 = ci*ck
                  term2 = ck*dir - ci*dkr + dik
                  term3 = ci*qkr + ck*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  e = term1*rr1 + term2*rr3 + term3*rr5
     &                   + term4*rr7 + term5*rr9
               end if
c
c     compute the full undamped energy for this interaction
c
               efull = mscale(k) * e
               if (efull .ne. 0.0d0) then
                  nem = nem + 1
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + efull
                  end if
               end if
c
c     compute the energy contribution for this interaction
c
               if (use_chgpen) then
                  scalek = mscale(k)
                  rr1i = dmpe(1) - (1.0d0-scalek*dmpi(1))*rr1
                  rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                  rr1k = dmpe(1) - (1.0d0-scalek*dmpk(1))*rr1
                  rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                  rr1ik = dmpe(1) - (1.0d0-scalek*dmpik(1))*rr1
                  rr3ik = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                  rr5ik = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                  rr7ik = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                  rr9ik = dmpe(9) - (1.0d0-scalek*dmpik(9))*rr9
                  rr1 = dmpe(1) - (1.0d0-scalek)*rr1
                  e = term1*rr1 + term4ik*rr7ik + term5ik*rr9ik
     &                   + term1i*rr1i + term1k*rr1k + term1ik*rr1ik
     &                   + term2i*rr3i + term2k*rr3k + term2ik*rr3ik
     &                   + term3i*rr5i + term3k*rr5k + term3ik*rr5ik
               else
                  scalek = 1.0d0 - mscale(k)
                  rr1 = dmpe(1) - scalek*rr1
                  rr3 = dmpe(3) - scalek*rr3
                  rr5 = dmpe(5) - scalek*rr5
                  rr7 = dmpe(7) - scalek*rr7
                  rr9 = dmpe(9) - scalek*rr9
                  e = term1*rr1 + term2*rr3 + term3*rr5
     &                   + term4*rr7 + term5*rr9
               end if
c
c     compute the energy contribution for this interaction
c
               em = em + e
               aem(i) = aem(i) + 0.5d0*e
               aem(k) = aem(k) + 0.5d0*e
c
c     print a message if the energy of this interaction is large
c
               huge = (abs(efull) .gt. 100.0d0)
               if ((debug.and.efull.ne.0.0d0)
     &               .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual Atomic Multipole',
     &                          ' Interactions :',
     &                       //,' Type',14x,'Atom Names',
     &                          15x,'Distance',8x,'Energy',/)
                  end if
                  write (iout,30)  i,name(i),k,name(k),r,efull
   30             format (' Mpole',5x,2(i7,'-',a3),9x,
     &                       f10.4,2x,f12.4)
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            mscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            mscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            mscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            mscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (mscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine emrecip3  --  PME reciprocal multipole analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "emrecip3" evaluates the reciprocal space portion of the particle
c     mesh Ewald energy due to atomic multipole interactions, and
c     partitions the energy among the atoms
c
c     literature references:
c
c     C. Sagui, L. G. Pedersen and T. A. Darden, "Towards an Accurate
c     Representation of Electrostatics in Classical Force Fields:
c     Efficient Implementation of Multipolar Interactions in
c     Biomolecular Simulations", Journal of Chemical Physics, 120,
c     73-87 (2004)
c
c     W. Smith and D. Fincham, "The Ewald Sum in Truncated Octahedral
c     and Rhombic Dodecahedral Boundary Conditions", Molecular
c     Simulation, 10, 67-71 (1993)
c
c     modifications for nonperiodic systems suggested by Tom Darden
c     during May 2007
c
c
      subroutine emrecip3
      use analyz
      use atoms
      use bound
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use mpole
      use mrecip
      use pme
      implicit none
      integer i,j,k,ii
      integer k1,k2,k3
      integer m1,m2,m3
      integer ntot,nff
      integer nf1,nf2,nf3
      real*8 e,r1,r2,r3
      real*8 f,h1,h2,h3
      real*8 volterm,denom
      real*8 hsq,expterm
      real*8 term,pterm
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      f = 0.5d0 * electric / dielec
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(cmp)) then
         if (size(cmp) .lt. 10*n)  deallocate (cmp)
      end if
      if (allocated(fmp)) then
         if (size(fmp) .lt. 10*n)  deallocate (fmp)
      end if
      if (allocated(fphi)) then
         if (size(fphi) .lt. 20*n)  deallocate (fphi)
      end if
      if (.not. allocated(cmp))  allocate (cmp(10,n))
      if (.not. allocated(fmp))  allocate (fmp(10,n))
      if (.not. allocated(fphi))  allocate (fphi(20,n))
c
c     perform dynamic allocation of some global arrays
c
      ntot = nfft1 * nfft2 * nfft3
      if (allocated(qgrid)) then
         if (size(qgrid) .ne. 2*ntot)  call fftclose
      end if
      if (.not. allocated(qgrid))  call fftsetup
c
c     setup spatial decomposition and B-spline coefficients
c
      call getchunk
      call moduli
      call bspline_fill
      call table_fill
c
c     copy the multipole moments into local storage areas
c
      do ii = 1, npole
         i = ipole(ii)
         cmp(1,i) = rpole(1,i)
         cmp(2,i) = rpole(2,i)
         cmp(3,i) = rpole(3,i)
         cmp(4,i) = rpole(4,i)
         cmp(5,i) = rpole(5,i)
         cmp(6,i) = rpole(9,i)
         cmp(7,i) = rpole(13,i)
         cmp(8,i) = 2.0d0 * rpole(6,i)
         cmp(9,i) = 2.0d0 * rpole(7,i)
         cmp(10,i) = 2.0d0 * rpole(10,i)
      end do
c
c     convert Cartesian multipoles to fractional coordinates
c
      call cmp_to_fmp (cmp,fmp)
c
c     assign PME grid and perform 3-D FFT forward transform
c
      call grid_mpole (fmp)
      call fftfront
c
c     make the scalar summation over reciprocal lattice
c
      pterm = (pi/aewald)**2
      volterm = pi * volbox
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      nff = nfft1 * nfft2
      ntot = nff * nfft3
      do i = 1, ntot-1
         k3 = i/nff + 1
         j = i - (k3-1)*nff
         k2 = j/nfft1 + 1
         k1 = j - (k2-1)*nfft1 + 1
         m1 = k1 - 1
         m2 = k2 - 1
         m3 = k3 - 1
         if (k1 .gt. nf1)  m1 = m1 - nfft1
         if (k2 .gt. nf2)  m2 = m2 - nfft2
         if (k3 .gt. nf3)  m3 = m3 - nfft3
         r1 = dble(m1)
         r2 = dble(m2)
         r3 = dble(m3)
         h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
         h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
         h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
         hsq = h1*h1 + h2*h2 + h3*h3
         term = -pterm * hsq
         expterm = 0.0d0
         if (term .gt. -50.0d0) then
            denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
            expterm = exp(term) / denom
            if (.not. use_bounds) then
               expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
            else if (nonprism) then
               if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
            end if
         end if
         qgrid(1,k1,k2,k3) = expterm * qgrid(1,k1,k2,k3)
         qgrid(2,k1,k2,k3) = expterm * qgrid(2,k1,k2,k3)
      end do
c
c     account for zeroth grid point for nonperiodic system
c
      qgrid(1,1,1,1) = 0.0d0
      qgrid(2,1,1,1) = 0.0d0
      if (.not. use_bounds) then
         expterm = 0.5d0 * pi / xbox
         qgrid(1,1,1,1) = expterm * qgrid(1,1,1,1)
         qgrid(2,1,1,1) = expterm * qgrid(2,1,1,1)
      end if
c
c     perform 3-D FFT backward transform and get potential
c
      call fftback
      call fphi_mpole (fphi)
c
c     increment the total permanent atomic multipole energy
c
      e = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         do k = 1, 10
            term = f * fmp(k,i) * fphi(k,i)
            e = e + term
            aem(i) = aem(i) + term
         end do
      end do
      em = em + e
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module energi  --  individual potential energy components  ##
c     ##                                                             ##
c     #################################################################
c
c
c     esum   total potential energy of the system
c     eb     bond stretch potential energy of the system
c     ea     angle bend potential energy of the system
c     eba    stretch-bend potential energy of the system
c     eub    Urey-Bradley potential energy of the system
c     eaa    angle-angle potential energy of the system
c     eopb   out-of-plane bend potential energy of the system
c     eopd   out-of-plane distance potential energy of the system
c     eid    improper dihedral potential energy of the system
c     eit    improper torsion potential energy of the system
c     et     torsional potential energy of the system
c     ept    pi-system torsion potential energy of the system
c     ebt    stretch-torsion potential energy of the system
c     eat    angle-torsion potential energy of the system
c     ett    torsion-torsion potential energy of the system
c     ev     van der Waals potential energy of the system
c     er     Pauli repulsion potential energy of the system
c     edsp   dampled dispersion potential energy of the system
c     ec     charge-charge potential energy of the system
c     ecd    charge-dipole potential energy of the system
c     ed     dipole-dipole potential energy of the system
c     em     atomic multipole potential energy of the system
c     ep     polarization potential energy of the system
c     ect    charge transfer potential energy of the system
c     erxf   reaction field potential energy of the system
c     es     solvation potential energy of the system
c     elf    metal ligand field potential energy of the system
c     eg     geometric restraint potential energy of the system
c     ex     extra term potential energy of the system
c
c
      module energi
      implicit none
      real*8 esum,eb,ea
      real*8 eba,eub,eaa
      real*8 eopb,eopd,eid
      real*8 eit,et,ept
      real*8 ebt,eat,ett
      real*8 ev,er,edsp
      real*8 ec,ecd,ed
      real*8 em,ep,ect
      real*8 erxf,es,elf
      real*8 eg,ex
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  function energy  --  evaluates energy terms and total  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "energy" calls the subroutines to calculate the potential
c     energy terms and sums up to form the total energy
c
c
      function energy ()
      use energi
      use iounit
      use limits
      use potent
      use vdwpot
      implicit none
      real*8 energy
      real*8 cutoff
c
c
c     zero out each of the potential energy components
c
      esum = 0.0d0
      eb = 0.0d0
      ea = 0.0d0
      eba = 0.0d0
      eub = 0.0d0
      eaa = 0.0d0
      eopb = 0.0d0
      eopd = 0.0d0
      eid = 0.0d0
      eit = 0.0d0
      et = 0.0d0
      ept = 0.0d0
      ebt = 0.0d0
      eat = 0.0d0
      ett = 0.0d0
      ev = 0.0d0
      er = 0.0d0
      edsp = 0.0d0
      ec = 0.0d0
      ecd = 0.0d0
      ed = 0.0d0
      em = 0.0d0
      ep = 0.0d0
      ect = 0.0d0
      erxf = 0.0d0
      es = 0.0d0
      elf = 0.0d0
      eg = 0.0d0
      ex = 0.0d0
c
c     update the pairwise interaction neighbor lists
c
      if (use_list)  call nblist
c
c     remove any previous use of the replicates method
c
      cutoff = 0.0d0
      call replica (cutoff)
c
c     many implicit solvation models require Born radii
c
      if (use_born)  call born
c
c     alter partial charges and multipoles for charge flux
c
      if (use_chgflx)  call alterchg
c
c     modify bond and torsion constants for pisystem
c
      if (use_orbit)  call picalc
c
c     call the local geometry energy component routines
c
      if (use_bond)  call ebond
      if (use_angle)  call eangle
      if (use_strbnd)  call estrbnd
      if (use_urey)  call eurey
      if (use_angang)  call eangang
      if (use_opbend)  call eopbend
      if (use_opdist)  call eopdist
      if (use_improp)  call eimprop
      if (use_imptor)  call eimptor
      if (use_tors)  call etors
      if (use_pitors)  call epitors
      if (use_strtor)  call estrtor
      if (use_angtor)  call eangtor
      if (use_tortor)  call etortor
c
c     call the electrostatic energy component routines
c
      if (use_charge)  call echarge
      if (use_chgdpl)  call echgdpl
      if (use_dipole)  call edipole
      if (use_mpole)  call empole
      if (use_polar)  call epolar
      if (use_chgtrn)  call echgtrn
      if (use_rxnfld)  call erxnfld
c
c     call the van der Waals energy component routines
c
      if (use_vdw) then
         if (vdwtyp .eq. 'LENNARD-JONES')  call elj
         if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck
         if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb
         if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal
         if (vdwtyp .eq. 'GAUSSIAN')  call egauss
      end if
      if (use_repel)  call erepel
      if (use_disp)  call edisp
c
c     call any miscellaneous energy component routines
c
      if (use_solv)  call esolv
      if (use_geom)  call egeom
      if (use_metal)  call emetal
      if (use_extra)  call extra
c
c     sum up to give the total potential energy
c
      esum = eb + ea + eba + eub + eaa + eopb + eopd + eid + eit
     &          + et + ept + ebt + eat + ett + ev + er + edsp
     &          + ec + ecd + ed + em + ep + ect + erxf + es + elf
     &          + eg + ex
      energy = esum
c
c     check for an illegal value for the total energy
c
c     if (isnan(esum)) then
      if (esum .ne. esum) then
         write (iout,10)
   10    format (/,' ENERGY  --  Illegal Value for the Total',
     &              ' Potential Energy')
         call fatal
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine eopbend  --  out-of-plane bending energy  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "eopbend" computes the out-of-plane bend potential energy at
c     trigonal centers via a Wilson-Decius-Cross or Allinger angle
c
c
      subroutine eopbend
      use angbnd
      use angpot
      use atoms
      use bound
      use energi
      use fields
      use group
      use math
      use opbend
      use usage
      implicit none
      integer i,iopbend
      integer ia,ib,ic,id
      real*8 e,force,angle
      real*8 sine,fgrp
      real*8 dt,dt2,dt3,dt4
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 xdb,ydb,zdb
      real*8 xad,yad,zad
      real*8 xcd,ycd,zcd
      real*8 rdb2,rad2,rcd2
      real*8 rab2,rcb2
      real*8 cc,ee
      logical proceed
c
c
c     zero out the out-of-plane bending energy component
c
      eopb = 0.0d0
      if (nopbend .eq. 0)  return
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nopbend,iopb,iang,opbk,use,
!$OMP& x,y,z,opbtyp,copb,qopb,popb,sopb,opbunit,use_group,use_polymer)
!$OMP& shared(eopb)
!$OMP DO reduction(+:eopb)
c
c     calculate the out-of-plane bending energy term
c
      do iopbend = 1, nopbend
         i = iopb(iopbend)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         id = iang(4,i)
         force = opbk(iopbend)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     get the coordinates of the atoms at trigonal center
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)
c
c     compute the out-of-plane bending angle
c
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            xad = xia - xid
            yad = yia - yid
            zad = zia - zid
            xcd = xic - xid
            ycd = yic - yid
            zcd = zic - zid
            if (use_polymer) then
               call image (xab,yab,zab)
               call image (xcb,ycb,zcb)
               call image (xdb,ydb,zdb)
               call image (xad,yad,zad)
               call image (xcd,ycd,zcd)
            end if
            rdb2 = max(xdb*xdb+ydb*ydb+zdb*zdb,0.0001d0)
c
c     W-D-C angle between A-B-C plane and B-D vector for D-B<AC
c
            if (opbtyp .eq. 'W-D-C') then
               rab2 = xab*xab + yab*yab + zab*zab
               rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
               cc = rab2*rcb2 - (xab*xcb+yab*ycb+zab*zcb)**2
c
c     Allinger angle between A-C-D plane and D-B vector for D-B<AC
c
            else if (opbtyp .eq. 'ALLINGER') then
               rad2 = xad*xad + yad*yad + zad*zad
               rcd2 = xcd*xcd + ycd*ycd + zcd*zcd
               cc = rad2*rcd2 - (xad*xcd+yad*ycd+zad*zcd)**2
            end if
c
c     find the out-of-plane angle bending energy
c
            if (cc .ne. 0.0d0) then
               ee = xdb*(yab*zcb-zab*ycb) + ydb*(zab*xcb-xab*zcb)
     &                 + zdb*(xab*ycb-yab*xcb)
               sine = abs(ee) / sqrt(cc*rdb2)
               sine = min(1.0d0,sine)
               angle = radian * asin(sine)
               dt = angle
               dt2 = dt * dt
               dt3 = dt2 * dt
               dt4 = dt2 * dt2
               e = opbunit * force * dt2
     &                * (1.0d0+copb*dt+qopb*dt2+popb*dt3+sopb*dt4)
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the total out-of-plane bending energy
c
               eopb = eopb + e
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eopbend1  --  out-of-plane energy and derivs  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "eopbend1" computes the out-of-plane bend potential energy and
c     first derivatives at trigonal centers via a Wilson-Decius-Cross
c     or Allinger angle
c
c
      subroutine eopbend1
      use angbnd
      use angpot
      use atoms
      use bound
      use deriv
      use energi
      use group
      use math
      use opbend
      use usage
      use virial
      implicit none
      integer i,iopbend
      integer ia,ib,ic,id
      real*8 e,angle,force
      real*8 dot,sine,fgrp
      real*8 cc,ee,term
      real*8 deddt,dedcos
      real*8 dt,dt2,dt3,dt4
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 xdb,ydb,zdb
      real*8 xad,yad,zad
      real*8 xcd,ycd,zcd
      real*8 rdb2,rad2,rcd2
      real*8 rab2,rcb2
      real*8 dccdxia,dccdyia,dccdzia
      real*8 dccdxic,dccdyic,dccdzic
      real*8 dccdxid,dccdyid,dccdzid
      real*8 deedxia,deedyia,deedzia
      real*8 deedxic,deedyic,deedzic
      real*8 deedxid,deedyid,deedzid
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out out-of-plane energy and first derivatives
c
      eopb = 0.0d0
      do i = 1, n
         deopb(1,i) = 0.0d0
         deopb(2,i) = 0.0d0
         deopb(3,i) = 0.0d0
      end do
      if (nopbend .eq. 0)  return
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nopbend,iopb,iang,opbk,use,
!$OMP& x,y,z,opbtyp,copb,qopb,popb,sopb,opbunit,use_group,use_polymer)
!$OMP& shared(eopb,deopb,vir)
!$OMP DO reduction(+:eopb,deopb,vir)
c
c     calculate the out-of-plane bending energy and derivatives
c
      do iopbend = 1, nopbend
         i = iopb(iopbend)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         id = iang(4,i)
         force = opbk(iopbend)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     get the coordinates of the atoms at trigonal center
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)
c
c     compute the out-of-plane bending angle
c
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            xad = xia - xid
            yad = yia - yid
            zad = zia - zid
            xcd = xic - xid
            ycd = yic - yid
            zcd = zic - zid
            if (use_polymer) then
               call image (xab,yab,zab)
               call image (xcb,ycb,zcb)
               call image (xdb,ydb,zdb)
               call image (xad,yad,zad)
               call image (xcd,ycd,zcd)
            end if
            rdb2 = max(xdb*xdb+ydb*ydb+zdb*zdb,0.0001d0)
c
c     W-D-C angle between A-B-C plane and B-D vector for D-B<AC
c
            if (opbtyp .eq. 'W-D-C') then
               rab2 = xab*xab + yab*yab + zab*zab
               rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
               dot = xab*xcb+yab*ycb+zab*zcb
               cc = rab2*rcb2 - dot*dot
c
c     Allinger angle between A-C-D plane and D-B vector for D-B<AC
c
            else if (opbtyp .eq. 'ALLINGER') then
               rad2 = xad*xad + yad*yad + zad*zad
               rcd2 = xcd*xcd + ycd*ycd + zcd*zcd
               dot = xad*xcd + yad*ycd + zad*zcd
               cc = rad2*rcd2 - dot*dot
            end if
c
c     find the out-of-plane angle bending energy
c
            if (cc .ne. 0.0d0) then
               ee = xdb*(yab*zcb-zab*ycb) + ydb*(zab*xcb-xab*zcb)
     &                 + zdb*(xab*ycb-yab*xcb)
               sine = abs(ee) / sqrt(cc*rdb2)
               sine = min(1.0d0,sine)
               angle = radian * asin(sine)
               dt = angle
               dt2 = dt * dt
               dt3 = dt2 * dt
               dt4 = dt2 * dt2
               e = opbunit * force * dt2
     &                * (1.0d0+copb*dt+qopb*dt2+popb*dt3+sopb*dt4)
               deddt = opbunit * force * dt * radian
     &                    * (2.0d0 + 3.0d0*copb*dt + 4.0d0*qopb*dt2
     &                        + 5.0d0*popb*dt3 + 6.0d0*sopb*dt4)
               dedcos = -deddt * sign(1.0d0,ee) / sqrt(cc*rdb2-ee*ee)
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  e = e * fgrp
                  dedcos = dedcos * fgrp
               end if
c
c     chain rule terms for first derivative components
c
               if (opbtyp .eq. 'W-D-C') then
                  term = ee / cc
                  dccdxia = (xab*rcb2-xcb*dot) * term
                  dccdyia = (yab*rcb2-ycb*dot) * term
                  dccdzia = (zab*rcb2-zcb*dot) * term
                  dccdxic = (xcb*rab2-xab*dot) * term
                  dccdyic = (ycb*rab2-yab*dot) * term
                  dccdzic = (zcb*rab2-zab*dot) * term
                  dccdxid = 0.0d0
                  dccdyid = 0.0d0
                  dccdzid = 0.0d0
               else if (opbtyp .eq. 'ALLINGER') then
                  term = ee / cc
                  dccdxia = (xad*rcd2-xcd*dot) * term
                  dccdyia = (yad*rcd2-ycd*dot) * term
                  dccdzia = (zad*rcd2-zcd*dot) * term
                  dccdxic = (xcd*rad2-xad*dot) * term
                  dccdyic = (ycd*rad2-yad*dot) * term
                  dccdzic = (zcd*rad2-zad*dot) * term
                  dccdxid = -dccdxia - dccdxic
                  dccdyid = -dccdyia - dccdyic
                  dccdzid = -dccdzia - dccdzic
               end if
               term = ee / rdb2
               deedxia = ydb*zcb - zdb*ycb
               deedyia = zdb*xcb - xdb*zcb
               deedzia = xdb*ycb - ydb*xcb
               deedxic = yab*zdb - zab*ydb
               deedyic = zab*xdb - xab*zdb
               deedzic = xab*ydb - yab*xdb
               deedxid = ycb*zab - zcb*yab + xdb*term
               deedyid = zcb*xab - xcb*zab + ydb*term
               deedzid = xcb*yab - ycb*xab + zdb*term
c
c     compute first derivative components for this angle
c
               dedxia = dedcos * (dccdxia+deedxia)
               dedyia = dedcos * (dccdyia+deedyia)
               dedzia = dedcos * (dccdzia+deedzia)
               dedxic = dedcos * (dccdxic+deedxic)
               dedyic = dedcos * (dccdyic+deedyic)
               dedzic = dedcos * (dccdzic+deedzic)
               dedxid = dedcos * (dccdxid+deedxid)
               dedyid = dedcos * (dccdyid+deedyid)
               dedzid = dedcos * (dccdzid+deedzid)
               dedxib = -dedxia - dedxic - dedxid
               dedyib = -dedyia - dedyic - dedyid
               dedzib = -dedzia - dedzic - dedzid
c
c     increment the out-of-plane bending energy and gradient
c
               eopb = eopb + e
               deopb(1,ia) = deopb(1,ia) + dedxia
               deopb(2,ia) = deopb(2,ia) + dedyia
               deopb(3,ia) = deopb(3,ia) + dedzia
               deopb(1,ib) = deopb(1,ib) + dedxib
               deopb(2,ib) = deopb(2,ib) + dedyib
               deopb(3,ib) = deopb(3,ib) + dedzib
               deopb(1,ic) = deopb(1,ic) + dedxic
               deopb(2,ic) = deopb(2,ic) + dedyic
               deopb(3,ic) = deopb(3,ic) + dedzic
               deopb(1,id) = deopb(1,id) + dedxid
               deopb(2,id) = deopb(2,id) + dedyid
               deopb(3,id) = deopb(3,id) + dedzid
c
c     increment the internal virial tensor components
c
               vxx = xab*dedxia + xcb*dedxic + xdb*dedxid
               vyx = yab*dedxia + ycb*dedxic + ydb*dedxid
               vzx = zab*dedxia + zcb*dedxic + zdb*dedxid
               vyy = yab*dedyia + ycb*dedyic + ydb*dedyid
               vzy = zab*dedyia + zcb*dedyic + zdb*dedyid
               vzz = zab*dedzia + zcb*dedzic + zdb*dedzid
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vyx
               vir(3,1) = vir(3,1) + vzx
               vir(1,2) = vir(1,2) + vyx
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vzy
               vir(1,3) = vir(1,3) + vzx
               vir(2,3) = vir(2,3) + vzy
               vir(3,3) = vir(3,3) + vzz
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine eopbend2  --  out-of-plane bend Hessian; numer  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "eopbend2" calculates second derivatives of the out-of-plane
c     bend energy via a Wilson-Decius-Cross or Allinger angle for
c     a single atom using finite difference methods
c
c
      subroutine eopbend2 (i)
      use angbnd
      use atoms
      use group
      use hessn
      use opbend
      implicit none
      integer i,j,k,iopbend
      integer ia,ib,ic,id
      real*8 eps,fgrp
      real*8 old,term
      real*8, allocatable :: de(:,:)
      real*8, allocatable :: d0(:,:)
      logical proceed
      logical twosided
c
c
c     set stepsize for derivatives and default group weight
c
      eps = 1.0d-5
      fgrp = 1.0d0
      twosided = .false.
      if (n .le. 50)  twosided = .true.
c
c     perform dynamic allocation of some local arrays
c
      allocate (de(3,n))
      allocate (d0(3,n))
c
c     compute numerical out-of-plane Hessian for current atom
c
      do iopbend = 1, nopbend
         k = iopb(iopbend)
         ia = iang(1,k)
         ib = iang(2,k)
         ic = iang(3,k)
         id = iang(4,k)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (i.eq.ia .or. i.eq.ib .or.
     &                              i.eq.ic .or. i.eq.id)
         if (proceed) then
            term = fgrp / eps
c
c     find first derivatives for the base structure
c
            if (.not. twosided) then
               call eopbend2a (iopbend,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
               end do
            end if
c
c     find numerical x-components via perturbed structures
c
            old = x(i)
            if (twosided) then
               x(i) = x(i) - 0.5d0*eps
               call eopbend2a (iopbend,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
               end do
            end if
            x(i) = x(i) + eps
            call eopbend2a (iopbend,de)
            x(i) = old
            do j = 1, 3
               hessx(j,ia) = hessx(j,ia) + term*(de(j,ia)-d0(j,ia))
               hessx(j,ib) = hessx(j,ib) + term*(de(j,ib)-d0(j,ib))
               hessx(j,ic) = hessx(j,ic) + term*(de(j,ic)-d0(j,ic))
               hessx(j,id) = hessx(j,id) + term*(de(j,id)-d0(j,id))
            end do
c
c     find numerical y-components via perturbed structures
c
            old = y(i)
            if (twosided) then
               y(i) = y(i) - 0.5d0*eps
               call eopbend2a (iopbend,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
               end do
            end if
            y(i) = y(i) + eps
            call eopbend2a (iopbend,de)
            y(i) = old
            do j = 1, 3
               hessy(j,ia) = hessy(j,ia) + term*(de(j,ia)-d0(j,ia))
               hessy(j,ib) = hessy(j,ib) + term*(de(j,ib)-d0(j,ib))
               hessy(j,ic) = hessy(j,ic) + term*(de(j,ic)-d0(j,ic))
               hessy(j,id) = hessy(j,id) + term*(de(j,id)-d0(j,id))
            end do
c
c     find numerical z-components via perturbed structures
c
            old = z(i)
            if (twosided) then
               z(i) = z(i) - 0.5d0*eps
               call eopbend2a (iopbend,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
               end do
            end if
            z(i) = z(i) + eps
            call eopbend2a (iopbend,de)
            z(i) = old
            do j = 1, 3
               hessz(j,ia) = hessz(j,ia) + term*(de(j,ia)-d0(j,ia))
               hessz(j,ib) = hessz(j,ib) + term*(de(j,ib)-d0(j,ib))
               hessz(j,ic) = hessz(j,ic) + term*(de(j,ic)-d0(j,ic))
               hessz(j,id) = hessz(j,id) + term*(de(j,id)-d0(j,id))
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (de)
      deallocate (d0)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eopbend2a  --  out-of-plane bend derivatives  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "eopbend2a" calculates out-of-plane bend first derivatives at
c     a trigonal center via a Wilson-Decius-Cross or Allinger angle;
c     used in computation of finite difference second derivatives
c
c
      subroutine eopbend2a (i,de)
      use angbnd
      use angpot
      use atoms
      use bound
      use math
      use opbend
      implicit none
      integer i,k
      integer ia,ib,ic,id
      real*8 angle,force
      real*8 dot,sine
      real*8 cc,ee,term
      real*8 deddt,dedcos
      real*8 dt,dt2,dt3,dt4
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 xdb,ydb,zdb
      real*8 xad,yad,zad
      real*8 xcd,ycd,zcd
      real*8 rdb2,rad2,rcd2
      real*8 rab2,rcb2
      real*8 dccdxia,dccdyia,dccdzia
      real*8 dccdxic,dccdyic,dccdzic
      real*8 dccdxid,dccdyid,dccdzid
      real*8 deedxia,deedyia,deedzia
      real*8 deedxic,deedyic,deedzic
      real*8 deedxid,deedyid,deedzid
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 de(3,*)
c
c
c     set the atom numbers and parameters for this angle
c
      k = iopb(i)
      ia = iang(1,k)
      ib = iang(2,k)
      ic = iang(3,k)
      id = iang(4,k)
      force = opbk(i)
c
c     get the coordinates of the atoms in the angle
c
      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)
c
c     zero out the first derivative components
c
      de(1,ia) = 0.0d0
      de(2,ia) = 0.0d0
      de(3,ia) = 0.0d0
      de(1,ib) = 0.0d0
      de(2,ib) = 0.0d0
      de(3,ib) = 0.0d0
      de(1,ic) = 0.0d0
      de(2,ic) = 0.0d0
      de(3,ic) = 0.0d0
      de(1,id) = 0.0d0
      de(2,id) = 0.0d0
      de(3,id) = 0.0d0
c
c     compute the out-of-plane bending angle
c
      xab = xia - xib
      yab = yia - yib
      zab = zia - zib
      xcb = xic - xib
      ycb = yic - yib
      zcb = zic - zib
      xdb = xid - xib
      ydb = yid - yib
      zdb = zid - zib
      xad = xia - xid
      yad = yia - yid
      zad = zia - zid
      xcd = xic - xid
      ycd = yic - yid
      zcd = zic - zid
      if (use_polymer) then
         call image (xab,yab,zab)
         call image (xcb,ycb,zcb)
         call image (xdb,ydb,zdb)
         call image (xad,yad,zad)
         call image (xcd,ycd,zcd)
      end if
      rdb2 = max(xdb*xdb+ydb*ydb+zdb*zdb,0.0001d0)
c
c     W-D-C angle between A-B-C plane and B-D vector for D-B<AC
c
      if (opbtyp .eq. 'W-D-C') then
         rab2 = xab*xab + yab*yab + zab*zab
         rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
         dot = xab*xcb+yab*ycb+zab*zcb
         cc = rab2*rcb2 - dot*dot
c
c     Allinger angle between A-C-D plane and D-B vector for D-B<AC
c
      else if (opbtyp .eq. 'ALLINGER') then
         rad2 = xad*xad + yad*yad + zad*zad
         rcd2 = xcd*xcd + ycd*ycd + zcd*zcd
         dot = xad*xcd + yad*ycd + zad*zcd
         cc = rad2*rcd2 - dot*dot
      end if
c
c     get the out-of-plane bending master chain rule terms
c
      if (cc .ne. 0.0d0) then
         ee = xdb*(yab*zcb-zab*ycb) + ydb*(zab*xcb-xab*zcb)
     &           + zdb*(xab*ycb-yab*xcb)
         sine = abs(ee) / sqrt(cc*rdb2)
         sine = min(1.0d0,sine)
         angle = radian * asin(sine)
         dt = angle
         dt2 = dt * dt
         dt3 = dt2 * dt
         dt4 = dt2 * dt2
         deddt = opbunit * force * dt * radian
     &              * (2.0d0 + 3.0d0*copb*dt + 4.0d0*qopb*dt2
     &                  + 5.0d0*popb*dt3 + 6.0d0*sopb*dt4)
         dedcos = -deddt * sign(1.0d0,ee) / sqrt(cc*rdb2-ee*ee)
c
c     chain rule terms for first derivative components
c
         if (opbtyp .eq. 'W-D-C') then
            term = ee / cc
            dccdxia = (xab*rcb2-xcb*dot) * term
            dccdyia = (yab*rcb2-ycb*dot) * term
            dccdzia = (zab*rcb2-zcb*dot) * term
            dccdxic = (xcb*rab2-xab*dot) * term
            dccdyic = (ycb*rab2-yab*dot) * term
            dccdzic = (zcb*rab2-zab*dot) * term
            dccdxid = 0.0d0
            dccdyid = 0.0d0
            dccdzid = 0.0d0
         else if (opbtyp .eq. 'ALLINGER') then
            term = ee / cc
            dccdxia = (xad*rcd2-xcd*dot) * term
            dccdyia = (yad*rcd2-ycd*dot) * term
            dccdzia = (zad*rcd2-zcd*dot) * term
            dccdxic = (xcd*rad2-xad*dot) * term
            dccdyic = (ycd*rad2-yad*dot) * term
            dccdzic = (zcd*rad2-zad*dot) * term
            dccdxid = -dccdxia - dccdxic
            dccdyid = -dccdyia - dccdyic
            dccdzid = -dccdzia - dccdzic
         end if
         term = ee / rdb2
         deedxia = ydb*zcb - zdb*ycb
         deedyia = zdb*xcb - xdb*zcb
         deedzia = xdb*ycb - ydb*xcb
         deedxic = yab*zdb - zab*ydb
         deedyic = zab*xdb - xab*zdb
         deedzic = xab*ydb - yab*xdb
         deedxid = ycb*zab - zcb*yab + xdb*term
         deedyid = zcb*xab - xcb*zab + ydb*term
         deedzid = xcb*yab - ycb*xab + zdb*term
c
c     compute first derivative components for this angle
c
         dedxia = dedcos * (dccdxia+deedxia)
         dedyia = dedcos * (dccdyia+deedyia)
         dedzia = dedcos * (dccdzia+deedzia)
         dedxic = dedcos * (dccdxic+deedxic)
         dedyic = dedcos * (dccdyic+deedyic)
         dedzic = dedcos * (dccdzic+deedzic)
         dedxid = dedcos * (dccdxid+deedxid)
         dedyid = dedcos * (dccdyid+deedyid)
         dedzid = dedcos * (dccdzid+deedzid)
         dedxib = -dedxia - dedxic - dedxid
         dedyib = -dedyia - dedyic - dedyid
         dedzib = -dedzia - dedzic - dedzid
c
c     set the out-of-plane bending derivatives
c
         de(1,ia) = dedxia
         de(2,ia) = dedyia
         de(3,ia) = dedzia
         de(1,ib) = dedxib
         de(2,ib) = dedyib
         de(3,ib) = dedzib
         de(1,ic) = dedxic
         de(2,ic) = dedyic
         de(3,ic) = dedzic
         de(1,id) = dedxid
         de(2,id) = dedyid
         de(3,id) = dedzid
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eopbend3  --  out-of-plane bending & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "eopbend3" computes the out-of-plane bend potential energy at
c     trigonal centers via a Wilson-Decius-Cross or Allinger angle;
c     also partitions the energy among the atoms
c
c
      subroutine eopbend3
      use action
      use analyz
      use angbnd
      use angpot
      use atomid
      use atoms
      use bound
      use energi
      use group
      use inform
      use iounit
      use math
      use opbend
      use usage
      implicit none
      integer i,iopbend
      integer ia,ib,ic,id
      real*8 e,angle,force
      real*8 sine,fgrp
      real*8 dt,dt2,dt3,dt4
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 xdb,ydb,zdb
      real*8 xad,yad,zad
      real*8 xcd,ycd,zcd
      real*8 rdb2,rad2,rcd2
      real*8 rab2,rcb2
      real*8 cc,ee
      logical proceed
      logical header,huge
c
c
c     zero out the out-of-plane bend energy and partitioning
c
      neopb = 0
      eopb = 0.0d0
      do i = 1, n
         aeopb(i) = 0.0d0
      end do
      if (nopbend .eq. 0)  return
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nopbend.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Out-of-Plane Bend Interactions :',
     &           //,' Type',25x,'Atom Names',21x,'Angle',
     &              6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nopbend,iopb,iang,opbk,use,
!$OMP& x,y,z,opbtyp,copb,qopb,popb,sopb,opbunit,use_group,use_polymer,
!$OMP& name,verbose,debug,header,iout)
!$OMP& shared(eopb,neopb,aeopb)
!$OMP DO reduction(+:eopb,neopb,aeopb)
c
c     calculate the out-of-plane bending energy term
c
      do iopbend = 1, nopbend
         i = iopb(iopbend)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         id = iang(4,i)
         force = opbk(iopbend)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     get the coordinates of the atoms at trigonal center
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)
c
c     compute the out-of-plane bending angle
c
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            xad = xia - xid
            yad = yia - yid
            zad = zia - zid
            xcd = xic - xid
            ycd = yic - yid
            zcd = zic - zid
            if (use_polymer) then
               call image (xab,yab,zab)
               call image (xcb,ycb,zcb)
               call image (xdb,ydb,zdb)
               call image (xad,yad,zad)
               call image (xcd,ycd,zcd)
            end if
            rdb2 = max(xdb*xdb+ydb*ydb+zdb*zdb,0.0001d0)
c
c     W-D-C angle between A-B-C plane and B-D vector for D-B<AC
c
            if (opbtyp .eq. 'W-D-C') then
               rab2 = xab*xab + yab*yab + zab*zab
               rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
               cc = rab2*rcb2 - (xab*xcb+yab*ycb+zab*zcb)**2
c
c     Allinger angle between A-C-D plane and D-B vector for D-B<AC
c
            else if (opbtyp .eq. 'ALLINGER') then
               rad2 = xad*xad + yad*yad + zad*zad
               rcd2 = xcd*xcd + ycd*ycd + zcd*zcd
               cc = rad2*rcd2 - (xad*xcd+yad*ycd+zad*zcd)**2
            end if
c
c     find the out-of-plane angle bending energy
c
            if (cc .ne. 0.0d0) then
               ee = xdb*(yab*zcb-zab*ycb) + ydb*(zab*xcb-xab*zcb)
     &                 + zdb*(xab*ycb-yab*xcb)
               sine = abs(ee) / sqrt(cc*rdb2)
               sine = min(1.0d0,sine)
               angle = radian * asin(sine)
               dt = angle
               dt2 = dt * dt
               dt3 = dt2 * dt
               dt4 = dt2 * dt2
               e = opbunit * force * dt2
     &                * (1.0d0+copb*dt+qopb*dt2+popb*dt3+sopb*dt4)
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the total out-of-plane bending energy
c
               neopb = neopb + 1
               eopb = eopb + e
               aeopb(ib) = aeopb(ib) + e
c
c     print a message if the energy of this interaction is large
c
               huge = (e .gt. 5.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual Out-of-Plane Bend',
     &                          ' Interactions :',
     &                       //,' Type',25x,'Atom Names',21x,'Angle',
     &                          6x,'Energy',/)
                  end if
                  write (iout,30)  id,name(id),ib,name(ib),ia,
     &                             name(ia),ic,name(ic),angle,e
   30             format (' O-P-Bend',2x,4(i7,'-',a3),f11.4,f12.4)
               end if
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine eopdist  --  out-of-plane distance energy  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "eopdist" computes the out-of-plane distance potential
c     energy at trigonal centers via the central atom height
c
c
      subroutine eopdist
      use angpot
      use atoms
      use bound
      use energi
      use group
      use opdist
      use usage
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,force,fgrp
      real*8 dt,dt2,dt3,dt4
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 xt,yt,zt,rt2
      logical proceed
c
c
c     zero out the out-of-plane distance energy component
c
      eopd = 0.0d0
      if (nopdist .eq. 0)  return
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nopdist,iopd,opdk,use,
!$OMP& x,y,z,copd,qopd,popd,sopd,opdunit,use_group,use_polymer)
!$OMP& shared(eopd)
!$OMP DO reduction(+:eopd)
c
c     calculate the out-of-plane distance energy term
c
      do i = 1, nopdist
         ia = iopd(1,i)
         ib = iopd(2,i)
         ic = iopd(3,i)
         id = iopd(4,i)
         force = opdk(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     get the coordinates of the defining atoms
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)
c
c     compute the out-of-plane distance for central atom
c
            xad = xia - xid
            yad = yia - yid
            zad = zia - zid
            xbd = xib - xid
            ybd = yib - yid
            zbd = zib - zid
            xcd = xic - xid
            ycd = yic - yid
            zcd = zic - zid
            if (use_polymer) then
               call image (xad,yad,zad)
               call image (xbd,ybd,zbd)
               call image (xcd,ycd,zcd)
            end if
            xt = ybd*zcd - zbd*ycd
            yt = zbd*xcd - xbd*zcd
            zt = xbd*ycd - ybd*xcd
            rt2 = xt*xt + yt*yt + zt*zt
            dt2 = (xt*xad + yt*yad + zt*zad)**2 / rt2
            dt = sqrt(dt2)
            dt3 = dt2 * dt
            dt4 = dt2 * dt2
c
c     find the out-of-plane distance energy
c
            e = opdunit * force * dt2
     &             * (1.0d0+copd*dt+qopd*dt2+popd*dt3+sopd*dt4)
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total out-of-plane distance energy
c
            eopd = eopd + e
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine eopdist1  --  out-of-plane dist energy & derivs  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "eopdist1" computes the out-of-plane distance potential
c     energy and first derivatives at trigonal centers via
c     the central atom height
c
c
      subroutine eopdist1
      use angpot
      use atoms
      use bound
      use deriv
      use energi
      use group
      use opdist
      use usage
      use virial
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,force,fgrp
      real*8 dot,deddt
      real*8 dt,dt2,dt3,dt4
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 xt,yt,zt
      real*8 rt2,drt2
      real*8 xtd,ytd,ztd
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out out-of-plane energy and first derivatives
c
      eopd = 0.0d0
      do i = 1, n
         deopd(1,i) = 0.0d0
         deopd(2,i) = 0.0d0
         deopd(3,i) = 0.0d0
      end do
      if (nopdist .eq. 0)  return
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nopdist,iopd,opdk,use,
!$OMP& x,y,z,copd,qopd,popd,sopd,opdunit,use_group,use_polymer)
!$OMP& shared(eopd,deopd,vir)
!$OMP DO reduction(+:eopd,deopd,vir)
c
c     calculate the out-of-plane distance energy and derivatives
c
      do i = 1, nopdist
         ia = iopd(1,i)
         ib = iopd(2,i)
         ic = iopd(3,i)
         id = iopd(4,i)
         force = opdk(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     get the coordinates of the defining atoms
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)
c
c     compute the out-of-plane distance for central atom
c
            xad = xia - xid
            yad = yia - yid
            zad = zia - zid
            xbd = xib - xid
            ybd = yib - yid
            zbd = zib - zid
            xcd = xic - xid
            ycd = yic - yid
            zcd = zic - zid
            if (use_polymer) then
               call image (xad,yad,zad)
               call image (xbd,ybd,zbd)
               call image (xcd,ycd,zcd)
            end if
            xt = ybd*zcd - zbd*ycd
            yt = zbd*xcd - xbd*zcd
            zt = xbd*ycd - ybd*xcd
            rt2 = xt*xt + yt*yt + zt*zt
            dot = xt*xad + yt*yad + zt*zad
            drt2 = dot / rt2
            dt2 = dot * drt2
            dt = sqrt(dt2)
            dt3 = dt2 * dt
            dt4 = dt2 * dt2
c
c     find the out-of-plane energy and master chain rule terms
c
            e = opdunit * force * dt2
     &             * (1.0d0+copd*dt+qopd*dt2+popd*dt3+sopd*dt4)
            deddt = opdunit * force * drt2
     &                 * (2.0d0 + 3.0d0*copd*dt + 4.0d0*qopd*dt2
     &                     + 5.0d0*popd*dt3 + 6.0d0*sopd*dt4)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e = e * fgrp
               deddt = deddt * fgrp
            end if
c
c     chain rule terms for first derivative components
c
            xtd = xad - xt*drt2
            ytd = yad - yt*drt2
            ztd = zad - zt*drt2
c
c     compute derivative components for this interaction
c
            dedxia = deddt * xt
            dedyia = deddt * yt
            dedzia = deddt * zt
            dedxib = deddt * (ycd*ztd-zcd*ytd)
            dedyib = deddt * (zcd*xtd-xcd*ztd)
            dedzib = deddt * (xcd*ytd-ycd*xtd)
            dedxic = deddt * (zbd*ytd-ybd*ztd)
            dedyic = deddt * (xbd*ztd-zbd*xtd)
            dedzic = deddt * (ybd*xtd-xbd*ytd)
c
c     get some derivative components by difference
c
            dedxid = -dedxia - dedxib - dedxic
            dedyid = -dedyia - dedyib - dedyic
            dedzid = -dedzia - dedzib - dedzic
c
c     increment the out-of-plane distance energy and gradient
c
            eopd = eopd + e
            deopd(1,ia) = deopd(1,ia) + dedxia
            deopd(2,ia) = deopd(2,ia) + dedyia
            deopd(3,ia) = deopd(3,ia) + dedzia
            deopd(1,ib) = deopd(1,ib) + dedxib
            deopd(2,ib) = deopd(2,ib) + dedyib
            deopd(3,ib) = deopd(3,ib) + dedzib
            deopd(1,ic) = deopd(1,ic) + dedxic
            deopd(2,ic) = deopd(2,ic) + dedyic
            deopd(3,ic) = deopd(3,ic) + dedzic
            deopd(1,id) = deopd(1,id) + dedxid
            deopd(2,id) = deopd(2,id) + dedyid
            deopd(3,id) = deopd(3,id) + dedzid
c
c     increment the internal virial tensor components
c
            vxx = xad*dedxia + xbd*dedxib + xcd*dedxic
            vyx = yad*dedxia + ybd*dedxib + ycd*dedxic
            vzx = zad*dedxia + zbd*dedxib + zcd*dedxic
            vyy = yad*dedyia + ybd*dedyib + ycd*dedyic
            vzy = zad*dedyia + zbd*dedyib + zcd*dedyic
            vzz = zad*dedzia + zbd*dedzib + zcd*dedzic
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eopdist2  --  atomwise out-plane dist Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "eopdist2" calculates second derivatives of the out-of-plane
c     distance energy for a single atom via the central atom height
c
c
      subroutine eopdist2 (i)
      use angpot
      use atoms
      use bound
      use group
      use hessn
      use opdist
      use usage
      implicit none
      integer i,kopdist
      integer ia,ib,ic,id
      real*8 force,fgrp
      real*8 dt,dt2,dt3,dt4
      real*8 deddt,drt2,ddrt
      real*8 dot,dotx,doty,dotz
      real*8 term,termd
      real*8 termx,termy,termz
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 xt,yt,zt,rt2
      real*8 xtd,ytd,ztd
      real*8 xyt,xzt,yxt
      real*8 yzt,zxt,zyt
      real*8 dxiaxia,dyiayia,dziazia
      real*8 dxibxib,dyibyib,dzibzib
      real*8 dxicxic,dyicyic,dziczic
      real*8 dxidxid,dyidyid,dzidzid
      real*8 dxiayia,dxiazia,dyiazia
      real*8 dxibyib,dxibzib,dyibzib
      real*8 dxicyic,dxiczic,dyiczic
      real*8 dxidyid,dxidzid,dyidzid
      real*8 dxiaxib,dxiayib,dxiazib
      real*8 dyiaxib,dyiayib,dyiazib
      real*8 dziaxib,dziayib,dziazib
      real*8 dxiaxic,dxiayic,dxiazic
      real*8 dyiaxic,dyiayic,dyiazic
      real*8 dziaxic,dziayic,dziazic
      real*8 dxiaxid,dxiayid,dxiazid
      real*8 dyiaxid,dyiayid,dyiazid
      real*8 dziaxid,dziayid,dziazid
      real*8 dxibxic,dxibyic,dxibzic
      real*8 dyibxic,dyibyic,dyibzic
      real*8 dzibxic,dzibyic,dzibzic
      real*8 dxibxid,dxibyid,dxibzid
      real*8 dyibxid,dyibyid,dyibzid
      real*8 dzibxid,dzibyid,dzibzid
      real*8 dxicxid,dxicyid,dxiczid
      real*8 dyicxid,dyicyid,dyiczid
      real*8 dzicxid,dzicyid,dziczid
      logical proceed
c
c
c     compute the out-of-plane distance term Hessian elements
c
      do kopdist = 1, nopdist
         ia = iopd(1,kopdist)
         ib = iopd(2,kopdist)
         ic = iopd(3,kopdist)
         id = iopd(4,kopdist)
         force = opdk(kopdist)
c
c     decide whether to compute the current interaction
c
         proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic .or. i.eq.id)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,id,0,0)
c
c     get the coordinates of the defining atoms
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)
c
c     compute the out-of-plane distance for central atom
c
            xad = xia - xid
            yad = yia - yid
            zad = zia - zid
            xbd = xib - xid
            ybd = yib - yid
            zbd = zib - zid
            xcd = xic - xid
            ycd = yic - yid
            zcd = zic - zid
            if (use_polymer) then
               call image (xad,yad,zad)
               call image (xbd,ybd,zbd)
               call image (xcd,ycd,zcd)
            end if
            xt = ybd*zcd - zbd*ycd
            yt = zbd*xcd - xbd*zcd
            zt = xbd*ycd - ybd*xcd
            rt2 = xt*xt + yt*yt + zt*zt
            dot = xt*xad + yt*yad + zt*zad
            drt2 = dot / rt2
            dt2 = dot * drt2
            dt = sqrt(dt2)
            dt3 = dt2 * dt
            dt4 = dt2 * dt2
            deddt = opdunit * force
     &                 * (2.0d0 + 3.0d0*copd*dt + 4.0d0*qopd*dt2
     &                     + 5.0d0*popd*dt3 + 6.0d0*sopd*dt4)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               deddt = deddt * fgrp
            end if
c
c     abbreviations for second derivative chain rule terms
c
            term = deddt / rt2
            termx = term * xt
            termy = term * yt
            termz = term * zt
            termd = term * dot
            xtd = xad - 2.0d0*xt*drt2
            ytd = yad - 2.0d0*yt*drt2
            ztd = zad - 2.0d0*zt*drt2
            xyt = xcd*ytd - ycd*xtd
            xzt = xbd*ztd - zbd*xtd
            yxt = ybd*xtd - xbd*ytd
            yzt = ycd*ztd - zcd*ytd
            zxt = zcd*xtd - xcd*ztd
            zyt = zbd*ytd - ybd*ztd
            ddrt = dot * drt2
            dotx = dot * xad
            doty = dot * yad
            dotz = dot * zad
c
c     chain rule terms for second derivative components
c
            dxiaxia = termx*xt
            dxiayia = termx*yt
            dxiazia = termx*zt
            dxiaxib = termx*yzt
            dxiayib = termx*zxt + termd*zcd
            dxiazib = termx*xyt - termd*ycd
            dxiaxic = termx*zyt
            dxiayic = termx*xzt - termd*zbd
            dxiazic = termx*yxt + termd*ybd
            dyiayia = termy*yt
            dyiazia = termy*zt
            dyiaxib = termy*yzt - termd*zcd
            dyiayib = termy*zxt
            dyiazib = termy*xyt + termd*xcd
            dyiaxic = termy*zyt + termd*zbd
            dyiayic = termy*xzt
            dyiazic = termy*yxt - termd*xbd
            dziazia = termz*zt
            dziaxib = termz*yzt + termd*ycd
            dziayib = termz*zxt - termd*xcd
            dziazib = termz*xyt
            dziaxic = termz*zyt - termd*ybd
            dziayic = termz*xzt + termd*xbd
            dziazic = termz*yxt
            dxibxib = term * (yzt*yzt - ddrt*(ycd*ycd+zcd*zcd))
            dxibyib = term * (yzt*zxt + ddrt*xcd*ycd)
            dxibzib = term * (yzt*xyt + ddrt*xcd*zcd)
            dxibxic = term * (yzt*zyt + ddrt*(ybd*ycd+zbd*zcd))
            dxibyic = term * (xzt*yzt - ddrt*(xbd*ycd+zt) + dotz)
            dxibzic = term * (yxt*yzt - ddrt*(xbd*zcd-yt) - doty)
            dyibyib = term * (zxt*zxt - ddrt*(xcd*xcd+zcd*zcd))
            dyibzib = term * (zxt*xyt + ddrt*ycd*zcd)
            dyibxic = term * (zyt*zxt - ddrt*(ybd*xcd-zt) - dotz)
            dyibyic = term * (zxt*xzt + ddrt*(xbd*xcd+zbd*zcd))
            dyibzic = term * (yxt*zxt - ddrt*(ybd*zcd+xt) + dotx)
            dzibzib = term * (xyt*xyt - ddrt*(xcd*xcd+ycd*ycd))
            dzibxic = term * (zyt*xyt - ddrt*(zbd*xcd+yt) + doty)
            dzibyic = term * (xzt*xyt - ddrt*(zbd*ycd-xt) - dotx)
            dzibzic = term * (xyt*yxt + ddrt*(xbd*xcd+ybd*ycd))
            dxicxic = term * (zyt*zyt - ddrt*(ybd*ybd+zbd*zbd))
            dxicyic = term * (zyt*xzt + ddrt*xbd*ybd)
            dxiczic = term * (zyt*yxt + ddrt*xbd*zbd)
            dyicyic = term * (xzt*xzt - ddrt*(xbd*xbd+zbd*zbd))
            dyiczic = term * (xzt*yxt + ddrt*ybd*zbd)
            dziczic = term * (yxt*yxt - ddrt*(xbd*xbd+ybd*ybd))
c
c     get some second derivative chain rule terms by difference
c
            dxiaxid = -dxiaxia - dxiaxib - dxiaxic
            dxiayid = -dxiayia - dxiayib - dxiayic
            dxiazid = -dxiazia - dxiazib - dxiazic
            dyiaxid = -dxiayia - dyiaxib - dyiaxic
            dyiayid = -dyiayia - dyiayib - dyiayic
            dyiazid = -dyiazia - dyiazib - dyiazic
            dziaxid = -dxiazia - dziaxib - dziaxic
            dziayid = -dyiazia - dziayib - dziayic
            dziazid = -dziazia - dziazib - dziazic
            dxibxid = -dxiaxib - dxibxib - dxibxic
            dxibyid = -dyiaxib - dxibyib - dxibyic
            dxibzid = -dziaxib - dxibzib - dxibzic
            dyibxid = -dxiayib - dxibyib - dyibxic
            dyibyid = -dyiayib - dyibyib - dyibyic
            dyibzid = -dziayib - dyibzib - dyibzic
            dzibxid = -dxiazib - dxibzib - dzibxic
            dzibyid = -dyiazib - dyibzib - dzibyic
            dzibzid = -dziazib - dzibzib - dzibzic
            dxicxid = -dxiaxic - dxibxic - dxicxic
            dxicyid = -dyiaxic - dyibxic - dxicyic
            dxiczid = -dziaxic - dzibxic - dxiczic
            dyicxid = -dxiayic - dxibyic - dxicyic
            dyicyid = -dyiayic - dyibyic - dyicyic
            dyiczid = -dziayic - dzibyic - dyiczic
            dzicxid = -dxiazic - dxibzic - dxiczic
            dzicyid = -dyiazic - dyibzic - dyiczic
            dziczid = -dziazic - dzibzic - dziczic
            dxidxid = -dxiaxid - dxibxid - dxicxid
            dxidyid = -dxiayid - dxibyid - dxicyid
            dxidzid = -dxiazid - dxibzid - dxiczid
            dyidyid = -dyiayid - dyibyid - dyicyid
            dyidzid = -dyiazid - dyibzid - dyiczid
            dzidzid = -dziazid - dzibzid - dziczid
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (i .eq. ia) then
               hessx(1,ia) = hessx(1,ia) + dxiaxia
               hessy(1,ia) = hessy(1,ia) + dxiayia
               hessz(1,ia) = hessz(1,ia) + dxiazia
               hessx(2,ia) = hessx(2,ia) + dxiayia
               hessy(2,ia) = hessy(2,ia) + dyiayia
               hessz(2,ia) = hessz(2,ia) + dyiazia
               hessx(3,ia) = hessx(3,ia) + dxiazia
               hessy(3,ia) = hessy(3,ia) + dyiazia
               hessz(3,ia) = hessz(3,ia) + dziazia
               hessx(1,ib) = hessx(1,ib) + dxiaxib
               hessy(1,ib) = hessy(1,ib) + dyiaxib
               hessz(1,ib) = hessz(1,ib) + dziaxib
               hessx(2,ib) = hessx(2,ib) + dxiayib
               hessy(2,ib) = hessy(2,ib) + dyiayib
               hessz(2,ib) = hessz(2,ib) + dziayib
               hessx(3,ib) = hessx(3,ib) + dxiazib
               hessy(3,ib) = hessy(3,ib) + dyiazib
               hessz(3,ib) = hessz(3,ib) + dziazib
               hessx(1,ic) = hessx(1,ic) + dxiaxic
               hessy(1,ic) = hessy(1,ic) + dyiaxic
               hessz(1,ic) = hessz(1,ic) + dziaxic
               hessx(2,ic) = hessx(2,ic) + dxiayic
               hessy(2,ic) = hessy(2,ic) + dyiayic
               hessz(2,ic) = hessz(2,ic) + dziayic
               hessx(3,ic) = hessx(3,ic) + dxiazic
               hessy(3,ic) = hessy(3,ic) + dyiazic
               hessz(3,ic) = hessz(3,ic) + dziazic
               hessx(1,id) = hessx(1,id) + dxiaxid
               hessy(1,id) = hessy(1,id) + dyiaxid
               hessz(1,id) = hessz(1,id) + dziaxid
               hessx(2,id) = hessx(2,id) + dxiayid
               hessy(2,id) = hessy(2,id) + dyiayid
               hessz(2,id) = hessz(2,id) + dziayid
               hessx(3,id) = hessx(3,id) + dxiazid
               hessy(3,id) = hessy(3,id) + dyiazid
               hessz(3,id) = hessz(3,id) + dziazid
            else if (i .eq. ib) then
               hessx(1,ib) = hessx(1,ib) + dxibxib
               hessy(1,ib) = hessy(1,ib) + dxibyib
               hessz(1,ib) = hessz(1,ib) + dxibzib
               hessx(2,ib) = hessx(2,ib) + dxibyib
               hessy(2,ib) = hessy(2,ib) + dyibyib
               hessz(2,ib) = hessz(2,ib) + dyibzib
               hessx(3,ib) = hessx(3,ib) + dxibzib
               hessy(3,ib) = hessy(3,ib) + dyibzib
               hessz(3,ib) = hessz(3,ib) + dzibzib
               hessx(1,ia) = hessx(1,ia) + dxiaxib
               hessy(1,ia) = hessy(1,ia) + dxiayib
               hessz(1,ia) = hessz(1,ia) + dxiazib
               hessx(2,ia) = hessx(2,ia) + dyiaxib
               hessy(2,ia) = hessy(2,ia) + dyiayib
               hessz(2,ia) = hessz(2,ia) + dyiazib
               hessx(3,ia) = hessx(3,ia) + dziaxib
               hessy(3,ia) = hessy(3,ia) + dziayib
               hessz(3,ia) = hessz(3,ia) + dziazib
               hessx(1,ic) = hessx(1,ic) + dxibxic
               hessy(1,ic) = hessy(1,ic) + dyibxic
               hessz(1,ic) = hessz(1,ic) + dzibxic
               hessx(2,ic) = hessx(2,ic) + dxibyic
               hessy(2,ic) = hessy(2,ic) + dyibyic
               hessz(2,ic) = hessz(2,ic) + dzibyic
               hessx(3,ic) = hessx(3,ic) + dxibzic
               hessy(3,ic) = hessy(3,ic) + dyibzic
               hessz(3,ic) = hessz(3,ic) + dzibzic
               hessx(1,id) = hessx(1,id) + dxibxid
               hessy(1,id) = hessy(1,id) + dyibxid
               hessz(1,id) = hessz(1,id) + dzibxid
               hessx(2,id) = hessx(2,id) + dxibyid
               hessy(2,id) = hessy(2,id) + dyibyid
               hessz(2,id) = hessz(2,id) + dzibyid
               hessx(3,id) = hessx(3,id) + dxibzid
               hessy(3,id) = hessy(3,id) + dyibzid
               hessz(3,id) = hessz(3,id) + dzibzid
            else if (i .eq. ic) then
               hessx(1,ic) = hessx(1,ic) + dxicxic
               hessy(1,ic) = hessy(1,ic) + dxicyic
               hessz(1,ic) = hessz(1,ic) + dxiczic
               hessx(2,ic) = hessx(2,ic) + dxicyic
               hessy(2,ic) = hessy(2,ic) + dyicyic
               hessz(2,ic) = hessz(2,ic) + dyiczic
               hessx(3,ic) = hessx(3,ic) + dxiczic
               hessy(3,ic) = hessy(3,ic) + dyiczic
               hessz(3,ic) = hessz(3,ic) + dziczic
               hessx(1,ia) = hessx(1,ia) + dxiaxic
               hessy(1,ia) = hessy(1,ia) + dxiayic
               hessz(1,ia) = hessz(1,ia) + dxiazic
               hessx(2,ia) = hessx(2,ia) + dyiaxic
               hessy(2,ia) = hessy(2,ia) + dyiayic
               hessz(2,ia) = hessz(2,ia) + dyiazic
               hessx(3,ia) = hessx(3,ia) + dziaxic
               hessy(3,ia) = hessy(3,ia) + dziayic
               hessz(3,ia) = hessz(3,ia) + dziazic
               hessx(1,ib) = hessx(1,ib) + dxibxic
               hessy(1,ib) = hessy(1,ib) + dxibyic
               hessz(1,ib) = hessz(1,ib) + dxibzic
               hessx(2,ib) = hessx(2,ib) + dyibxic
               hessy(2,ib) = hessy(2,ib) + dyibyic
               hessz(2,ib) = hessz(2,ib) + dyibzic
               hessx(3,ib) = hessx(3,ib) + dzibxic
               hessy(3,ib) = hessy(3,ib) + dzibyic
               hessz(3,ib) = hessz(3,ib) + dzibzic
               hessx(1,id) = hessx(1,id) + dxicxid
               hessy(1,id) = hessy(1,id) + dyicxid
               hessz(1,id) = hessz(1,id) + dzicxid
               hessx(2,id) = hessx(2,id) + dxicyid
               hessy(2,id) = hessy(2,id) + dyicyid
               hessz(2,id) = hessz(2,id) + dzicyid
               hessx(3,id) = hessx(3,id) + dxiczid
               hessy(3,id) = hessy(3,id) + dyiczid
               hessz(3,id) = hessz(3,id) + dziczid
            else if (i .eq. id) then
               hessx(1,id) = hessx(1,id) + dxidxid
               hessy(1,id) = hessy(1,id) + dxidyid
               hessz(1,id) = hessz(1,id) + dxidzid
               hessx(2,id) = hessx(2,id) + dxidyid
               hessy(2,id) = hessy(2,id) + dyidyid
               hessz(2,id) = hessz(2,id) + dyidzid
               hessx(3,id) = hessx(3,id) + dxidzid
               hessy(3,id) = hessy(3,id) + dyidzid
               hessz(3,id) = hessz(3,id) + dzidzid
               hessx(1,ia) = hessx(1,ia) + dxiaxid
               hessy(1,ia) = hessy(1,ia) + dxiayid
               hessz(1,ia) = hessz(1,ia) + dxiazid
               hessx(2,ia) = hessx(2,ia) + dyiaxid
               hessy(2,ia) = hessy(2,ia) + dyiayid
               hessz(2,ia) = hessz(2,ia) + dyiazid
               hessx(3,ia) = hessx(3,ia) + dziaxid
               hessy(3,ia) = hessy(3,ia) + dziayid
               hessz(3,ia) = hessz(3,ia) + dziazid
               hessx(1,ib) = hessx(1,ib) + dxibxid
               hessy(1,ib) = hessy(1,ib) + dxibyid
               hessz(1,ib) = hessz(1,ib) + dxibzid
               hessx(2,ib) = hessx(2,ib) + dyibxid
               hessy(2,ib) = hessy(2,ib) + dyibyid
               hessz(2,ib) = hessz(2,ib) + dyibzid
               hessx(3,ib) = hessx(3,ib) + dzibxid
               hessy(3,ib) = hessy(3,ib) + dzibyid
               hessz(3,ib) = hessz(3,ib) + dzibzid
               hessx(1,ic) = hessx(1,ic) + dxicxid
               hessy(1,ic) = hessy(1,ic) + dxicyid
               hessz(1,ic) = hessz(1,ic) + dxiczid
               hessx(2,ic) = hessx(2,ic) + dyicxid
               hessy(2,ic) = hessy(2,ic) + dyicyid
               hessz(2,ic) = hessz(2,ic) + dyiczid
               hessx(3,ic) = hessx(3,ic) + dzicxid
               hessy(3,ic) = hessy(3,ic) + dzicyid
               hessz(3,ic) = hessz(3,ic) + dziczid
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine eopdist3  --  out-of-plane distance & analysis  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "eopdist3" computes the out-of-plane distance potential energy
c     at trigonal centers via the central atom height; also partitions
c     the energy among the atoms
c
c
      subroutine eopdist3
      use action
      use analyz
      use angpot
      use atomid
      use atoms
      use bound
      use energi
      use group
      use inform
      use iounit
      use opdist
      use usage
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,force,fgrp
      real*8 dt,dt2,dt3,dt4
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 xt,yt,zt,rt2
      logical proceed
      logical header,huge
c
c
c     zero out the out-of-plane distance energy and partitioning
c
      neopd = 0
      eopd = 0.0d0
      do i = 1, n
         aeopd(i) = 0.0d0
      end do
      if (nopdist .eq. 0)  return
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nopdist.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Out-of-Plane Distance Interactions :',
     &           //,' Type',25x,'Atom Names',18x,'Distance',
     &              6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nopdist,iopd,opdk,use,
!$OMP& x,y,z,copd,qopd,popd,sopd,opdunit,use_group,use_polymer,
!$OMP& name,verbose,debug,header,iout)
!$OMP& shared(eopd,neopd,aeopd)
!$OMP DO reduction(+:eopd,neopd,aeopd)
c
c     calculate the out-of-plane distance energy term
c
      do i = 1, nopdist
         ia = iopd(1,i)
         ib = iopd(2,i)
         ic = iopd(3,i)
         id = iopd(4,i)
         force = opdk(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     get the coordinates of the central and peripheral atoms
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)
c
c     compute the out-of-plane distance for central atom
c
            xad = xia - xid
            yad = yia - yid
            zad = zia - zid
            xbd = xib - xid
            ybd = yib - yid
            zbd = zib - zid
            xcd = xic - xid
            ycd = yic - yid
            zcd = zic - zid
            if (use_polymer) then
               call image (xad,yad,zad)
               call image (xbd,ybd,zbd)
               call image (xcd,ycd,zcd)
            end if
            xt = ybd*zcd - zbd*ycd
            yt = zbd*xcd - xbd*zcd
            zt = xbd*ycd - ybd*xcd
            rt2 = xt*xt + yt*yt + zt*zt
            dt2 = (xt*xad + yt*yad + zt*zad)**2 / rt2
            dt = sqrt(dt2)
            dt3 = dt2 * dt
            dt4 = dt2 * dt2
c
c     find the out-of-plane distance energy
c
            e = opdunit * force * dt2
     &             * (1.0d0+copd*dt+qopd*dt2+popd*dt3+sopd*dt4)
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total out-of-plane distance energy
c
            neopd = neopd + 1
            eopd = eopd + e
            aeopd(ia) = aeopd(ia) + e
c
c     print a message if the energy of this interaction is large
c
            huge = (e .gt. 5.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Individual Out-of-Plane Distance',
     &                       ' Interactions :',
     &                    //,' Type',25x,'Atom Names',18x,'Distance',
     &                       6x,'Energy',/)
               end if
               write (iout,30)  ia,name(ia),ib,name(ib),ic,
     &                          name(ic),id,name(id),dt,e
   30          format (' O-P-Dist',2x,4(i7,'-',a3),f11.4,f12.4)
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine epitors  --  pi-system torsion potential energy  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "epitors" calculates the pi-system torsion potential energy
c
c
      subroutine epitors
      use atoms
      use bound
      use energi
      use group
      use pitors
      use torpot
      use usage
      implicit none
      integer i,ia,ib,ic
      integer id,ie,ig
      real*8 e,rdc,fgrp
      real*8 xt,yt,zt,rt2
      real*8 xu,yu,zu,ru2
      real*8 xtu,ytu,ztu,rtru
      real*8 v2,c2,s2,phi2
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xie,yie,zie
      real*8 xig,yig,zig
      real*8 xip,yip,zip
      real*8 xiq,yiq,ziq
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xec,yec,zec
      real*8 xgc,ygc,zgc
      real*8 xcp,ycp,zcp
      real*8 xdc,ydc,zdc
      real*8 xqd,yqd,zqd
      logical proceed
c
c
c     zero out the pi-system torsion potential energy
c
      ept = 0.0d0
      if (npitors .eq. 0)  return
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npitors,ipit,
!$OMP& use,x,y,z,kpit,ptorunit,use_group,use_polymer)
!$OMP& shared(ept)
!$OMP DO reduction(+:ept)
c
c     calculate the pi-system torsion angle energy term
c
      do i = 1, npitors
         ia = ipit(1,i)
         ib = ipit(2,i)
         ic = ipit(3,i)
         id = ipit(4,i)
         ie = ipit(5,i)
         ig = ipit(6,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,ie,ig)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic) .or.
     &                              use(id) .or. use(ie) .or. use(ig))
c
c     compute the value of the pi-system torsion 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)
            xie = x(ie)
            yie = y(ie)
            zie = z(ie)
            xig = x(ig)
            yig = y(ig)
            zig = z(ig)
            xad = xia - xid
            yad = yia - yid
            zad = zia - zid
            xbd = xib - xid
            ybd = yib - yid
            zbd = zib - zid
            xec = xie - xic
            yec = yie - yic
            zec = zie - zic
            xgc = xig - xic
            ygc = yig - yic
            zgc = zig - zic
            if (use_polymer) then
               call image (xad,yad,zad)
               call image (xbd,ybd,zbd)
               call image (xec,yec,zec)
               call image (xgc,ygc,zgc)
            end if
            xip = yad*zbd - ybd*zad + xic
            yip = zad*xbd - zbd*xad + yic
            zip = xad*ybd - xbd*yad + zic
            xiq = yec*zgc - ygc*zec + xid
            yiq = zec*xgc - zgc*xec + yid
            ziq = xec*ygc - xgc*yec + zid
            xcp = xic - xip
            ycp = yic - yip
            zcp = zic - zip
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            xqd = xiq - xid
            yqd = yiq - yid
            zqd = ziq - zid
            if (use_polymer) then
               call image (xcp,ycp,zcp)
               call image (xdc,ydc,zdc)
               call image (xqd,yqd,zqd)
            end if
            xt = ycp*zdc - ydc*zcp
            yt = zcp*xdc - zdc*xcp
            zt = xcp*ydc - xdc*ycp
            xu = ydc*zqd - yqd*zdc
            yu = zdc*xqd - zqd*xdc
            zu = xdc*yqd - xqd*ydc
            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
               rdc = sqrt(xdc*xdc + ydc*ydc + zdc*zdc)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xdc*xtu + ydc*ytu + zdc*ztu) / (rdc*rtru)
c
c     set the pi-system torsion parameters for this angle
c
               v2 = kpit(i)
               c2 = -1.0d0
               s2 = 0.0d0
c
c     compute the multiple angle trigonometry and the phase terms
c
               cosine2 = cosine*cosine - sine*sine
               sine2 = 2.0d0 * cosine * sine
               phi2 = 1.0d0 + (cosine2*c2 + sine2*s2)
c
c     calculate the pi-system torsion energy for this angle
c
               e = ptorunit * v2 * phi2
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the total pi-system torsion angle energy
c
               ept = ept + e
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine epitors1  --  pi-system torsion energy & derivs  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "epitors1" calculates the pi-system torsion potential energy
c     and first derivatives with respect to Cartesian coordinates
c
c
      subroutine epitors1
      use atoms
      use bound
      use deriv
      use energi
      use group
      use pitors
      use torpot
      use usage
      use virial
      implicit none
      integer i,ia,ib,ic
      integer id,ie,ig
      real*8 e,dedphi,fgrp
      real*8 xt,yt,zt,rt2
      real*8 xu,yu,zu,ru2
      real*8 xtu,ytu,ztu
      real*8 rdc,rtru
      real*8 v2,c2,s2
      real*8 phi2,dphi2
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xie,yie,zie
      real*8 xig,yig,zig
      real*8 xip,yip,zip
      real*8 xiq,yiq,ziq
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xec,yec,zec
      real*8 xgc,ygc,zgc
      real*8 xcp,ycp,zcp
      real*8 xdc,ydc,zdc
      real*8 xqd,yqd,zqd
      real*8 xdp,ydp,zdp
      real*8 xqc,yqc,zqc
      real*8 dedxt,dedyt,dedzt
      real*8 dedxu,dedyu,dedzu
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 dedxie,dedyie,dedzie
      real*8 dedxig,dedyig,dedzig
      real*8 dedxip,dedyip,dedzip
      real*8 dedxiq,dedyiq,dedziq
      real*8 vxterm,vyterm,vzterm
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out the pi-system torsion energy and first derivatives
c
      ept = 0.0d0
      do i = 1, n
         dept(1,i) = 0.0d0
         dept(2,i) = 0.0d0
         dept(3,i) = 0.0d0
      end do
      if (npitors .eq. 0)  return
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npitors,ipit,
!$OMP& use,x,y,z,kpit,ptorunit,use_group,use_polymer)
!$OMP& shared(ept,dept,vir)
!$OMP DO reduction(+:ept,dept,vir)
c
c     calculate the pi-system torsion angle energy and derivatives
c
      do i = 1, npitors
         ia = ipit(1,i)
         ib = ipit(2,i)
         ic = ipit(3,i)
         id = ipit(4,i)
         ie = ipit(5,i)
         ig = ipit(6,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,ie,ig)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic) .or.
     &                              use(id) .or. use(ie) .or. use(ig))
c
c     compute the value of the pi-system torsion 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)
            xie = x(ie)
            yie = y(ie)
            zie = z(ie)
            xig = x(ig)
            yig = y(ig)
            zig = z(ig)
            xad = xia - xid
            yad = yia - yid
            zad = zia - zid
            xbd = xib - xid
            ybd = yib - yid
            zbd = zib - zid
            xec = xie - xic
            yec = yie - yic
            zec = zie - zic
            xgc = xig - xic
            ygc = yig - yic
            zgc = zig - zic
            if (use_polymer) then
               call image (xad,yad,zad)
               call image (xbd,ybd,zbd)
               call image (xec,yec,zec)
               call image (xgc,ygc,zgc)
            end if
            xip = yad*zbd - ybd*zad + xic
            yip = zad*xbd - zbd*xad + yic
            zip = xad*ybd - xbd*yad + zic
            xiq = yec*zgc - ygc*zec + xid
            yiq = zec*xgc - zgc*xec + yid
            ziq = xec*ygc - xgc*yec + zid
            xcp = xic - xip
            ycp = yic - yip
            zcp = zic - zip
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            xqd = xiq - xid
            yqd = yiq - yid
            zqd = ziq - zid
            if (use_polymer) then
               call image (xcp,ycp,zcp)
               call image (xdc,ydc,zdc)
               call image (xqd,yqd,zqd)
            end if
            xt = ycp*zdc - ydc*zcp
            yt = zcp*xdc - zdc*xcp
            zt = xcp*ydc - xdc*ycp
            xu = ydc*zqd - yqd*zdc
            yu = zdc*xqd - zqd*xdc
            zu = xdc*yqd - xqd*ydc
            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
               rdc = sqrt(xdc*xdc + ydc*ydc + zdc*zdc)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xdc*xtu + ydc*ytu + zdc*ztu) / (rdc*rtru)
c
c     set the pi-system torsion parameters for this angle
c
               v2 = kpit(i)
               c2 = -1.0d0
               s2 = 0.0d0
c
c     compute the multiple angle trigonometry and the phase terms
c
               cosine2 = cosine*cosine - sine*sine
               sine2 = 2.0d0 * cosine * sine
               phi2 = 1.0d0 + (cosine2*c2 + sine2*s2)
               dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2)
c
c     calculate pi-system torsion energy and master chain rule term
c
               e = ptorunit * v2 * phi2
               dedphi = ptorunit * v2 * dphi2
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     chain rule terms for first derivative components
c
               xdp = xid - xip
               ydp = yid - yip
               zdp = zid - zip
               xqc = xiq - xic
               yqc = yiq - yic
               zqc = ziq - zic
               dedxt = dedphi * (yt*zdc - ydc*zt) / (rt2*rdc)
               dedyt = dedphi * (zt*xdc - zdc*xt) / (rt2*rdc)
               dedzt = dedphi * (xt*ydc - xdc*yt) / (rt2*rdc)
               dedxu = -dedphi * (yu*zdc - ydc*zu) / (ru2*rdc)
               dedyu = -dedphi * (zu*xdc - zdc*xu) / (ru2*rdc)
               dedzu = -dedphi * (xu*ydc - xdc*yu) / (ru2*rdc)
c
c     compute first derivative components for pi-system angle
c
               dedxip = zdc*dedyt - ydc*dedzt
               dedyip = xdc*dedzt - zdc*dedxt
               dedzip = ydc*dedxt - xdc*dedyt
               dedxic = ydp*dedzt - zdp*dedyt + zqd*dedyu - yqd*dedzu
               dedyic = zdp*dedxt - xdp*dedzt + xqd*dedzu - zqd*dedxu
               dedzic = xdp*dedyt - ydp*dedxt + yqd*dedxu - xqd*dedyu
               dedxid = zcp*dedyt - ycp*dedzt + yqc*dedzu - zqc*dedyu
               dedyid = xcp*dedzt - zcp*dedxt + zqc*dedxu - xqc*dedzu
               dedzid = ycp*dedxt - xcp*dedyt + xqc*dedyu - yqc*dedxu
               dedxiq = zdc*dedyu - ydc*dedzu
               dedyiq = xdc*dedzu - zdc*dedxu
               dedziq = ydc*dedxu - xdc*dedyu
c
c     compute first derivative components for individual atoms
c
               dedxia = ybd*dedzip - zbd*dedyip
               dedyia = zbd*dedxip - xbd*dedzip
               dedzia = xbd*dedyip - ybd*dedxip
               dedxib = zad*dedyip - yad*dedzip
               dedyib = xad*dedzip - zad*dedxip
               dedzib = yad*dedxip - xad*dedyip
               dedxie = ygc*dedziq - zgc*dedyiq
               dedyie = zgc*dedxiq - xgc*dedziq
               dedzie = xgc*dedyiq - ygc*dedxiq
               dedxig = zec*dedyiq - yec*dedziq
               dedyig = xec*dedziq - zec*dedxiq
               dedzig = yec*dedxiq - xec*dedyiq
               dedxic = dedxic + dedxip - dedxie - dedxig
               dedyic = dedyic + dedyip - dedyie - dedyig
               dedzic = dedzic + dedzip - dedzie - dedzig
               dedxid = dedxid + dedxiq - dedxia - dedxib
               dedyid = dedyid + dedyiq - dedyia - dedyib
               dedzid = dedzid + dedziq - dedzia - dedzib
c
c     increment the total pi-system torsion energy and gradient
c
               ept = ept + e
               dept(1,ia) = dept(1,ia) + dedxia
               dept(2,ia) = dept(2,ia) + dedyia
               dept(3,ia) = dept(3,ia) + dedzia
               dept(1,ib) = dept(1,ib) + dedxib
               dept(2,ib) = dept(2,ib) + dedyib
               dept(3,ib) = dept(3,ib) + dedzib
               dept(1,ic) = dept(1,ic) + dedxic
               dept(2,ic) = dept(2,ic) + dedyic
               dept(3,ic) = dept(3,ic) + dedzic
               dept(1,id) = dept(1,id) + dedxid
               dept(2,id) = dept(2,id) + dedyid
               dept(3,id) = dept(3,id) + dedzid
               dept(1,ie) = dept(1,ie) + dedxie
               dept(2,ie) = dept(2,ie) + dedyie
               dept(3,ie) = dept(3,ie) + dedzie
               dept(1,ig) = dept(1,ig) + dedxig
               dept(2,ig) = dept(2,ig) + dedyig
               dept(3,ig) = dept(3,ig) + dedzig
c
c     increment the internal virial tensor components
c
               vxterm = dedxid + dedxia + dedxib
               vyterm = dedyid + dedyia + dedyib
               vzterm = dedzid + dedzia + dedzib
               vxx = xdc*vxterm + xcp*dedxip - xqd*dedxiq
               vyx = ydc*vxterm + ycp*dedxip - yqd*dedxiq
               vzx = zdc*vxterm + zcp*dedxip - zqd*dedxiq
               vyy = ydc*vyterm + ycp*dedyip - yqd*dedyiq
               vzy = zdc*vyterm + zcp*dedyip - zqd*dedyiq
               vzz = zdc*vzterm + zcp*dedzip - zqd*dedziq
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vyx
               vir(3,1) = vir(3,1) + vzx
               vir(1,2) = vir(1,2) + vyx
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vzy
               vir(1,3) = vir(1,3) + vzx
               vir(2,3) = vir(2,3) + vzy
               vir(3,3) = vir(3,3) + vzz
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine epitors2  --  pi-system torsion Hessian; numer  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "epitors2" calculates the second derivatives of the pi-system
c     torsion energy for a single atom using finite difference methods
c
c
      subroutine epitors2 (i)
      use angbnd
      use atoms
      use group
      use hessn
      use pitors
      use usage
      implicit none
      integer i,j,ipitors
      integer ia,ib,ic
      integer id,ie,ig
      real*8 eps,fgrp
      real*8 old,term
      real*8, allocatable :: de(:,:)
      real*8, allocatable :: d0(:,:)
      logical proceed
      logical twosided
c
c
c     set stepsize for derivatives and default group weight
c
      eps = 1.0d-5
      fgrp = 1.0d0
      twosided = .false.
      if (n .le. 50)  twosided = .true.
c
c     perform dynamic allocation of some local arrays
c
      allocate (de(3,n))
      allocate (d0(3,n))
c
c     calculate numerical pi-system torsion Hessian for current atom
c
      do ipitors = 1, npitors
         ia = ipit(1,ipitors)
         ib = ipit(2,ipitors)
         ic = ipit(3,ipitors)
         id = ipit(4,ipitors)
         ie = ipit(5,ipitors)
         ig = ipit(6,ipitors)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,ie,ig)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic) .or.
     &                              use(id) .or. use(ie) .or. use(ig))
         if (proceed) then
            term = fgrp / eps
c
c     find first derivatives for the base structure
c
            if (.not. twosided) then
               call epitors2a (ipitors,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
                  d0(j,ie) = de(j,ie)
                  d0(j,ig) = de(j,ig)
               end do
            end if
c
c     find numerical x-components via perturbed structures
c
            old = x(i)
            if (twosided) then
               x(i) = x(i) - 0.5d0*eps
               call epitors2a (ipitors,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
                  d0(j,ie) = de(j,ie)
                  d0(j,ig) = de(j,ig)
               end do
            end if
            x(i) = x(i) + eps
            call epitors2a (ipitors,de)
            x(i) = old
            do j = 1, 3
               hessx(j,ia) = hessx(j,ia) + term*(de(j,ia)-d0(j,ia))
               hessx(j,ib) = hessx(j,ib) + term*(de(j,ib)-d0(j,ib))
               hessx(j,ic) = hessx(j,ic) + term*(de(j,ic)-d0(j,ic))
               hessx(j,id) = hessx(j,id) + term*(de(j,id)-d0(j,id))
               hessx(j,ie) = hessx(j,ie) + term*(de(j,ie)-d0(j,ie))
               hessx(j,ig) = hessx(j,ig) + term*(de(j,ig)-d0(j,ig))
            end do
c
c     find numerical y-components via perturbed structures
c
            old = y(i)
            if (twosided) then
               y(i) = y(i) - 0.5d0*eps
               call epitors2a (ipitors,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
                  d0(j,ie) = de(j,ie)
                  d0(j,ig) = de(j,ig)
               end do
            end if
            y(i) = y(i) + eps
            call epitors2a (ipitors,de)
            y(i) = old
            do j = 1, 3
               hessy(j,ia) = hessy(j,ia) + term*(de(j,ia)-d0(j,ia))
               hessy(j,ib) = hessy(j,ib) + term*(de(j,ib)-d0(j,ib))
               hessy(j,ic) = hessy(j,ic) + term*(de(j,ic)-d0(j,ic))
               hessy(j,id) = hessy(j,id) + term*(de(j,id)-d0(j,id))
               hessy(j,ie) = hessy(j,ie) + term*(de(j,ie)-d0(j,ie))
               hessy(j,ig) = hessy(j,ig) + term*(de(j,ig)-d0(j,ig))
            end do
c
c     find numerical z-components via perturbed structures
c
            old = z(i)
            if (twosided) then
               z(i) = z(i) - 0.5d0*eps
               call epitors2a (ipitors,de)
               do j = 1, 3
                  d0(j,ia) = de(j,ia)
                  d0(j,ib) = de(j,ib)
                  d0(j,ic) = de(j,ic)
                  d0(j,id) = de(j,id)
                  d0(j,ie) = de(j,ie)
                  d0(j,ig) = de(j,ig)
               end do
            end if
            z(i) = z(i) + eps
            call epitors2a (ipitors,de)
            z(i) = old
            do j = 1, 3
               hessz(j,ia) = hessz(j,ia) + term*(de(j,ia)-d0(j,ia))
               hessz(j,ib) = hessz(j,ib) + term*(de(j,ib)-d0(j,ib))
               hessz(j,ic) = hessz(j,ic) + term*(de(j,ic)-d0(j,ic))
               hessz(j,id) = hessz(j,id) + term*(de(j,id)-d0(j,id))
               hessz(j,ie) = hessz(j,ie) + term*(de(j,ie)-d0(j,ie))
               hessz(j,ig) = hessz(j,ig) + term*(de(j,ig)-d0(j,ig))
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (d0)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine epitors2a  --  pi-system torsion derivatives  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "epitors2a" calculates the pi-system torsion first derivatives;
c     used in computation of finite difference second derivatives
c
c
      subroutine epitors2a (i,de)
      use atoms
      use bound
      use deriv
      use pitors
      use torpot
      implicit none
      integer i,ia,ib,ic
      integer id,ie,ig
      real*8 dedphi,dphi2
      real*8 xt,yt,zt,rt2
      real*8 xu,yu,zu,ru2
      real*8 xtu,ytu,ztu
      real*8 rdc,rtru
      real*8 v2,c2,s2
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xie,yie,zie
      real*8 xig,yig,zig
      real*8 xip,yip,zip
      real*8 xiq,yiq,ziq
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xec,yec,zec
      real*8 xgc,ygc,zgc
      real*8 xcp,ycp,zcp
      real*8 xdc,ydc,zdc
      real*8 xqd,yqd,zqd
      real*8 xdp,ydp,zdp
      real*8 xqc,yqc,zqc
      real*8 dedxt,dedyt,dedzt
      real*8 dedxu,dedyu,dedzu
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 dedxie,dedyie,dedzie
      real*8 dedxig,dedyig,dedzig
      real*8 dedxip,dedyip,dedzip
      real*8 dedxiq,dedyiq,dedziq
      real*8 de(3,*)
c
c
c     set the atom numbers for this pi-system torsion
c
      ia = ipit(1,i)
      ib = ipit(2,i)
      ic = ipit(3,i)
      id = ipit(4,i)
      ie = ipit(5,i)
      ig = ipit(6,i)
c
c     compute the value of the pi-system torsion angle
c
      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)
      xie = x(ie)
      yie = y(ie)
      zie = z(ie)
      xig = x(ig)
      yig = y(ig)
      zig = z(ig)
      xad = xia - xid
      yad = yia - yid
      zad = zia - zid
      xbd = xib - xid
      ybd = yib - yid
      zbd = zib - zid
      xec = xie - xic
      yec = yie - yic
      zec = zie - zic
      xgc = xig - xic
      ygc = yig - yic
      zgc = zig - zic
      if (use_polymer) then
         call image (xad,yad,zad)
         call image (xbd,ybd,zbd)
         call image (xec,yec,zec)
         call image (xgc,ygc,zgc)
      end if
      xip = yad*zbd - ybd*zad + xic
      yip = zad*xbd - zbd*xad + yic
      zip = xad*ybd - xbd*yad + zic
      xiq = yec*zgc - ygc*zec + xid
      yiq = zec*xgc - zgc*xec + yid
      ziq = xec*ygc - xgc*yec + zid
      xcp = xic - xip
      ycp = yic - yip
      zcp = zic - zip
      xdc = xid - xic
      ydc = yid - yic
      zdc = zid - zic
      xqd = xiq - xid
      yqd = yiq - yid
      zqd = ziq - zid
      if (use_polymer) then
         call image (xcp,ycp,zcp)
         call image (xdc,ydc,zdc)
         call image (xqd,yqd,zqd)
      end if
      xt = ycp*zdc - ydc*zcp
      yt = zcp*xdc - zdc*xcp
      zt = xcp*ydc - xdc*ycp
      xu = ydc*zqd - yqd*zdc
      yu = zdc*xqd - zqd*xdc
      zu = xdc*yqd - xqd*ydc
      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
         rdc = sqrt(xdc*xdc + ydc*ydc + zdc*zdc)
         cosine = (xt*xu + yt*yu + zt*zu) / rtru
         sine = (xdc*xtu + ydc*ytu + zdc*ztu) / (rdc*rtru)
c
c     set the pi-system torsion parameters for this angle
c
         v2 = kpit(i)
         c2 = -1.0d0
         s2 = 0.0d0
c
c     compute the multiple angle trigonometry and the phase terms
c
         cosine2 = cosine*cosine - sine*sine
         sine2 = 2.0d0 * cosine * sine
         dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2)
c
c     calculate pi-system torsion energy and master chain rule term
c
         dedphi = ptorunit * v2 * dphi2
c
c     chain rule terms for first derivative components
c
         xdp = xid - xip
         ydp = yid - yip
         zdp = zid - zip
         xqc = xiq - xic
         yqc = yiq - yic
         zqc = ziq - zic
         dedxt = dedphi * (yt*zdc - ydc*zt) / (rt2*rdc)
         dedyt = dedphi * (zt*xdc - zdc*xt) / (rt2*rdc)
         dedzt = dedphi * (xt*ydc - xdc*yt) / (rt2*rdc)
         dedxu = -dedphi * (yu*zdc - ydc*zu) / (ru2*rdc)
         dedyu = -dedphi * (zu*xdc - zdc*xu) / (ru2*rdc)
         dedzu = -dedphi * (xu*ydc - xdc*yu) / (ru2*rdc)
c
c     compute first derivative components for pi-system angle
c
         dedxip = zdc*dedyt - ydc*dedzt
         dedyip = xdc*dedzt - zdc*dedxt
         dedzip = ydc*dedxt - xdc*dedyt
         dedxic = ydp*dedzt - zdp*dedyt + zqd*dedyu - yqd*dedzu
         dedyic = zdp*dedxt - xdp*dedzt + xqd*dedzu - zqd*dedxu
         dedzic = xdp*dedyt - ydp*dedxt + yqd*dedxu - xqd*dedyu
         dedxid = zcp*dedyt - ycp*dedzt + yqc*dedzu - zqc*dedyu
         dedyid = xcp*dedzt - zcp*dedxt + zqc*dedxu - xqc*dedzu
         dedzid = ycp*dedxt - xcp*dedyt + xqc*dedyu - yqc*dedxu
         dedxiq = zdc*dedyu - ydc*dedzu
         dedyiq = xdc*dedzu - zdc*dedxu
         dedziq = ydc*dedxu - xdc*dedyu
c
c     compute first derivative components for individual atoms
c
         dedxia = ybd*dedzip - zbd*dedyip
         dedyia = zbd*dedxip - xbd*dedzip
         dedzia = xbd*dedyip - ybd*dedxip
         dedxib = zad*dedyip - yad*dedzip
         dedyib = xad*dedzip - zad*dedxip
         dedzib = yad*dedxip - xad*dedyip
         dedxie = ygc*dedziq - zgc*dedyiq
         dedyie = zgc*dedxiq - xgc*dedziq
         dedzie = xgc*dedyiq - ygc*dedxiq
         dedxig = zec*dedyiq - yec*dedziq
         dedyig = xec*dedziq - zec*dedxiq
         dedzig = yec*dedxiq - xec*dedyiq
         dedxic = dedxic + dedxip - dedxie - dedxig
         dedyic = dedyic + dedyip - dedyie - dedyig
         dedzic = dedzic + dedzip - dedzie - dedzig
         dedxid = dedxid + dedxiq - dedxia - dedxib
         dedyid = dedyid + dedyiq - dedyia - dedyib
         dedzid = dedzid + dedziq - dedzia - dedzib
c
c     increment the total pi-system torsion energy and gradient
c
         de(1,ia) = dedxia
         de(2,ia) = dedyia
         de(3,ia) = dedzia
         de(1,ib) = dedxib
         de(2,ib) = dedyib
         de(3,ib) = dedzib
         de(1,ic) = dedxic
         de(2,ic) = dedyic
         de(3,ic) = dedzic
         de(1,id) = dedxid
         de(2,id) = dedyid
         de(3,id) = dedzid
         de(1,ie) = dedxie
         de(2,ie) = dedyie
         de(3,ie) = dedzie
         de(1,ig) = dedxig
         de(2,ig) = dedyig
         de(3,ig) = dedzig
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###################################################################
c     ##                                                               ##
c     ##  subroutine epitors3  --  pi-system torsion potential energy  ##
c     ##                                                               ##
c     ###################################################################
c
c
c     "epitors3" calculates the pi-system torsion potential energy;
c     also partitions the energy terms among the atoms
c
c
      subroutine epitors3
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use energi
      use group
      use inform
      use iounit
      use math
      use pitors
      use torpot
      use usage
      implicit none
      integer i,ia,ib,ic
      integer id,ie,ig
      real*8 e,rdc
      real*8 angle,fgrp
      real*8 xt,yt,zt,rt2
      real*8 xu,yu,zu,ru2
      real*8 xtu,ytu,ztu,rtru
      real*8 v2,c2,s2,phi2
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xie,yie,zie
      real*8 xig,yig,zig
      real*8 xip,yip,zip
      real*8 xiq,yiq,ziq
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xec,yec,zec
      real*8 xgc,ygc,zgc
      real*8 xcp,ycp,zcp
      real*8 xdc,ydc,zdc
      real*8 xqd,yqd,zqd
      logical proceed
      logical header,huge
c
c
c     zero out the pi-system torsion energy and partitioning terms
c
      nept = 0
      ept = 0.0d0
      do i = 1, n
         aept(i) = 0.0d0
      end do
      if (npitors .eq. 0)  return
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. npitors.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Pi-System Torsion Interactions :',
     &           //,' Type',14x,'Atom Names',32x,'Angle',
     &              6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npitors,ipit,
!$OMP& use,x,y,z,kpit,ptorunit,use_group,use_polymer,
!$OMP& name,verbose,debug,header,iout)
!$OMP& shared(ept,nept,aept)
!$OMP DO reduction(+:ept,nept,aept)
c
c     calculate the pi-system torsion angle energy term
c
      do i = 1, npitors
         ia = ipit(1,i)
         ib = ipit(2,i)
         ic = ipit(3,i)
         id = ipit(4,i)
         ie = ipit(5,i)
         ig = ipit(6,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,ie,ig)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic) .or.
     &                              use(id) .or. use(ie) .or. use(ig))
c
c     compute the value of the pi-system torsion 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)
            xie = x(ie)
            yie = y(ie)
            zie = z(ie)
            xig = x(ig)
            yig = y(ig)
            zig = z(ig)
            xad = xia - xid
            yad = yia - yid
            zad = zia - zid
            xbd = xib - xid
            ybd = yib - yid
            zbd = zib - zid
            xec = xie - xic
            yec = yie - yic
            zec = zie - zic
            xgc = xig - xic
            ygc = yig - yic
            zgc = zig - zic
            if (use_polymer) then
               call image (xad,yad,zad)
               call image (xbd,ybd,zbd)
               call image (xec,yec,zec)
               call image (xgc,ygc,zgc)
            end if
            xip = yad*zbd - ybd*zad + xic
            yip = zad*xbd - zbd*xad + yic
            zip = xad*ybd - xbd*yad + zic
            xiq = yec*zgc - ygc*zec + xid
            yiq = zec*xgc - zgc*xec + yid
            ziq = xec*ygc - xgc*yec + zid
            xcp = xic - xip
            ycp = yic - yip
            zcp = zic - zip
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            xqd = xiq - xid
            yqd = yiq - yid
            zqd = ziq - zid
            if (use_polymer) then
               call image (xcp,ycp,zcp)
               call image (xdc,ydc,zdc)
               call image (xqd,yqd,zqd)
            end if
            xt = ycp*zdc - ydc*zcp
            yt = zcp*xdc - zdc*xcp
            zt = xcp*ydc - xdc*ycp
            xu = ydc*zqd - yqd*zdc
            yu = zdc*xqd - zqd*xdc
            zu = xdc*yqd - xqd*ydc
            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
               rdc = sqrt(xdc*xdc + ydc*ydc + zdc*zdc)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xdc*xtu + ydc*ytu + zdc*ztu) / (rdc*rtru)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               if (sine .lt. 0.0d0)  angle = -angle
               if (angle .gt. 90.0d0)  angle = angle - 180.0d0
               if (angle .lt. -90.0d0)  angle = angle + 180.0d0
c
c     set the pi-system torsion parameters for this angle
c
               v2 = kpit(i)
               c2 = -1.0d0
               s2 = 0.0d0
c
c     compute the multiple angle trigonometry and the phase terms
c
               cosine2 = cosine*cosine - sine*sine
               sine2 = 2.0d0 * cosine * sine
               phi2 = 1.0d0 + (cosine2*c2 + sine2*s2)
c
c     calculate the pi-system torsion energy for this angle
c
               e = ptorunit * v2 * phi2
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the total pi-system torsion angle energy
c
               nept = nept + 1
               ept = ept + e
               aept(ic) = aept(ic) + 0.5d0*e
               aept(id) = aept(id) + 0.5d0*e
c
c     print a message if the energy of this interaction is large
c
               huge = (e .gt. 5.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual Pi-System Torsion',
     &                          ' Interactions :',
     &                       //,' Type',14x,'Atom Names',32x,'Angle',
     &                          6x,'Energy',/)
                  end if
                  write (iout,30)  ic,name(ic),id,name(id),angle,e
   30             format (' PiTors',4x,2(i7,'-',a3),23x,f10.4,f12.4)
               end if
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##################################################
c     ##  COPYRIGHT (C) 2015  by  Jay William Ponder  ##
c     ##              All Rights Reserved             ##
c     ##################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine epolar  --  induced dipole polarization energy  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "epolar" calculates the polarization energy due to induced
c     dipole interactions
c
c
      subroutine epolar
      use limits
      implicit none
      logical pairwise
c
c
c     choose the method to sum over polarization interactions
c
      pairwise = .false.
      if (pairwise) then
         if (use_ewald) then
            if (use_mlist) then
               call epolar0d
            else
               call epolar0c
            end if
         else
            if (use_mlist) then
               call epolar0b
            else
               call epolar0a
            end if
         end if
      else
         call epolar0e
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine epolar0a  --  double loop polarization energy  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "epolar0a" calculates the induced dipole polarization energy
c     using a double loop, and partitions the energy among atoms
c
c
      subroutine epolar0a
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use energi
      use extfld
      use mplpot
      use mpole
      use polar
      use polgrp
      use polpot
      use potent
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 e,f,scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr3,rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 dir,diu,qiu,uir
      real*8 dkr,dku,qku,ukr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 dmpi(7),dmpk(7)
      real*8 dmpik(7)
      real*8, allocatable :: pscale(:)
      character*6 mode
c
c
c     zero out the total induced dipole polarization energy
c
      ep = 0.0d0
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     compute the dipole polarization energy component
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               diu = dix*ukx + diy*uky + diz*ukz
               qiu = qix*ukx + qiy*uky + qiz*ukz
               uir = uix*xr + uiy*yr + uiz*zr
               dku = dkx*uix + dky*uiy + dkz*uiz
               qku = qkx*uix + qky*uiy + qkz*uiz
               ukr = ukx*xr + uky*yr + ukz*zr
c
c     find the energy value for Thole polarization damping
c
               if (use_thole) then
                  call damptholed (i,k,7,r,dmpik)
                  scalek = pscale(k)
                  rr3 = f * scalek / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3 = dmpik(3) * rr3
                  rr5 = dmpik(5) * rr5
                  rr7 = dmpik(7) * rr7
                  term1 = ck*uir - ci*ukr + diu + dku
                  term2 = 2.0d0*(qiu-qku) - uir*dkr - dir*ukr
                  term3 = uir*qkr - ukr*qir
                  e = term1*rr3 + term2*rr5 + term3*rr7
c
c     find the energy value for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampdir (r,alphai,alphak,dmpi,dmpk)
                  scalek = pscale(k)
                  rr3 = f * scalek / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpi(3) * rr3
                  rr5i = dmpi(5) * rr5
                  rr7i = dmpi(7) * rr7
                  rr3k = dmpk(3) * rr3
                  rr5k = dmpk(5) * rr5
                  rr7k = dmpk(7) * rr7
                  e = uir*(corek*rr3+valk*rr3k)
     &                   - ukr*(corei*rr3+vali*rr3i)
     &                   + diu*rr3i + dku*rr3k
     &                   + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                   - dkr*uir*rr5k - dir*ukr*rr5i
     &                   + qkr*uir*rr7k - qir*ukr*rr7i
               end if
c
c     increment the overall polarization energy components
c
               ep = ep + e
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ci = rpole(1,i)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            qixx = rpole(5,i)
            qixy = rpole(6,i)
            qixz = rpole(7,i)
            qiyy = rpole(9,i)
            qiyz = rpole(10,i)
            qizz = rpole(13,i)
            uix = uind(1,i)
            uiy = uind(2,i)
            uiz = uind(3,i)
            if (use_chgpen) then
               corei = pcore(i)
               vali = pval(i)
               alphai = palpha(i)
            end if
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               do jcell = 2, ncell
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  if (use_bounds)  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (.not. (use_polymer .and. r2.le.polycut2))
     &               pscale(k) = 1.0d0
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     ck = rpole(1,k)
                     dkx = rpole(2,k)
                     dky = rpole(3,k)
                     dkz = rpole(4,k)
                     qkxx = rpole(5,k)
                     qkxy = rpole(6,k)
                     qkxz = rpole(7,k)
                     qkyy = rpole(9,k)
                     qkyz = rpole(10,k)
                     qkzz = rpole(13,k)
                     ukx = uind(1,k)
                     uky = uind(2,k)
                     ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
                     dir = dix*xr + diy*yr + diz*zr
                     qix = qixx*xr + qixy*yr + qixz*zr
                     qiy = qixy*xr + qiyy*yr + qiyz*zr
                     qiz = qixz*xr + qiyz*yr + qizz*zr
                     qir = qix*xr + qiy*yr + qiz*zr
                     dkr = dkx*xr + dky*yr + dkz*zr
                     qkx = qkxx*xr + qkxy*yr + qkxz*zr
                     qky = qkxy*xr + qkyy*yr + qkyz*zr
                     qkz = qkxz*xr + qkyz*yr + qkzz*zr
                     qkr = qkx*xr + qky*yr + qkz*zr
                     diu = dix*ukx + diy*uky + diz*ukz
                     qiu = qix*ukx + qiy*uky + qiz*ukz
                     uir = uix*xr + uiy*yr + uiz*zr
                     dku = dkx*uix + dky*uiy + dkz*uiz
                     qku = qkx*uix + qky*uiy + qkz*uiz
                     ukr = ukx*xr + uky*yr + ukz*zr
c
c     find the energy value for Thole polarization damping
c
                     if (use_thole) then
                        call damptholed (i,k,7,r,dmpik)
                        scalek = pscale(k)
                        rr3 = f * scalek / (r*r2)
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr3 = dmpik(3) * rr3
                        rr5 = dmpik(5) * rr5
                        rr7 = dmpik(7) * rr7
                        term1 = ck*uir - ci*ukr + diu + dku
                        term2 = 2.0d0*(qiu-qku) - uir*dkr - dir*ukr
                        term3 = uir*qkr - ukr*qir
                        e = term1*rr3 + term2*rr5 + term3*rr7
c
c     find the energy value for charge penetration damping
c
                     else if (use_chgpen) then
                        corek = pcore(k)
                        valk = pval(k)
                        alphak = palpha(k)
                        call dampdir (r,alphai,alphak,dmpi,dmpk)
                        scalek = pscale(k)
                        rr3 = f * scalek / (r*r2)
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr3i = dmpi(3) * rr3
                        rr5i = dmpi(5) * rr5
                        rr7i = dmpi(7) * rr7
                        rr3k = dmpk(3) * rr3
                        rr5k = dmpk(5) * rr5
                        rr7k = dmpk(7) * rr7
                        e = uir*(corek*rr3+valk*rr3k)
     &                         - ukr*(corei*rr3+vali*rr3i)
     &                         + diu*rr3i + dku*rr3k
     &                         + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                         - dkr*uir*rr5k - dir*ukr*rr5i
     &                         + qkr*uir*rr7k - qir*ukr*rr7i
                     end if
c
c     increment the overall polarization energy components
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ep = ep + e
                  end if
               end do
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     increment polarization energy due to external field
c
      if (use_exfld) then
         do i = 1, npole
            e = 0.0d0
            do j = 1, 3
               e = e - f*uind(j,i)*exfld(j)
            end do
            ep = ep + e
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine epolar0b  --  neighbor list polarization energy  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "epolar0b" calculates the induced dipole polarization energy
c     using a neighbor list
c
c
      subroutine epolar0b
      use atoms
      use bound
      use chgpen
      use chgpot
      use couple
      use energi
      use extfld
      use mplpot
      use mpole
      use neigh
      use polar
      use polgrp
      use polpot
      use potent
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      real*8 e,f,scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr3,rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 dir,diu,qiu,uir
      real*8 dkr,dku,qku,ukr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 dmpi(7),dmpk(7)
      real*8 dmpik(7)
      real*8, allocatable :: pscale(:)
      character*6 mode
c
c
c     zero out the total polarization energy and partitioning
c
      ep = 0.0d0
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,rpole,x,y,z,pcore,pval,palpha,uind,n12,i12,
!$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14,
!$OMP& p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale,
!$OMP& p5iscale,nelst,elst,use_thole,use_chgpen,use_bounds,f,off2,
!$OMP& exfld,use_exfld)
!$OMP& firstprivate(pscale) shared (ep)
!$OMP DO reduction(+:ep)
c
c     compute the dipole polarization energy component
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               diu = dix*ukx + diy*uky + diz*ukz
               qiu = qix*ukx + qiy*uky + qiz*ukz
               uir = uix*xr + uiy*yr + uiz*zr
               dku = dkx*uix + dky*uiy + dkz*uiz
               qku = qkx*uix + qky*uiy + qkz*uiz
               ukr = ukx*xr + uky*yr + ukz*zr
c
c     find the energy value for Thole polarization damping
c
               if (use_thole) then
                  call damptholed (i,k,7,r,dmpik)
                  scalek = pscale(k)
                  rr3 = f * scalek / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3 = dmpik(3) * rr3
                  rr5 = dmpik(5) * rr5
                  rr7 = dmpik(7) * rr7
                  term1 = ck*uir - ci*ukr + diu + dku
                  term2 = 2.0d0*(qiu-qku) - uir*dkr - dir*ukr
                  term3 = uir*qkr - ukr*qir
                  e = term1*rr3 + term2*rr5 + term3*rr7
c
c     find the energy value for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampdir (r,alphai,alphak,dmpi,dmpk)
                  scalek = pscale(k)
                  rr3 = f * scalek / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpi(3) * rr3
                  rr5i = dmpi(5) * rr5
                  rr7i = dmpi(7) * rr7
                  rr3k = dmpk(3) * rr3
                  rr5k = dmpk(5) * rr5
                  rr7k = dmpk(7) * rr7
                  e = uir*(corek*rr3+valk*rr3k)
     &                   - ukr*(corei*rr3+vali*rr3i)
     &                   + diu*rr3i + dku*rr3k
     &                   + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                   - dkr*uir*rr5k - dir*ukr*rr5i
     &                   + qkr*uir*rr7k - qir*ukr*rr7i
               end if
c
c     increment the overall polarization energy components
c
               ep = ep + e
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
c
c     increment polarization energy due to external field
c
      if (use_exfld) then
!$OMP    DO reduction(+:ep)
         do i = 1, npole
            e = 0.0d0
            do j = 1, 3
               e = e - f*uind(j,i)*exfld(j)
            end do
            ep = ep + e
         end do
!$OMP    END DO
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     ###################################################################
c     ##                                                               ##
c     ##  subroutine epolar0c  --  Ewald polarization derivs via loop  ##
c     ##                                                               ##
c     ###################################################################
c
c
c     "epolar0c" calculates the dipole polarization energy with respect
c     to Cartesian coordinates using particle mesh Ewald summation and
c     a double loop
c
c
      subroutine epolar0c
      use atoms
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use mpole
      use pme
      use polar
      use polpot
      use potent
      implicit none
      integer i,ii
      real*8 e,f,term,fterm
      real*8 dix,diy,diz
      real*8 uix,uiy,uiz,uii
      real*8 xd,yd,zd
      real*8 xu,yu,zu
c
c
c     zero out the polarization energy and derivatives
c
      ep = 0.0d0
      if (npole .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bsporder
      aewald = apewald
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     compute the real space part of the Ewald summation
c
      call epreal0c
c
c     compute the reciprocal space part of the Ewald summation
c
      call eprecip
c
c     compute the Ewald self-energy term over all the atoms
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / rootpi
      do ii = 1, npole
         i = ipole(ii)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         uii = dix*uix + diy*uiy + diz*uiz
         e = fterm * term * uii / 3.0d0
         ep = ep + e
      end do
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         xu = 0.0d0
         yu = 0.0d0
         zu = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            xd = xd + rpole(2,i) + rpole(1,i)*x(i)
            yd = yd + rpole(3,i) + rpole(1,i)*y(i)
            zd = zd + rpole(4,i) + rpole(1,i)*z(i)
            xu = xu + uind(1,i)
            yu = yu + uind(2,i)
            zu = zu + uind(3,i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         ep = ep + term*(xd*xu+yd*yu+zd*zu)
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine epreal0c  --  real space polar energy via loop  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "epreal0c" calculates the induced dipole polarization energy
c     using particle mesh Ewald summation and a double loop
c
c
      subroutine epreal0c
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use energi
      use extfld
      use math
      use mplpot
      use mpole
      use polar
      use polgrp
      use polpot
      use potent
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk,jcell
      real*8 e,f,scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 sr3,sr5,sr7
      real*8 r,r2,rr3,rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 dir,diu,qiu,uir
      real*8 dkr,dku,qku,ukr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 dmpi(7),dmpk(7)
      real*8 dmpik(7),dmpe(7)
      real*8, allocatable :: pscale(:)
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     compute the dipole polarization energy component
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               diu = dix*ukx + diy*uky + diz*ukz
               qiu = qix*ukx + qiy*uky + qiz*ukz
               uir = uix*xr + uiy*yr + uiz*zr
               dku = dkx*uix + dky*uiy + dkz*uiz
               qku = qkx*uix + qky*uiy + qkz*uiz
               ukr = ukx*xr + uky*yr + ukz*zr
c
c     calculate real space Ewald error function damping
c
               call dampewald (7,r,r2,f,dmpe)
c
c     find the energy value for Thole polarization damping
c
               if (use_thole) then
                  call damptholed (i,k,7,r,dmpik)
                  scalek = pscale(k)
                  rr3 = f / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  sr3 = dmpik(3) * rr3
                  sr5 = dmpik(5) * rr5
                  sr7 = dmpik(7) * rr7
                  sr3 = dmpe(3) - rr3 + sr3
                  sr5 = dmpe(5) - rr5 + sr5
                  sr7 = dmpe(7) - rr7 + sr7
                  term1 = ck*uir - ci*ukr + diu + dku
                  term2 = 2.0d0*(qiu-qku) - uir*dkr - dir*ukr
                  term3 = uir*qkr - ukr*qir
                  e = term1*sr3 + term2*sr5 + term3*sr7
c
c     find the energy value for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampdir (r,alphai,alphak,dmpi,dmpk)
                  scalek = pscale(k)
                  rr3 = f * scalek / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpi(3) * rr3
                  rr5i = dmpi(5) * rr5
                  rr7i = dmpi(7) * rr7
                  rr3k = dmpk(3) * rr3
                  rr5k = dmpk(5) * rr5
                  rr7k = dmpk(7) * rr7
                  rr3 = f / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpe(3) - rr3 + rr3i
                  rr5i = dmpe(5) - rr5 + rr5i
                  rr7i = dmpe(7) - rr7 + rr7i
                  rr3k = dmpe(3) - rr3 + rr3k
                  rr5k = dmpe(5) - rr5 + rr5k
                  rr7k = dmpe(7) - rr7 + rr7k
                  rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                  e = uir*(corek*rr3+valk*rr3k)
     &                   - ukr*(corei*rr3+vali*rr3i)
     &                   + diu*rr3i + dku*rr3k
     &                   + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                   - dkr*uir*rr5k - dir*ukr*rr5i
     &                   + qkr*uir*rr7k - qir*ukr*rr7i
               end if
c
c     compute the energy contribution for this interaction
c
               ep = ep + e
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ci = rpole(1,i)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            qixx = rpole(5,i)
            qixy = rpole(6,i)
            qixz = rpole(7,i)
            qiyy = rpole(9,i)
            qiyz = rpole(10,i)
            qizz = rpole(13,i)
            uix = uind(1,i)
            uiy = uind(2,i)
            uiz = uind(3,i)
            if (use_chgpen) then
               corei = pcore(i)
               vali = pval(i)
               alphai = palpha(i)
            end if
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               do jcell = 2, ncell
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  if (use_bounds)  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (.not. (use_polymer .and. r2.le.polycut2)) then
                     pscale(k) = 1.0d0
                  end if
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     ck = rpole(1,k)
                     dkx = rpole(2,k)
                     dky = rpole(3,k)
                     dkz = rpole(4,k)
                     qkxx = rpole(5,k)
                     qkxy = rpole(6,k)
                     qkxz = rpole(7,k)
                     qkyy = rpole(9,k)
                     qkyz = rpole(10,k)
                     qkzz = rpole(13,k)
                     ukx = uind(1,k)
                     uky = uind(2,k)
                     ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
                     dir = dix*xr + diy*yr + diz*zr
                     qix = qixx*xr + qixy*yr + qixz*zr
                     qiy = qixy*xr + qiyy*yr + qiyz*zr
                     qiz = qixz*xr + qiyz*yr + qizz*zr
                     qir = qix*xr + qiy*yr + qiz*zr
                     dkr = dkx*xr + dky*yr + dkz*zr
                     qkx = qkxx*xr + qkxy*yr + qkxz*zr
                     qky = qkxy*xr + qkyy*yr + qkyz*zr
                     qkz = qkxz*xr + qkyz*yr + qkzz*zr
                     qkr = qkx*xr + qky*yr + qkz*zr
                     diu = dix*ukx + diy*uky + diz*ukz
                     qiu = qix*ukx + qiy*uky + qiz*ukz
                     uir = uix*xr + uiy*yr + uiz*zr
                     dku = dkx*uix + dky*uiy + dkz*uiz
                     qku = qkx*uix + qky*uiy + qkz*uiz
                     ukr = ukx*xr + uky*yr + ukz*zr
c
c     calculate real space Ewald error function damping
c
                     call dampewald (7,r,r2,f,dmpe)
c
c     find the energy value for Thole polarization damping
c
                     if (use_thole) then
                        call damptholed (i,k,7,r,dmpik)
                        scalek = pscale(k)
                        rr3 = f / (r*r2)
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        sr3 = dmpik(3) * rr3
                        sr5 = dmpik(5) * rr5
                        sr7 = dmpik(7) * rr7
                        sr3 = dmpe(3) - rr3 + sr3
                        sr5 = dmpe(5) - rr5 + sr5
                        sr7 = dmpe(7) - rr7 + sr7
                        term1 = ck*uir - ci*ukr + diu + dku
                        term2 = 2.0d0*(qiu-qku) - uir*dkr - dir*ukr
                        term3 = uir*qkr - ukr*qir
                        e = term1*sr3 + term2*sr5 + term3*sr7
c
c     find the energy value for charge penetration damping
c
                     else if (use_chgpen) then
                        corek = pcore(k)
                        valk = pval(k)
                        alphak = palpha(k)
                        call dampdir (r,alphai,alphak,dmpi,dmpk)
                        scalek = pscale(k)
                        rr3 = f * scalek / (r*r2)
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr3i = dmpi(3) * rr3
                        rr5i = dmpi(5) * rr5
                        rr7i = dmpi(7) * rr7
                        rr3k = dmpk(3) * rr3
                        rr5k = dmpk(5) * rr5
                        rr7k = dmpk(7) * rr7
                        rr3 = f / (r*r2)
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr3i = dmpe(3) - rr3 + rr3i
                        rr5i = dmpe(5) - rr5 + rr5i
                        rr7i = dmpe(7) - rr7 + rr7i
                        rr3k = dmpe(3) - rr3 + rr3k
                        rr5k = dmpe(5) - rr5 + rr5k
                        rr7k = dmpe(7) - rr7 + rr7k
                        rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                        e = uir*(corek*rr3+valk*rr3k)
     &                         - ukr*(corei*rr3+vali*rr3i)
     &                         + diu*rr3i + dku*rr3k
     &                         + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                         - dkr*uir*rr5k - dir*ukr*rr5i
     &                         + qkr*uir*rr7k - qir*ukr*rr7i
                     end if
c
c     compute the energy contribution for this interaction
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ep = ep + e
                  end if
               end do
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     increment polarization energy due to external field
c
      if (use_exfld) then
         do i = 1, npole
            e = 0.0d0
            do j = 1, 3
               e = e - f*uind(j,i)*exfld(j)
            end do
            ep = ep + e
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     ###################################################################
c     ##                                                               ##
c     ##  subroutine epolar0d  --  Ewald polarization derivs via list  ##
c     ##                                                               ##
c     ###################################################################
c
c
c     "epolar0d" calculates the dipole polarization energy with respect
c     to Cartesian coordinates using particle mesh Ewald summation and
c     a neighbor list
c
c
      subroutine epolar0d
      use atoms
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use mpole
      use pme
      use polar
      use polpot
      use potent
      implicit none
      integer i,ii
      real*8 e,f,term,fterm
      real*8 dix,diy,diz
      real*8 uix,uiy,uiz,uii
      real*8 xd,yd,zd
      real*8 xu,yu,zu
c
c
c     zero out the polarization energy and derivatives
c
      ep = 0.0d0
      if (npole .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bsporder
      aewald = apewald
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     compute the real space part of the Ewald summation
c
      call epreal0d
c
c     compute the reciprocal space part of the Ewald summation
c
      call eprecip
c
c     compute the Ewald self-energy term over all the atoms
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / rootpi
      do ii = 1, npole
         i = ipole(ii)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         uii = dix*uix + diy*uiy + diz*uiz
         e = fterm * term * uii / 3.0d0
         ep = ep + e
      end do
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         xu = 0.0d0
         yu = 0.0d0
         zu = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            xd = xd + rpole(2,i) + rpole(1,i)*x(i)
            yd = yd + rpole(3,i) + rpole(1,i)*y(i)
            zd = zd + rpole(4,i) + rpole(1,i)*z(i)
            xu = xu + uind(1,i)
            yu = yu + uind(2,i)
            zu = zu + uind(3,i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         ep = ep + term*(xd*xu+yd*yu+zd*zu)
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine epreal0d  --  real space polar energy via list  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "epreal0d" calculates the induced dipole polarization energy
c     using particle mesh Ewald summation and a neighbor list
c
c
      subroutine epreal0d
      use atoms
      use bound
      use chgpen
      use chgpot
      use couple
      use energi
      use extfld
      use math
      use mplpot
      use mpole
      use neigh
      use polar
      use polgrp
      use polpot
      use potent
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      real*8 e,f,scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 sr3,sr5,sr7
      real*8 r,r2,rr3,rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 dir,diu,qiu,uir
      real*8 dkr,dku,qku,ukr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 dmpi(7),dmpk(7)
      real*8 dmpik(7),dmpe(7)
      real*8, allocatable :: pscale(:)
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,rpole,uind,x,y,z,pcore,pval,palpha,n12,i12,
!$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14,
!$OMP& p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale,
!$OMP& p5iscale,nelst,elst,use_thole,use_chgpen,use_bounds,off2,f,
!$OMP& exfld,use_exfld)
!$OMP& firstprivate(pscale) shared (ep)
!$OMP DO reduction(+:ep)
c
c     compute the dipole polarization energy component
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               diu = dix*ukx + diy*uky + diz*ukz
               qiu = qix*ukx + qiy*uky + qiz*ukz
               uir = uix*xr + uiy*yr + uiz*zr
               dku = dkx*uix + dky*uiy + dkz*uiz
               qku = qkx*uix + qky*uiy + qkz*uiz
               ukr = ukx*xr + uky*yr + ukz*zr
c
c     calculate real space Ewald error function damping
c
               call dampewald (7,r,r2,f,dmpe)
c
c     find the energy value for Thole polarization damping
c
               if (use_thole) then
                  call damptholed (i,k,7,r,dmpik)
                  scalek = pscale(k)
                  rr3 = f / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  sr3 = dmpik(3) * rr3
                  sr5 = dmpik(5) * rr5
                  sr7 = dmpik(7) * rr7
                  sr3 = dmpe(3) - rr3 + sr3
                  sr5 = dmpe(5) - rr5 + sr5
                  sr7 = dmpe(7) - rr7 + sr7
                  term1 = ck*uir - ci*ukr + diu + dku
                  term2 = 2.0d0*(qiu-qku) - uir*dkr - dir*ukr
                  term3 = uir*qkr - ukr*qir
                  e = term1*sr3 + term2*sr5 + term3*sr7
c
c     find the energy value for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampdir (r,alphai,alphak,dmpi,dmpk)
                  scalek = pscale(k)
                  rr3 = f * scalek / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpi(3) * rr3
                  rr5i = dmpi(5) * rr5
                  rr7i = dmpi(7) * rr7
                  rr3k = dmpk(3) * rr3
                  rr5k = dmpk(5) * rr5
                  rr7k = dmpk(7) * rr7
                  rr3 = f / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpe(3) - rr3 + rr3i
                  rr5i = dmpe(5) - rr5 + rr5i
                  rr7i = dmpe(7) - rr7 + rr7i
                  rr3k = dmpe(3) - rr3 + rr3k
                  rr5k = dmpe(5) - rr5 + rr5k
                  rr7k = dmpe(7) - rr7 + rr7k
                  rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                  e = uir*(corek*rr3+valk*rr3k)
     &                   - ukr*(corei*rr3+vali*rr3i)
     &                   + diu*rr3i + dku*rr3k
     &                   + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                   - dkr*uir*rr5k - dir*ukr*rr5i
     &                   + qkr*uir*rr7k - qir*ukr*rr7i
               end if
c
c     compute the energy contribution for this interaction
c
               ep = ep + e
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
c
c     increment polarization energy due to external field
c
      if (use_exfld) then
!$OMP    DO reduction(+:ep)
         do i = 1, npole
            e = 0.0d0
            do j = 1, 3
               e = e - f*uind(j,i)*exfld(j)
            end do
            ep = ep + e
         end do
!$OMP    END DO
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine epolar0e  --  single-loop polarization energy  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "epreal0e" calculates the induced dipole polarization energy
c     from the induced dipoles times the electric field
c
c
      subroutine epolar0e
      use atoms
      use boxes
      use chgpot
      use energi
      use ewald
      use limits
      use math
      use mpole
      use polar
      use polpot
      use potent
      implicit none
      integer i,j,ii
      real*8 e,f,fi,term
      real*8 xd,yd,zd
      real*8 xu,yu,zu
      real*8 dix,diy,diz
      real*8 uix,uiy,uiz
c
c
c     zero out the total polarization energy
c
      ep = 0.0d0
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     set the energy unit conversion factor
c
      f = -0.5d0 * electric / dielec
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private(ii,j,fi,e)
!$OMP DO reduction(+:ep)
c
c     get polarization energy via induced dipoles times field
c
      do ii = 1, npole
         i = ipole(ii)
         if (douind(i)) then
            fi = f / polarity(i)
            e = 0.0d0
            do j = 1, 3
               e = e + fi*uind(j,i)*udirp(j,i)
            end do
            ep = ep + e
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     compute the cell dipole boundary correction term
c
      if (use_ewald) then
         if (boundary .eq. 'VACUUM') then
            f = electric / dielec
            xd = 0.0d0
            yd = 0.0d0
            zd = 0.0d0
            xu = 0.0d0
            yu = 0.0d0
            zu = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               dix = rpole(2,i)
               diy = rpole(3,i)
               diz = rpole(4,i)
               uix = uind(1,i)
               uiy = uind(2,i)
               uiz = uind(3,i)
               xd = xd + dix + rpole(1,i)*x(i)
               yd = yd + diy + rpole(1,i)*y(i)
               zd = zd + diz + rpole(1,i)*z(i)
               xu = xu + uix
               yu = yu + uiy
               zu = zu + uiz
            end do
            term = (2.0d0/3.0d0) * f * (pi/volbox)
            e = term * (xd*xu+yd*yu+zd*zu)
            ep = ep + e
         end if
      end if
      return
      end
c
c
c     ###################################################################
c     ##                                                               ##
c     ##  subroutine eprecip  --  PME recip space polarization energy  ##
c     ##                                                               ##
c     ###################################################################
c
c
c     "eprecip" evaluates the reciprocal space portion of particle
c     mesh Ewald summation energy due to dipole polarization
c
c     literature reference:
c
c     C. Sagui, L. G. Pedersen and T. A. Darden, "Towards an Accurate
c     Representation of Electrostatics in Classical Force Fields:
c     Efficient Implementation of Multipolar Interactions in
c     Biomolecular Simulations", Journal of Chemical Physics, 120,
c     73-87 (2004)
c
c     modifications for nonperiodic systems suggested by Tom Darden
c     during May 2007
c
c
      subroutine eprecip
      use atoms
      use bound
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use mpole
      use mrecip
      use pme
      use polar
      use polpot
      use potent
      implicit none
      integer i,j,ii
      integer k1,k2,k3
      integer m1,m2,m3
      integer ntot,nff
      integer nf1,nf2,nf3
      real*8 e,r1,r2,r3
      real*8 f,h1,h2,h3
      real*8 volterm,denom
      real*8 hsq,expterm
      real*8 term,pterm
      real*8 a(3,3)
      real*8, allocatable :: fuind(:,:)
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      f = 0.5d0 * electric / dielec
c
c     perform dynamic allocation of some global arrays
c
      if (.not.use_mpole .or. aewald.ne.aeewald) then
         if (allocated(cmp)) then
            if (size(cmp) .lt. 10*n)  deallocate (cmp)
         end if
         if (allocated(fmp)) then
            if (size(fmp) .lt. 10*n)  deallocate (fmp)
         end if
         if (allocated(fphi)) then
            if (size(fphi) .lt. 20*n)  deallocate (fphi)
         end if
         if (.not. allocated(cmp))  allocate (cmp(10,n))
         if (.not. allocated(fmp))  allocate (fmp(10,n))
         if (.not. allocated(fphi))  allocate (fphi(20,n))
c
c     perform dynamic allocation of some global arrays
c
         ntot = nfft1 * nfft2 * nfft3
         if (allocated(qgrid)) then
            if (size(qgrid) .ne. 2*ntot)  call fftclose
         end if
         if (.not. allocated(qgrid))  call fftsetup
c
c     setup spatial decomposition and B-spline coefficients
c
         call getchunk
         call moduli
         call bspline_fill
         call table_fill
c
c     assign only the permanent multipoles to the PME grid
c     and perform the 3-D FFT forward transformation
c
         do ii = 1, npole
            i = ipole(ii)
            cmp(1,i) = rpole(1,i)
            cmp(2,i) = rpole(2,i)
            cmp(3,i) = rpole(3,i)
            cmp(4,i) = rpole(4,i)
            cmp(5,i) = rpole(5,i)
            cmp(6,i) = rpole(9,i)
            cmp(7,i) = rpole(13,i)
            cmp(8,i) = 2.0d0 * rpole(6,i)
            cmp(9,i) = 2.0d0 * rpole(7,i)
            cmp(10,i) = 2.0d0 * rpole(10,i)
         end do
         call cmp_to_fmp (cmp,fmp)
         call grid_mpole (fmp)
         call fftfront
c
c     make the scalar summation over reciprocal lattice
c
         pterm = (pi/aewald)**2
         volterm = pi * volbox
         nf1 = (nfft1+1) / 2
         nf2 = (nfft2+1) / 2
         nf3 = (nfft3+1) / 2
         nff = nfft1 * nfft2
         ntot = nff * nfft3
         do i = 1, ntot-1
            k3 = i/nff + 1
            j = i - (k3-1)*nff
            k2 = j/nfft1 + 1
            k1 = j - (k2-1)*nfft1 + 1
            m1 = k1 - 1
            m2 = k2 - 1
            m3 = k3 - 1
            if (k1 .gt. nf1)  m1 = m1 - nfft1
            if (k2 .gt. nf2)  m2 = m2 - nfft2
            if (k3 .gt. nf3)  m3 = m3 - nfft3
            r1 = dble(m1)
            r2 = dble(m2)
            r3 = dble(m3)
            h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
            h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
            h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
            hsq = h1*h1 + h2*h2 + h3*h3
            term = -pterm * hsq
            expterm = 0.0d0
            if (term .gt. -50.0d0) then
               denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
               expterm = exp(term) / denom
               if (.not. use_bounds) then
                  expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
               else if (nonprism) then
                  if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
               end if
            end if
            qgrid(1,k1,k2,k3) = expterm * qgrid(1,k1,k2,k3)
            qgrid(2,k1,k2,k3) = expterm * qgrid(2,k1,k2,k3)
         end do
c
c     account for zeroth grid point for nonperiodic system
c
         qgrid(1,1,1,1) = 0.0d0
         qgrid(2,1,1,1) = 0.0d0
         if (.not. use_bounds) then
            expterm = 0.5d0 * pi / xbox
            qgrid(1,1,1,1) = expterm * qgrid(1,1,1,1)
            qgrid(2,1,1,1) = expterm * qgrid(2,1,1,1)
         end if
c
c     perform 3-D FFT backward transform and get potential
c
         call fftback
         call fphi_mpole (fphi)
      end if
c
c     set matrix for Cartesian to fractional induced dipoles
c
      do i = 1, 3
         a(1,i) = dble(nfft1) * recip(i,1)
         a(2,i) = dble(nfft2) * recip(i,2)
         a(3,i) = dble(nfft3) * recip(i,3)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (fuind(3,n))
c
c     increment the induced dipole polarization energy
c
      e = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            fuind(j,i) = a(j,1)*uind(1,i) + a(j,2)*uind(2,i)
     &                      + a(j,3)*uind(3,i)
            term = f * fuind(j,i) * fphi(j+1,i)
            e = e + term
         end do
      end do
      ep = ep + e
c
c     perform deallocation of some local arrays
c
      deallocate (fuind)
      return
      end
c
c
c     ##################################################
c     ##  COPYRIGHT (C) 2015  by  Jay William Ponder  ##
c     ##              All Rights Reserved             ##
c     ##################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine epolar1  --  polarization energy & derivs  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "epolar1" calculates the induced dipole polarization energy
c     and first derivatives with respect to Cartesian coordinates
c
c
      subroutine epolar1
      use iounit
      use limits
      use mplpot
      use polpot
      implicit none
c
c
c     check for use of TCG polarization with charge penetration
c
      if (poltyp.eq.'TCG' .and. use_chgpen) then
         write (iout,10)
   10    format (/,' EPOLAR1  --  TCG Polarization not Available',
     &              ' with Charge Penetration')
         call fatal
      end if
c
c     choose the method to sum over polarization interactions
c
      if (use_ewald) then
         if (use_mlist) then
            call epolar1d
         else
            call epolar1c
         end if
      else
         if (use_mlist) then
            call epolar1b
         else
            call epolar1a
         end if
      end if
c
c     modify the gradient and virial for exchange polarization
c
      if (use_expol) then
         call dexpol
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine epolar1a  --  double loop polarization derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "epolar1a" calculates the dipole polarization energy and
c     derivatives with respect to Cartesian coordinates using a
c     pairwise double loop
c
c
      subroutine epolar1a
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use deriv
      use energi
      use molcul
      use mplpot
      use mpole
      use polar
      use polgrp
      use polopt
      use polpot
      use poltcg
      use potent
      use shunt
      use virial
      implicit none
      integer i,j,k,m
      integer ii,kk,jcell
      integer ix,iy,iz
      integer it,kt
      real*8 f,pgamma
      real*8 pdi,pti,ddi
      real*8 damp,expdamp
      real*8 temp3,temp5,temp7
      real*8 sc3,sc5,sc7
      real*8 sr3,sr5,sr7
      real*8 psr3,psr5,psr7
      real*8 dsr3,dsr5,dsr7
      real*8 dsr3i,dsr5i,dsr7i
      real*8 dsr3k,dsr5k,dsr7k
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 uixp,uiyp,uizp
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 ukxp,ukyp,ukzp
      real*8 dir,uir,uirp
      real*8 dkr,ukr,ukrp
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 uirm,ukrm
      real*8 uirt,ukrt
      real*8 tuir,tukr
      real*8 tixx,tiyy,tizz
      real*8 tixy,tixz,tiyz
      real*8 tkxx,tkyy,tkzz
      real*8 tkxy,tkxz,tkyz
      real*8 tix3,tiy3,tiz3
      real*8 tix5,tiy5,tiz5
      real*8 tkx3,tky3,tkz3
      real*8 tkx5,tky5,tkz5
      real*8 term1,term2,term3
      real*8 term4,term5,term6
      real*8 term7,term8
      real*8 term1core
      real*8 term1i,term2i,term3i
      real*8 term4i,term5i,term6i
      real*8 term7i,term8i
      real*8 term1k,term2k,term3k
      real*8 term4k,term5k,term6k
      real*8 term7k,term8k
      real*8 poti,potk
      real*8 depx,depy,depz
      real*8 frcx,frcy,frcz
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 rc3(3),rc5(3),rc7(3)
      real*8 tep(3),fix(3)
      real*8 fiy(3),fiz(3)
      real*8 uax(3),uay(3),uaz(3)
      real*8 ubx(3),uby(3),ubz(3)
      real*8 uaxp(3),uayp(3),uazp(3)
      real*8 ubxp(3),ubyp(3),ubzp(3)
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9)
      real*8, allocatable :: pscale(:)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: wscale(:)
      real*8, allocatable :: ufld(:,:)
      real*8, allocatable :: dufld(:,:)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
      character*6 mode
c
c
c     zero out the polarization energy and derivatives
c
      ep = 0.0d0
      do i = 1, n
         do j = 1, 3
            dep(j,i) = 0.0d0
         end do
      end do
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     compute the total induced dipole polarization energy
c
      call epolar1e
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
      allocate (dscale(n))
      allocate (uscale(n))
      allocate (wscale(n))
      allocate (ufld(3,n))
      allocate (dufld(6,n))
      allocate (pot(n))
      allocate (decfx(n))
      allocate (decfy(n))
      allocate (decfz(n))
c
c     set exclusion coefficients and arrays to store fields
c
      do i = 1, n
         pscale(i) = 1.0d0
         dscale(i) = 1.0d0
         uscale(i) = 1.0d0
         wscale(i) = 1.0d0
         do j = 1, 3
            ufld(j,i) = 0.0d0
         end do
         do j = 1, 6
            dufld(j,i) = 0.0d0
         end do
         pot(i) = 0.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     compute the dipole polarization gradient components
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         uixp = uinp(1,i)
         uiyp = uinp(2,i)
         uizp = uinp(3,i)
         do j = 1, tcgnab
            uax(j) = uad(1,i,j)
            uay(j) = uad(2,i,j)
            uaz(j) = uad(3,i,j)
            uaxp(j) = uap(1,i,j)
            uayp(j) = uap(2,i,j)
            uazp(j) = uap(3,i,j)
            ubx(j) = ubd(1,i,j)
            uby(j) = ubd(2,i,j)
            ubz(j) = ubd(3,i,j)
            ubxp(j) = ubp(1,i,j)
            ubyp(j) = ubp(2,i,j)
            ubzp(j) = ubp(3,i,j)
         end do
         if (use_thole) then
            pdi = pdamp(i)
            pti = thole(i)
            ddi = tholed(i)
         else if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
               uscale(ip14(j,i)) = u4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
               ukxp = uinp(1,k)
               ukyp = uinp(2,k)
               ukzp = uinp(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               uir = uix*xr + uiy*yr + uiz*zr
               uirp = uixp*xr + uiyp*yr + uizp*zr
               ukr = ukx*xr + uky*yr + ukz*zr
               ukrp = ukxp*xr + ukyp*yr + ukzp*zr
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
c
c     set initial values for tha damping scale factors
c
               sc3 = 1.0d0
               sc5 = 1.0d0
               sc7 = 1.0d0
               do j = 1, 3
                  rc3(j) = 0.0d0
                  rc5(j) = 0.0d0
                  rc7(j) = 0.0d0
               end do
c
c     apply Thole polarization damping to scale factors
c
               if (use_thole) then
                  damp = pdi * pdamp(k)
                  it = jpolar(i)
                  kt = jpolar(k)
                  if (use_tholed) then
                     pgamma = thdval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**(1.5d0)
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp) 
                           sc3 = 1.0d0 - expdamp 
                           sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp
     &                                      +0.15d0*damp**2)
                           temp3 = 0.5d0 * damp * expdamp 
                           temp5 = 1.5d0 * (1.0d0+damp)
                           temp7 = 5.0d0*(1.5d0*damp*expdamp
     &                                *(0.35d0+0.35d0*damp
     &                                   +0.15d0*damp**2))/(temp3*temp5)
                           temp3 = temp3 * rr5
                           temp5 = temp5 / r2
                           temp7 = temp7 / r2
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  else
                     pgamma = thlval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**3
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp)
                           sc3 = 1.0d0 - expdamp
                           sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+damp
     &                                      +0.6d0*damp**2)
                           temp3 = damp * expdamp * rr5
                           temp5 = 3.0d0 * damp / r2
                           temp7 = (-1.0d0+3.0d0*damp) / r2
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  end if
                  sr3 = rr3 * sc3
                  sr5 = rr5 * sc5
                  sr7 = rr7 * sc7
                  dsr3 = sr3 * dscale(k)
                  dsr5 = sr5 * dscale(k)
                  dsr7 = sr7 * dscale(k)
                  psr3 = sr3 * pscale(k)
                  psr5 = sr5 * pscale(k)
                  psr7 = sr7 * pscale(k)
c
c     apply charge penetration damping to scale factors
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik)
                  dsr3i = 2.0d0 * rr3 * dmpi(3) * dscale(k)
                  dsr5i = 2.0d0 * rr5 * dmpi(5) * dscale(k)
                  dsr7i = 2.0d0 * rr7 * dmpi(7) * dscale(k)
                  dsr3k = 2.0d0 * rr3 * dmpk(3) * dscale(k)
                  dsr5k = 2.0d0 * rr5 * dmpk(5) * dscale(k)
                  dsr7k = 2.0d0 * rr7 * dmpk(7) * dscale(k)
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_thole) then
                     poti = -ukr*psr3 - ukrp*dsr3
                     potk = uir*psr3 + uirp*dsr3
                  else if (use_chgpen) then
                     poti = -ukr * dsr3i
                     potk = uir * dsr3k
                  end if
                  pot(i) = pot(i) + poti 
                  pot(k) = pot(k) + potk 
               end if
c
c     get the induced dipole field used for dipole torques
c
               if (use_thole) then
                  tix3 = psr3*ukx + dsr3*ukxp
                  tiy3 = psr3*uky + dsr3*ukyp
                  tiz3 = psr3*ukz + dsr3*ukzp
                  tkx3 = psr3*uix + dsr3*uixp
                  tky3 = psr3*uiy + dsr3*uiyp
                  tkz3 = psr3*uiz + dsr3*uizp
                  tuir = -psr5*ukr - dsr5*ukrp
                  tukr = -psr5*uir - dsr5*uirp
               else if (use_chgpen) then
                  tix3 = dsr3i*ukx
                  tiy3 = dsr3i*uky
                  tiz3 = dsr3i*ukz
                  tkx3 = dsr3k*uix
                  tky3 = dsr3k*uiy
                  tkz3 = dsr3k*uiz
                  tuir = -dsr5i*ukr
                  tukr = -dsr5k*uir
               end if
               ufld(1,i) = ufld(1,i) + tix3 + xr*tuir
               ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir
               ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir
               ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr
               ufld(2,k) = ufld(2,k) + tky3 + yr*tukr
               ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr
c
c     get induced dipole field gradient used for quadrupole torques
c
               if (use_thole) then
                  tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp)
                  tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp)
                  tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp)
                  tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp)
                  tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp)
                  tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp)
                  tuir = -psr7*ukr - dsr7*ukrp
                  tukr = -psr7*uir - dsr7*uirp
               else if (use_chgpen) then
                  tix5 = 2.0d0 * (dsr5i*ukx)
                  tiy5 = 2.0d0 * (dsr5i*uky)
                  tiz5 = 2.0d0 * (dsr5i*ukz)
                  tkx5 = 2.0d0 * (dsr5k*uix)
                  tky5 = 2.0d0 * (dsr5k*uiy)
                  tkz5 = 2.0d0 * (dsr5k*uiz)
                  tuir = -dsr7i*ukr
                  tukr = -dsr7k*uir
               end if
               dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir
               dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5
     &                         + 2.0d0*xr*yr*tuir
               dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir
               dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5
     &                         + 2.0d0*xr*zr*tuir
               dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5
     &                         + 2.0d0*yr*zr*tuir
               dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir
               dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr
               dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5
     &                         - 2.0d0*xr*yr*tukr
               dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr
               dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5
     &                         - 2.0d0*xr*zr*tukr
               dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5
     &                         - 2.0d0*yr*zr*tukr
               dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr
c
c     get the field gradient for direct polarization force
c
               if (use_thole) then
                  term1 = sc3*(rr3-rr5*xr*xr) + rc3(1)*xr
                  term2 = (sc3+sc5)*rr5*xr - rc3(1)
                  term3 = sc5*(rr7*xr*xr-rr5) - rc5(1)*xr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*xr-rc5(1)+1.5d0*sc7*rr7*xr)
                  term6 = xr * (sc7*rr9*xr-rc7(1))
                  tixx = ci*term1 + dix*term2 - dir*term3
     &                      - qixx*term4 + qix*term5 - qir*term6
     &                      + (qiy*yr+qiz*zr)*sc7*rr7
                  tkxx = ck*term1 - dkx*term2 + dkr*term3
     &                      - qkxx*term4 + qkx*term5 - qkr*term6
     &                      + (qky*yr+qkz*zr)*sc7*rr7
                  term1 = sc3*(rr3-rr5*yr*yr) + rc3(2)*yr
                  term2 = (sc3+sc5)*rr5*yr - rc3(2)
                  term3 = sc5*(rr7*yr*yr-rr5) - rc5(2)*yr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*yr-rc5(2)+1.5d0*sc7*rr7*yr)
                  term6 = yr * (sc7*rr9*yr-rc7(2))
                  tiyy = ci*term1 + diy*term2 - dir*term3
     &                      - qiyy*term4 + qiy*term5 - qir*term6
     &                      + (qix*xr+qiz*zr)*sc7*rr7
                  tkyy = ck*term1 - dky*term2 + dkr*term3
     &                      - qkyy*term4 + qky*term5 - qkr*term6
     &                      + (qkx*xr+qkz*zr)*sc7*rr7
                  term1 = sc3*(rr3-rr5*zr*zr) + rc3(3)*zr
                  term2 = (sc3+sc5)*rr5*zr - rc3(3)
                  term3 = sc5*(rr7*zr*zr-rr5) - rc5(3)*zr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*zr-rc5(3)+1.5d0*sc7*rr7*zr)
                  term6 = zr * (sc7*rr9*zr-rc7(3))
                  tizz = ci*term1 + diz*term2 - dir*term3
     &                      - qizz*term4 + qiz*term5 - qir*term6
     &                      + (qix*xr+qiy*yr)*sc7*rr7
                  tkzz = ck*term1 - dkz*term2 + dkr*term3
     &                      - qkzz*term4 + qkz*term5 - qkr*term6
     &                      + (qkx*xr+qky*yr)*sc7*rr7
                  term2 = sc3*rr5*xr - rc3(1)
                  term1 = yr * term2
                  term3 = sc5 * rr5 * yr
                  term4 = yr * (sc5*rr7*xr-rc5(1))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*xr-rc5(1))
                  term7 = 2.0d0 * sc7 * rr7 * yr
                  term8 = yr * (sc7*rr9*xr-rc7(1))
                  tixy = -ci*term1 + diy*term2 + dix*term3
     &                      - dir*term4 - qixy*term5 + qiy*term6
     &                      + qix*term7 - qir*term8
                  tkxy = -ck*term1 - dky*term2 - dkx*term3
     &                      + dkr*term4 - qkxy*term5 + qky*term6
     &                      + qkx*term7 - qkr*term8
                  term2 = sc3*rr5*xr - rc3(1)
                  term1 = zr * term2
                  term3 = sc5 * rr5 * zr
                  term4 = zr * (sc5*rr7*xr-rc5(1))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*xr-rc5(1))
                  term7 = 2.0d0 * sc7 * rr7 * zr
                  term8 = zr * (sc7*rr9*xr-rc7(1))
                  tixz = -ci*term1 + diz*term2 + dix*term3
     &                      - dir*term4 - qixz*term5 + qiz*term6
     &                      + qix*term7 - qir*term8
                  tkxz = -ck*term1 - dkz*term2 - dkx*term3
     &                      + dkr*term4 - qkxz*term5 + qkz*term6
     &                      + qkx*term7 - qkr*term8
                  term2 = sc3*rr5*yr - rc3(2)
                  term1 = zr * term2
                  term3 = sc5 * rr5 * zr
                  term4 = zr * (sc5*rr7*yr-rc5(2))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*yr-rc5(2))
                  term7 = 2.0d0 * sc7 * rr7 * zr
                  term8 = zr * (sc7*rr9*yr-rc7(2))
                  tiyz = -ci*term1 + diz*term2 + diy*term3
     &                      - dir*term4 - qiyz*term5 + qiz*term6
     &                      + qiy*term7 - qir*term8
                  tkyz = -ck*term1 - dkz*term2 - dky*term3
     &                      + dkr*term4 - qkyz*term5 + qkz*term6
     &                      + qky*term7 - qkr*term8
c
c     get the field gradient for direct polarization force
c
               else if (use_chgpen) then
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*xr*xr
                  term1core = rr3 - rr5*xr*xr
                  term2i = 2.0d0*rr5*dmpi(5)*xr 
                  term3i = rr7*dmpi(7)*xr*xr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*xr
                  term6i = rr9*dmpi(9)*xr*xr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*xr*xr
                  term2k = 2.0d0*rr5*dmpk(5)*xr
                  term3k = rr7*dmpk(7)*xr*xr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*xr
                  term6k = rr9*dmpk(9)*xr*xr
                  tixx = vali*term1i + corei*term1core  
     &                      + dix*term2i - dir*term3i
     &                      - qixx*term4i + qix*term5i - qir*term6i
     &                      + (qiy*yr+qiz*zr)*rr7*dmpi(7)
                  tkxx = valk*term1k + corek*term1core
     &                      - dkx*term2k + dkr*term3k
     &                      - qkxx*term4k + qkx*term5k - qkr*term6k
     &                      + (qky*yr+qkz*zr)*rr7*dmpk(7)
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*yr*yr
                  term1core = rr3 - rr5*yr*yr
                  term2i = 2.0d0*rr5*dmpi(5)*yr
                  term3i = rr7*dmpi(7)*yr*yr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*yr
                  term6i = rr9*dmpi(9)*yr*yr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*yr*yr
                  term2k = 2.0d0*rr5*dmpk(5)*yr
                  term3k = rr7*dmpk(7)*yr*yr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*yr
                  term6k = rr9*dmpk(9)*yr*yr
                  tiyy = vali*term1i + corei*term1core
     &                      + diy*term2i - dir*term3i
     &                      - qiyy*term4i + qiy*term5i - qir*term6i
     &                      + (qix*xr+qiz*zr)*rr7*dmpi(7)
                  tkyy = valk*term1k + corek*term1core
     &                      - dky*term2k + dkr*term3k
     &                      - qkyy*term4k + qky*term5k - qkr*term6k
     &                      + (qkx*xr+qkz*zr)*rr7*dmpk(7)
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*zr*zr
                  term1core = rr3 - rr5*zr*zr
                  term2i = 2.0d0*rr5*dmpi(5)*zr
                  term3i = rr7*dmpi(7)*zr*zr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*zr
                  term6i = rr9*dmpi(9)*zr*zr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*zr*zr
                  term2k = 2.0d0*rr5*dmpk(5)*zr
                  term3k = rr7*dmpk(7)*zr*zr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*zr
                  term6k = rr9*dmpk(9)*zr*zr
                  tizz = vali*term1i + corei*term1core
     &                      + diz*term2i - dir*term3i
     &                      - qizz*term4i + qiz*term5i - qir*term6i
     &                      + (qix*xr+qiy*yr)*rr7*dmpi(7)
                  tkzz = valk*term1k + corek*term1core
     &                      - dkz*term2k + dkr*term3k
     &                      - qkzz*term4k + qkz*term5k - qkr*term6k
     &                      + (qkx*xr+qky*yr)*rr7*dmpk(7)
                  term2i = rr5*dmpi(5)*xr 
                  term1i = yr * term2i
                  term1core = rr5*xr*yr
                  term3i = rr5*dmpi(5)*yr
                  term4i = yr * (rr7*dmpi(7)*xr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*xr
                  term7i = 2.0d0*rr7*dmpi(7)*yr
                  term8i = yr*rr9*dmpi(9)*xr
                  term2k = rr5*dmpk(5)*xr
                  term1k = yr * term2k
                  term3k = rr5*dmpk(5)*yr
                  term4k = yr * (rr7*dmpk(7)*xr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*xr
                  term7k = 2.0d0*rr7*dmpk(7)*yr
                  term8k = yr*rr9*dmpk(9)*xr
                  tixy = -vali*term1i - corei*term1core 
     &                      + diy*term2i + dix*term3i
     &                      - dir*term4i - qixy*term5i + qiy*term6i
     &                      + qix*term7i - qir*term8i
                  tkxy = -valk*term1k - corek*term1core 
     &                      - dky*term2k - dkx*term3k
     &                      + dkr*term4k - qkxy*term5k + qky*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5*dmpi(5)*xr
                  term1i = zr * term2i
                  term1core = rr5*xr*zr
                  term3i = rr5*dmpi(5)*zr
                  term4i = zr * (rr7*dmpi(7)*xr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*xr
                  term7i = 2.0d0*rr7*dmpi(7)*zr
                  term8i = zr*rr9*dmpi(9)*xr
                  term2k = rr5*dmpk(5)*xr
                  term1k = zr * term2k
                  term3k = rr5*dmpk(5)*zr
                  term4k = zr * (rr7*dmpk(7)*xr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*xr
                  term7k = 2.0d0*rr7*dmpk(7)*zr
                  term8k = zr*rr9*dmpk(9)*xr
                  tixz = -vali*term1i - corei*term1core
     &                      + diz*term2i + dix*term3i
     &                      - dir*term4i - qixz*term5i + qiz*term6i
     &                      + qix*term7i - qir*term8i
                  tkxz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dkx*term3k
     &                      + dkr*term4k - qkxz*term5k + qkz*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5*dmpi(5)*yr
                  term1i = zr * term2i
                  term1core = rr5*yr*zr
                  term3i = rr5*dmpi(5)*zr
                  term4i = zr * (rr7*dmpi(7)*yr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*yr
                  term7i = 2.0d0*rr7*dmpi(7)*zr
                  term8i = zr*rr9*dmpi(9)*yr
                  term2k = rr5*dmpk(5)*yr
                  term1k = zr * term2k
                  term3k = rr5*dmpk(5)*zr
                  term4k = zr * (rr7*dmpk(7)*yr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*yr
                  term7k = 2.0d0*rr7*dmpk(7)*zr
                  term8k = zr*rr9*dmpk(9)*yr
                  tiyz = -vali*term1i - corei*term1core
     &                      + diz*term2i + diy*term3i
     &                      - dir*term4i - qiyz*term5i + qiz*term6i
     &                      + qiy*term7i - qir*term8i
                  tkyz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dky*term3k
     &                      + dkr*term4k - qkyz*term5k + qkz*term6k
     &                      + qky*term7k - qkr*term8k
               end if
c
c     get the dEd/dR terms for Thole direct polarization force
c
               if (use_thole) then
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      - tkxx*uixp - tkxy*uiyp - tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      - tkxy*uixp - tkyy*uiyp - tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      - tkxz*uixp - tkyz*uiyp - tkzz*uizp
                  frcx = dscale(k) * depx
                  frcy = dscale(k) * depy
                  frcz = dscale(k) * depz
c
c     get the dEp/dR terms for Thole direct polarization force
c
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = frcx + pscale(k)*depx
                  frcy = frcy + pscale(k)*depy
                  frcz = frcz + pscale(k)*depz
c
c     get the dEp/dR terms for chgpen direct polarization force
c
               else if (use_chgpen) then
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = 2.0d0*dscale(k)*depx
                  frcy = 2.0d0*dscale(k)*depy
                  frcz = 2.0d0*dscale(k)*depz
               end if
c
c     reset Thole values if alternate direct damping was used
c
               if (use_tholed) then
                  sc3 = 1.0d0
                  sc5 = 1.0d0
                  do j = 1, 3
                     rc3(j) = 0.0d0
                     rc5(j) = 0.0d0
                  end do
                  damp = pdi * pdamp(k)
                  if (damp .ne. 0.0d0) then
                     pgamma = min(pti,thole(k))
                     damp = pgamma * (r/damp)**3
                     if (damp .lt. 50.0d0) then
                        expdamp = exp(-damp)
                        sc3 = 1.0d0 - expdamp
                        sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                        temp3 = damp * expdamp * rr5
                        temp5 = 3.0d0 * damp / r2
                        rc3(1) = xr * temp3
                        rc3(2) = yr * temp3
                        rc3(3) = zr * temp3
                        rc5(1) = rc3(1) * temp5
                        rc5(2) = rc3(2) * temp5
                        rc5(3) = rc3(3) * temp5
                     end if
                  end if
               end if
c
c     get the dtau/dr terms used for mutual polarization force
c
               if (poltyp.eq.'MUTUAL' .and. use_thole) then
                  term1 = (sc3+sc5) * rr5
                  term2 = term1*xr - rc3(1)
                  term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr - rc3(2)
                  term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr - rc3(3)
                  term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = sc5 * rr5 * yr
                  term2 = sc3*rr5*xr - rc3(1)
                  term3 = yr * (sc5*rr7*xr-rc5(1))
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = sc5 * rr5 * zr
                  term3 = zr * (sc5*rr7*xr-rc5(1))
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = sc3*rr5*yr - rc3(2)
                  term3 = zr * (sc5*rr7*yr-rc5(2))
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + uscale(k)*depx
                  frcy = frcy + uscale(k)*depy
                  frcz = frcz + uscale(k)*depz
c
c     get the dtau/dr terms used for mutual polarization force
c
               else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then
                  term1 = 2.0d0 * dmpik(5) * rr5
                  term2 = term1*xr
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr 
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr 
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr 
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr 
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr 
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = rr5*dmpik(5)*yr
                  term2 = rr5*dmpik(5)*xr 
                  term3 = yr * (rr7*dmpik(7)*xr)
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = rr5 *dmpik(5) * zr
                  term3 = zr * (rr7*dmpik(7)*xr)
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = rr5*dmpik(5)*yr 
                  term3 = zr * (rr7*dmpik(7)*yr)
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + wscale(k)*depx
                  frcy = frcy + wscale(k)*depy
                  frcz = frcz + wscale(k)*depz
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_thole) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = (sc3+sc5) * rr5
                        term2 = term1*xr - rc3(1)
                        term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                        tixx = uopt(j,1,ii)*term2 + uirm*term3
                        tkxx = uopt(m,1,kk)*term2 + ukrm*term3
                        term2 = term1*yr - rc3(2)
                        term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                        tiyy = uopt(j,2,ii)*term2 + uirm*term3
                        tkyy = uopt(m,2,kk)*term2 + ukrm*term3
                        term2 = term1*zr - rc3(3)
                        term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                        tizz = uopt(j,3,ii)*term2 + uirm*term3
                        tkzz = uopt(m,3,kk)*term2 + ukrm*term3
                        term1 = sc5 * rr5 * yr
                        term2 = sc3*rr5*xr - rc3(1)
                        term3 = yr * (sc5*rr7*xr-rc5(1))
                        tixy = uopt(j,1,ii)*term1 + uopt(j,2,ii)*term2
     &                            - uirm*term3
                        tkxy = uopt(m,1,kk)*term1 + uopt(m,2,kk)*term2
     &                            - ukrm*term3
                        term1 = sc5 * rr5 * zr
                        term3 = zr * (sc5*rr7*xr-rc5(1))
                        tixz = uopt(j,1,ii)*term1 + uopt(j,3,ii)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,kk)*term1 + uopt(m,3,kk)*term2
     &                            - ukrm*term3
                        term2 = sc3*rr5*yr - rc3(2)
                        term3 = zr * (sc5*rr7*yr-rc5(2))
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*uscale(k)*depx
                        frcy = frcy + copm(j+m+1)*uscale(k)*depy
                        frcz = frcz + copm(j+m+1)*uscale(k)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_chgpen) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = 2.0d0 * dmpik(5) * rr5
                        term2 = term1*xr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr
                        tixx = uopt(j,1,i)*term2 + uirm*term3
                        tkxx = uopt(m,1,k)*term2 + ukrm*term3
                        term2 = term1*yr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr
                        tiyy = uopt(j,2,i)*term2 + uirm*term3
                        tkyy = uopt(m,2,k)*term2 + ukrm*term3
                        term2 = term1*zr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr
                        tizz = uopt(j,3,i)*term2 + uirm*term3
                        tkzz = uopt(m,3,k)*term2 + ukrm*term3
                        term1 = rr5*dmpik(5)*yr
                        term2 = rr5*dmpik(5)*xr
                        term3 = yr * (rr7*dmpik(7)*xr)
                        tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2
     &                            - uirm*term3
                        tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2
     &                            - ukrm*term3
                        term1 = rr5 *dmpik(5) * zr
                        term3 = zr * (rr7*dmpik(7)*xr)
                        tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        term2 = rr5*dmpik(5)*yr
                        term3 = zr * (rr7*dmpik(7)*yr)
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*wscale(k)*depx
                        frcy = frcy + copm(j+m+1)*wscale(k)*depy
                        frcz = frcz + copm(j+m+1)*wscale(k)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for TCG polarization force
c
               else if (poltyp.eq.'TCG' .and. use_thole) then
                  do j = 1, tcgnab
                     ukx = ubd(1,k,j)
                     uky = ubd(2,k,j)
                     ukz = ubd(3,k,j)
                     ukxp = ubp(1,k,j)
                     ukyp = ubp(2,k,j)
                     ukzp = ubp(3,k,j)
                     uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = (sc3+sc5) * rr5
                     term2 = term1*xr - rc3(1)
                     term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                     tixx = uax(j)*term2 + uirt*term3
                     tkxx = ukx*term2 + ukrt*term3
                     term2 = term1*yr - rc3(2)
                     term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                     tiyy = uay(j)*term2 + uirt*term3
                     tkyy = uky*term2 + ukrt*term3
                     term2 = term1*zr - rc3(3)
                     term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                     tizz = uaz(j)*term2 + uirt*term3
                     tkzz = ukz*term2 + ukrt*term3
                     term1 = sc5 * rr5 * yr
                     term2 = sc3*rr5*xr - rc3(1)
                     term3 = yr * (sc5*rr7*xr-rc5(1))
                     tixy = uax(j)*term1 + uay(j)*term2 - uirt*term3
                     tkxy = ukx*term1 + uky*term2 - ukrt*term3
                     term1 = sc5 * rr5 * zr
                     term3 = zr * (sc5*rr7*xr-rc5(1))
                     tixz = uax(j)*term1 + uaz(j)*term2 - uirt*term3
                     tkxz = ukx*term1 + ukz*term2 - ukrt*term3
                     term2 = sc3*rr5*yr - rc3(2)
                     term3 = zr * (sc5*rr7*yr-rc5(2))
                     tiyz = uay(j)*term1 + uaz(j)*term2 - uirt*term3
                     tkyz = uky*term1 + ukz*term2 - ukrt*term3
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*uaxp(j) + tkxy*uayp(j)
     &                         + tkxz*uazp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*uaxp(j) + tkyy*uayp(j)
     &                         + tkyz*uazp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*uaxp(j) + tkyz*uayp(j)
     &                         + tkzz*uazp(j)
                     frcx = frcx + uscale(k)*depx
                     frcy = frcy + uscale(k)*depy
                     frcz = frcz + uscale(k)*depz
                     ukx = uad(1,k,j)
                     uky = uad(2,k,j)
                     ukz = uad(3,k,j)
                     ukxp = uap(1,k,j)
                     ukyp = uap(2,k,j)
                     ukzp = uap(3,k,j)
                     uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = (sc3+sc5) * rr5
                     term2 = term1*xr - rc3(1)
                     term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                     tixx = ubx(j)*term2 + uirt*term3
                     tkxx = ukx*term2 + ukrt*term3
                     term2 = term1*yr - rc3(2)
                     term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                     tiyy = uby(j)*term2 + uirt*term3
                     tkyy = uky*term2 + ukrt*term3
                     term2 = term1*zr - rc3(3)
                     term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                     tizz = ubz(j)*term2 + uirt*term3
                     tkzz = ukz*term2 + ukrt*term3
                     term1 = sc5 * rr5 * yr
                     term2 = sc3*rr5*xr - rc3(1)
                     term3 = yr * (sc5*rr7*xr-rc5(1))
                     tixy = ubx(j)*term1 + uby(j)*term2 - uirt*term3
                     tkxy = ukx*term1 + uky*term2 - ukrt*term3
                     term1 = sc5 * rr5 * zr
                     term3 = zr * (sc5*rr7*xr-rc5(1))
                     tixz = ubx(j)*term1 + ubz(j)*term2 - uirt*term3
                     tkxz = ukx*term1 + ukz*term2 - ukrt*term3
                     term2 = sc3*rr5*yr - rc3(2)
                     term3 = zr * (sc5*rr7*yr-rc5(2))
                     tiyz = uby(j)*term1 + ubz(j)*term2 - uirt*term3
                     tkyz = uky*term1 + ukz*term2 - ukrt*term3
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*ubxp(j) + tkxy*ubyp(j)
     &                         + tkxz*ubzp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*ubxp(j) + tkyy*ubyp(j)
     &                         + tkyz*ubzp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*ubxp(j) + tkyz*ubyp(j)
     &                         + tkzz*ubzp(j)
                     frcx = frcx + uscale(k)*depx
                     frcy = frcy + uscale(k)*depy
                     frcz = frcz + uscale(k)*depz
                  end do
               end if
c
c     increment force-based gradient on the interaction sites
c
               dep(1,i) = dep(1,i) + frcx
               dep(2,i) = dep(2,i) + frcy
               dep(3,i) = dep(3,i) + frcz
               dep(1,k) = dep(1,k) - frcx
               dep(2,k) = dep(2,k) - frcy
               dep(3,k) = dep(3,k) - frcz
c
c     increment the virial due to pairwise Cartesian forces
c
               vxx = -xr * frcx
               vxy = -0.5d0 * (yr*frcx+xr*frcy)
               vxz = -0.5d0 * (zr*frcx+xr*frcz)
               vyy = -yr * frcy
               vyz = -0.5d0 * (zr*frcy+yr*frcz)
               vzz = -zr * frcz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
               uscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction with other unit cells
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         uixp = uinp(1,i)
         uiyp = uinp(2,i)
         uizp = uinp(3,i)
         do j = 1, tcgnab
            uax(j) = uad(1,i,j)
            uay(j) = uad(2,i,j)
            uaz(j) = uad(3,i,j)
            uaxp(j) = uap(1,i,j)
            uayp(j) = uap(2,i,j)
            uazp(j) = uap(3,i,j)
            ubx(j) = ubd(1,i,j)
            uby(j) = ubd(2,i,j)
            ubz(j) = ubd(3,i,j)
            ubxp(j) = ubp(1,i,j)
            ubyp(j) = ubp(2,i,j)
            ubzp(j) = ubp(3,i,j)
         end do
         if (use_thole) then
            pdi = pdamp(i)
            pti = thole(i)
            ddi = tholed(i)
         else if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
               uscale(ip14(j,i)) = u4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii, npole
            k = ipole(kk)
            do jcell = 2, ncell
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call imager (xr,yr,zr,jcell)
            r2 = xr*xr + yr*yr + zr*zr
            if (.not. (use_polymer .and. r2.le.polycut2)) then
               pscale(k) = 1.0d0
               dscale(k) = 1.0d0
               uscale(k) = 1.0d0
            end if
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
               ukxp = uinp(1,k)
               ukyp = uinp(2,k)
               ukzp = uinp(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               uir = uix*xr + uiy*yr + uiz*zr
               uirp = uixp*xr + uiyp*yr + uizp*zr
               ukr = ukx*xr + uky*yr + ukz*zr
               ukrp = ukxp*xr + ukyp*yr + ukzp*zr
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
c
c     apply Thole polarization damping to scale factors
c
               sc3 = 1.0d0
               sc5 = 1.0d0
               sc7 = 1.0d0
               do j = 1, 3
                  rc3(j) = 0.0d0
                  rc5(j) = 0.0d0
                  rc7(j) = 0.0d0
               end do
c
c     apply Thole polarization damping to scale factors
c
               if (use_thole) then
                  damp = pdi * pdamp(k)
                  it = jpolar(i)
                  kt = jpolar(k)
                  if (use_tholed) then
                     pgamma = thdval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**(1.5d0)
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp) 
                           sc3 = 1.0d0 - expdamp 
                           sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp
     &                                      +0.15d0*damp**2)
                           temp3 = 0.5d0 * damp * expdamp 
                           temp5 = 1.5d0 * (1.0d0+damp)
                           temp7 = 5.0d0*(1.5d0*damp*expdamp
     &                                *(0.35d0+0.35d0*damp
     &                                   +0.15d0*damp**2))/(temp3*temp5)
                           temp3 = temp3 * rr5
                           temp5 = temp5 / r2
                           temp7 = temp7 / r2
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  else
                     pgamma = thlval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**3
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp)
                           sc3 = 1.0d0 - expdamp
                           sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+damp
     &                                      +0.6d0*damp**2)
                           temp3 = damp * expdamp * rr5
                           temp5 = 3.0d0 * damp / r2
                           temp7 = (-1.0d0+3.0d0*damp) / r2
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  end if
                  sr3 = rr3 * sc3
                  sr5 = rr5 * sc5
                  sr7 = rr7 * sc7
                  dsr3 = sr3 * dscale(k)
                  dsr5 = sr5 * dscale(k)
                  dsr7 = sr7 * dscale(k)
                  psr3 = sr3 * pscale(k)
                  psr5 = sr5 * pscale(k)
                  psr7 = sr7 * pscale(k)
c
c     apply charge penetration damping to scale factors
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik)
                  dsr3i = 2.0d0 * rr3 * dmpi(3) * dscale(k)
                  dsr5i = 2.0d0 * rr5 * dmpi(5) * dscale(k)
                  dsr7i = 2.0d0 * rr7 * dmpi(7) * dscale(k)
                  dsr3k = 2.0d0 * rr3 * dmpk(3) * dscale(k)
                  dsr5k = 2.0d0 * rr5 * dmpk(5) * dscale(k)
                  dsr7k = 2.0d0 * rr7 * dmpk(7) * dscale(k)
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_thole) then
                     poti = -ukr*psr3 - ukrp*dsr3
                     potk = uir*psr3 + uirp*dsr3
                  else if (use_chgpen) then
                     poti = -ukr * dsr3i
                     potk = uir * dsr3k
                  end if
                  pot(i) = pot(i) + poti 
                  pot(k) = pot(k) + potk 
               end if
c
c     get the induced dipole field used for dipole torques
c
               if (use_thole) then
                  tix3 = psr3*ukx + dsr3*ukxp
                  tiy3 = psr3*uky + dsr3*ukyp
                  tiz3 = psr3*ukz + dsr3*ukzp
                  tkx3 = psr3*uix + dsr3*uixp
                  tky3 = psr3*uiy + dsr3*uiyp
                  tkz3 = psr3*uiz + dsr3*uizp
                  tuir = -psr5*ukr - dsr5*ukrp
                  tukr = -psr5*uir - dsr5*uirp
               else if (use_chgpen) then
                  tix3 = dsr3i*ukx
                  tiy3 = dsr3i*uky
                  tiz3 = dsr3i*ukz
                  tkx3 = dsr3k*uix
                  tky3 = dsr3k*uiy
                  tkz3 = dsr3k*uiz
                  tuir = -dsr5i*ukr
                  tukr = -dsr5k*uir
               end if
               ufld(1,i) = ufld(1,i) + tix3 + xr*tuir
               ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir
               ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir
               ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr
               ufld(2,k) = ufld(2,k) + tky3 + yr*tukr
               ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr
c
c     get induced dipole field gradient used for quadrupole torques
c
               if (use_thole) then
                  tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp)
                  tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp)
                  tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp)
                  tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp)
                  tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp)
                  tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp)
                  tuir = -psr7*ukr - dsr7*ukrp
                  tukr = -psr7*uir - dsr7*uirp
               else if (use_chgpen) then
                  tix5 = 2.0d0 * (dsr5i*ukx)
                  tiy5 = 2.0d0 * (dsr5i*uky)
                  tiz5 = 2.0d0 * (dsr5i*ukz)
                  tkx5 = 2.0d0 * (dsr5k*uix)
                  tky5 = 2.0d0 * (dsr5k*uiy)
                  tkz5 = 2.0d0 * (dsr5k*uiz)
                  tuir = -dsr7i*ukr
                  tukr = -dsr7k*uir
               end if
               dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir
               dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5
     &                         + 2.0d0*xr*yr*tuir
               dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir
               dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5
     &                         + 2.0d0*xr*zr*tuir
               dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5
     &                         + 2.0d0*yr*zr*tuir
               dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir
               dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr
               dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5
     &                         - 2.0d0*xr*yr*tukr
               dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr
               dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5
     &                         - 2.0d0*xr*zr*tukr
               dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5
     &                         - 2.0d0*yr*zr*tukr
               dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr
c
c     get the field gradient for direct polarization force
c
               if (use_thole) then
                  term1 = sc3*(rr3-rr5*xr*xr) + rc3(1)*xr
                  term2 = (sc3+sc5)*rr5*xr - rc3(1)
                  term3 = sc5*(rr7*xr*xr-rr5) - rc5(1)*xr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*xr-rc5(1)+1.5d0*sc7*rr7*xr)
                  term6 = xr * (sc7*rr9*xr-rc7(1))
                  tixx = ci*term1 + dix*term2 - dir*term3
     &                      - qixx*term4 + qix*term5 - qir*term6
     &                      + (qiy*yr+qiz*zr)*sc7*rr7
                  tkxx = ck*term1 - dkx*term2 + dkr*term3
     &                      - qkxx*term4 + qkx*term5 - qkr*term6
     &                      + (qky*yr+qkz*zr)*sc7*rr7
                  term1 = sc3*(rr3-rr5*yr*yr) + rc3(2)*yr
                  term2 = (sc3+sc5)*rr5*yr - rc3(2)
                  term3 = sc5*(rr7*yr*yr-rr5) - rc5(2)*yr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*yr-rc5(2)+1.5d0*sc7*rr7*yr)
                  term6 = yr * (sc7*rr9*yr-rc7(2))
                  tiyy = ci*term1 + diy*term2 - dir*term3
     &                      - qiyy*term4 + qiy*term5 - qir*term6
     &                      + (qix*xr+qiz*zr)*sc7*rr7
                  tkyy = ck*term1 - dky*term2 + dkr*term3
     &                      - qkyy*term4 + qky*term5 - qkr*term6
     &                      + (qkx*xr+qkz*zr)*sc7*rr7
                  term1 = sc3*(rr3-rr5*zr*zr) + rc3(3)*zr
                  term2 = (sc3+sc5)*rr5*zr - rc3(3)
                  term3 = sc5*(rr7*zr*zr-rr5) - rc5(3)*zr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*zr-rc5(3)+1.5d0*sc7*rr7*zr)
                  term6 = zr * (sc7*rr9*zr-rc7(3))
                  tizz = ci*term1 + diz*term2 - dir*term3
     &                      - qizz*term4 + qiz*term5 - qir*term6
     &                      + (qix*xr+qiy*yr)*sc7*rr7
                  tkzz = ck*term1 - dkz*term2 + dkr*term3
     &                      - qkzz*term4 + qkz*term5 - qkr*term6
     &                      + (qkx*xr+qky*yr)*sc7*rr7
                  term2 = sc3*rr5*xr - rc3(1)
                  term1 = yr * term2
                  term3 = sc5 * rr5 * yr
                  term4 = yr * (sc5*rr7*xr-rc5(1))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*xr-rc5(1))
                  term7 = 2.0d0 * sc7 * rr7 * yr
                  term8 = yr * (sc7*rr9*xr-rc7(1))
                  tixy = -ci*term1 + diy*term2 + dix*term3
     &                      - dir*term4 - qixy*term5 + qiy*term6
     &                      + qix*term7 - qir*term8
                  tkxy = -ck*term1 - dky*term2 - dkx*term3
     &                      + dkr*term4 - qkxy*term5 + qky*term6
     &                      + qkx*term7 - qkr*term8
                  term2 = sc3*rr5*xr - rc3(1)
                  term1 = zr * term2
                  term3 = sc5 * rr5 * zr
                  term4 = zr * (sc5*rr7*xr-rc5(1))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*xr-rc5(1))
                  term7 = 2.0d0 * sc7 * rr7 * zr
                  term8 = zr * (sc7*rr9*xr-rc7(1))
                  tixz = -ci*term1 + diz*term2 + dix*term3
     &                      - dir*term4 - qixz*term5 + qiz*term6
     &                      + qix*term7 - qir*term8
                  tkxz = -ck*term1 - dkz*term2 - dkx*term3
     &                      + dkr*term4 - qkxz*term5 + qkz*term6
     &                      + qkx*term7 - qkr*term8
                  term2 = sc3*rr5*yr - rc3(2)
                  term1 = zr * term2
                  term3 = sc5 * rr5 * zr
                  term4 = zr * (sc5*rr7*yr-rc5(2))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*yr-rc5(2))
                  term7 = 2.0d0 * sc7 * rr7 * zr
                  term8 = zr * (sc7*rr9*yr-rc7(2))
                  tiyz = -ci*term1 + diz*term2 + diy*term3
     &                      - dir*term4 - qiyz*term5 + qiz*term6
     &                      + qiy*term7 - qir*term8
                  tkyz = -ck*term1 - dkz*term2 - dky*term3
     &                      + dkr*term4 - qkyz*term5 + qkz*term6
     &                      + qky*term7 - qkr*term8
c
c     get the field gradient for direct polarization force
c
               else if (use_chgpen) then
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*xr*xr
                  term1core = rr3 - rr5*xr*xr
                  term2i = 2.0d0*rr5*dmpi(5)*xr 
                  term3i = rr7*dmpi(7)*xr*xr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*xr
                  term6i = rr9*dmpi(9)*xr*xr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*xr*xr
                  term2k = 2.0d0*rr5*dmpk(5)*xr
                  term3k = rr7*dmpk(7)*xr*xr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*xr
                  term6k = rr9*dmpk(9)*xr*xr
                  tixx = vali*term1i + corei*term1core  
     &                      + dix*term2i - dir*term3i
     &                      - qixx*term4i + qix*term5i - qir*term6i
     &                      + (qiy*yr+qiz*zr)*rr7*dmpi(7)
                  tkxx = valk*term1k + corek*term1core
     &                      - dkx*term2k + dkr*term3k
     &                      - qkxx*term4k + qkx*term5k - qkr*term6k
     &                      + (qky*yr+qkz*zr)*rr7*dmpk(7)
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*yr*yr
                  term1core = rr3 - rr5*yr*yr
                  term2i = 2.0d0*rr5*dmpi(5)*yr
                  term3i = rr7*dmpi(7)*yr*yr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*yr
                  term6i = rr9*dmpi(9)*yr*yr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*yr*yr
                  term2k = 2.0d0*rr5*dmpk(5)*yr
                  term3k = rr7*dmpk(7)*yr*yr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*yr
                  term6k = rr9*dmpk(9)*yr*yr
                  tiyy = vali*term1i + corei*term1core
     &                      + diy*term2i - dir*term3i
     &                      - qiyy*term4i + qiy*term5i - qir*term6i
     &                      + (qix*xr+qiz*zr)*rr7*dmpi(7)
                  tkyy = valk*term1k + corek*term1core
     &                      - dky*term2k + dkr*term3k
     &                      - qkyy*term4k + qky*term5k - qkr*term6k
     &                      + (qkx*xr+qkz*zr)*rr7*dmpk(7)
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*zr*zr
                  term1core = rr3 - rr5*zr*zr
                  term2i = 2.0d0*rr5*dmpi(5)*zr
                  term3i = rr7*dmpi(7)*zr*zr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*zr
                  term6i = rr9*dmpi(9)*zr*zr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*zr*zr
                  term2k = 2.0d0*rr5*dmpk(5)*zr
                  term3k = rr7*dmpk(7)*zr*zr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*zr
                  term6k = rr9*dmpk(9)*zr*zr
                  tizz = vali*term1i + corei*term1core
     &                      + diz*term2i - dir*term3i
     &                      - qizz*term4i + qiz*term5i - qir*term6i
     &                      + (qix*xr+qiy*yr)*rr7*dmpi(7)
                  tkzz = valk*term1k + corek*term1core
     &                      - dkz*term2k + dkr*term3k
     &                      - qkzz*term4k + qkz*term5k - qkr*term6k
     &                      + (qkx*xr+qky*yr)*rr7*dmpk(7)
                  term2i = rr5*dmpi(5)*xr 
                  term1i = yr * term2i
                  term1core = rr5*xr*yr
                  term3i = rr5*dmpi(5)*yr
                  term4i = yr * (rr7*dmpi(7)*xr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*xr
                  term7i = 2.0d0*rr7*dmpi(7)*yr
                  term8i = yr*rr9*dmpi(9)*xr
                  term2k = rr5*dmpk(5)*xr
                  term1k = yr * term2k
                  term3k = rr5*dmpk(5)*yr
                  term4k = yr * (rr7*dmpk(7)*xr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*xr
                  term7k = 2.0d0*rr7*dmpk(7)*yr
                  term8k = yr*rr9*dmpk(9)*xr
                  tixy = -vali*term1i - corei*term1core 
     &                      + diy*term2i + dix*term3i
     &                      - dir*term4i - qixy*term5i + qiy*term6i
     &                      + qix*term7i - qir*term8i
                  tkxy = -valk*term1k - corek*term1core 
     &                      - dky*term2k - dkx*term3k
     &                      + dkr*term4k - qkxy*term5k + qky*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5*dmpi(5)*xr
                  term1i = zr * term2i
                  term1core = rr5*xr*zr
                  term3i = rr5*dmpi(5)*zr
                  term4i = zr * (rr7*dmpi(7)*xr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*xr
                  term7i = 2.0d0*rr7*dmpi(7)*zr
                  term8i = zr*rr9*dmpi(9)*xr
                  term2k = rr5*dmpk(5)*xr
                  term1k = zr * term2k
                  term3k = rr5*dmpk(5)*zr
                  term4k = zr * (rr7*dmpk(7)*xr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*xr
                  term7k = 2.0d0*rr7*dmpk(7)*zr
                  term8k = zr*rr9*dmpk(9)*xr
                  tixz = -vali*term1i - corei*term1core
     &                      + diz*term2i + dix*term3i
     &                      - dir*term4i - qixz*term5i + qiz*term6i
     &                      + qix*term7i - qir*term8i
                  tkxz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dkx*term3k
     &                      + dkr*term4k - qkxz*term5k + qkz*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5*dmpi(5)*yr
                  term1i = zr * term2i
                  term1core = rr5*yr*zr
                  term3i = rr5*dmpi(5)*zr
                  term4i = zr * (rr7*dmpi(7)*yr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*yr
                  term7i = 2.0d0*rr7*dmpi(7)*zr
                  term8i = zr*rr9*dmpi(9)*yr
                  term2k = rr5*dmpk(5)*yr
                  term1k = zr * term2k
                  term3k = rr5*dmpk(5)*zr
                  term4k = zr * (rr7*dmpk(7)*yr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*yr
                  term7k = 2.0d0*rr7*dmpk(7)*zr
                  term8k = zr*rr9*dmpk(9)*yr
                  tiyz = -vali*term1i - corei*term1core
     &                      + diz*term2i + diy*term3i
     &                      - dir*term4i - qiyz*term5i + qiz*term6i
     &                      + qiy*term7i - qir*term8i
                  tkyz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dky*term3k
     &                      + dkr*term4k - qkyz*term5k + qkz*term6k
     &                      + qky*term7k - qkr*term8k
               end if
c
c     get the dEd/dR terms for Thole direct polarization force
c
               if (use_thole) then
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      - tkxx*uixp - tkxy*uiyp - tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      - tkxy*uixp - tkyy*uiyp - tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      - tkxz*uixp - tkyz*uiyp - tkzz*uizp
                  frcx = dscale(k) * depx
                  frcy = dscale(k) * depy
                  frcz = dscale(k) * depz
c
c     get the dEp/dR terms for Thole direct polarization force
c
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = frcx + pscale(k)*depx
                  frcy = frcy + pscale(k)*depy
                  frcz = frcz + pscale(k)*depz
c
c     get the dEp/dR terms for chgpen direct polarization force
c
               else if (use_chgpen) then
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = 2.0d0*dscale(k)*depx
                  frcy = 2.0d0*dscale(k)*depy
                  frcz = 2.0d0*dscale(k)*depz
               end if
c
c     reset Thole values if alternate direct damping was used
c
               if (use_tholed) then
                  sc3 = 1.0d0
                  sc5 = 1.0d0
                  do j = 1, 3
                     rc3(j) = 0.0d0
                     rc5(j) = 0.0d0
                  end do
                  damp = pdi * pdamp(k)
                  if (damp .ne. 0.0d0) then
                     pgamma = min(pti,thole(k))
                     damp = pgamma * (r/damp)**3
                     if (damp .lt. 50.0d0) then
                        expdamp = exp(-damp)
                        sc3 = 1.0d0 - expdamp
                        sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                        temp3 = damp * expdamp * rr5
                        temp5 = 3.0d0 * damp / r2
                        rc3(1) = xr * temp3
                        rc3(2) = yr * temp3
                        rc3(3) = zr * temp3
                        rc5(1) = rc3(1) * temp5
                        rc5(2) = rc3(2) * temp5
                        rc5(3) = rc3(3) * temp5
                     end if
                  end if
               end if
c
c     get the dtau/dr terms used for mutual polarization force
c
               if (poltyp.eq.'MUTUAL' .and. use_thole) then
                  term1 = (sc3+sc5) * rr5
                  term2 = term1*xr - rc3(1)
                  term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr - rc3(2)
                  term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr - rc3(3)
                  term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = sc5 * rr5 * yr
                  term2 = sc3*rr5*xr - rc3(1)
                  term3 = yr * (sc5*rr7*xr-rc5(1))
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = sc5 * rr5 * zr
                  term3 = zr * (sc5*rr7*xr-rc5(1))
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = sc3*rr5*yr - rc3(2)
                  term3 = zr * (sc5*rr7*yr-rc5(2))
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + uscale(k)*depx
                  frcy = frcy + uscale(k)*depy
                  frcz = frcz + uscale(k)*depz
c
c     get the dtau/dr terms used for mutual polarization force
c
               else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then
                  term1 = 2.0d0 * dmpik(5) * rr5
                  term2 = term1*xr
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr 
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr 
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr 
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr 
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr 
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = rr5*dmpik(5)*yr
                  term2 = rr5*dmpik(5)*xr 
                  term3 = yr * (rr7*dmpik(7)*xr)
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = rr5 *dmpik(5) * zr
                  term3 = zr * (rr7*dmpik(7)*xr)
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = rr5*dmpik(5)*yr 
                  term3 = zr * (rr7*dmpik(7)*yr)
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + wscale(k)*depx
                  frcy = frcy + wscale(k)*depy
                  frcz = frcz + wscale(k)*depz
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_thole) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = (sc3+sc5) * rr5
                        term2 = term1*xr - rc3(1)
                        term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                        tixx = uopt(j,1,ii)*term2 + uirm*term3
                        tkxx = uopt(m,1,kk)*term2 + ukrm*term3
                        term2 = term1*yr - rc3(2)
                        term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                        tiyy = uopt(j,2,ii)*term2 + uirm*term3
                        tkyy = uopt(m,2,kk)*term2 + ukrm*term3
                        term2 = term1*zr - rc3(3)
                        term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                        tizz = uopt(j,3,ii)*term2 + uirm*term3
                        tkzz = uopt(m,3,kk)*term2 + ukrm*term3
                        term1 = sc5 * rr5 * yr
                        term2 = sc3*rr5*xr - rc3(1)
                        term3 = yr * (sc5*rr7*xr-rc5(1))
                        tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2
     &                            - uirm*term3
                        tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2
     &                            - ukrm*term3
                        term1 = sc5 * rr5 * zr
                        term3 = zr * (sc5*rr7*xr-rc5(1))
                        tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        term2 = sc3*rr5*yr - rc3(2)
                        term3 = zr * (sc5*rr7*yr-rc5(2))
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*uscale(k)*depx
                        frcy = frcy + copm(j+m+1)*uscale(k)*depy
                        frcz = frcz + copm(j+m+1)*uscale(k)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_chgpen) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = 2.0d0 * dmpik(5) * rr5
                        term2 = term1*xr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr
                        tixx = uopt(j,1,i)*term2 + uirm*term3
                        tkxx = uopt(m,1,k)*term2 + ukrm*term3
                        term2 = term1*yr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr
                        tiyy = uopt(j,2,i)*term2 + uirm*term3
                        tkyy = uopt(m,2,k)*term2 + ukrm*term3
                        term2 = term1*zr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr
                        tizz = uopt(j,3,i)*term2 + uirm*term3
                        tkzz = uopt(m,3,k)*term2 + ukrm*term3
                        term1 = rr5*dmpik(5)*yr
                        term2 = rr5*dmpik(5)*xr
                        term3 = yr * (rr7*dmpik(7)*xr)
                        tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2
     &                            - uirm*term3
                        tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2
     &                            - ukrm*term3
                        term1 = rr5 *dmpik(5) * zr
                        term3 = zr * (rr7*dmpik(7)*xr)
                        tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        term2 = rr5*dmpik(5)*yr
                        term3 = zr * (rr7*dmpik(7)*yr)
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*wscale(k)*depx
                        frcy = frcy + copm(j+m+1)*wscale(k)*depy
                        frcz = frcz + copm(j+m+1)*wscale(k)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for TCG polarization force
c
               else if (poltyp.eq.'TCG' .and. use_thole) then
                  do j = 1, tcgnab
                     ukx = ubd(1,k,j)
                     uky = ubd(2,k,j)
                     ukz = ubd(3,k,j)
                     ukxp = ubp(1,k,j)
                     ukyp = ubp(2,k,j)
                     ukzp = ubp(3,k,j)
                     uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = (sc3+sc5) * rr5
                     term2 = term1*xr - rc3(1)
                     term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                     tixx = uax(j)*term2 + uirt*term3
                     tkxx = ukx*term2 + ukrt*term3
                     term2 = term1*yr - rc3(2)
                     term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                     tiyy = uay(j)*term2 + uirt*term3
                     tkyy = uky*term2 + ukrt*term3
                     term2 = term1*zr - rc3(3)
                     term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                     tizz = uaz(j)*term2 + uirt*term3
                     tkzz = ukz*term2 + ukrt*term3
                     term1 = sc5 * rr5 * yr
                     term2 = sc3*rr5*xr - rc3(1)
                     term3 = yr * (sc5*rr7*xr-rc5(1))
                     tixy = uax(j)*term1 + uay(j)*term2 - uirt*term3
                     tkxy = ukx*term1 + uky*term2 - ukrt*term3
                     term1 = sc5 * rr5 * zr
                     term3 = zr * (sc5*rr7*xr-rc5(1))
                     tixz = uax(j)*term1 + uaz(j)*term2 - uirt*term3
                     tkxz = ukx*term1 + ukz*term2 - ukrt*term3
                     term2 = sc3*rr5*yr - rc3(2)
                     term3 = zr * (sc5*rr7*yr-rc5(2))
                     tiyz = uay(j)*term1 + uaz(j)*term2 - uirt*term3
                     tkyz = uky*term1 + ukz*term2 - ukrt*term3
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*uaxp(j) + tkxy*uayp(j)
     &                         + tkxz*uazp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*uaxp(j) + tkyy*uayp(j)
     &                         + tkyz*uazp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*uaxp(j) + tkyz*uayp(j)
     &                         + tkzz*uazp(j)
                     frcx = frcx + uscale(k)*depx
                     frcy = frcy + uscale(k)*depy
                     frcz = frcz + uscale(k)*depz
                     ukx = uad(1,k,j)
                     uky = uad(2,k,j)
                     ukz = uad(3,k,j)
                     ukxp = uap(1,k,j)
                     ukyp = uap(2,k,j)
                     ukzp = uap(3,k,j)
                     uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = (sc3+sc5) * rr5
                     term2 = term1*xr - rc3(1)
                     term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                     tixx = ubx(j)*term2 + uirt*term3
                     tkxx = ukx*term2 + ukrt*term3
                     term2 = term1*yr - rc3(2)
                     term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                     tiyy = uby(j)*term2 + uirt*term3
                     tkyy = uky*term2 + ukrt*term3
                     term2 = term1*zr - rc3(3)
                     term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                     tizz = ubz(j)*term2 + uirt*term3
                     tkzz = ukz*term2 + ukrt*term3
                     term1 = sc5 * rr5 * yr
                     term2 = sc3*rr5*xr - rc3(1)
                     term3 = yr * (sc5*rr7*xr-rc5(1))
                     tixy = ubx(j)*term1 + uby(j)*term2 - uirt*term3
                     tkxy = ukx*term1 + uky*term2 - ukrt*term3
                     term1 = sc5 * rr5 * zr
                     term3 = zr * (sc5*rr7*xr-rc5(1))
                     tixz = ubx(j)*term1 + ubz(j)*term2 - uirt*term3
                     tkxz = ukx*term1 + ukz*term2 - ukrt*term3
                     term2 = sc3*rr5*yr - rc3(2)
                     term3 = zr * (sc5*rr7*yr-rc5(2))
                     tiyz = uby(j)*term1 + ubz(j)*term2 - uirt*term3
                     tkyz = uky*term1 + ukz*term2 - ukrt*term3
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*ubxp(j) + tkxy*ubyp(j)
     &                         + tkxz*ubzp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*ubxp(j) + tkyy*ubyp(j)
     &                         + tkyz*ubzp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*ubxp(j) + tkyz*ubyp(j)
     &                         + tkzz*ubzp(j)
                     frcx = frcx + uscale(k)*depx
                     frcy = frcy + uscale(k)*depy
                     frcz = frcz + uscale(k)*depz
                  end do
               end if
c
c     force and torque components scaled for self-interactions
c
               if (i .eq. k) then
                  frcx = 0.5d0 * frcx
                  frcy = 0.5d0 * frcy
                  frcz = 0.5d0 * frcz
                  psr3 = 0.5d0 * psr3
                  psr5 = 0.5d0 * psr5
                  psr7 = 0.5d0 * psr7
                  dsr3 = 0.5d0 * dsr3
                  dsr5 = 0.5d0 * dsr5
                  dsr7 = 0.5d0 * dsr7
               end if
c
c     increment force-based gradient on the interaction sites
c
               dep(1,i) = dep(1,i) + frcx
               dep(2,i) = dep(2,i) + frcy
               dep(3,i) = dep(3,i) + frcz
               dep(1,k) = dep(1,k) - frcx
               dep(2,k) = dep(2,k) - frcy
               dep(3,k) = dep(3,k) - frcz
c
c     increment the virial due to pairwise Cartesian forces
c
               vxx = -xr * frcx
               vxy = -0.5d0 * (yr*frcx+xr*frcy)
               vxz = -0.5d0 * (zr*frcx+xr*frcz)
               vyy = -yr * frcy
               vyz = -0.5d0 * (zr*frcy+yr*frcz)
               vzz = -zr * frcz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
            end do
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
               uscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
      end if
c
c     torque is induced field and gradient cross permanent moments
c
      do ii = 1, npole
         i = ipole(ii)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         tep(1) = diz*ufld(2,i) - diy*ufld(3,i)
     &               + qixz*dufld(2,i) - qixy*dufld(4,i)
     &               + 2.0d0*qiyz*(dufld(3,i)-dufld(6,i))
     &               + (qizz-qiyy)*dufld(5,i)
         tep(2) = dix*ufld(3,i) - diz*ufld(1,i)
     &               - qiyz*dufld(2,i) + qixy*dufld(5,i)
     &               + 2.0d0*qixz*(dufld(6,i)-dufld(1,i))
     &               + (qixx-qizz)*dufld(4,i)
         tep(3) = diy*ufld(1,i) - dix*ufld(2,i)
     &               + qiyz*dufld(4,i) - qixz*dufld(5,i)
     &               + 2.0d0*qixy*(dufld(1,i)-dufld(3,i))
     &               + (qiyy-qixx)*dufld(2,i)
         call torque (i,tep,fix,fiy,fiz,dep)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3))
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     modify the gradient and virial for charge flux
c
      if (use_chgflx) then
         call dcflux (pot,decfx,decfy,decfz)
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            frcx = decfx(i)
            frcy = decfy(i)
            frcz = decfz(i)
            dep(1,i) = dep(1,i) + frcx
            dep(2,i) = dep(2,i) + frcy
            dep(3,i) = dep(3,i) + frcz
            vxx = xi * frcx
            vxy = yi * frcx
            vxz = zi * frcx
            vyy = yi * frcy
            vyz = zi * frcy
            vzz = zi * frcz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vxy
            vir(3,1) = vir(3,1) + vxz
            vir(1,2) = vir(1,2) + vxy
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vyz
            vir(1,3) = vir(1,3) + vxz
            vir(2,3) = vir(2,3) + vyz
            vir(3,3) = vir(3,3) + vzz
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      deallocate (dscale)
      deallocate (uscale)
      deallocate (wscale)
      deallocate (ufld)
      deallocate (dufld)
      deallocate (pot)
      deallocate (decfx)
      deallocate (decfy)
      deallocate (decfz)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine epolar1b  --  neighbor list polarization derivs  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "epolar1b" calculates the dipole polarization energy and
c     derivatives with respect to Cartesian coordinates using a
c     neighbor list
c
c
      subroutine epolar1b
      use atoms
      use bound
      use chgpen
      use chgpot
      use couple
      use deriv
      use energi
      use molcul
      use mplpot
      use mpole
      use neigh
      use polar
      use polgrp
      use polopt
      use polpot
      use poltcg
      use potent
      use shunt
      use virial
      implicit none
      integer i,j,k,m
      integer ii,kk,kkk
      integer ix,iy,iz
      integer it,kt
      real*8 f,pgamma
      real*8 pdi,pti,ddi
      real*8 damp,expdamp
      real*8 temp3,temp5,temp7
      real*8 sc3,sc5,sc7
      real*8 sr3,sr5,sr7
      real*8 psr3,psr5,psr7
      real*8 dsr3,dsr5,dsr7
      real*8 dsr3i,dsr5i,dsr7i
      real*8 dsr3k,dsr5k,dsr7k
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 uixp,uiyp,uizp
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 ukxp,ukyp,ukzp
      real*8 dir,uir,uirp
      real*8 dkr,ukr,ukrp
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 uirm,ukrm
      real*8 uirt,ukrt
      real*8 tuir,tukr
      real*8 tixx,tiyy,tizz
      real*8 tixy,tixz,tiyz
      real*8 tkxx,tkyy,tkzz
      real*8 tkxy,tkxz,tkyz
      real*8 tix3,tiy3,tiz3
      real*8 tix5,tiy5,tiz5
      real*8 tkx3,tky3,tkz3
      real*8 tkx5,tky5,tkz5
      real*8 term1,term2,term3
      real*8 term4,term5,term6
      real*8 term7,term8
      real*8 term1core
      real*8 term1i,term2i,term3i
      real*8 term4i,term5i,term6i
      real*8 term7i,term8i
      real*8 term1k,term2k,term3k
      real*8 term4k,term5k,term6k
      real*8 term7k,term8k
      real*8 poti,potk
      real*8 depx,depy,depz
      real*8 frcx,frcy,frcz
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 rc3(3),rc5(3),rc7(3)
      real*8 tep(3),fix(3)
      real*8 fiy(3),fiz(3)
      real*8 uax(3),uay(3),uaz(3)
      real*8 ubx(3),uby(3),ubz(3)
      real*8 uaxp(3),uayp(3),uazp(3)
      real*8 ubxp(3),ubyp(3),ubzp(3)
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9)
      real*8, allocatable :: pscale(:)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: wscale(:)
      real*8, allocatable :: ufld(:,:)
      real*8, allocatable :: dufld(:,:)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
      character*6 mode
c
c
c     zero out the polarization energy and derivatives
c
      ep = 0.0d0
      do i = 1, n
         do j = 1, 3
            dep(j,i) = 0.0d0
         end do
      end do
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     compute the total induced dipole polarization energy
c
      call epolar1e
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
      allocate (dscale(n))
      allocate (uscale(n))
      allocate (wscale(n))
      allocate (ufld(3,n))
      allocate (dufld(6,n))
      allocate (pot(n))
      allocate (decfx(n))
      allocate (decfy(n))
      allocate (decfz(n))
c
c     set exclusion coefficients and arrays to store fields
c
      do i = 1, n
         pscale(i) = 1.0d0
         dscale(i) = 1.0d0
         uscale(i) = 1.0d0
         wscale(i) = 1.0d0
         do j = 1, 3
            ufld(j,i) = 0.0d0
         end do
         do j = 1, 6
            dufld(j,i) = 0.0d0
         end do
         pot(i) = 0.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,x,y,z,rpole,uind,
!$OMP& uinp,jpolar,thole,tholed,pdamp,thlval,thdval,pcore,pval,palpha,
!$OMP& n12,i12,n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,
!$OMP& np14,ip14,p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,
!$OMP& p4iscale,p5iscale,d1scale,d2scale,d3scale,d4scale,u1scale,
!$OMP& u2scale,u3scale,u4scale,w2scale,w3scale,w4scale,w5scale,nelst,
!$OMP& elst,dpequal,use_thole,use_tholed,use_chgpen,use_chgflx,
!$OMP& use_bounds,off2,f,molcule,optorder,copm,uopt,uoptp,poltyp,
!$OMP& tcgnab,uad,uap,ubd,ubp,xaxis,yaxis,zaxis)
!$OMP& shared (dep,ufld,dufld,pot,vir)
!$OMP& firstprivate(pscale,dscale,uscale,wscale)
!$OMP DO reduction(+:dep,ufld,dufld,pot,vir)
c
c     compute the dipole polarization gradient components
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         uixp = uinp(1,i)
         uiyp = uinp(2,i)
         uizp = uinp(3,i)
         do j = 1, tcgnab
            uax(j) = uad(1,i,j)
            uay(j) = uad(2,i,j)
            uaz(j) = uad(3,i,j)
            uaxp(j) = uap(1,i,j)
            uayp(j) = uap(2,i,j)
            uazp(j) = uap(3,i,j)
            ubx(j) = ubd(1,i,j)
            uby(j) = ubd(2,i,j)
            ubz(j) = ubd(3,i,j)
            ubxp(j) = ubp(1,i,j)
            ubyp(j) = ubp(2,i,j)
            ubzp(j) = ubp(3,i,j)
         end do
         if (use_thole) then
            pdi = pdamp(i)
            pti = thole(i)
            ddi = tholed(i)
         else if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
               uscale(ip14(j,i)) = u4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
               ukxp = uinp(1,k)
               ukyp = uinp(2,k)
               ukzp = uinp(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               uir = uix*xr + uiy*yr + uiz*zr
               uirp = uixp*xr + uiyp*yr + uizp*zr
               ukr = ukx*xr + uky*yr + ukz*zr
               ukrp = ukxp*xr + ukyp*yr + ukzp*zr
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
c
c     set initial values for tha damping scale factors
c
               sc3 = 1.0d0
               sc5 = 1.0d0
               sc7 = 1.0d0
               do j = 1, 3
                  rc3(j) = 0.0d0
                  rc5(j) = 0.0d0
                  rc7(j) = 0.0d0
               end do
c
c     apply Thole polarization damping to scale factors
c
               if (use_thole) then
                  damp = pdi * pdamp(k)
                  it = jpolar(i)
                  kt = jpolar(k)
                  if (use_tholed) then
                     pgamma = thdval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**(1.5d0)
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp) 
                           sc3 = 1.0d0 - expdamp 
                           sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp
     &                                      +0.15d0*damp**2)
                           temp3 = 0.5d0 * damp * expdamp 
                           temp5 = 1.5d0 * (1.0d0+damp)
                           temp7 = 5.0d0*(1.5d0*damp*expdamp
     &                                *(0.35d0+0.35d0*damp
     &                                   +0.15d0*damp**2))/(temp3*temp5)
                           temp3 = temp3 * rr5
                           temp5 = temp5 / r2
                           temp7 = temp7 / r2
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  else
                     pgamma = thlval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**3
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp)
                           sc3 = 1.0d0 - expdamp
                           sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+damp
     &                                      +0.6d0*damp**2)
                           temp3 = damp * expdamp * rr5
                           temp5 = 3.0d0 * damp / r2
                           temp7 = (-1.0d0+3.0d0*damp) / r2
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  end if
                  sr3 = rr3 * sc3
                  sr5 = rr5 * sc5
                  sr7 = rr7 * sc7
                  dsr3 = sr3 * dscale(k)
                  dsr5 = sr5 * dscale(k)
                  dsr7 = sr7 * dscale(k)
                  psr3 = sr3 * pscale(k)
                  psr5 = sr5 * pscale(k)
                  psr7 = sr7 * pscale(k)
c
c     apply charge penetration damping to scale factors
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik)
                  dsr3i = 2.0d0 * rr3 * dmpi(3) * dscale(k)
                  dsr5i = 2.0d0 * rr5 * dmpi(5) * dscale(k)
                  dsr7i = 2.0d0 * rr7 * dmpi(7) * dscale(k)
                  dsr3k = 2.0d0 * rr3 * dmpk(3) * dscale(k)
                  dsr5k = 2.0d0 * rr5 * dmpk(5) * dscale(k)
                  dsr7k = 2.0d0 * rr7 * dmpk(7) * dscale(k)
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_thole) then
                     poti = -ukr*psr3 - ukrp*dsr3
                     potk = uir*psr3 + uirp*dsr3
                  else if (use_chgpen) then
                     poti = -ukr * dsr3i
                     potk = uir * dsr3k
                  end if
                  pot(i) = pot(i) + poti 
                  pot(k) = pot(k) + potk 
               end if
c
c     get the induced dipole field used for dipole torques
c
               if (use_thole) then
                  tix3 = psr3*ukx + dsr3*ukxp
                  tiy3 = psr3*uky + dsr3*ukyp
                  tiz3 = psr3*ukz + dsr3*ukzp
                  tkx3 = psr3*uix + dsr3*uixp
                  tky3 = psr3*uiy + dsr3*uiyp
                  tkz3 = psr3*uiz + dsr3*uizp
                  tuir = -psr5*ukr - dsr5*ukrp
                  tukr = -psr5*uir - dsr5*uirp
               else if (use_chgpen) then
                  tix3 = dsr3i*ukx
                  tiy3 = dsr3i*uky
                  tiz3 = dsr3i*ukz
                  tkx3 = dsr3k*uix
                  tky3 = dsr3k*uiy
                  tkz3 = dsr3k*uiz
                  tuir = -dsr5i*ukr
                  tukr = -dsr5k*uir
               end if
               ufld(1,i) = ufld(1,i) + tix3 + xr*tuir
               ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir
               ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir
               ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr
               ufld(2,k) = ufld(2,k) + tky3 + yr*tukr
               ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr
c
c     get induced dipole field gradient used for quadrupole torques
c
               if (use_thole) then
                  tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp)
                  tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp)
                  tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp)
                  tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp)
                  tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp)
                  tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp)
                  tuir = -psr7*ukr - dsr7*ukrp
                  tukr = -psr7*uir - dsr7*uirp
               else if (use_chgpen) then
                  tix5 = 2.0d0 * (dsr5i*ukx)
                  tiy5 = 2.0d0 * (dsr5i*uky)
                  tiz5 = 2.0d0 * (dsr5i*ukz)
                  tkx5 = 2.0d0 * (dsr5k*uix)
                  tky5 = 2.0d0 * (dsr5k*uiy)
                  tkz5 = 2.0d0 * (dsr5k*uiz)
                  tuir = -dsr7i*ukr
                  tukr = -dsr7k*uir
               end if
               dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir
               dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5
     &                         + 2.0d0*xr*yr*tuir
               dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir
               dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5
     &                         + 2.0d0*xr*zr*tuir
               dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5
     &                         + 2.0d0*yr*zr*tuir
               dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir
               dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr
               dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5
     &                         - 2.0d0*xr*yr*tukr
               dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr
               dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5
     &                         - 2.0d0*xr*zr*tukr
               dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5
     &                         - 2.0d0*yr*zr*tukr
               dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr
c
c     get the field gradient for direct polarization force
c
               if (use_thole) then
                  term1 = sc3*(rr3-rr5*xr*xr) + rc3(1)*xr
                  term2 = (sc3+sc5)*rr5*xr - rc3(1)
                  term3 = sc5*(rr7*xr*xr-rr5) - rc5(1)*xr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*xr-rc5(1)+1.5d0*sc7*rr7*xr)
                  term6 = xr * (sc7*rr9*xr-rc7(1))
                  tixx = ci*term1 + dix*term2 - dir*term3
     &                      - qixx*term4 + qix*term5 - qir*term6
     &                      + (qiy*yr+qiz*zr)*sc7*rr7
                  tkxx = ck*term1 - dkx*term2 + dkr*term3
     &                      - qkxx*term4 + qkx*term5 - qkr*term6
     &                      + (qky*yr+qkz*zr)*sc7*rr7
                  term1 = sc3*(rr3-rr5*yr*yr) + rc3(2)*yr
                  term2 = (sc3+sc5)*rr5*yr - rc3(2)
                  term3 = sc5*(rr7*yr*yr-rr5) - rc5(2)*yr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*yr-rc5(2)+1.5d0*sc7*rr7*yr)
                  term6 = yr * (sc7*rr9*yr-rc7(2))
                  tiyy = ci*term1 + diy*term2 - dir*term3
     &                      - qiyy*term4 + qiy*term5 - qir*term6
     &                      + (qix*xr+qiz*zr)*sc7*rr7
                  tkyy = ck*term1 - dky*term2 + dkr*term3
     &                      - qkyy*term4 + qky*term5 - qkr*term6
     &                      + (qkx*xr+qkz*zr)*sc7*rr7
                  term1 = sc3*(rr3-rr5*zr*zr) + rc3(3)*zr
                  term2 = (sc3+sc5)*rr5*zr - rc3(3)
                  term3 = sc5*(rr7*zr*zr-rr5) - rc5(3)*zr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*zr-rc5(3)+1.5d0*sc7*rr7*zr)
                  term6 = zr * (sc7*rr9*zr-rc7(3))
                  tizz = ci*term1 + diz*term2 - dir*term3
     &                      - qizz*term4 + qiz*term5 - qir*term6
     &                      + (qix*xr+qiy*yr)*sc7*rr7
                  tkzz = ck*term1 - dkz*term2 + dkr*term3
     &                      - qkzz*term4 + qkz*term5 - qkr*term6
     &                      + (qkx*xr+qky*yr)*sc7*rr7
                  term2 = sc3*rr5*xr - rc3(1)
                  term1 = yr * term2
                  term3 = sc5 * rr5 * yr
                  term4 = yr * (sc5*rr7*xr-rc5(1))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*xr-rc5(1))
                  term7 = 2.0d0 * sc7 * rr7 * yr
                  term8 = yr * (sc7*rr9*xr-rc7(1))
                  tixy = -ci*term1 + diy*term2 + dix*term3
     &                      - dir*term4 - qixy*term5 + qiy*term6
     &                      + qix*term7 - qir*term8
                  tkxy = -ck*term1 - dky*term2 - dkx*term3
     &                      + dkr*term4 - qkxy*term5 + qky*term6
     &                      + qkx*term7 - qkr*term8
                  term2 = sc3*rr5*xr - rc3(1)
                  term1 = zr * term2
                  term3 = sc5 * rr5 * zr
                  term4 = zr * (sc5*rr7*xr-rc5(1))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*xr-rc5(1))
                  term7 = 2.0d0 * sc7 * rr7 * zr
                  term8 = zr * (sc7*rr9*xr-rc7(1))
                  tixz = -ci*term1 + diz*term2 + dix*term3
     &                      - dir*term4 - qixz*term5 + qiz*term6
     &                      + qix*term7 - qir*term8
                  tkxz = -ck*term1 - dkz*term2 - dkx*term3
     &                      + dkr*term4 - qkxz*term5 + qkz*term6
     &                      + qkx*term7 - qkr*term8
                  term2 = sc3*rr5*yr - rc3(2)
                  term1 = zr * term2
                  term3 = sc5 * rr5 * zr
                  term4 = zr * (sc5*rr7*yr-rc5(2))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*yr-rc5(2))
                  term7 = 2.0d0 * sc7 * rr7 * zr
                  term8 = zr * (sc7*rr9*yr-rc7(2))
                  tiyz = -ci*term1 + diz*term2 + diy*term3
     &                      - dir*term4 - qiyz*term5 + qiz*term6
     &                      + qiy*term7 - qir*term8
                  tkyz = -ck*term1 - dkz*term2 - dky*term3
     &                      + dkr*term4 - qkyz*term5 + qkz*term6
     &                      + qky*term7 - qkr*term8
c
c     get the field gradient for direct polarization force
c
               else if (use_chgpen) then
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*xr*xr
                  term1core = rr3 - rr5*xr*xr
                  term2i = 2.0d0*rr5*dmpi(5)*xr 
                  term3i = rr7*dmpi(7)*xr*xr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*xr
                  term6i = rr9*dmpi(9)*xr*xr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*xr*xr
                  term2k = 2.0d0*rr5*dmpk(5)*xr
                  term3k = rr7*dmpk(7)*xr*xr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*xr
                  term6k = rr9*dmpk(9)*xr*xr
                  tixx = vali*term1i + corei*term1core  
     &                      + dix*term2i - dir*term3i
     &                      - qixx*term4i + qix*term5i - qir*term6i
     &                      + (qiy*yr+qiz*zr)*rr7*dmpi(7)
                  tkxx = valk*term1k + corek*term1core
     &                      - dkx*term2k + dkr*term3k
     &                      - qkxx*term4k + qkx*term5k - qkr*term6k
     &                      + (qky*yr+qkz*zr)*rr7*dmpk(7)
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*yr*yr
                  term1core = rr3 - rr5*yr*yr
                  term2i = 2.0d0*rr5*dmpi(5)*yr
                  term3i = rr7*dmpi(7)*yr*yr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*yr
                  term6i = rr9*dmpi(9)*yr*yr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*yr*yr
                  term2k = 2.0d0*rr5*dmpk(5)*yr
                  term3k = rr7*dmpk(7)*yr*yr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*yr
                  term6k = rr9*dmpk(9)*yr*yr
                  tiyy = vali*term1i + corei*term1core
     &                      + diy*term2i - dir*term3i
     &                      - qiyy*term4i + qiy*term5i - qir*term6i
     &                      + (qix*xr+qiz*zr)*rr7*dmpi(7)
                  tkyy = valk*term1k + corek*term1core
     &                      - dky*term2k + dkr*term3k
     &                      - qkyy*term4k + qky*term5k - qkr*term6k
     &                      + (qkx*xr+qkz*zr)*rr7*dmpk(7)
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*zr*zr
                  term1core = rr3 - rr5*zr*zr
                  term2i = 2.0d0*rr5*dmpi(5)*zr
                  term3i = rr7*dmpi(7)*zr*zr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*zr
                  term6i = rr9*dmpi(9)*zr*zr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*zr*zr
                  term2k = 2.0d0*rr5*dmpk(5)*zr
                  term3k = rr7*dmpk(7)*zr*zr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*zr
                  term6k = rr9*dmpk(9)*zr*zr
                  tizz = vali*term1i + corei*term1core
     &                      + diz*term2i - dir*term3i
     &                      - qizz*term4i + qiz*term5i - qir*term6i
     &                      + (qix*xr+qiy*yr)*rr7*dmpi(7)
                  tkzz = valk*term1k + corek*term1core
     &                      - dkz*term2k + dkr*term3k
     &                      - qkzz*term4k + qkz*term5k - qkr*term6k
     &                      + (qkx*xr+qky*yr)*rr7*dmpk(7)
                  term2i = rr5*dmpi(5)*xr 
                  term1i = yr * term2i
                  term1core = rr5*xr*yr
                  term3i = rr5*dmpi(5)*yr
                  term4i = yr * (rr7*dmpi(7)*xr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*xr
                  term7i = 2.0d0*rr7*dmpi(7)*yr
                  term8i = yr*rr9*dmpi(9)*xr
                  term2k = rr5*dmpk(5)*xr
                  term1k = yr * term2k
                  term3k = rr5*dmpk(5)*yr
                  term4k = yr * (rr7*dmpk(7)*xr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*xr
                  term7k = 2.0d0*rr7*dmpk(7)*yr
                  term8k = yr*rr9*dmpk(9)*xr
                  tixy = -vali*term1i - corei*term1core 
     &                      + diy*term2i + dix*term3i
     &                      - dir*term4i - qixy*term5i + qiy*term6i
     &                      + qix*term7i - qir*term8i
                  tkxy = -valk*term1k - corek*term1core 
     &                      - dky*term2k - dkx*term3k
     &                      + dkr*term4k - qkxy*term5k + qky*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5*dmpi(5)*xr
                  term1i = zr * term2i
                  term1core = rr5*xr*zr
                  term3i = rr5*dmpi(5)*zr
                  term4i = zr * (rr7*dmpi(7)*xr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*xr
                  term7i = 2.0d0*rr7*dmpi(7)*zr
                  term8i = zr*rr9*dmpi(9)*xr
                  term2k = rr5*dmpk(5)*xr
                  term1k = zr * term2k
                  term3k = rr5*dmpk(5)*zr
                  term4k = zr * (rr7*dmpk(7)*xr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*xr
                  term7k = 2.0d0*rr7*dmpk(7)*zr
                  term8k = zr*rr9*dmpk(9)*xr
                  tixz = -vali*term1i - corei*term1core
     &                      + diz*term2i + dix*term3i
     &                      - dir*term4i - qixz*term5i + qiz*term6i
     &                      + qix*term7i - qir*term8i
                  tkxz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dkx*term3k
     &                      + dkr*term4k - qkxz*term5k + qkz*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5*dmpi(5)*yr
                  term1i = zr * term2i
                  term1core = rr5*yr*zr
                  term3i = rr5*dmpi(5)*zr
                  term4i = zr * (rr7*dmpi(7)*yr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*yr
                  term7i = 2.0d0*rr7*dmpi(7)*zr
                  term8i = zr*rr9*dmpi(9)*yr
                  term2k = rr5*dmpk(5)*yr
                  term1k = zr * term2k
                  term3k = rr5*dmpk(5)*zr
                  term4k = zr * (rr7*dmpk(7)*yr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*yr
                  term7k = 2.0d0*rr7*dmpk(7)*zr
                  term8k = zr*rr9*dmpk(9)*yr
                  tiyz = -vali*term1i - corei*term1core
     &                      + diz*term2i + diy*term3i
     &                      - dir*term4i - qiyz*term5i + qiz*term6i
     &                      + qiy*term7i - qir*term8i
                  tkyz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dky*term3k
     &                      + dkr*term4k - qkyz*term5k + qkz*term6k
     &                      + qky*term7k - qkr*term8k
               end if
c
c     get the dEd/dR terms for Thole direct polarization force
c
               if (use_thole) then
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      - tkxx*uixp - tkxy*uiyp - tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      - tkxy*uixp - tkyy*uiyp - tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      - tkxz*uixp - tkyz*uiyp - tkzz*uizp
                  frcx = dscale(k) * depx
                  frcy = dscale(k) * depy
                  frcz = dscale(k) * depz
c
c     get the dEp/dR terms for Thole direct polarization force
c
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = frcx + pscale(k)*depx
                  frcy = frcy + pscale(k)*depy
                  frcz = frcz + pscale(k)*depz
c
c     get the dEp/dR terms for chgpen direct polarization force
c
               else if (use_chgpen) then
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = 2.0d0*dscale(k)*depx
                  frcy = 2.0d0*dscale(k)*depy
                  frcz = 2.0d0*dscale(k)*depz
               end if
c
c     reset Thole values if alternate direct damping was used
c
               if (use_tholed) then
                  sc3 = 1.0d0
                  sc5 = 1.0d0
                  do j = 1, 3
                     rc3(j) = 0.0d0
                     rc5(j) = 0.0d0
                  end do
                  damp = pdi * pdamp(k)
                  if (damp .ne. 0.0d0) then
                     pgamma = min(pti,thole(k))
                     damp = pgamma * (r/damp)**3
                     if (damp .lt. 50.0d0) then
                        expdamp = exp(-damp)
                        sc3 = 1.0d0 - expdamp
                        sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                        temp3 = damp * expdamp * rr5
                        temp5 = 3.0d0 * damp / r2
                        rc3(1) = xr * temp3
                        rc3(2) = yr * temp3
                        rc3(3) = zr * temp3
                        rc5(1) = rc3(1) * temp5
                        rc5(2) = rc3(2) * temp5
                        rc5(3) = rc3(3) * temp5
                     end if
                  end if
               end if
c
c     get the dtau/dr terms used for mutual polarization force
c
               if (poltyp.eq.'MUTUAL' .and. use_thole) then
                  term1 = (sc3+sc5) * rr5
                  term2 = term1*xr - rc3(1)
                  term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr - rc3(2)
                  term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr - rc3(3)
                  term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = sc5 * rr5 * yr
                  term2 = sc3*rr5*xr - rc3(1)
                  term3 = yr * (sc5*rr7*xr-rc5(1))
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = sc5 * rr5 * zr
                  term3 = zr * (sc5*rr7*xr-rc5(1))
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = sc3*rr5*yr - rc3(2)
                  term3 = zr * (sc5*rr7*yr-rc5(2))
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + uscale(k)*depx
                  frcy = frcy + uscale(k)*depy
                  frcz = frcz + uscale(k)*depz
c
c     get the dtau/dr terms used for mutual polarization force
c
               else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then
                  term1 = 2.0d0 * dmpik(5) * rr5
                  term2 = term1*xr
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr 
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr 
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr 
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr 
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr 
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = rr5*dmpik(5)*yr
                  term2 = rr5*dmpik(5)*xr 
                  term3 = yr * (rr7*dmpik(7)*xr)
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = rr5 *dmpik(5) * zr
                  term3 = zr * (rr7*dmpik(7)*xr)
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = rr5*dmpik(5)*yr 
                  term3 = zr * (rr7*dmpik(7)*yr)
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + wscale(k)*depx
                  frcy = frcy + wscale(k)*depy
                  frcz = frcz + wscale(k)*depz
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_thole) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = (sc3+sc5) * rr5
                        term2 = term1*xr - rc3(1)
                        term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                        tixx = uopt(j,1,ii)*term2 + uirm*term3
                        tkxx = uopt(m,1,kk)*term2 + ukrm*term3
                        term2 = term1*yr - rc3(2)
                        term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                        tiyy = uopt(j,2,ii)*term2 + uirm*term3
                        tkyy = uopt(m,2,kk)*term2 + ukrm*term3
                        term2 = term1*zr - rc3(3)
                        term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                        tizz = uopt(j,3,ii)*term2 + uirm*term3
                        tkzz = uopt(m,3,kk)*term2 + ukrm*term3
                        term1 = sc5 * rr5 * yr
                        term2 = sc3*rr5*xr - rc3(1)
                        term3 = yr * (sc5*rr7*xr-rc5(1))
                        tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2
     &                            - uirm*term3
                        tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2
     &                            - ukrm*term3
                        term1 = sc5 * rr5 * zr
                        term3 = zr * (sc5*rr7*xr-rc5(1))
                        tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        term2 = sc3*rr5*yr - rc3(2)
                        term3 = zr * (sc5*rr7*yr-rc5(2))
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*uscale(k)*depx
                        frcy = frcy + copm(j+m+1)*uscale(k)*depy
                        frcz = frcz + copm(j+m+1)*uscale(k)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_chgpen) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = 2.0d0 * dmpik(5) * rr5
                        term2 = term1*xr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr
                        tixx = uopt(j,1,i)*term2 + uirm*term3
                        tkxx = uopt(m,1,k)*term2 + ukrm*term3
                        term2 = term1*yr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr
                        tiyy = uopt(j,2,i)*term2 + uirm*term3
                        tkyy = uopt(m,2,k)*term2 + ukrm*term3
                        term2 = term1*zr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr
                        tizz = uopt(j,3,i)*term2 + uirm*term3
                        tkzz = uopt(m,3,k)*term2 + ukrm*term3
                        term1 = rr5*dmpik(5)*yr
                        term2 = rr5*dmpik(5)*xr
                        term3 = yr * (rr7*dmpik(7)*xr)
                        tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2
     &                            - uirm*term3
                        tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2
     &                            - ukrm*term3
                        term1 = rr5 *dmpik(5) * zr
                        term3 = zr * (rr7*dmpik(7)*xr)
                        tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        term2 = rr5*dmpik(5)*yr
                        term3 = zr * (rr7*dmpik(7)*yr)
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*wscale(k)*depx
                        frcy = frcy + copm(j+m+1)*wscale(k)*depy
                        frcz = frcz + copm(j+m+1)*wscale(k)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for TCG polarization force
c
               else if (poltyp.eq.'TCG' .and. use_thole) then
                  do j = 1, tcgnab
                     ukx = ubd(1,k,j)
                     uky = ubd(2,k,j)
                     ukz = ubd(3,k,j)
                     ukxp = ubp(1,k,j)
                     ukyp = ubp(2,k,j)
                     ukzp = ubp(3,k,j)
                     uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = (sc3+sc5) * rr5
                     term2 = term1*xr - rc3(1)
                     term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                     tixx = uax(j)*term2 + uirt*term3
                     tkxx = ukx*term2 + ukrt*term3
                     term2 = term1*yr - rc3(2)
                     term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                     tiyy = uay(j)*term2 + uirt*term3
                     tkyy = uky*term2 + ukrt*term3
                     term2 = term1*zr - rc3(3)
                     term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                     tizz = uaz(j)*term2 + uirt*term3
                     tkzz = ukz*term2 + ukrt*term3
                     term1 = sc5 * rr5 * yr
                     term2 = sc3*rr5*xr - rc3(1)
                     term3 = yr * (sc5*rr7*xr-rc5(1))
                     tixy = uax(j)*term1 + uay(j)*term2 - uirt*term3
                     tkxy = ukx*term1 + uky*term2 - ukrt*term3
                     term1 = sc5 * rr5 * zr
                     term3 = zr * (sc5*rr7*xr-rc5(1))
                     tixz = uax(j)*term1 + uaz(j)*term2 - uirt*term3
                     tkxz = ukx*term1 + ukz*term2 - ukrt*term3
                     term2 = sc3*rr5*yr - rc3(2)
                     term3 = zr * (sc5*rr7*yr-rc5(2))
                     tiyz = uay(j)*term1 + uaz(j)*term2 - uirt*term3
                     tkyz = uky*term1 + ukz*term2 - ukrt*term3
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*uaxp(j) + tkxy*uayp(j)
     &                         + tkxz*uazp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*uaxp(j) + tkyy*uayp(j)
     &                         + tkyz*uazp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*uaxp(j) + tkyz*uayp(j)
     &                         + tkzz*uazp(j)
                     frcx = frcx + uscale(k)*depx
                     frcy = frcy + uscale(k)*depy
                     frcz = frcz + uscale(k)*depz
                     ukx = uad(1,k,j)
                     uky = uad(2,k,j)
                     ukz = uad(3,k,j)
                     ukxp = uap(1,k,j)
                     ukyp = uap(2,k,j)
                     ukzp = uap(3,k,j)
                     uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = (sc3+sc5) * rr5
                     term2 = term1*xr - rc3(1)
                     term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                     tixx = ubx(j)*term2 + uirt*term3
                     tkxx = ukx*term2 + ukrt*term3
                     term2 = term1*yr - rc3(2)
                     term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                     tiyy = uby(j)*term2 + uirt*term3
                     tkyy = uky*term2 + ukrt*term3
                     term2 = term1*zr - rc3(3)
                     term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                     tizz = ubz(j)*term2 + uirt*term3
                     tkzz = ukz*term2 + ukrt*term3
                     term1 = sc5 * rr5 * yr
                     term2 = sc3*rr5*xr - rc3(1)
                     term3 = yr * (sc5*rr7*xr-rc5(1))
                     tixy = ubx(j)*term1 + uby(j)*term2 - uirt*term3
                     tkxy = ukx*term1 + uky*term2 - ukrt*term3
                     term1 = sc5 * rr5 * zr
                     term3 = zr * (sc5*rr7*xr-rc5(1))
                     tixz = ubx(j)*term1 + ubz(j)*term2 - uirt*term3
                     tkxz = ukx*term1 + ukz*term2 - ukrt*term3
                     term2 = sc3*rr5*yr - rc3(2)
                     term3 = zr * (sc5*rr7*yr-rc5(2))
                     tiyz = uby(j)*term1 + ubz(j)*term2 - uirt*term3
                     tkyz = uky*term1 + ukz*term2 - ukrt*term3
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*ubxp(j) + tkxy*ubyp(j)
     &                         + tkxz*ubzp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*ubxp(j) + tkyy*ubyp(j)
     &                         + tkyz*ubzp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*ubxp(j) + tkyz*ubyp(j)
     &                         + tkzz*ubzp(j)
                     frcx = frcx + uscale(k)*depx
                     frcy = frcy + uscale(k)*depy
                     frcz = frcz + uscale(k)*depz
                  end do
               end if
c
c     increment force-based gradient on the interaction sites
c
               dep(1,i) = dep(1,i) + frcx
               dep(2,i) = dep(2,i) + frcy
               dep(3,i) = dep(3,i) + frcz
               dep(1,k) = dep(1,k) - frcx
               dep(2,k) = dep(2,k) - frcy
               dep(3,k) = dep(3,k) - frcz
c
c     increment the virial due to pairwise Cartesian forces
c
               vxx = -xr * frcx
               vxy = -0.5d0 * (yr*frcx+xr*frcy)
               vxz = -0.5d0 * (zr*frcx+xr*frcz)
               vyy = -yr * frcy
               vyz = -0.5d0 * (zr*frcy+yr*frcz)
               vzz = -zr * frcz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
               uscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP DO reduction(+:dep,vir)
c
c     torque is induced field and gradient cross permanent moments
c
      do ii = 1, npole
         i = ipole(ii)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         tep(1) = diz*ufld(2,i) - diy*ufld(3,i)
     &               + qixz*dufld(2,i) - qixy*dufld(4,i)
     &               + 2.0d0*qiyz*(dufld(3,i)-dufld(6,i))
     &               + (qizz-qiyy)*dufld(5,i)
         tep(2) = dix*ufld(3,i) - diz*ufld(1,i)
     &               - qiyz*dufld(2,i) + qixy*dufld(5,i)
     &               + 2.0d0*qixz*(dufld(6,i)-dufld(1,i))
     &               + (qixx-qizz)*dufld(4,i)
         tep(3) = diy*ufld(1,i) - dix*ufld(2,i)
     &               + qiyz*dufld(4,i) - qixz*dufld(5,i)
     &               + 2.0d0*qixy*(dufld(1,i)-dufld(3,i))
     &               + (qiyy-qixx)*dufld(2,i)
         call torque (i,tep,fix,fiy,fiz,dep)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3))
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
c
c     modify the gradient and virial for charge flux
c
      if (use_chgflx) then
         call dcflux (pot,decfx,decfy,decfz)
!$OMP    DO reduction(+:dep,vir)
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            frcx = decfx(i)
            frcy = decfy(i)
            frcz = decfz(i)
            dep(1,i) = dep(1,i) + frcx
            dep(2,i) = dep(2,i) + frcy
            dep(3,i) = dep(3,i) + frcz
            vxx = xi * frcx
            vxy = yi * frcx
            vxz = zi * frcx
            vyy = yi * frcy
            vyz = zi * frcy
            vzz = zi * frcz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vxy
            vir(3,1) = vir(3,1) + vxz
            vir(1,2) = vir(1,2) + vxy
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vyz
            vir(1,3) = vir(1,3) + vxz
            vir(2,3) = vir(2,3) + vyz
            vir(3,3) = vir(3,3) + vzz
         end do
!$OMP    END DO
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      deallocate (dscale)
      deallocate (uscale)
      deallocate (wscale)
      deallocate (ufld)
      deallocate (dufld)
      deallocate (pot)
      deallocate (decfx)
      deallocate (decfy)
      deallocate (decfz)
      return
      end
c
c
c     ###################################################################
c     ##                                                               ##
c     ##  subroutine epolar1c  --  Ewald polarization derivs via loop  ##
c     ##                                                               ##
c     ###################################################################
c
c
c     "epolar1c" calculates the dipole polarization energy and
c     derivatives with respect to Cartesian coordinates using
c     particle mesh Ewald summation and a double loop
c
c
      subroutine epolar1c
      use atoms
      use boxes
      use chgpot
      use deriv
      use energi
      use ewald
      use math
      use mpole
      use pme
      use polar
      use polpot
      use poltcg
      use potent
      use virial
      implicit none
      integer i,j,ii
      integer ix,iy,iz
      real*8 f,term
      real*8 dix,diy,diz
      real*8 uix,uiy,uiz
      real*8 xd,yd,zd
      real*8 xq,yq,zq
      real*8 xu,yu,zu
      real*8 xup,yup,zup
      real*8 xv,yv,zv,vterm
      real*8 xufield,yufield
      real*8 zufield
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 fix(3),fiy(3),fiz(3)
      real*8 tep(3)
c
c
c     zero out the polarization energy and derivatives
c
      ep = 0.0d0
      do i = 1, n
         do j = 1, 3
            dep(j,i) = 0.0d0
         end do
      end do
      if (npole .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bsporder
      aewald = apewald
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     compute the total induced dipole polarization energy
c
      call epolar1e
c
c     compute the real space part of the Ewald summation
c
      call epreal1c
c
c     compute the reciprocal space part of the Ewald summation
c
      call eprecip1
c
c     compute the Ewald self-energy torque and virial terms
c
      term = (4.0d0/3.0d0) * f * aewald**3 / rootpi
      do ii = 1, npole
         i = ipole(ii)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         uix = 0.5d0 * (uind(1,i)+uinp(1,i))
         uiy = 0.5d0 * (uind(2,i)+uinp(2,i))
         uiz = 0.5d0 * (uind(3,i)+uinp(3,i))
         tep(1) = term * (diy*uiz-diz*uiy)
         tep(2) = term * (diz*uix-dix*uiz)
         tep(3) = term * (dix*uiy-diy*uix)
         call torque (i,tep,fix,fiy,fiz,dep)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                     + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                     + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3))
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                     + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         xu = 0.0d0
         yu = 0.0d0
         zu = 0.0d0
         xup = 0.0d0
         yup = 0.0d0
         zup = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            xd = xd + rpole(2,i) + rpole(1,i)*x(i)
            yd = yd + rpole(3,i) + rpole(1,i)*y(i)
            zd = zd + rpole(4,i) + rpole(1,i)*z(i)
            xu = xu + uind(1,i)
            yu = yu + uind(2,i)
            zu = zu + uind(3,i)
            xup = xup + uinp(1,i)
            yup = yup + uinp(2,i)
            zup = zup + uinp(3,i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         ep = ep + term*(xd*xu+yd*yu+zd*zu)
         do ii = 1, npole
            i = ipole(ii)
            dep(1,i) = dep(1,i) + term*rpole(1,i)*(xu+xup)
            dep(2,i) = dep(2,i) + term*rpole(1,i)*(yu+yup)
            dep(3,i) = dep(3,i) + term*rpole(1,i)*(zu+zup)
         end do
         xufield = -term * (xu+xup)
         yufield = -term * (yu+yup)
         zufield = -term * (zu+zup)
         do ii = 1, npole
            tep(1) = rpole(3,i)*zufield - rpole(4,i)*yufield
            tep(2) = rpole(4,i)*xufield - rpole(2,i)*zufield
            tep(3) = rpole(2,i)*yufield - rpole(3,i)*xufield
            call torque (i,tep,fix,fiy,fiz,dep)
         end do
c
c     boundary correction to virial due to overall cell dipole
c
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         xq = 0.0d0
         yq = 0.0d0
         zq = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            xd = xd + rpole(2,i)
            yd = yd + rpole(3,i)
            zd = zd + rpole(4,i)
            xq = xq + rpole(1,i)*x(i)
            yq = yq + rpole(1,i)*y(i)
            zq = zq + rpole(1,i)*z(i)
         end do
         xv = xq * (xu+xup)
         yv = yq * (yu+yup)
         zv = zq * (zu+zup)
         vterm = xv + yv + zv + xu*xup + yu*yup + zu*zup
     &              + xd*(xu+xup) + yd*(yu+yup) + zd*(zu+zup)
         vterm = term * vterm
         vir(1,1) = vir(1,1) + term*xv + vterm
         vir(2,1) = vir(2,1) + term*xv
         vir(3,1) = vir(3,1) + term*xv
         vir(1,2) = vir(1,2) + term*yv
         vir(2,2) = vir(2,2) + term*yv + vterm
         vir(3,2) = vir(3,2) + term*yv
         vir(1,3) = vir(1,3) + term*zv
         vir(2,3) = vir(2,3) + term*zv
         vir(3,3) = vir(3,3) + term*zv + vterm
         if (poltyp .eq. 'DIRECT') then
            vterm = term * (xu*xup+yu*yup+zu*zup)
            vir(1,1) = vir(1,1) + vterm
            vir(2,2) = vir(2,2) + vterm
            vir(3,3) = vir(3,3) + vterm
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine epreal1c  --  Ewald real space derivs via loop  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "epreal1c" evaluates the real space portion of the Ewald
c     summation energy and gradient due to dipole polarization
c     via a double loop
c
c
      subroutine epreal1c
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use deriv
      use ewald
      use math
      use mplpot
      use molcul
      use mpole
      use polar
      use polgrp
      use polopt
      use polpot
      use poltcg
      use potent
      use shunt
      use virial
      implicit none
      integer i,j,k,m
      integer ii,kk,jcell
      integer ix,iy,iz
      integer it,kt
      real*8 f,pgamma
      real*8 pdi,pti,ddi
      real*8 damp,expdamp
      real*8 temp3,temp5,temp7
      real*8 sc3,sc5,sc7
      real*8 psc3,psc5,psc7
      real*8 dsc3,dsc5,dsc7
      real*8 usc3,usc5
      real*8 psr3,psr5,psr7
      real*8 dsr3,dsr5,dsr7
      real*8 usr3,usr5
      real*8 rr3core,rr5core
      real*8 rr3i,rr5i
      real*8 rr7i,rr9i
      real*8 rr3k,rr5k
      real*8 rr7k,rr9k
      real*8 rr5ik,rr7ik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 uixp,uiyp,uizp
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 ukxp,ukyp,ukzp
      real*8 dir,uir,uirp
      real*8 dkr,ukr,ukrp
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 uirm,ukrm
      real*8 uirt,ukrt
      real*8 tuir,tukr
      real*8 tixx,tiyy,tizz
      real*8 tixy,tixz,tiyz
      real*8 tkxx,tkyy,tkzz
      real*8 tkxy,tkxz,tkyz
      real*8 tix3,tiy3,tiz3
      real*8 tix5,tiy5,tiz5
      real*8 tkx3,tky3,tkz3
      real*8 tkx5,tky5,tkz5
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 term6,term7
      real*8 term1core
      real*8 term1i,term2i,term3i
      real*8 term4i,term5i,term6i
      real*8 term7i,term8i
      real*8 term1k,term2k,term3k
      real*8 term4k,term5k,term6k
      real*8 term7k,term8k
      real*8 poti,potk
      real*8 depx,depy,depz
      real*8 frcx,frcy,frcz
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 rc3(3),rc5(3),rc7(3)
      real*8 prc3(3),prc5(3),prc7(3)
      real*8 drc3(3),drc5(3),drc7(3)
      real*8 urc3(3),urc5(3),tep(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 uax(3),uay(3),uaz(3)
      real*8 ubx(3),uby(3),ubz(3)
      real*8 uaxp(3),uayp(3),uazp(3)
      real*8 ubxp(3),ubyp(3),ubzp(3)
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9),dmpe(9)
      real*8, allocatable :: pscale(:)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: wscale(:)
      real*8, allocatable :: ufld(:,:)
      real*8, allocatable :: dufld(:,:)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
      allocate (dscale(n))
      allocate (uscale(n))
      allocate (wscale(n))
      allocate (ufld(3,n))
      allocate (dufld(6,n))
      allocate (pot(n))
      allocate (decfx(n))
      allocate (decfy(n))
      allocate (decfz(n))
c
c     set exclusion coefficients and arrays to store fields
c
      do i = 1, n
         pscale(i) = 1.0d0
         dscale(i) = 1.0d0
         uscale(i) = 1.0d0
         wscale(i) = 1.0d0
         do j = 1, 3
            ufld(j,i) = 0.0d0
         end do
         do j = 1, 6
            dufld(j,i) = 0.0d0
         end do
         pot(i) = 0.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     compute the dipole polarization gradient components
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         uixp = uinp(1,i)
         uiyp = uinp(2,i)
         uizp = uinp(3,i)
         do j = 1, tcgnab
            uax(j) = uad(1,i,j)
            uay(j) = uad(2,i,j)
            uaz(j) = uad(3,i,j)
            uaxp(j) = uap(1,i,j)
            uayp(j) = uap(2,i,j)
            uazp(j) = uap(3,i,j)
            ubx(j) = ubd(1,i,j)
            uby(j) = ubd(2,i,j)
            ubz(j) = ubd(3,i,j)
            ubxp(j) = ubp(1,i,j)
            ubyp(j) = ubp(2,i,j)
            ubzp(j) = ubp(3,i,j)
         end do
         if (use_thole) then
            pdi = pdamp(i)
            pti = thole(i)
            ddi = tholed(i)
         else if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
               uscale(ip14(j,i)) = u4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
               ukxp = uinp(1,k)
               ukyp = uinp(2,k)
               ukzp = uinp(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               uir = uix*xr + uiy*yr + uiz*zr
               uirp = uixp*xr + uiyp*yr + uizp*zr
               ukr = ukx*xr + uky*yr + ukz*zr
               ukrp = ukxp*xr + ukyp*yr + ukzp*zr
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
c
c     calculate real space Ewald error function damping
c
               call dampewald (9,r,r2,f,dmpe)
c
c     apply Thole polarization damping to scale factors
c
               sc3 = 1.0d0
               sc5 = 1.0d0
               sc7 = 1.0d0
               do j = 1, 3
                  rc3(j) = 0.0d0
                  rc5(j) = 0.0d0
                  rc7(j) = 0.0d0
               end do
c
c     apply Thole polarization damping to scale factors
c
               if (use_thole) then
                  damp = pdi * pdamp(k)
                  it = jpolar(i)
                  kt = jpolar(k)
                  if (use_tholed) then
                     pgamma = thdval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**(1.5d0)
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp) 
                           sc3 = 1.0d0 - expdamp 
                           sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp
     &                                      +0.15d0*damp**2)
                           temp3 = 1.5d0 * damp * expdamp / r2
                           temp5 = 0.5d0 * (1.0d0+damp)
                           temp7 = 0.7d0 + 0.15d0*damp**2/temp5
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  else
                     pgamma = thlval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**3
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp)
                           sc3 = 1.0d0 - expdamp
                           sc5 = 1.0d0 - (1.0d0+damp)*expdamp
                           sc7 = 1.0d0 - (1.0d0+damp+0.6d0*damp**2)
     &                                          *expdamp
                           temp3 = 3.0d0 * damp * expdamp / r2
                           temp5 = damp
                           temp7 = -0.2d0 + 0.6d0*damp
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  end if
                  psc3 = 1.0d0 - sc3*pscale(k)
                  psc5 = 1.0d0 - sc5*pscale(k)
                  psc7 = 1.0d0 - sc7*pscale(k)
                  dsc3 = 1.0d0 - sc3*dscale(k)
                  dsc5 = 1.0d0 - sc5*dscale(k)
                  dsc7 = 1.0d0 - sc7*dscale(k)
                  usc3 = 1.0d0 - sc3*uscale(k)
                  usc5 = 1.0d0 - sc5*uscale(k)
                  psr3 = dmpe(3) - psc3*rr3
                  psr5 = dmpe(5) - psc5*rr5
                  psr7 = dmpe(7) - psc7*rr7
                  dsr3 = dmpe(3) - dsc3*rr3
                  dsr5 = dmpe(5) - dsc5*rr5
                  dsr7 = dmpe(7) - dsc7*rr7
                  usr3 = dmpe(3) - usc3*rr3
                  usr5 = dmpe(5) - usc5*rr5
                  do j = 1, 3
                     prc3(j) = rc3(j) * pscale(k)
                     prc5(j) = rc5(j) * pscale(k)
                     prc7(j) = rc7(j) * pscale(k)
                     drc3(j) = rc3(j) * dscale(k)
                     drc5(j) = rc5(j) * dscale(k)
                     drc7(j) = rc7(j) * dscale(k)
                     urc3(j) = rc3(j) * uscale(k)
                     urc5(j) = rc5(j) * uscale(k)
                  end do
c
c     apply charge penetration damping to scale factors
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik)
                  rr3core = dmpe(3) - (1.0d0-dscale(k))*rr3
                  rr5core = dmpe(5) - (1.0d0-dscale(k))*rr5
                  rr3i = dmpe(3) - (1.0d0-dscale(k)*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-dscale(k)*dmpi(5))*rr5
                  rr7i = dmpe(7) - (1.0d0-dscale(k)*dmpi(7))*rr7
                  rr9i = dmpe(9) - (1.0d0-dscale(k)*dmpi(9))*rr9
                  rr3k = dmpe(3) - (1.0d0-dscale(k)*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-dscale(k)*dmpk(5))*rr5
                  rr7k = dmpe(7) - (1.0d0-dscale(k)*dmpk(7))*rr7
                  rr9k = dmpe(9) - (1.0d0-dscale(k)*dmpk(9))*rr9
                  rr5ik = dmpe(5) - (1.0d0-wscale(k)*dmpik(5))*rr5
                  rr7ik = dmpe(7) - (1.0d0-wscale(k)*dmpik(7))*rr7
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_thole) then
                     poti = -ukr*psr3 - ukrp*dsr3
                     potk = uir*psr3 + uirp*dsr3
                  else if (use_chgpen) then
                     poti = -2.0d0 * ukr * rr3i
                     potk = 2.0d0 * uir * rr3k
                  end if
                  pot(i) = pot(i) + poti 
                  pot(k) = pot(k) + potk 
               end if
c
c     get the induced dipole field used for dipole torques
c
               if (use_thole) then
                  tix3 = psr3*ukx + dsr3*ukxp
                  tiy3 = psr3*uky + dsr3*ukyp
                  tiz3 = psr3*ukz + dsr3*ukzp
                  tkx3 = psr3*uix + dsr3*uixp
                  tky3 = psr3*uiy + dsr3*uiyp
                  tkz3 = psr3*uiz + dsr3*uizp
                  tuir = -psr5*ukr - dsr5*ukrp
                  tukr = -psr5*uir - dsr5*uirp
               else if (use_chgpen) then
                  tix3 = 2.0d0*rr3i*ukx
                  tiy3 = 2.0d0*rr3i*uky
                  tiz3 = 2.0d0*rr3i*ukz
                  tkx3 = 2.0d0*rr3k*uix
                  tky3 = 2.0d0*rr3k*uiy
                  tkz3 = 2.0d0*rr3k*uiz
                  tuir = -2.0d0*rr5i*ukr
                  tukr = -2.0d0*rr5k*uir
               end if
               ufld(1,i) = ufld(1,i) + tix3 + xr*tuir
               ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir
               ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir
               ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr
               ufld(2,k) = ufld(2,k) + tky3 + yr*tukr
               ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr
c
c     get induced dipole field gradient used for quadrupole torques
c
               if (use_thole) then
                  tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp)
                  tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp)
                  tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp)
                  tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp)
                  tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp)
                  tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp)
                  tuir = -psr7*ukr - dsr7*ukrp
                  tukr = -psr7*uir - dsr7*uirp
               else if (use_chgpen) then
                  tix5 = 4.0d0 * (rr5i*ukx)
                  tiy5 = 4.0d0 * (rr5i*uky)
                  tiz5 = 4.0d0 * (rr5i*ukz)
                  tkx5 = 4.0d0 * (rr5k*uix)
                  tky5 = 4.0d0 * (rr5k*uiy)
                  tkz5 = 4.0d0 * (rr5k*uiz)
                  tuir = -2.0d0*rr7i*ukr 
                  tukr = -2.0d0*rr7k*uir 
               end if
               dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir
               dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5
     &                         + 2.0d0*xr*yr*tuir
               dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir
               dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5
     &                         + 2.0d0*xr*zr*tuir
               dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5
     &                         + 2.0d0*yr*zr*tuir
               dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir
               dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr
               dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5
     &                         - 2.0d0*xr*yr*tukr
               dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr
               dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5
     &                         - 2.0d0*xr*zr*tukr
               dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5
     &                         - 2.0d0*yr*zr*tukr
               dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr
c
c     get the dEd/dR terms used for direct polarization force
c
               if (use_thole) then
                  term1 = dmpe(5) - dsc3*rr5
                  term2 = dmpe(7) - dsc5*rr7
                  term3 = -dsr3 + term1*xr*xr - rr3*xr*drc3(1)
                  term4 = rr3*drc3(1) - term1*xr - dsr5*xr
                  term5 = term2*xr*xr - dsr5 - rr5*xr*drc5(1)
                  term6 = (dmpe(9)-dsc7*rr9)*xr*xr - dmpe(7)
     &                       - rr7*xr*drc7(1)
                  term7 = rr5*drc5(1) - 2.0d0*dmpe(7)*xr
     &                       + (dsc5+1.5d0*dsc7)*rr7*xr
                  tixx = ci*term3 + dix*term4 + dir*term5
     &                      + 2.0d0*dsr5*qixx + (qiy*yr+qiz*zr)*dsc7*rr7
     &                      + 2.0d0*qix*term7 + qir*term6
                  tkxx = ck*term3 - dkx*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkxx + (qky*yr+qkz*zr)*dsc7*rr7
     &                      + 2.0d0*qkx*term7 + qkr*term6
                  term3 = -dsr3 + term1*yr*yr - rr3*yr*drc3(2)
                  term4 = rr3*drc3(2) - term1*yr - dsr5*yr
                  term5 = term2*yr*yr - dsr5 - rr5*yr*drc5(2)
                  term6 = (dmpe(9)-dsc7*rr9)*yr*yr - dmpe(7)
     &                       - rr7*yr*drc7(2)
                  term7 = rr5*drc5(2) - 2.0d0*dmpe(7)*yr
     &                       + (dsc5+1.5d0*dsc7)*rr7*yr
                  tiyy = ci*term3 + diy*term4 + dir*term5
     &                      + 2.0d0*dsr5*qiyy + (qix*xr+qiz*zr)*dsc7*rr7
     &                      + 2.0d0*qiy*term7 + qir*term6
                  tkyy = ck*term3 - dky*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkyy + (qkx*xr+qkz*zr)*dsc7*rr7
     &                      + 2.0d0*qky*term7 + qkr*term6
                  term3 = -dsr3 + term1*zr*zr - rr3*zr*drc3(3)
                  term4 = rr3*drc3(3) - term1*zr - dsr5*zr
                  term5 = term2*zr*zr - dsr5 - rr5*zr*drc5(3)
                  term6 = (dmpe(9)-dsc7*rr9)*zr*zr - dmpe(7)
     &                       - rr7*zr*drc7(3)
                  term7 = rr5*drc5(3) - 2.0d0*dmpe(7)*zr
     &                       + (dsc5+1.5d0*dsc7)*rr7*zr
                  tizz = ci*term3 + diz*term4 + dir*term5
     &                      + 2.0d0*dsr5*qizz + (qix*xr+qiy*yr)*dsc7*rr7
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkzz = ck*term3 - dkz*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkzz + (qkx*xr+qky*yr)*dsc7*rr7
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  term3 = term1*xr*yr - rr3*yr*drc3(1)
                  term4 = rr3*drc3(1) - term1*xr
                  term5 = term2*xr*yr - rr5*yr*drc5(1)
                  term6 = (dmpe(9)-dsc7*rr9)*xr*yr - rr7*yr*drc7(1)
                  term7 = rr5*drc5(1) - term2*xr
                  tixy = ci*term3 - dsr5*dix*yr + diy*term4 + dir*term5
     &                      + 2.0d0*dsr5*qixy - 2.0d0*dsr7*yr*qix
     &                      + 2.0d0*qiy*term7 + qir*term6
                  tkxy = ck*term3 + dsr5*dkx*yr - dky*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkxy - 2.0d0*dsr7*yr*qkx
     &                      + 2.0d0*qky*term7 + qkr*term6
                  term3 = term1*xr*zr - rr3*zr*drc3(1)
                  term5 = term2*xr*zr - rr5*zr*drc5(1)
                  term6 = (dmpe(9)-dsc7*rr9)*xr*zr - rr7*zr*drc7(1)
                  tixz = ci*term3 - dsr5*dix*zr + diz*term4 + dir*term5
     &                      + 2.0d0*dsr5*qixz - 2.0d0*dsr7*zr*qix
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkxz = ck*term3 + dsr5*dkx*zr - dkz*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkxz - 2.0d0*dsr7*zr*qkx
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  term3 = term1*yr*zr - rr3*zr*drc3(2)
                  term4 = rr3*drc3(2) - term1*yr
                  term5 = term2*yr*zr - rr5*zr*drc5(2)
                  term6 = (dmpe(9)-dsc7*rr9)*yr*zr - rr7*zr*drc7(2)
                  term7 = rr5*drc5(2) - term2*yr
                  tiyz = ci*term3 - dsr5*diy*zr + diz*term4 + dir*term5
     &                      + 2.0d0*dsr5*qiyz - 2.0d0*dsr7*zr*qiy
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkyz = ck*term3 + dsr5*dky*zr - dkz*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkyz - 2.0d0*dsr7*zr*qky
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      - tkxx*uixp - tkxy*uiyp - tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      - tkxy*uixp - tkyy*uiyp - tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      - tkxz*uixp - tkyz*uiyp - tkzz*uizp
                  frcx = depx
                  frcy = depy
                  frcz = depz
c
c     get the dEp/dR terms used for direct polarization force
c
                  term1 = dmpe(5) - psc3*rr5
                  term2 = dmpe(7) - psc5*rr7
                  term3 = -psr3 + term1*xr*xr - rr3*xr*prc3(1)
                  term4 = rr3*prc3(1) - term1*xr - psr5*xr
                  term5 = term2*xr*xr - psr5 - rr5*xr*prc5(1)
                  term6 = (dmpe(9)-psc7*rr9)*xr*xr - dmpe(7)
     &                       - rr7*xr*prc7(1)
                  term7 = rr5*prc5(1) - 2.0d0*dmpe(7)*xr
     &                       + (psc5+1.5d0*psc7)*rr7*xr
                  tixx = ci*term3 + dix*term4 + dir*term5
     &                      + 2.0d0*psr5*qixx + (qiy*yr+qiz*zr)*psc7*rr7
     &                      + 2.0d0*qix*term7 + qir*term6
                  tkxx = ck*term3 - dkx*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkxx + (qky*yr+qkz*zr)*psc7*rr7
     &                      + 2.0d0*qkx*term7 + qkr*term6
                  term3 = -psr3 + term1*yr*yr - rr3*yr*prc3(2)
                  term4 = rr3*prc3(2) - term1*yr - psr5*yr
                  term5 = term2*yr*yr - psr5 - rr5*yr*prc5(2)
                  term6 = (dmpe(9)-psc7*rr9)*yr*yr - dmpe(7)
     &                       - rr7*yr*prc7(2)
                  term7 = rr5*prc5(2) - 2.0d0*dmpe(7)*yr
     &                       + (psc5+1.5d0*psc7)*rr7*yr
                  tiyy = ci*term3 + diy*term4 + dir*term5
     &                      + 2.0d0*psr5*qiyy + (qix*xr+qiz*zr)*psc7*rr7
     &                      + 2.0d0*qiy*term7 + qir*term6
                  tkyy = ck*term3 - dky*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkyy + (qkx*xr+qkz*zr)*psc7*rr7
     &                      + 2.0d0*qky*term7 + qkr*term6
                  term3 = -psr3 + term1*zr*zr - rr3*zr*prc3(3)
                  term4 = rr3*prc3(3) - term1*zr - psr5*zr
                  term5 = term2*zr*zr - psr5 - rr5*zr*prc5(3)
                  term6 = (dmpe(9)-psc7*rr9)*zr*zr - dmpe(7)
     &                       - rr7*zr*prc7(3)
                  term7 = rr5*prc5(3) - 2.0d0*dmpe(7)*zr
     &                       + (psc5+1.5d0*psc7)*rr7*zr
                  tizz = ci*term3 + diz*term4 + dir*term5
     &                      + 2.0d0*psr5*qizz + (qix*xr+qiy*yr)*psc7*rr7
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkzz = ck*term3 - dkz*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkzz + (qkx*xr+qky*yr)*psc7*rr7
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  term3 = term1*xr*yr - rr3*yr*prc3(1)
                  term4 = rr3*prc3(1) - term1*xr
                  term5 = term2*xr*yr - rr5*yr*prc5(1)
                  term6 = (dmpe(9)-psc7*rr9)*xr*yr - rr7*yr*prc7(1)
                  term7 = rr5*prc5(1) - term2*xr
                  tixy = ci*term3 - psr5*dix*yr + diy*term4 + dir*term5
     &                      + 2.0d0*psr5*qixy - 2.0d0*psr7*yr*qix
     &                      + 2.0d0*qiy*term7 + qir*term6
                  tkxy = ck*term3 + psr5*dkx*yr - dky*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkxy - 2.0d0*psr7*yr*qkx
     &                      + 2.0d0*qky*term7 + qkr*term6
                  term3 = term1*xr*zr - rr3*zr*prc3(1)
                  term5 = term2*xr*zr - rr5*zr*prc5(1)
                  term6 = (dmpe(9)-psc7*rr9)*xr*zr - rr7*zr*prc7(1)
                  tixz = ci*term3 - psr5*dix*zr + diz*term4 + dir*term5
     &                      + 2.0d0*psr5*qixz - 2.0d0*psr7*zr*qix
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkxz = ck*term3 + psr5*dkx*zr - dkz*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkxz - 2.0d0*psr7*zr*qkx
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  term3 = term1*yr*zr - rr3*zr*prc3(2)
                  term4 = rr3*prc3(2) - term1*yr
                  term5 = term2*yr*zr - rr5*zr*prc5(2)
                  term6 = (dmpe(9)-psc7*rr9)*yr*zr - rr7*zr*prc7(2)
                  term7 = rr5*prc5(2) - term2*yr
                  tiyz = ci*term3 - psr5*diy*zr + diz*term4 + dir*term5
     &                      + 2.0d0*psr5*qiyz - 2.0d0*psr7*zr*qiy
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkyz = ck*term3 + psr5*dky*zr - dkz*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkyz - 2.0d0*psr7*zr*qky
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = frcx + depx
                  frcy = frcy + depy
                  frcz = frcz + depz
c
c     get the field gradient for direct polarization force
c
               else if (use_chgpen) then
                  term1i = rr3i - rr5i*xr*xr
                  term1core = rr3core - rr5core*xr*xr
                  term2i = 2.0d0*rr5i*xr 
                  term3i = rr7i*xr*xr - rr5i
                  term4i = 2.0d0*rr5i
                  term5i = 5.0d0*rr7i*xr
                  term6i = rr9i*xr*xr
                  term1k = rr3k - rr5k*xr*xr
                  term2k = 2.0d0*rr5k*xr
                  term3k = rr7k*xr*xr - rr5k
                  term4k = 2.0d0*rr5k
                  term5k = 5.0d0*rr7k*xr
                  term6k = rr9k*xr*xr
                  tixx = vali*term1i + corei*term1core  
     &                      + dix*term2i - dir*term3i
     &                      - qixx*term4i + qix*term5i - qir*term6i
     &                      + (qiy*yr+qiz*zr)*rr7i
                  tkxx = valk*term1k + corek*term1core
     &                      - dkx*term2k + dkr*term3k
     &                      - qkxx*term4k + qkx*term5k - qkr*term6k
     &                      + (qky*yr+qkz*zr)*rr7k
                  term1i = rr3i - rr5i*yr*yr
                  term1core = rr3core - rr5core*yr*yr
                  term2i = 2.0d0*rr5i*yr
                  term3i = rr7i*yr*yr - rr5i
                  term4i = 2.0d0*rr5i
                  term5i = 5.0d0*rr7i*yr
                  term6i = rr9i*yr*yr
                  term1k = rr3k - rr5k*yr*yr
                  term2k = 2.0d0*rr5k*yr
                  term3k = rr7k*yr*yr - rr5k
                  term4k = 2.0d0*rr5k
                  term5k = 5.0d0*rr7k*yr
                  term6k = rr9k*yr*yr
                  tiyy = vali*term1i + corei*term1core
     &                      + diy*term2i - dir*term3i
     &                      - qiyy*term4i + qiy*term5i - qir*term6i
     &                      + (qix*xr+qiz*zr)*rr7i
                  tkyy = valk*term1k + corek*term1core
     &                      - dky*term2k + dkr*term3k
     &                      - qkyy*term4k + qky*term5k - qkr*term6k
     &                      + (qkx*xr+qkz*zr)*rr7k
                  term1i = rr3i - rr5i*zr*zr
                  term1core = rr3core - rr5core*zr*zr
                  term2i = 2.0d0*rr5i*zr
                  term3i = rr7i*zr*zr - rr5i
                  term4i = 2.0d0*rr5i
                  term5i = 5.0d0*rr7i*zr
                  term6i = rr9i*zr*zr
                  term1k = rr3k - rr5k*zr*zr
                  term2k = 2.0d0*rr5k*zr
                  term3k = rr7k*zr*zr - rr5k
                  term4k = 2.0d0*rr5k
                  term5k = 5.0d0*rr7k*zr
                  term6k = rr9k*zr*zr
                  tizz = vali*term1i + corei*term1core
     &                      + diz*term2i - dir*term3i
     &                      - qizz*term4i + qiz*term5i - qir*term6i
     &                      + (qix*xr+qiy*yr)*rr7i
                  tkzz = valk*term1k + corek*term1core
     &                      - dkz*term2k + dkr*term3k
     &                      - qkzz*term4k + qkz*term5k - qkr*term6k
     &                      + (qkx*xr+qky*yr)*rr7k
                  term2i = rr5i*xr 
                  term1i = yr * term2i
                  term1core = rr5core*xr*yr
                  term3i = rr5i*yr
                  term4i = yr * (rr7i*xr)
                  term5i = 2.0d0*rr5i
                  term6i = 2.0d0*rr7i*xr
                  term7i = 2.0d0*rr7i*yr
                  term8i = yr*rr9i*xr
                  term2k = rr5k*xr
                  term1k = yr * term2k
                  term3k = rr5k*yr
                  term4k = yr * (rr7k*xr)
                  term5k = 2.0d0*rr5k
                  term6k = 2.0d0*rr7k*xr
                  term7k = 2.0d0*rr7k*yr
                  term8k = yr*rr9k*xr
                  tixy = -vali*term1i - corei*term1core 
     &                      + diy*term2i + dix*term3i
     &                      - dir*term4i - qixy*term5i + qiy*term6i
     &                      + qix*term7i - qir*term8i
                  tkxy = -valk*term1k - corek*term1core 
     &                      - dky*term2k - dkx*term3k
     &                      + dkr*term4k - qkxy*term5k + qky*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5i*xr
                  term1i = zr * term2i
                  term1core = rr5core*xr*zr
                  term3i = rr5i*zr
                  term4i = zr * (rr7i*xr)
                  term5i = 2.0d0*rr5i
                  term6i = 2.0d0*rr7i*xr
                  term7i = 2.0d0*rr7i*zr
                  term8i = zr*rr9i*xr
                  term2k = rr5k*xr
                  term1k = zr * term2k
                  term3k = rr5k*zr
                  term4k = zr * (rr7k*xr)
                  term5k = 2.0d0*rr5k
                  term6k = 2.0d0*rr7k*xr
                  term7k = 2.0d0*rr7k*zr
                  term8k = zr*rr9k*xr
                  tixz = -vali*term1i - corei*term1core
     &                      + diz*term2i + dix*term3i
     &                      - dir*term4i - qixz*term5i + qiz*term6i
     &                      + qix*term7i - qir*term8i
                  tkxz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dkx*term3k
     &                      + dkr*term4k - qkxz*term5k + qkz*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5i*yr
                  term1i = zr * term2i
                  term1core = rr5core*yr*zr
                  term3i = rr5i*zr
                  term4i = zr * (rr7i*yr)
                  term5i = 2.0d0*rr5i
                  term6i = 2.0d0*rr7i*yr
                  term7i = 2.0d0*rr7i*zr
                  term8i = zr*rr9i*yr
                  term2k = rr5k*yr
                  term1k = zr * term2k
                  term3k = rr5k*zr
                  term4k = zr * (rr7k*yr)
                  term5k = 2.0d0*rr5k
                  term6k = 2.0d0*rr7k*yr
                  term7k = 2.0d0*rr7k*zr
                  term8k = zr*rr9k*yr
                  tiyz = -vali*term1i - corei*term1core
     &                      + diz*term2i + diy*term3i
     &                      - dir*term4i - qiyz*term5i + qiz*term6i
     &                      + qiy*term7i - qir*term8i
                  tkyz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dky*term3k
     &                      + dkr*term4k - qkyz*term5k + qkz*term6k
     &                      + qky*term7k - qkr*term8k
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = -2.0d0 * depx
                  frcy = -2.0d0 * depy
                  frcz = -2.0d0 * depz
               end if
c
c     reset Thole values if alternate direct damping was used
c
               if (use_tholed) then
                  sc3 = 1.0d0
                  sc5 = 1.0d0
                  do j = 1, 3
                     rc3(j) = 0.0d0
                     rc5(j) = 0.0d0
                  end do
                  damp = pdi * pdamp(k)
                  if (damp .ne. 0.0d0) then
                     pgamma = min(pti,thole(k))
                     damp = pgamma * (r/damp)**3
                     if (damp .lt. 50.0d0) then
                        expdamp = exp(-damp)
                        sc3 = 1.0d0 - expdamp
                        sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                        temp3 = 3.0d0 * damp * expdamp / r2
                        temp5 = damp
                        rc3(1) = xr * temp3
                        rc3(2) = yr * temp3
                        rc3(3) = zr * temp3
                        rc5(1) = rc3(1) * temp5
                        rc5(2) = rc3(2) * temp5
                        rc5(3) = rc3(3) * temp5
                     end if
                  end if
                  usc3 = 1.0d0 - sc3*uscale(k)
                  usc5 = 1.0d0 - sc5*uscale(k)
                  usr3 = dmpe(3) - usc3*rr3
                  usr5 = dmpe(5) - usc5*rr5
                  do j = 1, 3
                     urc3(j) = rc3(j) * uscale(k)
                     urc5(j) = rc5(j) * uscale(k)
                  end do
               end if
c
c     get the dtau/dr terms used for mutual polarization force
c
               if (poltyp.eq.'MUTUAL' .and. use_thole) then
                  term1 = dmpe(5) - usc3*rr5
                  term2 = dmpe(7) - usc5*rr7
                  term3 = usr5 + term1
                  term4 = rr3 * uscale(k)
                  term5 = -xr*term3 + rc3(1)*term4
                  term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1)
                  tixx = uix*term5 + uir*term6
                  tkxx = ukx*term5 + ukr*term6
                  term5 = -yr*term3 + rc3(2)*term4
                  term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2)
                  tiyy = uiy*term5 + uir*term6
                  tkyy = uky*term5 + ukr*term6
                  term5 = -zr*term3 + rc3(3)*term4
                  term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3)
                  tizz = uiz*term5 + uir*term6
                  tkzz = ukz*term5 + ukr*term6
                  term4 = -usr5 * yr
                  term5 = -xr*term1 + rr3*urc3(1)
                  term6 = xr*yr*term2 - rr5*yr*urc5(1)
                  tixy = uix*term4 + uiy*term5 + uir*term6
                  tkxy = ukx*term4 + uky*term5 + ukr*term6
                  term4 = -usr5 * zr
                  term6 = xr*zr*term2 - rr5*zr*urc5(1)
                  tixz = uix*term4 + uiz*term5 + uir*term6
                  tkxz = ukx*term4 + ukz*term5 + ukr*term6
                  term5 = -yr*term1 + rr3*urc3(2)
                  term6 = yr*zr*term2 - rr5*zr*urc5(2)
                  tiyz = uiy*term4 + uiz*term5 + uir*term6
                  tkyz = uky*term4 + ukz*term5 + ukr*term6
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + depx
                  frcy = frcy + depy
                  frcz = frcz + depz
c
c     get the dtau/dr terms used for mutual polarization force
c
               else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then
                  term1 = 2.0d0 * rr5ik
                  term2 = term1*xr
                  term3 = rr5ik - rr7ik*xr*xr
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr
                  term3 = rr5ik - rr7ik*yr*yr
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr
                  term3 = rr5ik - rr7ik*zr*zr
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = rr5ik*yr
                  term2 = rr5ik*xr
                  term3 = yr * (rr7ik*xr)
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = rr5ik * zr
                  term3 = zr * (rr7ik*xr)
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = rr5ik*yr
                  term3 = zr * (rr7ik*yr)
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx - depx
                  frcy = frcy - depy
                  frcz = frcz - depz
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_thole) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = dmpe(5) - usc3*rr5
                        term2 = dmpe(7) - usc5*rr7
                        term3 = usr5 + term1
                        term4 = rr3 * uscale(k)
                        term5 = -xr*term3 + rc3(1)*term4
                        term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1)
                        tixx = uopt(j,1,ii)*term5 + uirm*term6
                        tkxx = uopt(m,1,kk)*term5 + ukrm*term6
                        term5 = -yr*term3 + rc3(2)*term4
                        term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2)
                        tiyy = uopt(j,2,ii)*term5 + uirm*term6
                        tkyy = uopt(m,2,kk)*term5 + ukrm*term6
                        term5 = -zr*term3 + rc3(3)*term4
                        term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3)
                        tizz = uopt(j,3,ii)*term5 + uirm*term6
                        tkzz = uopt(m,3,kk)*term5 + ukrm*term6
                        term4 = -usr5 * yr
                        term5 = -xr*term1 + rr3*urc3(1)
                        term6 = xr*yr*term2 - rr5*yr*urc5(1)
                        tixy = uopt(j,1,i)*term4 + uopt(j,2,i)*term5
     &                            + uirm*term6
                        tkxy = uopt(m,1,k)*term4 + uopt(m,2,k)*term5
     &                            + ukrm*term6
                        term4 = -usr5 * zr
                        term6 = xr*zr*term2 - rr5*zr*urc5(1)
                        tixz = uopt(j,1,ii)*term4 + uopt(j,3,ii)*term5
     &                            + uirm*term6
                        tkxz = uopt(m,1,kk)*term4 + uopt(m,3,kk)*term5
     &                            + ukrm*term6
                        term5 = -yr*term1 + rr3*urc3(2)
                        term6 = yr*zr*term2 - rr5*zr*urc5(2)
                        tiyz = uopt(j,2,i)*term4 + uopt(j,3,i)*term5
     &                            + uirm*term6
                        tkyz = uopt(m,2,k)*term4 + uopt(m,3,k)*term5
     &                            + ukrm*term6
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*depx
                        frcy = frcy + copm(j+m+1)*depy
                        frcz = frcz + copm(j+m+1)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_chgpen) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = 2.0d0 * rr5ik
                        term2 = term1*xr
                        term3 = rr5ik - rr7ik*xr*xr
                        tixx = uopt(j,1,i)*term2 + uirm*term3
                        tkxx = uopt(m,1,k)*term2 + ukrm*term3
                        term2 = term1*yr
                        term3 = rr5ik - rr7ik*yr*yr
                        tiyy = uopt(j,2,i)*term2 + uirm*term3
                        tkyy = uopt(m,2,k)*term2 + ukrm*term3
                        term2 = term1*zr
                        term3 = rr5ik - rr7ik*zr*zr
                        tizz = uopt(j,3,i)*term2 + uirm*term3
                        tkzz = uopt(m,3,k)*term2 + ukrm*term3
                        term1 = rr5ik*yr
                        term2 = rr5ik*xr
                        term3 = yr * (rr7ik*xr)
                        tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2 
     &                       - uirm*term3
                        tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2 
     &                       - ukrm*term3
                        term1 = rr5ik * zr
                        term3 = zr * (rr7ik*xr)
                        tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        term2 = rr5ik*yr
                        term3 = zr * (rr7ik*yr)
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx - copm(j+m+1)*depx
                        frcy = frcy - copm(j+m+1)*depy
                        frcz = frcz - copm(j+m+1)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for TCG polarization force
c
               else if (poltyp.eq.'TCG' .and. use_thole) then
                  do j = 1, tcgnab
                     ukx = ubd(1,k,j)
                     uky = ubd(2,k,j)
                     ukz = ubd(3,k,j)
                     ukxp = ubp(1,k,j)
                     ukyp = ubp(2,k,j)
                     ukzp = ubp(3,k,j)
                     uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = dmpe(5) - usc3*rr5
                     term2 = dmpe(7) - usc5*rr7
                     term3 = usr5 + term1
                     term4 = rr3 * uscale(k)
                     term5 = -xr*term3 + rc3(1)*term4
                     term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1)
                     tixx = uax(j)*term5 + uirt*term6
                     tkxx = ukx*term5 + ukrt*term6
                     term5 = -yr*term3 + rc3(2)*term4
                     term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2)
                     tiyy = uay(j)*term5 + uirt*term6
                     tkyy = uky*term5 + ukrt*term6
                     term5 = -zr*term3 + rc3(3)*term4
                     term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3)
                     tizz = uaz(j)*term5 + uirt*term6
                     tkzz = ukz*term5 + ukrt*term6
                     term4 = -usr5 * yr
                     term5 = -xr*term1 + rr3*urc3(1)
                     term6 = xr*yr*term2 - rr5*yr*urc5(1)
                     tixy = uax(j)*term4 + uay(j)*term5 + uirt*term6
                     tkxy = ukx*term4 + uky*term5 + ukrt*term6
                     term4 = -usr5 * zr
                     term6 = xr*zr*term2 - rr5*zr*urc5(1)
                     tixz = uax(j)*term4 + uaz(j)*term5 + uirt*term6
                     tkxz = ukx*term4 + ukz*term5 + ukrt*term6
                     term5 = -yr*term1 + rr3*urc3(2)
                     term6 = yr*zr*term2 - rr5*zr*urc5(2)
                     tiyz = uay(j)*term4 + uaz(j)*term5 + uirt*term6
                     tkyz = uky*term4 + ukz*term5 + ukrt*term6
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*uaxp(j) + tkxy*uayp(j)
     &                         + tkxz*uazp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*uaxp(j) + tkyy*uayp(j)
     &                         + tkyz*uazp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*uaxp(j) + tkyz*uayp(j)
     &                         + tkzz*uazp(j)
                     frcx = frcx + depx
                     frcy = frcy + depy
                     frcz = frcz + depz
                     ukx = uad(1,k,j)
                     uky = uad(2,k,j)
                     ukz = uad(3,k,j)
                     ukxp = uap(1,k,j)
                     ukyp = uap(2,k,j)
                     ukzp = uap(3,k,j)
                     uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = dmpe(5) - usc3*rr5
                     term2 = dmpe(7) - usc5*rr7
                     term3 = usr5 + term1
                     term4 = rr3 * uscale(k)
                     term5 = -xr*term3 + rc3(1)*term4
                     term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1)
                     tixx = ubx(j)*term5 + uirt*term6
                     tkxx = ukx*term5 + ukrt*term6
                     term5 = -yr*term3 + rc3(2)*term4
                     term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2)
                     tiyy = uby(j)*term5 + uirt*term6
                     tkyy = uky*term5 + ukrt*term6
                     term5 = -zr*term3 + rc3(3)*term4
                     term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3)
                     tizz = ubz(j)*term5 + uirt*term6
                     tkzz = ukz*term5 + ukrt*term6
                     term4 = -usr5 * yr
                     term5 = -xr*term1 + rr3*urc3(1)
                     term6 = xr*yr*term2 - rr5*yr*urc5(1)
                     tixy = ubx(j)*term4 + uby(j)*term5 + uirt*term6
                     tkxy = ukx*term4 + uky*term5 + ukrt*term6
                     term4 = -usr5 * zr
                     term6 = xr*zr*term2 - rr5*zr*urc5(1)
                     tixz = ubx(j)*term4 + ubz(j)*term5 + uirt*term6
                     tkxz = ukx*term4 + ukz*term5 + ukrt*term6
                     term5 = -yr*term1 + rr3*urc3(2)
                     term6 = yr*zr*term2 - rr5*zr*urc5(2)
                     tiyz = uby(j)*term4 + ubz(j)*term5 + uirt*term6
                     tkyz = uky*term4 + ukz*term5 + ukrt*term6
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*ubxp(j) + tkxy*ubyp(j)
     &                         + tkxz*ubzp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*ubxp(j) + tkyy*ubyp(j)
     &                         + tkyz*ubzp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*ubxp(j) + tkyz*ubyp(j)
     &                         + tkzz*ubzp(j)
                     frcx = frcx + depx
                     frcy = frcy + depy
                     frcz = frcz + depz
                  end do
               end if
c
c     increment force-based gradient on the interaction sites
c
               dep(1,i) = dep(1,i) - frcx
               dep(2,i) = dep(2,i) - frcy
               dep(3,i) = dep(3,i) - frcz
               dep(1,k) = dep(1,k) + frcx
               dep(2,k) = dep(2,k) + frcy
               dep(3,k) = dep(3,k) + frcz
c
c     increment the virial due to pairwise Cartesian forces
c
               vxx = xr * frcx
               vxy = 0.5d0 * (yr*frcx+xr*frcy)
               vxz = 0.5d0 * (zr*frcx+xr*frcz)
               vyy = yr * frcy
               vyz = 0.5d0 * (zr*frcy+yr*frcz)
               vzz = zr * frcz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
               uscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction with other unit cells
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         uixp = uinp(1,i)
         uiyp = uinp(2,i)
         uizp = uinp(3,i)
         do j = 1, tcgnab
            uax(j) = uad(1,i,j)
            uay(j) = uad(2,i,j)
            uaz(j) = uad(3,i,j)
            uaxp(j) = uap(1,i,j)
            uayp(j) = uap(2,i,j)
            uazp(j) = uap(3,i,j)
            ubx(j) = ubd(1,i,j)
            uby(j) = ubd(2,i,j)
            ubz(j) = ubd(3,i,j)
            ubxp(j) = ubp(1,i,j)
            ubyp(j) = ubp(2,i,j)
            ubzp(j) = ubp(3,i,j)
         end do
         if (use_thole) then
            pdi = pdamp(i)
            pti = thole(i)
            ddi = tholed(i)
         else if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
               uscale(ip14(j,i)) = u4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii, npole
            k = ipole(kk)
            do jcell = 2, ncell
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            call imager (xr,yr,zr,jcell)
            r2 = xr*xr + yr*yr + zr*zr
            if (.not. (use_polymer .and. r2.le.polycut2)) then
               pscale(k) = 1.0d0
               dscale(k) = 1.0d0
               uscale(k) = 1.0d0
            end if
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
               ukxp = uinp(1,k)
               ukyp = uinp(2,k)
               ukzp = uinp(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               uir = uix*xr + uiy*yr + uiz*zr
               uirp = uixp*xr + uiyp*yr + uizp*zr
               ukr = ukx*xr + uky*yr + ukz*zr
               ukrp = ukxp*xr + ukyp*yr + ukzp*zr
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
c
c     calculate real space Ewald error function damping
c
               call dampewald (9,r,r2,f,dmpe)
c
c     apply Thole polarization damping to scale factors
c
               sc3 = 1.0d0
               sc5 = 1.0d0
               sc7 = 1.0d0
               do j = 1, 3
                  rc3(j) = 0.0d0
                  rc5(j) = 0.0d0
                  rc7(j) = 0.0d0
               end do
c
c     apply Thole polarization damping to scale factors
c
               if (use_thole) then
                  damp = pdi * pdamp(k)
                  it = jpolar(i)
                  kt = jpolar(k)
                  if (use_tholed) then
                     pgamma = thdval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**(1.5d0)
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp) 
                           sc3 = 1.0d0 - expdamp 
                           sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp
     &                                      +0.15d0*damp**2)
                           temp3 = 1.5d0 * damp * expdamp / r2
                           temp5 = 0.5d0 * (1.0d0+damp)
                           temp7 = 0.7d0 + 0.15d0*damp**2/temp5
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  else
                     pgamma = thlval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**3
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp)
                           sc3 = 1.0d0 - expdamp
                           sc5 = 1.0d0 - (1.0d0+damp)*expdamp
                           sc7 = 1.0d0 - (1.0d0+damp+0.6d0*damp**2)
     &                                          *expdamp
                           temp3 = 3.0d0 * damp * expdamp / r2
                           temp5 = damp
                           temp7 = -0.2d0 + 0.6d0*damp
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  end if
                  psc3 = 1.0d0 - sc3*pscale(k)
                  psc5 = 1.0d0 - sc5*pscale(k)
                  psc7 = 1.0d0 - sc7*pscale(k)
                  dsc3 = 1.0d0 - sc3*dscale(k)
                  dsc5 = 1.0d0 - sc5*dscale(k)
                  dsc7 = 1.0d0 - sc7*dscale(k)
                  usc3 = 1.0d0 - sc3*uscale(k)
                  usc5 = 1.0d0 - sc5*uscale(k)
                  psr3 = dmpe(3) - psc3*rr3
                  psr5 = dmpe(5) - psc5*rr5
                  psr7 = dmpe(7) - psc7*rr7
                  dsr3 = dmpe(3) - dsc3*rr3
                  dsr5 = dmpe(5) - dsc5*rr5
                  dsr7 = dmpe(7) - dsc7*rr7
                  usr3 = dmpe(3) - usc3*rr3
                  usr5 = dmpe(5) - usc5*rr5
                  do j = 1, 3
                     prc3(j) = rc3(j) * pscale(k)
                     prc5(j) = rc5(j) * pscale(k)
                     prc7(j) = rc7(j) * pscale(k)
                     drc3(j) = rc3(j) * dscale(k)
                     drc5(j) = rc5(j) * dscale(k)
                     drc7(j) = rc7(j) * dscale(k)
                     urc3(j) = rc3(j) * uscale(k)
                     urc5(j) = rc5(j) * uscale(k)
                  end do
c
c     apply charge penetration damping to scale factors
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik)
                  rr3core = dmpe(3) - (1.0d0-dscale(k))*rr3
                  rr5core = dmpe(5) - (1.0d0-dscale(k))*rr5
                  rr3i = dmpe(3) - (1.0d0-dscale(k)*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-dscale(k)*dmpi(5))*rr5
                  rr7i = dmpe(7) - (1.0d0-dscale(k)*dmpi(7))*rr7
                  rr9i = dmpe(9) - (1.0d0-dscale(k)*dmpi(9))*rr9
                  rr3k = dmpe(3) - (1.0d0-dscale(k)*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-dscale(k)*dmpk(5))*rr5
                  rr7k = dmpe(7) - (1.0d0-dscale(k)*dmpk(7))*rr7
                  rr9k = dmpe(9) - (1.0d0-dscale(k)*dmpk(9))*rr9
                  rr5ik = dmpe(5) - (1.0d0-wscale(k)*dmpik(5))*rr5
                  rr7ik = dmpe(7) - (1.0d0-wscale(k)*dmpik(7))*rr7
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_thole) then
                     poti = -ukr*psr3 - ukrp*dsr3
                     potk = uir*psr3 + uirp*dsr3
                  else if (use_chgpen) then
                     poti = -2.0d0 * ukr * rr3i
                     potk = 2.0d0 * uir * rr3k
                  end if
                  pot(i) = pot(i) + poti 
                  pot(k) = pot(k) + potk 
               end if
c
c     get the induced dipole field used for dipole torques
c
               if (use_thole) then
                  tix3 = psr3*ukx + dsr3*ukxp
                  tiy3 = psr3*uky + dsr3*ukyp
                  tiz3 = psr3*ukz + dsr3*ukzp
                  tkx3 = psr3*uix + dsr3*uixp
                  tky3 = psr3*uiy + dsr3*uiyp
                  tkz3 = psr3*uiz + dsr3*uizp
                  tuir = -psr5*ukr - dsr5*ukrp
                  tukr = -psr5*uir - dsr5*uirp
               else if (use_chgpen) then
                  tix3 = 2.0d0*rr3i*ukx
                  tiy3 = 2.0d0*rr3i*uky
                  tiz3 = 2.0d0*rr3i*ukz
                  tkx3 = 2.0d0*rr3k*uix
                  tky3 = 2.0d0*rr3k*uiy
                  tkz3 = 2.0d0*rr3k*uiz
                  tuir = -2.0d0*rr5i*ukr
                  tukr = -2.0d0*rr5k*uir
               end if
               ufld(1,i) = ufld(1,i) + tix3 + xr*tuir
               ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir
               ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir
               ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr
               ufld(2,k) = ufld(2,k) + tky3 + yr*tukr
               ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr
c
c     get induced dipole field gradient used for quadrupole torques
c
               if (use_thole) then
                  tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp)
                  tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp)
                  tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp)
                  tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp)
                  tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp)
                  tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp)
                  tuir = -psr7*ukr - dsr7*ukrp
                  tukr = -psr7*uir - dsr7*uirp
               else if (use_chgpen) then
                  tix5 = 4.0d0 * (rr5i*ukx)
                  tiy5 = 4.0d0 * (rr5i*uky)
                  tiz5 = 4.0d0 * (rr5i*ukz)
                  tkx5 = 4.0d0 * (rr5k*uix)
                  tky5 = 4.0d0 * (rr5k*uiy)
                  tkz5 = 4.0d0 * (rr5k*uiz)
                  tuir = -2.0d0*rr7i*ukr 
                  tukr = -2.0d0*rr7k*uir 
               end if
               dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir
               dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5
     &                         + 2.0d0*xr*yr*tuir
               dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir
               dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5
     &                         + 2.0d0*xr*zr*tuir
               dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5
     &                         + 2.0d0*yr*zr*tuir
               dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir
               dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr
               dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5
     &                         - 2.0d0*xr*yr*tukr
               dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr
               dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5
     &                         - 2.0d0*xr*zr*tukr
               dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5
     &                         - 2.0d0*yr*zr*tukr
               dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr
c
c     get the dEd/dR terms used for direct polarization force
c
               if (use_thole) then
                  term1 = dmpe(5) - dsc3*rr5
                  term2 = dmpe(7) - dsc5*rr7
                  term3 = -dsr3 + term1*xr*xr - rr3*xr*drc3(1)
                  term4 = rr3*drc3(1) - term1*xr - dsr5*xr
                  term5 = term2*xr*xr - dsr5 - rr5*xr*drc5(1)
                  term6 = (dmpe(9)-dsc7*rr9)*xr*xr - dmpe(7)
     &                       - rr7*xr*drc7(1)
                  term7 = rr5*drc5(1) - 2.0d0*dmpe(7)*xr
     &                       + (dsc5+1.5d0*dsc7)*rr7*xr
                  tixx = ci*term3 + dix*term4 + dir*term5
     &                      + 2.0d0*dsr5*qixx + (qiy*yr+qiz*zr)*dsc7*rr7
     &                      + 2.0d0*qix*term7 + qir*term6
                  tkxx = ck*term3 - dkx*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkxx + (qky*yr+qkz*zr)*dsc7*rr7
     &                      + 2.0d0*qkx*term7 + qkr*term6
                  term3 = -dsr3 + term1*yr*yr - rr3*yr*drc3(2)
                  term4 = rr3*drc3(2) - term1*yr - dsr5*yr
                  term5 = term2*yr*yr - dsr5 - rr5*yr*drc5(2)
                  term6 = (dmpe(9)-dsc7*rr9)*yr*yr - dmpe(7)
     &                       - rr7*yr*drc7(2)
                  term7 = rr5*drc5(2) - 2.0d0*dmpe(7)*yr
     &                       + (dsc5+1.5d0*dsc7)*rr7*yr
                  tiyy = ci*term3 + diy*term4 + dir*term5
     &                      + 2.0d0*dsr5*qiyy + (qix*xr+qiz*zr)*dsc7*rr7
     &                      + 2.0d0*qiy*term7 + qir*term6
                  tkyy = ck*term3 - dky*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkyy + (qkx*xr+qkz*zr)*dsc7*rr7
     &                      + 2.0d0*qky*term7 + qkr*term6
                  term3 = -dsr3 + term1*zr*zr - rr3*zr*drc3(3)
                  term4 = rr3*drc3(3) - term1*zr - dsr5*zr
                  term5 = term2*zr*zr - dsr5 - rr5*zr*drc5(3)
                  term6 = (dmpe(9)-dsc7*rr9)*zr*zr - dmpe(7)
     &                       - rr7*zr*drc7(3)
                  term7 = rr5*drc5(3) - 2.0d0*dmpe(7)*zr
     &                       + (dsc5+1.5d0*dsc7)*rr7*zr
                  tizz = ci*term3 + diz*term4 + dir*term5
     &                      + 2.0d0*dsr5*qizz + (qix*xr+qiy*yr)*dsc7*rr7
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkzz = ck*term3 - dkz*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkzz + (qkx*xr+qky*yr)*dsc7*rr7
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  term3 = term1*xr*yr - rr3*yr*drc3(1)
                  term4 = rr3*drc3(1) - term1*xr
                  term5 = term2*xr*yr - rr5*yr*drc5(1)
                  term6 = (dmpe(9)-dsc7*rr9)*xr*yr - rr7*yr*drc7(1)
                  term7 = rr5*drc5(1) - term2*xr
                  tixy = ci*term3 - dsr5*dix*yr + diy*term4 + dir*term5
     &                      + 2.0d0*dsr5*qixy - 2.0d0*dsr7*yr*qix
     &                      + 2.0d0*qiy*term7 + qir*term6
                  tkxy = ck*term3 + dsr5*dkx*yr - dky*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkxy - 2.0d0*dsr7*yr*qkx
     &                      + 2.0d0*qky*term7 + qkr*term6
                  term3 = term1*xr*zr - rr3*zr*drc3(1)
                  term5 = term2*xr*zr - rr5*zr*drc5(1)
                  term6 = (dmpe(9)-dsc7*rr9)*xr*zr - rr7*zr*drc7(1)
                  tixz = ci*term3 - dsr5*dix*zr + diz*term4 + dir*term5
     &                      + 2.0d0*dsr5*qixz - 2.0d0*dsr7*zr*qix
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkxz = ck*term3 + dsr5*dkx*zr - dkz*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkxz - 2.0d0*dsr7*zr*qkx
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  term3 = term1*yr*zr - rr3*zr*drc3(2)
                  term4 = rr3*drc3(2) - term1*yr
                  term5 = term2*yr*zr - rr5*zr*drc5(2)
                  term6 = (dmpe(9)-dsc7*rr9)*yr*zr - rr7*zr*drc7(2)
                  term7 = rr5*drc5(2) - term2*yr
                  tiyz = ci*term3 - dsr5*diy*zr + diz*term4 + dir*term5
     &                      + 2.0d0*dsr5*qiyz - 2.0d0*dsr7*zr*qiy
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkyz = ck*term3 + dsr5*dky*zr - dkz*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkyz - 2.0d0*dsr7*zr*qky
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      - tkxx*uixp - tkxy*uiyp - tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      - tkxy*uixp - tkyy*uiyp - tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      - tkxz*uixp - tkyz*uiyp - tkzz*uizp
                  frcx = depx
                  frcy = depy
                  frcz = depz
c
c     get the dEp/dR terms used for direct polarization force
c
                  term1 = dmpe(5) - psc3*rr5
                  term2 = dmpe(7) - psc5*rr7
                  term3 = -psr3 + term1*xr*xr - rr3*xr*prc3(1)
                  term4 = rr3*prc3(1) - term1*xr - psr5*xr
                  term5 = term2*xr*xr - psr5 - rr5*xr*prc5(1)
                  term6 = (dmpe(9)-psc7*rr9)*xr*xr - dmpe(7)
     &                       - rr7*xr*prc7(1)
                  term7 = rr5*prc5(1) - 2.0d0*dmpe(7)*xr
     &                       + (psc5+1.5d0*psc7)*rr7*xr
                  tixx = ci*term3 + dix*term4 + dir*term5
     &                      + 2.0d0*psr5*qixx + (qiy*yr+qiz*zr)*psc7*rr7
     &                      + 2.0d0*qix*term7 + qir*term6
                  tkxx = ck*term3 - dkx*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkxx + (qky*yr+qkz*zr)*psc7*rr7
     &                      + 2.0d0*qkx*term7 + qkr*term6
                  term3 = -psr3 + term1*yr*yr - rr3*yr*prc3(2)
                  term4 = rr3*prc3(2) - term1*yr - psr5*yr
                  term5 = term2*yr*yr - psr5 - rr5*yr*prc5(2)
                  term6 = (dmpe(9)-psc7*rr9)*yr*yr - dmpe(7)
     &                       - rr7*yr*prc7(2)
                  term7 = rr5*prc5(2) - 2.0d0*dmpe(7)*yr
     &                       + (psc5+1.5d0*psc7)*rr7*yr
                  tiyy = ci*term3 + diy*term4 + dir*term5
     &                      + 2.0d0*psr5*qiyy + (qix*xr+qiz*zr)*psc7*rr7
     &                      + 2.0d0*qiy*term7 + qir*term6
                  tkyy = ck*term3 - dky*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkyy + (qkx*xr+qkz*zr)*psc7*rr7
     &                      + 2.0d0*qky*term7 + qkr*term6
                  term3 = -psr3 + term1*zr*zr - rr3*zr*prc3(3)
                  term4 = rr3*prc3(3) - term1*zr - psr5*zr
                  term5 = term2*zr*zr - psr5 - rr5*zr*prc5(3)
                  term6 = (dmpe(9)-psc7*rr9)*zr*zr - dmpe(7)
     &                       - rr7*zr*prc7(3)
                  term7 = rr5*prc5(3) - 2.0d0*dmpe(7)*zr
     &                       + (psc5+1.5d0*psc7)*rr7*zr
                  tizz = ci*term3 + diz*term4 + dir*term5
     &                      + 2.0d0*psr5*qizz + (qix*xr+qiy*yr)*psc7*rr7
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkzz = ck*term3 - dkz*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkzz + (qkx*xr+qky*yr)*psc7*rr7
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  term3 = term1*xr*yr - rr3*yr*prc3(1)
                  term4 = rr3*prc3(1) - term1*xr
                  term5 = term2*xr*yr - rr5*yr*prc5(1)
                  term6 = (dmpe(9)-psc7*rr9)*xr*yr - rr7*yr*prc7(1)
                  term7 = rr5*prc5(1) - term2*xr
                  tixy = ci*term3 - psr5*dix*yr + diy*term4 + dir*term5
     &                      + 2.0d0*psr5*qixy - 2.0d0*psr7*yr*qix
     &                      + 2.0d0*qiy*term7 + qir*term6
                  tkxy = ck*term3 + psr5*dkx*yr - dky*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkxy - 2.0d0*psr7*yr*qkx
     &                      + 2.0d0*qky*term7 + qkr*term6
                  term3 = term1*xr*zr - rr3*zr*prc3(1)
                  term5 = term2*xr*zr - rr5*zr*prc5(1)
                  term6 = (dmpe(9)-psc7*rr9)*xr*zr - rr7*zr*prc7(1)
                  tixz = ci*term3 - psr5*dix*zr + diz*term4 + dir*term5
     &                      + 2.0d0*psr5*qixz - 2.0d0*psr7*zr*qix
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkxz = ck*term3 + psr5*dkx*zr - dkz*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkxz - 2.0d0*psr7*zr*qkx
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  term3 = term1*yr*zr - rr3*zr*prc3(2)
                  term4 = rr3*prc3(2) - term1*yr
                  term5 = term2*yr*zr - rr5*zr*prc5(2)
                  term6 = (dmpe(9)-psc7*rr9)*yr*zr - rr7*zr*prc7(2)
                  term7 = rr5*prc5(2) - term2*yr
                  tiyz = ci*term3 - psr5*diy*zr + diz*term4 + dir*term5
     &                      + 2.0d0*psr5*qiyz - 2.0d0*psr7*zr*qiy
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkyz = ck*term3 + psr5*dky*zr - dkz*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkyz - 2.0d0*psr7*zr*qky
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = frcx + depx
                  frcy = frcy + depy
                  frcz = frcz + depz
c
c     get the field gradient for direct polarization force
c
               else if (use_chgpen) then
                  term1i = rr3i - rr5i*xr*xr
                  term1core = rr3core - rr5core*xr*xr
                  term2i = 2.0d0*rr5i*xr 
                  term3i = rr7i*xr*xr - rr5i
                  term4i = 2.0d0*rr5i
                  term5i = 5.0d0*rr7i*xr
                  term6i = rr9i*xr*xr
                  term1k = rr3k - rr5k*xr*xr
                  term2k = 2.0d0*rr5k*xr
                  term3k = rr7k*xr*xr - rr5k
                  term4k = 2.0d0*rr5k
                  term5k = 5.0d0*rr7k*xr
                  term6k = rr9k*xr*xr
                  tixx = vali*term1i + corei*term1core  
     &                      + dix*term2i - dir*term3i
     &                      - qixx*term4i + qix*term5i - qir*term6i
     &                      + (qiy*yr+qiz*zr)*rr7i
                  tkxx = valk*term1k + corek*term1core
     &                      - dkx*term2k + dkr*term3k
     &                      - qkxx*term4k + qkx*term5k - qkr*term6k
     &                      + (qky*yr+qkz*zr)*rr7k
                  term1i = rr3i - rr5i*yr*yr
                  term1core = rr3core - rr5core*yr*yr
                  term2i = 2.0d0*rr5i*yr
                  term3i = rr7i*yr*yr - rr5i
                  term4i = 2.0d0*rr5i
                  term5i = 5.0d0*rr7i*yr
                  term6i = rr9i*yr*yr
                  term1k = rr3k - rr5k*yr*yr
                  term2k = 2.0d0*rr5k*yr
                  term3k = rr7k*yr*yr - rr5k
                  term4k = 2.0d0*rr5k
                  term5k = 5.0d0*rr7k*yr
                  term6k = rr9k*yr*yr
                  tiyy = vali*term1i + corei*term1core
     &                      + diy*term2i - dir*term3i
     &                      - qiyy*term4i + qiy*term5i - qir*term6i
     &                      + (qix*xr+qiz*zr)*rr7i
                  tkyy = valk*term1k + corek*term1core
     &                      - dky*term2k + dkr*term3k
     &                      - qkyy*term4k + qky*term5k - qkr*term6k
     &                      + (qkx*xr+qkz*zr)*rr7k
                  term1i = rr3i - rr5i*zr*zr
                  term1core = rr3core - rr5core*zr*zr
                  term2i = 2.0d0*rr5i*zr
                  term3i = rr7i*zr*zr - rr5i
                  term4i = 2.0d0*rr5i
                  term5i = 5.0d0*rr7i*zr
                  term6i = rr9i*zr*zr
                  term1k = rr3k - rr5k*zr*zr
                  term2k = 2.0d0*rr5k*zr
                  term3k = rr7k*zr*zr - rr5k
                  term4k = 2.0d0*rr5k
                  term5k = 5.0d0*rr7k*zr
                  term6k = rr9k*zr*zr
                  tizz = vali*term1i + corei*term1core
     &                      + diz*term2i - dir*term3i
     &                      - qizz*term4i + qiz*term5i - qir*term6i
     &                      + (qix*xr+qiy*yr)*rr7i
                  tkzz = valk*term1k + corek*term1core
     &                      - dkz*term2k + dkr*term3k
     &                      - qkzz*term4k + qkz*term5k - qkr*term6k
     &                      + (qkx*xr+qky*yr)*rr7k
                  term2i = rr5i*xr 
                  term1i = yr * term2i
                  term1core = rr5core*xr*yr
                  term3i = rr5i*yr
                  term4i = yr * (rr7i*xr)
                  term5i = 2.0d0*rr5i
                  term6i = 2.0d0*rr7i*xr
                  term7i = 2.0d0*rr7i*yr
                  term8i = yr*rr9i*xr
                  term2k = rr5k*xr
                  term1k = yr * term2k
                  term3k = rr5k*yr
                  term4k = yr * (rr7k*xr)
                  term5k = 2.0d0*rr5k
                  term6k = 2.0d0*rr7k*xr
                  term7k = 2.0d0*rr7k*yr
                  term8k = yr*rr9k*xr
                  tixy = -vali*term1i - corei*term1core 
     &                      + diy*term2i + dix*term3i
     &                      - dir*term4i - qixy*term5i + qiy*term6i
     &                      + qix*term7i - qir*term8i
                  tkxy = -valk*term1k - corek*term1core 
     &                      - dky*term2k - dkx*term3k
     &                      + dkr*term4k - qkxy*term5k + qky*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5i*xr
                  term1i = zr * term2i
                  term1core = rr5core*xr*zr
                  term3i = rr5i*zr
                  term4i = zr * (rr7i*xr)
                  term5i = 2.0d0*rr5i
                  term6i = 2.0d0*rr7i*xr
                  term7i = 2.0d0*rr7i*zr
                  term8i = zr*rr9i*xr
                  term2k = rr5k*xr
                  term1k = zr * term2k
                  term3k = rr5k*zr
                  term4k = zr * (rr7k*xr)
                  term5k = 2.0d0*rr5k
                  term6k = 2.0d0*rr7k*xr
                  term7k = 2.0d0*rr7k*zr
                  term8k = zr*rr9k*xr
                  tixz = -vali*term1i - corei*term1core
     &                      + diz*term2i + dix*term3i
     &                      - dir*term4i - qixz*term5i + qiz*term6i
     &                      + qix*term7i - qir*term8i
                  tkxz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dkx*term3k
     &                      + dkr*term4k - qkxz*term5k + qkz*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5i*yr
                  term1i = zr * term2i
                  term1core = rr5core*yr*zr
                  term3i = rr5i*zr
                  term4i = zr * (rr7i*yr)
                  term5i = 2.0d0*rr5i
                  term6i = 2.0d0*rr7i*yr
                  term7i = 2.0d0*rr7i*zr
                  term8i = zr*rr9i*yr
                  term2k = rr5k*yr
                  term1k = zr * term2k
                  term3k = rr5k*zr
                  term4k = zr * (rr7k*yr)
                  term5k = 2.0d0*rr5k
                  term6k = 2.0d0*rr7k*yr
                  term7k = 2.0d0*rr7k*zr
                  term8k = zr*rr9k*yr
                  tiyz = -vali*term1i - corei*term1core
     &                      + diz*term2i + diy*term3i
     &                      - dir*term4i - qiyz*term5i + qiz*term6i
     &                      + qiy*term7i - qir*term8i
                  tkyz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dky*term3k
     &                      + dkr*term4k - qkyz*term5k + qkz*term6k
     &                      + qky*term7k - qkr*term8k
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = -2.0d0 * depx
                  frcy = -2.0d0 * depy
                  frcz = -2.0d0 * depz
               end if
c
c     reset Thole values if alternate direct damping was used
c
               if (use_tholed) then
                  sc3 = 1.0d0
                  sc5 = 1.0d0
                  do j = 1, 3
                     rc3(j) = 0.0d0
                     rc5(j) = 0.0d0
                  end do
                  damp = pdi * pdamp(k)
                  if (damp .ne. 0.0d0) then
                     pgamma = min(pti,thole(k))
                     damp = pgamma * (r/damp)**3
                     if (damp .lt. 50.0d0) then
                        expdamp = exp(-damp)
                        sc3 = 1.0d0 - expdamp
                        sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                        temp3 = 3.0d0 * damp * expdamp / r2
                        temp5 = damp
                        rc3(1) = xr * temp3
                        rc3(2) = yr * temp3
                        rc3(3) = zr * temp3
                        rc5(1) = rc3(1) * temp5
                        rc5(2) = rc3(2) * temp5
                        rc5(3) = rc3(3) * temp5
                     end if
                  end if
                  usc3 = 1.0d0 - sc3*uscale(k)
                  usc5 = 1.0d0 - sc5*uscale(k)
                  usr3 = dmpe(3) - usc3*rr3
                  usr5 = dmpe(5) - usc5*rr5
                  do j = 1, 3
                     urc3(j) = rc3(j) * uscale(k)
                     urc5(j) = rc5(j) * uscale(k)
                  end do
               end if
c
c     get the dtau/dr terms used for mutual polarization force
c
               if (poltyp.eq.'MUTUAL' .and. use_thole) then
                  term1 = dmpe(5) - usc3*rr5
                  term2 = dmpe(7) - usc5*rr7
                  term3 = usr5 + term1
                  term4 = rr3 * uscale(k)
                  term5 = -xr*term3 + rc3(1)*term4
                  term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1)
                  tixx = uix*term5 + uir*term6
                  tkxx = ukx*term5 + ukr*term6
                  term5 = -yr*term3 + rc3(2)*term4
                  term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2)
                  tiyy = uiy*term5 + uir*term6
                  tkyy = uky*term5 + ukr*term6
                  term5 = -zr*term3 + rc3(3)*term4
                  term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3)
                  tizz = uiz*term5 + uir*term6
                  tkzz = ukz*term5 + ukr*term6
                  term4 = -usr5 * yr
                  term5 = -xr*term1 + rr3*urc3(1)
                  term6 = xr*yr*term2 - rr5*yr*urc5(1)
                  tixy = uix*term4 + uiy*term5 + uir*term6
                  tkxy = ukx*term4 + uky*term5 + ukr*term6
                  term4 = -usr5 * zr
                  term6 = xr*zr*term2 - rr5*zr*urc5(1)
                  tixz = uix*term4 + uiz*term5 + uir*term6
                  tkxz = ukx*term4 + ukz*term5 + ukr*term6
                  term5 = -yr*term1 + rr3*urc3(2)
                  term6 = yr*zr*term2 - rr5*zr*urc5(2)
                  tiyz = uiy*term4 + uiz*term5 + uir*term6
                  tkyz = uky*term4 + ukz*term5 + ukr*term6
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + depx
                  frcy = frcy + depy
                  frcz = frcz + depz
c
c     get the dtau/dr terms used for mutual polarization force
c
               else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then
                  term1 = 2.0d0 * rr5ik
                  term2 = term1*xr
                  term3 = rr5ik - rr7ik*xr*xr
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr
                  term3 = rr5ik - rr7ik*yr*yr
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr
                  term3 = rr5ik - rr7ik*zr*zr
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = rr5ik*yr
                  term2 = rr5ik*xr
                  term3 = yr * (rr7ik*xr)
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = rr5ik * zr
                  term3 = zr * (rr7ik*xr)
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = rr5ik*yr
                  term3 = zr * (rr7ik*yr)
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx - depx
                  frcy = frcy - depy
                  frcz = frcz - depz
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_thole) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = dmpe(5) - usc3*rr5
                        term2 = dmpe(7) - usc5*rr7
                        term3 = usr5 + term1
                        term4 = rr3 * uscale(k)
                        term5 = -xr*term3 + rc3(1)*term4
                        term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1)
                        tixx = uopt(j,1,ii)*term5 + uirm*term6
                        tkxx = uopt(m,1,kk)*term5 + ukrm*term6
                        term5 = -yr*term3 + rc3(2)*term4
                        term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2)
                        tiyy = uopt(j,2,ii)*term5 + uirm*term6
                        tkyy = uopt(m,2,kk)*term5 + ukrm*term6
                        term5 = -zr*term3 + rc3(3)*term4
                        term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3)
                        tizz = uopt(j,3,ii)*term5 + uirm*term6
                        tkzz = uopt(m,3,kk)*term5 + ukrm*term6
                        term4 = -usr5 * yr
                        term5 = -xr*term1 + rr3*urc3(1)
                        term6 = xr*yr*term2 - rr5*yr*urc5(1)
                        tixy = uopt(j,1,i)*term4 + uopt(j,2,i)*term5
     &                            + uirm*term6
                        tkxy = uopt(m,1,k)*term4 + uopt(m,2,k)*term5
     &                            + ukrm*term6
                        term4 = -usr5 * zr
                        term6 = xr*zr*term2 - rr5*zr*urc5(1)
                        tixz = uopt(j,1,ii)*term4 + uopt(j,3,ii)*term5
     &                            + uirm*term6
                        tkxz = uopt(m,1,kk)*term4 + uopt(m,3,kk)*term5
     &                            + ukrm*term6
                        term5 = -yr*term1 + rr3*urc3(2)
                        term6 = yr*zr*term2 - rr5*zr*urc5(2)
                        tiyz = uopt(j,2,i)*term4 + uopt(j,3,i)*term5
     &                            + uirm*term6
                        tkyz = uopt(m,2,k)*term4 + uopt(m,3,k)*term5
     &                            + ukrm*term6
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*depx
                        frcy = frcy + copm(j+m+1)*depy
                        frcz = frcz + copm(j+m+1)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_chgpen) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = 2.0d0 * rr5ik
                        term2 = term1*xr
                        term3 = rr5ik - rr7ik*xr*xr
                        tixx = uopt(j,1,i)*term2 + uirm*term3
                        tkxx = uopt(m,1,k)*term2 + ukrm*term3
                        term2 = term1*yr
                        term3 = rr5ik - rr7ik*yr*yr
                        tiyy = uopt(j,2,i)*term2 + uirm*term3
                        tkyy = uopt(m,2,k)*term2 + ukrm*term3
                        term2 = term1*zr
                        term3 = rr5ik - rr7ik*zr*zr
                        tizz = uopt(j,3,i)*term2 + uirm*term3
                        tkzz = uopt(m,3,k)*term2 + ukrm*term3
                        term1 = rr5ik*yr
                        term2 = rr5ik*xr
                        term3 = yr * (rr7ik*xr)
                        tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2 
     &                       - uirm*term3
                        tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2 
     &                       - ukrm*term3
                        term1 = rr5ik * zr
                        term3 = zr * (rr7ik*xr)
                        tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        term2 = rr5ik*yr
                        term3 = zr * (rr7ik*yr)
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx - copm(j+m+1)*depx
                        frcy = frcy - copm(j+m+1)*depy
                        frcz = frcz - copm(j+m+1)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for TCG polarization force
c
               else if (poltyp.eq.'TCG' .and. use_thole) then
                  do j = 1, tcgnab
                     ukx = ubd(1,k,j)
                     uky = ubd(2,k,j)
                     ukz = ubd(3,k,j)
                     ukxp = ubp(1,k,j)
                     ukyp = ubp(2,k,j)
                     ukzp = ubp(3,k,j)
                     uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = dmpe(5) - usc3*rr5
                     term2 = dmpe(7) - usc5*rr7
                     term3 = usr5 + term1
                     term4 = rr3 * uscale(k)
                     term5 = -xr*term3 + rc3(1)*term4
                     term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1)
                     tixx = uax(j)*term5 + uirt*term6
                     tkxx = ukx*term5 + ukrt*term6
                     term5 = -yr*term3 + rc3(2)*term4
                     term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2)
                     tiyy = uay(j)*term5 + uirt*term6
                     tkyy = uky*term5 + ukrt*term6
                     term5 = -zr*term3 + rc3(3)*term4
                     term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3)
                     tizz = uaz(j)*term5 + uirt*term6
                     tkzz = ukz*term5 + ukrt*term6
                     term4 = -usr5 * yr
                     term5 = -xr*term1 + rr3*urc3(1)
                     term6 = xr*yr*term2 - rr5*yr*urc5(1)
                     tixy = uax(j)*term4 + uay(j)*term5 + uirt*term6
                     tkxy = ukx*term4 + uky*term5 + ukrt*term6
                     term4 = -usr5 * zr
                     term6 = xr*zr*term2 - rr5*zr*urc5(1)
                     tixz = uax(j)*term4 + uaz(j)*term5 + uirt*term6
                     tkxz = ukx*term4 + ukz*term5 + ukrt*term6
                     term5 = -yr*term1 + rr3*urc3(2)
                     term6 = yr*zr*term2 - rr5*zr*urc5(2)
                     tiyz = uay(j)*term4 + uaz(j)*term5 + uirt*term6
                     tkyz = uky*term4 + ukz*term5 + ukrt*term6
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*uaxp(j) + tkxy*uayp(j)
     &                         + tkxz*uazp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*uaxp(j) + tkyy*uayp(j)
     &                         + tkyz*uazp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*uaxp(j) + tkyz*uayp(j)
     &                         + tkzz*uazp(j)
                     frcx = frcx + depx
                     frcy = frcy + depy
                     frcz = frcz + depz
                     ukx = uad(1,k,j)
                     uky = uad(2,k,j)
                     ukz = uad(3,k,j)
                     ukxp = uap(1,k,j)
                     ukyp = uap(2,k,j)
                     ukzp = uap(3,k,j)
                     uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = dmpe(5) - usc3*rr5
                     term2 = dmpe(7) - usc5*rr7
                     term3 = usr5 + term1
                     term4 = rr3 * uscale(k)
                     term5 = -xr*term3 + rc3(1)*term4
                     term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1)
                     tixx = ubx(j)*term5 + uirt*term6
                     tkxx = ukx*term5 + ukrt*term6
                     term5 = -yr*term3 + rc3(2)*term4
                     term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2)
                     tiyy = uby(j)*term5 + uirt*term6
                     tkyy = uky*term5 + ukrt*term6
                     term5 = -zr*term3 + rc3(3)*term4
                     term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3)
                     tizz = ubz(j)*term5 + uirt*term6
                     tkzz = ukz*term5 + ukrt*term6
                     term4 = -usr5 * yr
                     term5 = -xr*term1 + rr3*urc3(1)
                     term6 = xr*yr*term2 - rr5*yr*urc5(1)
                     tixy = ubx(j)*term4 + uby(j)*term5 + uirt*term6
                     tkxy = ukx*term4 + uky*term5 + ukrt*term6
                     term4 = -usr5 * zr
                     term6 = xr*zr*term2 - rr5*zr*urc5(1)
                     tixz = ubx(j)*term4 + ubz(j)*term5 + uirt*term6
                     tkxz = ukx*term4 + ukz*term5 + ukrt*term6
                     term5 = -yr*term1 + rr3*urc3(2)
                     term6 = yr*zr*term2 - rr5*zr*urc5(2)
                     tiyz = uby(j)*term4 + ubz(j)*term5 + uirt*term6
                     tkyz = uky*term4 + ukz*term5 + ukrt*term6
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*ubxp(j) + tkxy*ubyp(j)
     &                         + tkxz*ubzp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*ubxp(j) + tkyy*ubyp(j)
     &                         + tkyz*ubzp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*ubxp(j) + tkyz*ubyp(j)
     &                         + tkzz*ubzp(j)
                     frcx = frcx + depx
                     frcy = frcy + depy
                     frcz = frcz + depz
                  end do
               end if
c
c     force and torque components scaled for self-interactions
c
               if (i .eq. k) then
                  frcx = 0.5d0 * frcx
                  frcy = 0.5d0 * frcy
                  frcz = 0.5d0 * frcz
                  do j = 1, 3
                     psr3 = 0.5d0 * psr3
                     psr5 = 0.5d0 * psr5
                     psr7 = 0.5d0 * psr7
                     dsr3 = 0.5d0 * dsr3
                     dsr5 = 0.5d0 * dsr5
                     dsr7 = 0.5d0 * dsr7
                  end do
               end if
c
c     increment force-based gradient on the interaction sites
c
               dep(1,i) = dep(1,i) - frcx
               dep(2,i) = dep(2,i) - frcy
               dep(3,i) = dep(3,i) - frcz
               dep(1,k) = dep(1,k) + frcx
               dep(2,k) = dep(2,k) + frcy
               dep(3,k) = dep(3,k) + frcz
c
c     increment the virial due to pairwise Cartesian forces
c
               vxx = xr * frcx
               vxy = 0.5d0 * (yr*frcx+xr*frcy)
               vxz = 0.5d0 * (zr*frcx+xr*frcz)
               vyy = yr * frcy
               vyz = 0.5d0 * (zr*frcy+yr*frcz)
               vzz = zr * frcz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
            end do
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
               uscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
      end if
c
c     torque is induced field and gradient cross permanent moments
c
      do ii = 1, npole
         i = ipole(ii)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         tep(1) = diz*ufld(2,i) - diy*ufld(3,i)
     &               + qixz*dufld(2,i) - qixy*dufld(4,i)
     &               + 2.0d0*qiyz*(dufld(3,i)-dufld(6,i))
     &               + (qizz-qiyy)*dufld(5,i)
         tep(2) = dix*ufld(3,i) - diz*ufld(1,i)
     &               - qiyz*dufld(2,i) + qixy*dufld(5,i)
     &               + 2.0d0*qixz*(dufld(6,i)-dufld(1,i))
     &               + (qixx-qizz)*dufld(4,i)
         tep(3) = diy*ufld(1,i) - dix*ufld(2,i)
     &               + qiyz*dufld(4,i) - qixz*dufld(5,i)
     &               + 2.0d0*qixy*(dufld(1,i)-dufld(3,i))
     &               + (qiyy-qixx)*dufld(2,i)
         call torque (i,tep,fix,fiy,fiz,dep)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3))
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     modify the gradient and virial for charge flux
c
      if (use_chgflx) then
         call dcflux (pot,decfx,decfy,decfz)
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            frcx = decfx(i)
            frcy = decfy(i)
            frcz = decfz(i)
            dep(1,i) = dep(1,i) + frcx
            dep(2,i) = dep(2,i) + frcy
            dep(3,i) = dep(3,i) + frcz
            vxx = xi * frcx
            vxy = yi * frcx
            vxz = zi * frcx
            vyy = yi * frcy
            vyz = zi * frcy
            vzz = zi * frcz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vxy
            vir(3,1) = vir(3,1) + vxz
            vir(1,2) = vir(1,2) + vxy
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vyz
            vir(1,3) = vir(1,3) + vxz
            vir(2,3) = vir(2,3) + vyz
            vir(3,3) = vir(3,3) + vzz
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      deallocate (dscale)
      deallocate (uscale)
      deallocate (wscale)
      deallocate (ufld)
      deallocate (dufld)
      deallocate (pot)
      deallocate (decfx)
      deallocate (decfy)
      deallocate (decfz)
      return
      end
c
c
c     ###################################################################
c     ##                                                               ##
c     ##  subroutine epolar1d  --  Ewald polarization derivs via list  ##
c     ##                                                               ##
c     ###################################################################
c
c
c     "epolar1d" calculates the dipole polarization energy and
c     derivatives with respect to Cartesian coordinates using
c     particle mesh Ewald summation and a neighbor list
c
c
      subroutine epolar1d
      use atoms
      use boxes
      use chgpot
      use deriv
      use energi
      use ewald
      use math
      use mpole
      use pme
      use polar
      use polpot
      use poltcg
      use potent
      use virial
      implicit none
      integer i,j,ii
      integer ix,iy,iz
      real*8 f,term
      real*8 dix,diy,diz
      real*8 uix,uiy,uiz
      real*8 xd,yd,zd
      real*8 xq,yq,zq
      real*8 xu,yu,zu
      real*8 xup,yup,zup
      real*8 xv,yv,zv,vterm
      real*8 xufield,yufield
      real*8 zufield
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 fix(3),fiy(3),fiz(3)
      real*8 tep(3)
c
c
c     zero out the polarization energy and derivatives
c
      ep = 0.0d0
      do i = 1, n
         do j = 1, 3
            dep(j,i) = 0.0d0
         end do
      end do
      if (npole .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bsporder
      aewald = apewald
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     compute the total induced dipole polarization energy
c
      call epolar1e
c
c     compute the real space part of the Ewald summation
c
      call epreal1d
c
c     compute the reciprocal space part of the Ewald summation
c
      call eprecip1
c
c     compute the Ewald self-energy torque and virial terms
c
      term = (4.0d0/3.0d0) * f * aewald**3 / rootpi
      do ii = 1, npole
         i = ipole(ii)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         uix = 0.5d0 * (uind(1,i)+uinp(1,i))
         uiy = 0.5d0 * (uind(2,i)+uinp(2,i))
         uiz = 0.5d0 * (uind(3,i)+uinp(3,i))
         tep(1) = term * (diy*uiz-diz*uiy)
         tep(2) = term * (diz*uix-dix*uiz)
         tep(3) = term * (dix*uiy-diy*uix)
         call torque (i,tep,fix,fiy,fiz,dep)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                     + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                     + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3))
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                     + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         xu = 0.0d0
         yu = 0.0d0
         zu = 0.0d0
         xup = 0.0d0
         yup = 0.0d0
         zup = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            xd = xd + rpole(2,i) + rpole(1,i)*x(ii)
            yd = yd + rpole(3,i) + rpole(1,i)*y(ii)
            zd = zd + rpole(4,i) + rpole(1,i)*z(ii)
            xu = xu + uind(1,i)
            yu = yu + uind(2,i)
            zu = zu + uind(3,i)
            xup = xup + uinp(1,i)
            yup = yup + uinp(2,i)
            zup = zup + uinp(3,i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         do ii = 1, npole
            i = ipole(ii)
            dep(1,i) = dep(1,i) + term*rpole(1,i)*(xu+xup)
            dep(2,i) = dep(2,i) + term*rpole(1,i)*(yu+yup)
            dep(3,i) = dep(3,i) + term*rpole(1,i)*(zu+zup)
         end do
         xufield = -term * (xu+xup)
         yufield = -term * (yu+yup)
         zufield = -term * (zu+zup)
         do ii = 1, npole
            tep(1) = rpole(3,i)*zufield - rpole(4,i)*yufield
            tep(2) = rpole(4,i)*xufield - rpole(2,i)*zufield
            tep(3) = rpole(2,i)*yufield - rpole(3,i)*xufield
            call torque (i,tep,fix,fiy,fiz,dep)
         end do
c
c     boundary correction to virial due to overall cell dipole
c
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         xq = 0.0d0
         yq = 0.0d0
         zq = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            xd = xd + rpole(2,i)
            yd = yd + rpole(3,i)
            zd = zd + rpole(4,i)
            xq = xq + rpole(1,i)*x(i)
            yq = yq + rpole(1,i)*y(i)
            zq = zq + rpole(1,i)*z(i)
         end do
         xv = xq * (xu+xup)
         yv = yq * (yu+yup)
         zv = zq * (zu+zup)
         vterm = xv + yv + zv + xu*xup + yu*yup + zu*zup
     &              + xd*(xu+xup) + yd*(yu+yup) + zd*(zu+zup)
         vterm = term * vterm
         vir(1,1) = vir(1,1) + term*xv + vterm
         vir(2,1) = vir(2,1) + term*xv
         vir(3,1) = vir(3,1) + term*xv
         vir(1,2) = vir(1,2) + term*yv
         vir(2,2) = vir(2,2) + term*yv + vterm
         vir(3,2) = vir(3,2) + term*yv
         vir(1,3) = vir(1,3) + term*zv
         vir(2,3) = vir(2,3) + term*zv
         vir(3,3) = vir(3,3) + term*zv + vterm
         if (poltyp .eq. 'DIRECT') then
            vterm = term * (xu*xup+yu*yup+zu*zup)
            vir(1,1) = vir(1,1) + vterm
            vir(2,2) = vir(2,2) + vterm
            vir(3,3) = vir(3,3) + vterm
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine epreal1d  --  Ewald real space derivs via list  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "epreal1d" evaluates the real space portion of the Ewald
c     summation energy and gradient due to dipole polarization
c     via a neighbor list
c
c
      subroutine epreal1d
      use atoms
      use bound
      use chgpen
      use chgpot
      use couple
      use deriv
      use ewald
      use math
      use mplpot
      use mpole
      use neigh
      use polar
      use polgrp
      use polopt
      use polpot
      use poltcg
      use potent
      use shunt
      use virial
      implicit none
      integer i,j,k,m
      integer ii,kk,kkk
      integer ix,iy,iz
      integer it,kt
      real*8 f,pgamma
      real*8 pdi,pti,ddi
      real*8 damp,expdamp
      real*8 temp3,temp5,temp7
      real*8 sc3,sc5,sc7
      real*8 psc3,psc5,psc7
      real*8 dsc3,dsc5,dsc7
      real*8 usc3,usc5
      real*8 psr3,psr5,psr7
      real*8 dsr3,dsr5,dsr7
      real*8 usr3,usr5
      real*8 rr3core,rr5core
      real*8 rr3i,rr5i
      real*8 rr7i,rr9i
      real*8 rr3k,rr5k
      real*8 rr7k,rr9k
      real*8 rr5ik,rr7ik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 uixp,uiyp,uizp
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 ukxp,ukyp,ukzp
      real*8 dir,uir,uirp
      real*8 dkr,ukr,ukrp
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 uirm,ukrm
      real*8 uirt,ukrt
      real*8 tuir,tukr
      real*8 tixx,tiyy,tizz
      real*8 tixy,tixz,tiyz
      real*8 tkxx,tkyy,tkzz
      real*8 tkxy,tkxz,tkyz
      real*8 tix3,tiy3,tiz3
      real*8 tix5,tiy5,tiz5
      real*8 tkx3,tky3,tkz3
      real*8 tkx5,tky5,tkz5
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 term6,term7
      real*8 term1core
      real*8 term1i,term2i,term3i
      real*8 term4i,term5i,term6i
      real*8 term7i,term8i
      real*8 term1k,term2k,term3k
      real*8 term4k,term5k,term6k
      real*8 term7k,term8k
      real*8 poti,potk
      real*8 depx,depy,depz
      real*8 frcx,frcy,frcz
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 rc3(3),rc5(3),rc7(3)
      real*8 prc3(3),prc5(3),prc7(3)
      real*8 drc3(3),drc5(3),drc7(3)
      real*8 urc3(3),urc5(3),tep(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 uax(3),uay(3),uaz(3)
      real*8 ubx(3),uby(3),ubz(3)
      real*8 uaxp(3),uayp(3),uazp(3)
      real*8 ubxp(3),ubyp(3),ubzp(3)
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9),dmpe(9)
      real*8, allocatable :: pscale(:)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: wscale(:)
      real*8, allocatable :: ufld(:,:)
      real*8, allocatable :: dufld(:,:)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
      character*6 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
      allocate (dscale(n))
      allocate (uscale(n))
      allocate (wscale(n))
      allocate (ufld(3,n))
      allocate (dufld(6,n))
      allocate (pot(n))
      allocate (decfx(n))
      allocate (decfy(n))
      allocate (decfz(n))
c
c     set exclusion coefficients and arrays to store fields
c
      do i = 1, n
         pscale(i) = 1.0d0
         dscale(i) = 1.0d0
         uscale(i) = 1.0d0
         wscale(i) = 1.0d0
         do j = 1, 3
            ufld(j,i) = 0.0d0
         end do
         do j = 1, 6
            dufld(j,i) = 0.0d0
         end do
         pot(i) = 0.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,x,y,z,rpole,uind,
!$OMP& uinp,jpolar,thole,tholed,pdamp,thlval,thdval,pcore,pval,palpha,
!$OMP& n12,i12,n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,
!$OMP& np14,ip14,p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,
!$OMP& p4iscale,p5iscale,d1scale,d2scale,d3scale,d4scale,u1scale,
!$OMP& u2scale,u3scale,u4scale,w2scale,w3scale,w4scale,w5scale,nelst,
!$OMP& elst,dpequal,use_thole,use_tholed,use_chgpen,use_chgflx,
!$OMP& use_bounds,off2,f,aewald,optorder,copm,uopt,uoptp,poltyp,
!$OMP& tcgnab,uad,uap,ubd,ubp,xaxis,yaxis,zaxis)
!$OMP& shared (dep,ufld,dufld,pot,vir)
!$OMP& firstprivate(pscale,dscale,uscale,wscale)
!$OMP DO reduction(+:dep,ufld,dufld,pot,vir)
c
c     compute the dipole polarization gradient components
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         uixp = uinp(1,i)
         uiyp = uinp(2,i)
         uizp = uinp(3,i)
         do j = 1, tcgnab
            uax(j) = uad(1,i,j)
            uay(j) = uad(2,i,j)
            uaz(j) = uad(3,i,j)
            uaxp(j) = uap(1,i,j)
            uayp(j) = uap(2,i,j)
            uazp(j) = uap(3,i,j)
            ubx(j) = ubd(1,i,j)
            uby(j) = ubd(2,i,j)
            ubz(j) = ubd(3,i,j)
            ubxp(j) = ubp(1,i,j)
            ubyp(j) = ubp(2,i,j)
            ubzp(j) = ubp(3,i,j)
         end do
         if (use_thole) then
            pdi = pdamp(i)
            pti = thole(i)
            ddi = tholed(i)
         else if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
               uscale(ip14(j,i)) = u4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
               ukxp = uinp(1,k)
               ukyp = uinp(2,k)
               ukzp = uinp(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               uir = uix*xr + uiy*yr + uiz*zr
               uirp = uixp*xr + uiyp*yr + uizp*zr
               ukr = ukx*xr + uky*yr + ukz*zr
               ukrp = ukxp*xr + ukyp*yr + ukzp*zr
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
c
c     calculate real space Ewald error function damping
c
               call dampewald (9,r,r2,f,dmpe)
c
c     set initial values for tha damping scale factors
c
               sc3 = 1.0d0
               sc5 = 1.0d0
               sc7 = 1.0d0
               do j = 1, 3
                  rc3(j) = 0.0d0
                  rc5(j) = 0.0d0
                  rc7(j) = 0.0d0
               end do
c
c     apply Thole polarization damping to scale factors
c
               if (use_thole) then
                  damp = pdi * pdamp(k)
                  it = jpolar(i)
                  kt = jpolar(k)
                  if (use_tholed) then
                     pgamma = thdval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**(1.5d0)
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp) 
                           sc3 = 1.0d0 - expdamp 
                           sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp
     &                                      +0.15d0*damp**2)
                           temp3 = 1.5d0 * damp * expdamp / r2
                           temp5 = 0.5d0 * (1.0d0+damp)
                           temp7 = 0.7d0 + 0.15d0*damp**2/temp5
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  else
                     pgamma = thlval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**3
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp)
                           sc3 = 1.0d0 - expdamp
                           sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+damp
     &                                      +0.6d0*damp**2)
                           temp3 = 3.0d0 * damp * expdamp / r2
                           temp5 = damp
                           temp7 = -0.2d0 + 0.6d0*damp
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  end if
                  psc3 = 1.0d0 - sc3*pscale(k)
                  psc5 = 1.0d0 - sc5*pscale(k)
                  psc7 = 1.0d0 - sc7*pscale(k)
                  dsc3 = 1.0d0 - sc3*dscale(k)
                  dsc5 = 1.0d0 - sc5*dscale(k)
                  dsc7 = 1.0d0 - sc7*dscale(k)
                  usc3 = 1.0d0 - sc3*uscale(k)
                  usc5 = 1.0d0 - sc5*uscale(k)
                  psr3 = dmpe(3) - psc3*rr3
                  psr5 = dmpe(5) - psc5*rr5
                  psr7 = dmpe(7) - psc7*rr7
                  dsr3 = dmpe(3) - dsc3*rr3
                  dsr5 = dmpe(5) - dsc5*rr5
                  dsr7 = dmpe(7) - dsc7*rr7
                  usr3 = dmpe(3) - usc3*rr3
                  usr5 = dmpe(5) - usc5*rr5
                  do j = 1, 3
                     prc3(j) = rc3(j) * pscale(k)
                     prc5(j) = rc5(j) * pscale(k)
                     prc7(j) = rc7(j) * pscale(k)
                     drc3(j) = rc3(j) * dscale(k)
                     drc5(j) = rc5(j) * dscale(k)
                     drc7(j) = rc7(j) * dscale(k)
                     urc3(j) = rc3(j) * uscale(k)
                     urc5(j) = rc5(j) * uscale(k)
                  end do
c
c     apply charge penetration damping to scale factors
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik)
                  rr3core = dmpe(3) - (1.0d0-dscale(k))*rr3
                  rr5core = dmpe(5) - (1.0d0-dscale(k))*rr5
                  rr3i = dmpe(3) - (1.0d0-dscale(k)*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-dscale(k)*dmpi(5))*rr5
                  rr7i = dmpe(7) - (1.0d0-dscale(k)*dmpi(7))*rr7
                  rr9i = dmpe(9) - (1.0d0-dscale(k)*dmpi(9))*rr9
                  rr3k = dmpe(3) - (1.0d0-dscale(k)*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-dscale(k)*dmpk(5))*rr5
                  rr7k = dmpe(7) - (1.0d0-dscale(k)*dmpk(7))*rr7
                  rr9k = dmpe(9) - (1.0d0-dscale(k)*dmpk(9))*rr9
                  rr5ik = dmpe(5) - (1.0d0-wscale(k)*dmpik(5))*rr5
                  rr7ik = dmpe(7) - (1.0d0-wscale(k)*dmpik(7))*rr7
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_thole) then
                     poti = -ukr*psr3 - ukrp*dsr3
                     potk = uir*psr3 + uirp*dsr3
                  else if (use_chgpen) then
                     poti = -2.0d0 * ukr * rr3i
                     potk = 2.0d0 * uir * rr3k
                  end if
                  pot(i) = pot(i) + poti 
                  pot(k) = pot(k) + potk 
               end if
c
c     get the induced dipole field used for dipole torques
c
               if (use_thole) then
                  tix3 = psr3*ukx + dsr3*ukxp
                  tiy3 = psr3*uky + dsr3*ukyp
                  tiz3 = psr3*ukz + dsr3*ukzp
                  tkx3 = psr3*uix + dsr3*uixp
                  tky3 = psr3*uiy + dsr3*uiyp
                  tkz3 = psr3*uiz + dsr3*uizp
                  tuir = -psr5*ukr - dsr5*ukrp
                  tukr = -psr5*uir - dsr5*uirp
               else if (use_chgpen) then
                  tix3 = 2.0d0*rr3i*ukx
                  tiy3 = 2.0d0*rr3i*uky
                  tiz3 = 2.0d0*rr3i*ukz
                  tkx3 = 2.0d0*rr3k*uix
                  tky3 = 2.0d0*rr3k*uiy
                  tkz3 = 2.0d0*rr3k*uiz
                  tuir = -2.0d0*rr5i*ukr
                  tukr = -2.0d0*rr5k*uir
               end if
               ufld(1,i) = ufld(1,i) + tix3 + xr*tuir
               ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir
               ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir
               ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr
               ufld(2,k) = ufld(2,k) + tky3 + yr*tukr
               ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr
c
c     get induced dipole field gradient used for quadrupole torques
c
               if (use_thole) then
                  tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp)
                  tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp)
                  tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp)
                  tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp)
                  tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp)
                  tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp)
                  tuir = -psr7*ukr - dsr7*ukrp
                  tukr = -psr7*uir - dsr7*uirp
               else if (use_chgpen) then
                  tix5 = 4.0d0 * (rr5i*ukx)
                  tiy5 = 4.0d0 * (rr5i*uky)
                  tiz5 = 4.0d0 * (rr5i*ukz)
                  tkx5 = 4.0d0 * (rr5k*uix)
                  tky5 = 4.0d0 * (rr5k*uiy)
                  tkz5 = 4.0d0 * (rr5k*uiz)
                  tuir = -2.0d0*rr7i*ukr 
                  tukr = -2.0d0*rr7k*uir 
               end if
               dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir
               dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5
     &                         + 2.0d0*xr*yr*tuir
               dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir
               dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5
     &                         + 2.0d0*xr*zr*tuir
               dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5
     &                         + 2.0d0*yr*zr*tuir
               dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir
               dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr
               dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5
     &                         - 2.0d0*xr*yr*tukr
               dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr
               dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5
     &                         - 2.0d0*xr*zr*tukr
               dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5
     &                         - 2.0d0*yr*zr*tukr
               dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr
c
c     get the dEd/dR terms used for direct polarization force
c
               if (use_thole) then
                  term1 = dmpe(5) - dsc3*rr5
                  term2 = dmpe(7) - dsc5*rr7
                  term3 = -dsr3 + term1*xr*xr - rr3*xr*drc3(1)
                  term4 = rr3*drc3(1) - term1*xr - dsr5*xr
                  term5 = term2*xr*xr - dsr5 - rr5*xr*drc5(1)
                  term6 = (dmpe(9)-dsc7*rr9)*xr*xr - dmpe(7)
     &                       - rr7*xr*drc7(1)
                  term7 = rr5*drc5(1) - 2.0d0*dmpe(7)*xr
     &                       + (dsc5+1.5d0*dsc7)*rr7*xr
                  tixx = ci*term3 + dix*term4 + dir*term5
     &                      + 2.0d0*dsr5*qixx + (qiy*yr+qiz*zr)*dsc7*rr7
     &                      + 2.0d0*qix*term7 + qir*term6
                  tkxx = ck*term3 - dkx*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkxx + (qky*yr+qkz*zr)*dsc7*rr7
     &                      + 2.0d0*qkx*term7 + qkr*term6
                  term3 = -dsr3 + term1*yr*yr - rr3*yr*drc3(2)
                  term4 = rr3*drc3(2) - term1*yr - dsr5*yr
                  term5 = term2*yr*yr - dsr5 - rr5*yr*drc5(2)
                  term6 = (dmpe(9)-dsc7*rr9)*yr*yr - dmpe(7)
     &                       - rr7*yr*drc7(2)
                  term7 = rr5*drc5(2) - 2.0d0*dmpe(7)*yr
     &                       + (dsc5+1.5d0*dsc7)*rr7*yr
                  tiyy = ci*term3 + diy*term4 + dir*term5
     &                      + 2.0d0*dsr5*qiyy + (qix*xr+qiz*zr)*dsc7*rr7
     &                      + 2.0d0*qiy*term7 + qir*term6
                  tkyy = ck*term3 - dky*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkyy + (qkx*xr+qkz*zr)*dsc7*rr7
     &                      + 2.0d0*qky*term7 + qkr*term6
                  term3 = -dsr3 + term1*zr*zr - rr3*zr*drc3(3)
                  term4 = rr3*drc3(3) - term1*zr - dsr5*zr
                  term5 = term2*zr*zr - dsr5 - rr5*zr*drc5(3)
                  term6 = (dmpe(9)-dsc7*rr9)*zr*zr - dmpe(7)
     &                       - rr7*zr*drc7(3)
                  term7 = rr5*drc5(3) - 2.0d0*dmpe(7)*zr
     &                       + (dsc5+1.5d0*dsc7)*rr7*zr
                  tizz = ci*term3 + diz*term4 + dir*term5
     &                      + 2.0d0*dsr5*qizz + (qix*xr+qiy*yr)*dsc7*rr7
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkzz = ck*term3 - dkz*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkzz + (qkx*xr+qky*yr)*dsc7*rr7
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  term3 = term1*xr*yr - rr3*yr*drc3(1)
                  term4 = rr3*drc3(1) - term1*xr
                  term5 = term2*xr*yr - rr5*yr*drc5(1)
                  term6 = (dmpe(9)-dsc7*rr9)*xr*yr - rr7*yr*drc7(1)
                  term7 = rr5*drc5(1) - term2*xr
                  tixy = ci*term3 - dsr5*dix*yr + diy*term4 + dir*term5
     &                      + 2.0d0*dsr5*qixy - 2.0d0*dsr7*yr*qix
     &                      + 2.0d0*qiy*term7 + qir*term6
                  tkxy = ck*term3 + dsr5*dkx*yr - dky*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkxy - 2.0d0*dsr7*yr*qkx
     &                      + 2.0d0*qky*term7 + qkr*term6
                  term3 = term1*xr*zr - rr3*zr*drc3(1)
                  term5 = term2*xr*zr - rr5*zr*drc5(1)
                  term6 = (dmpe(9)-dsc7*rr9)*xr*zr - rr7*zr*drc7(1)
                  tixz = ci*term3 - dsr5*dix*zr + diz*term4 + dir*term5
     &                      + 2.0d0*dsr5*qixz - 2.0d0*dsr7*zr*qix
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkxz = ck*term3 + dsr5*dkx*zr - dkz*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkxz - 2.0d0*dsr7*zr*qkx
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  term3 = term1*yr*zr - rr3*zr*drc3(2)
                  term4 = rr3*drc3(2) - term1*yr
                  term5 = term2*yr*zr - rr5*zr*drc5(2)
                  term6 = (dmpe(9)-dsc7*rr9)*yr*zr - rr7*zr*drc7(2)
                  term7 = rr5*drc5(2) - term2*yr
                  tiyz = ci*term3 - dsr5*diy*zr + diz*term4 + dir*term5
     &                      + 2.0d0*dsr5*qiyz - 2.0d0*dsr7*zr*qiy
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkyz = ck*term3 + dsr5*dky*zr - dkz*term4 - dkr*term5
     &                      + 2.0d0*dsr5*qkyz - 2.0d0*dsr7*zr*qky
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      - tkxx*uixp - tkxy*uiyp - tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      - tkxy*uixp - tkyy*uiyp - tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      - tkxz*uixp - tkyz*uiyp - tkzz*uizp
                  frcx = depx
                  frcy = depy
                  frcz = depz
c
c     get the dEp/dR terms used for direct polarization force
c
                  term1 = dmpe(5) - psc3*rr5
                  term2 = dmpe(7) - psc5*rr7
                  term3 = -psr3 + term1*xr*xr - rr3*xr*prc3(1)
                  term4 = rr3*prc3(1) - term1*xr - psr5*xr
                  term5 = term2*xr*xr - psr5 - rr5*xr*prc5(1)
                  term6 = (dmpe(9)-psc7*rr9)*xr*xr - dmpe(7)
     &                       - rr7*xr*prc7(1)
                  term7 = rr5*prc5(1) - 2.0d0*dmpe(7)*xr
     &                       + (psc5+1.5d0*psc7)*rr7*xr
                  tixx = ci*term3 + dix*term4 + dir*term5
     &                      + 2.0d0*psr5*qixx + (qiy*yr+qiz*zr)*psc7*rr7
     &                      + 2.0d0*qix*term7 + qir*term6
                  tkxx = ck*term3 - dkx*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkxx + (qky*yr+qkz*zr)*psc7*rr7
     &                      + 2.0d0*qkx*term7 + qkr*term6
                  term3 = -psr3 + term1*yr*yr - rr3*yr*prc3(2)
                  term4 = rr3*prc3(2) - term1*yr - psr5*yr
                  term5 = term2*yr*yr - psr5 - rr5*yr*prc5(2)
                  term6 = (dmpe(9)-psc7*rr9)*yr*yr - dmpe(7)
     &                       - rr7*yr*prc7(2)
                  term7 = rr5*prc5(2) - 2.0d0*dmpe(7)*yr
     &                       + (psc5+1.5d0*psc7)*rr7*yr
                  tiyy = ci*term3 + diy*term4 + dir*term5
     &                      + 2.0d0*psr5*qiyy + (qix*xr+qiz*zr)*psc7*rr7
     &                      + 2.0d0*qiy*term7 + qir*term6
                  tkyy = ck*term3 - dky*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkyy + (qkx*xr+qkz*zr)*psc7*rr7
     &                      + 2.0d0*qky*term7 + qkr*term6
                  term3 = -psr3 + term1*zr*zr - rr3*zr*prc3(3)
                  term4 = rr3*prc3(3) - term1*zr - psr5*zr
                  term5 = term2*zr*zr - psr5 - rr5*zr*prc5(3)
                  term6 = (dmpe(9)-psc7*rr9)*zr*zr - dmpe(7)
     &                       - rr7*zr*prc7(3)
                  term7 = rr5*prc5(3) - 2.0d0*dmpe(7)*zr
     &                       + (psc5+1.5d0*psc7)*rr7*zr
                  tizz = ci*term3 + diz*term4 + dir*term5
     &                      + 2.0d0*psr5*qizz + (qix*xr+qiy*yr)*psc7*rr7
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkzz = ck*term3 - dkz*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkzz + (qkx*xr+qky*yr)*psc7*rr7
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  term3 = term1*xr*yr - rr3*yr*prc3(1)
                  term4 = rr3*prc3(1) - term1*xr
                  term5 = term2*xr*yr - rr5*yr*prc5(1)
                  term6 = (dmpe(9)-psc7*rr9)*xr*yr - rr7*yr*prc7(1)
                  term7 = rr5*prc5(1) - term2*xr
                  tixy = ci*term3 - psr5*dix*yr + diy*term4 + dir*term5
     &                      + 2.0d0*psr5*qixy - 2.0d0*psr7*yr*qix
     &                      + 2.0d0*qiy*term7 + qir*term6
                  tkxy = ck*term3 + psr5*dkx*yr - dky*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkxy - 2.0d0*psr7*yr*qkx
     &                      + 2.0d0*qky*term7 + qkr*term6
                  term3 = term1*xr*zr - rr3*zr*prc3(1)
                  term5 = term2*xr*zr - rr5*zr*prc5(1)
                  term6 = (dmpe(9)-psc7*rr9)*xr*zr - rr7*zr*prc7(1)
                  tixz = ci*term3 - psr5*dix*zr + diz*term4 + dir*term5
     &                      + 2.0d0*psr5*qixz - 2.0d0*psr7*zr*qix
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkxz = ck*term3 + psr5*dkx*zr - dkz*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkxz - 2.0d0*psr7*zr*qkx
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  term3 = term1*yr*zr - rr3*zr*prc3(2)
                  term4 = rr3*prc3(2) - term1*yr
                  term5 = term2*yr*zr - rr5*zr*prc5(2)
                  term6 = (dmpe(9)-psc7*rr9)*yr*zr - rr7*zr*prc7(2)
                  term7 = rr5*prc5(2) - term2*yr
                  tiyz = ci*term3 - psr5*diy*zr + diz*term4 + dir*term5
     &                      + 2.0d0*psr5*qiyz - 2.0d0*psr7*zr*qiy
     &                      + 2.0d0*qiz*term7 + qir*term6
                  tkyz = ck*term3 + psr5*dky*zr - dkz*term4 - dkr*term5
     &                      + 2.0d0*psr5*qkyz - 2.0d0*psr7*zr*qky
     &                      + 2.0d0*qkz*term7 + qkr*term6
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = frcx + depx
                  frcy = frcy + depy
                  frcz = frcz + depz
c
c     get the field gradient for direct polarization force
c
               else if (use_chgpen) then
                  term1i = rr3i - rr5i*xr*xr
                  term1core = rr3core - rr5core*xr*xr
                  term2i = 2.0d0*rr5i*xr 
                  term3i = rr7i*xr*xr - rr5i
                  term4i = 2.0d0*rr5i
                  term5i = 5.0d0*rr7i*xr
                  term6i = rr9i*xr*xr
                  term1k = rr3k - rr5k*xr*xr
                  term2k = 2.0d0*rr5k*xr
                  term3k = rr7k*xr*xr - rr5k
                  term4k = 2.0d0*rr5k
                  term5k = 5.0d0*rr7k*xr
                  term6k = rr9k*xr*xr
                  tixx = vali*term1i + corei*term1core  
     &                      + dix*term2i - dir*term3i
     &                      - qixx*term4i + qix*term5i - qir*term6i
     &                      + (qiy*yr+qiz*zr)*rr7i
                  tkxx = valk*term1k + corek*term1core
     &                      - dkx*term2k + dkr*term3k
     &                      - qkxx*term4k + qkx*term5k - qkr*term6k
     &                      + (qky*yr+qkz*zr)*rr7k
                  term1i = rr3i - rr5i*yr*yr
                  term1core = rr3core - rr5core*yr*yr
                  term2i = 2.0d0*rr5i*yr
                  term3i = rr7i*yr*yr - rr5i
                  term4i = 2.0d0*rr5i
                  term5i = 5.0d0*rr7i*yr
                  term6i = rr9i*yr*yr
                  term1k = rr3k - rr5k*yr*yr
                  term2k = 2.0d0*rr5k*yr
                  term3k = rr7k*yr*yr - rr5k
                  term4k = 2.0d0*rr5k
                  term5k = 5.0d0*rr7k*yr
                  term6k = rr9k*yr*yr
                  tiyy = vali*term1i + corei*term1core
     &                      + diy*term2i - dir*term3i
     &                      - qiyy*term4i + qiy*term5i - qir*term6i
     &                      + (qix*xr+qiz*zr)*rr7i
                  tkyy = valk*term1k + corek*term1core
     &                      - dky*term2k + dkr*term3k
     &                      - qkyy*term4k + qky*term5k - qkr*term6k
     &                      + (qkx*xr+qkz*zr)*rr7k
                  term1i = rr3i - rr5i*zr*zr
                  term1core = rr3core - rr5core*zr*zr
                  term2i = 2.0d0*rr5i*zr
                  term3i = rr7i*zr*zr - rr5i
                  term4i = 2.0d0*rr5i
                  term5i = 5.0d0*rr7i*zr
                  term6i = rr9i*zr*zr
                  term1k = rr3k - rr5k*zr*zr
                  term2k = 2.0d0*rr5k*zr
                  term3k = rr7k*zr*zr - rr5k
                  term4k = 2.0d0*rr5k
                  term5k = 5.0d0*rr7k*zr
                  term6k = rr9k*zr*zr
                  tizz = vali*term1i + corei*term1core
     &                      + diz*term2i - dir*term3i
     &                      - qizz*term4i + qiz*term5i - qir*term6i
     &                      + (qix*xr+qiy*yr)*rr7i
                  tkzz = valk*term1k + corek*term1core
     &                      - dkz*term2k + dkr*term3k
     &                      - qkzz*term4k + qkz*term5k - qkr*term6k
     &                      + (qkx*xr+qky*yr)*rr7k
                  term2i = rr5i*xr 
                  term1i = yr * term2i
                  term1core = rr5core*xr*yr
                  term3i = rr5i*yr
                  term4i = yr * (rr7i*xr)
                  term5i = 2.0d0*rr5i
                  term6i = 2.0d0*rr7i*xr
                  term7i = 2.0d0*rr7i*yr
                  term8i = yr*rr9i*xr
                  term2k = rr5k*xr
                  term1k = yr * term2k
                  term3k = rr5k*yr
                  term4k = yr * (rr7k*xr)
                  term5k = 2.0d0*rr5k
                  term6k = 2.0d0*rr7k*xr
                  term7k = 2.0d0*rr7k*yr
                  term8k = yr*rr9k*xr
                  tixy = -vali*term1i - corei*term1core 
     &                      + diy*term2i + dix*term3i
     &                      - dir*term4i - qixy*term5i + qiy*term6i
     &                      + qix*term7i - qir*term8i
                  tkxy = -valk*term1k - corek*term1core 
     &                      - dky*term2k - dkx*term3k
     &                      + dkr*term4k - qkxy*term5k + qky*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5i*xr
                  term1i = zr * term2i
                  term1core = rr5core*xr*zr
                  term3i = rr5i*zr
                  term4i = zr * (rr7i*xr)
                  term5i = 2.0d0*rr5i
                  term6i = 2.0d0*rr7i*xr
                  term7i = 2.0d0*rr7i*zr
                  term8i = zr*rr9i*xr
                  term2k = rr5k*xr
                  term1k = zr * term2k
                  term3k = rr5k*zr
                  term4k = zr * (rr7k*xr)
                  term5k = 2.0d0*rr5k
                  term6k = 2.0d0*rr7k*xr
                  term7k = 2.0d0*rr7k*zr
                  term8k = zr*rr9k*xr
                  tixz = -vali*term1i - corei*term1core
     &                      + diz*term2i + dix*term3i
     &                      - dir*term4i - qixz*term5i + qiz*term6i
     &                      + qix*term7i - qir*term8i
                  tkxz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dkx*term3k
     &                      + dkr*term4k - qkxz*term5k + qkz*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5i*yr
                  term1i = zr * term2i
                  term1core = rr5core*yr*zr
                  term3i = rr5i*zr
                  term4i = zr * (rr7i*yr)
                  term5i = 2.0d0*rr5i
                  term6i = 2.0d0*rr7i*yr
                  term7i = 2.0d0*rr7i*zr
                  term8i = zr*rr9i*yr
                  term2k = rr5k*yr
                  term1k = zr * term2k
                  term3k = rr5k*zr
                  term4k = zr * (rr7k*yr)
                  term5k = 2.0d0*rr5k
                  term6k = 2.0d0*rr7k*yr
                  term7k = 2.0d0*rr7k*zr
                  term8k = zr*rr9k*yr
                  tiyz = -vali*term1i - corei*term1core
     &                      + diz*term2i + diy*term3i
     &                      - dir*term4i - qiyz*term5i + qiz*term6i
     &                      + qiy*term7i - qir*term8i
                  tkyz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dky*term3k
     &                      + dkr*term4k - qkyz*term5k + qkz*term6k
     &                      + qky*term7k - qkr*term8k
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = -2.0d0 * depx
                  frcy = -2.0d0 * depy
                  frcz = -2.0d0 * depz
               end if
c
c     reset Thole values if alternate direct damping was used
c
               if (use_tholed) then
                  sc3 = 1.0d0
                  sc5 = 1.0d0
                  do j = 1, 3
                     rc3(j) = 0.0d0
                     rc5(j) = 0.0d0
                  end do
                  damp = pdi * pdamp(k)
                  if (damp .ne. 0.0d0) then
                     pgamma = min(pti,thole(k))
                     damp = pgamma * (r/damp)**3
                     if (damp .lt. 50.0d0) then
                        expdamp = exp(-damp)
                        sc3 = 1.0d0 - expdamp
                        sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                        temp3 = 3.0d0 * damp * expdamp / r2
                        temp5 = damp
                        rc3(1) = xr * temp3
                        rc3(2) = yr * temp3
                        rc3(3) = zr * temp3
                        rc5(1) = rc3(1) * temp5
                        rc5(2) = rc3(2) * temp5
                        rc5(3) = rc3(3) * temp5
                     end if
                  end if
                  usc3 = 1.0d0 - sc3*uscale(k)
                  usc5 = 1.0d0 - sc5*uscale(k)
                  usr3 = dmpe(3) - usc3*rr3
                  usr5 = dmpe(5) - usc5*rr5
                  do j = 1, 3
                     urc3(j) = rc3(j) * uscale(k)
                     urc5(j) = rc5(j) * uscale(k)
                  end do
               end if
c
c     get the dtau/dr terms used for mutual polarization force
c
               if (poltyp.eq.'MUTUAL' .and. use_thole) then
                  term1 = dmpe(5) - usc3*rr5
                  term2 = dmpe(7) - usc5*rr7
                  term3 = usr5 + term1
                  term4 = rr3 * uscale(k)
                  term5 = -xr*term3 + rc3(1)*term4
                  term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1)
                  tixx = uix*term5 + uir*term6
                  tkxx = ukx*term5 + ukr*term6
                  term5 = -yr*term3 + rc3(2)*term4
                  term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2)
                  tiyy = uiy*term5 + uir*term6
                  tkyy = uky*term5 + ukr*term6
                  term5 = -zr*term3 + rc3(3)*term4
                  term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3)
                  tizz = uiz*term5 + uir*term6
                  tkzz = ukz*term5 + ukr*term6
                  term4 = -usr5 * yr
                  term5 = -xr*term1 + rr3*urc3(1)
                  term6 = xr*yr*term2 - rr5*yr*urc5(1)
                  tixy = uix*term4 + uiy*term5 + uir*term6
                  tkxy = ukx*term4 + uky*term5 + ukr*term6
                  term4 = -usr5 * zr
                  term6 = xr*zr*term2 - rr5*zr*urc5(1)
                  tixz = uix*term4 + uiz*term5 + uir*term6
                  tkxz = ukx*term4 + ukz*term5 + ukr*term6
                  term5 = -yr*term1 + rr3*urc3(2)
                  term6 = yr*zr*term2 - rr5*zr*urc5(2)
                  tiyz = uiy*term4 + uiz*term5 + uir*term6
                  tkyz = uky*term4 + ukz*term5 + ukr*term6
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + depx
                  frcy = frcy + depy
                  frcz = frcz + depz
c
c     get the dtau/dr terms used for mutual polarization force
c
               else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then
                  term1 = 2.0d0 * rr5ik
                  term2 = term1*xr
                  term3 = rr5ik - rr7ik*xr*xr
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr
                  term3 = rr5ik - rr7ik*yr*yr
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr
                  term3 = rr5ik - rr7ik*zr*zr
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = rr5ik*yr
                  term2 = rr5ik*xr
                  term3 = yr * (rr7ik*xr)
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = rr5ik * zr
                  term3 = zr * (rr7ik*xr)
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = rr5ik*yr
                  term3 = zr * (rr7ik*yr)
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx - depx
                  frcy = frcy - depy
                  frcz = frcz - depz
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_thole) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = dmpe(5) - usc3*rr5
                        term2 = dmpe(7) - usc5*rr7
                        term3 = usr5 + term1
                        term4 = rr3 * uscale(k)
                        term5 = -xr*term3 + rc3(1)*term4
                        term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1)
                        tixx = uopt(j,1,ii)*term5 + uirm*term6
                        tkxx = uopt(m,1,kk)*term5 + ukrm*term6
                        term5 = -yr*term3 + rc3(2)*term4
                        term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2)
                        tiyy = uopt(j,2,ii)*term5 + uirm*term6
                        tkyy = uopt(m,2,kk)*term5 + ukrm*term6
                        term5 = -zr*term3 + rc3(3)*term4
                        term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3)
                        tizz = uopt(j,3,ii)*term5 + uirm*term6
                        tkzz = uopt(m,3,kk)*term5 + ukrm*term6
                        term4 = -usr5 * yr
                        term5 = -xr*term1 + rr3*urc3(1)
                        term6 = xr*yr*term2 - rr5*yr*urc5(1)
                        tixy = uopt(j,1,i)*term4 + uopt(j,2,i)*term5
     &                            + uirm*term6
                        tkxy = uopt(m,1,k)*term4 + uopt(m,2,k)*term5
     &                            + ukrm*term6
                        term4 = -usr5 * zr
                        term6 = xr*zr*term2 - rr5*zr*urc5(1)
                        tixz = uopt(j,1,i)*term4 + uopt(j,3,i)*term5
     &                            + uirm*term6
                        tkxz = uopt(m,1,k)*term4 + uopt(m,3,k)*term5
     &                            + ukrm*term6
                        term5 = -yr*term1 + rr3*urc3(2)
                        term6 = yr*zr*term2 - rr5*zr*urc5(2)
                        tiyz = uopt(j,2,ii)*term4 + uopt(j,3,ii)*term5
     &                            + uirm*term6
                        tkyz = uopt(m,2,kk)*term4 + uopt(m,3,kk)*term5
     &                            + ukrm*term6
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*depx
                        frcy = frcy + copm(j+m+1)*depy
                        frcz = frcz + copm(j+m+1)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_chgpen) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = 2.0d0 * rr5ik
                        term2 = term1*xr
                        term3 = rr5ik - rr7ik*xr*xr
                        tixx = uopt(j,1,i)*term2 + uirm*term3
                        tkxx = uopt(m,1,k)*term2 + ukrm*term3
                        term2 = term1*yr
                        term3 = rr5ik - rr7ik*yr*yr
                        tiyy = uopt(j,2,i)*term2 + uirm*term3
                        tkyy = uopt(m,2,k)*term2 + ukrm*term3
                        term2 = term1*zr
                        term3 = rr5ik - rr7ik*zr*zr
                        tizz = uopt(j,3,i)*term2 + uirm*term3
                        tkzz = uopt(m,3,k)*term2 + ukrm*term3
                        term1 = rr5ik*yr
                        term2 = rr5ik*xr
                        term3 = yr * (rr7ik*xr)
                        tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2 
     &                       - uirm*term3
                        tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2 
     &                       - ukrm*term3
                        term1 = rr5ik * zr
                        term3 = zr * (rr7ik*xr)
                        tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        term2 = rr5ik*yr
                        term3 = zr * (rr7ik*yr)
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx - copm(j+m+1)*depx
                        frcy = frcy - copm(j+m+1)*depy
                        frcz = frcz - copm(j+m+1)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for TCG polarization force
c
               else if (poltyp.eq.'TCG' .and. use_thole) then
                  do j = 1, tcgnab
                     ukx = ubd(1,k,j)
                     uky = ubd(2,k,j)
                     ukz = ubd(3,k,j)
                     ukxp = ubp(1,k,j)
                     ukyp = ubp(2,k,j)
                     ukzp = ubp(3,k,j)
                     uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = dmpe(5) - usc3*rr5
                     term2 = dmpe(7) - usc5*rr7
                     term3 = usr5 + term1
                     term4 = rr3 * uscale(k)
                     term5 = -xr*term3 + rc3(1)*term4
                     term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1)
                     tixx = uax(j)*term5 + uirt*term6
                     tkxx = ukx*term5 + ukrt*term6
                     term5 = -yr*term3 + rc3(2)*term4
                     term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2)
                     tiyy = uay(j)*term5 + uirt*term6
                     tkyy = uky*term5 + ukrt*term6
                     term5 = -zr*term3 + rc3(3)*term4
                     term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3)
                     tizz = uaz(j)*term5 + uirt*term6
                     tkzz = ukz*term5 + ukrt*term6
                     term4 = -usr5 * yr
                     term5 = -xr*term1 + rr3*urc3(1)
                     term6 = xr*yr*term2 - rr5*yr*urc5(1)
                     tixy = uax(j)*term4 + uay(j)*term5 + uirt*term6
                     tkxy = ukx*term4 + uky*term5 + ukrt*term6
                     term4 = -usr5 * zr
                     term6 = xr*zr*term2 - rr5*zr*urc5(1)
                     tixz = uax(j)*term4 + uaz(j)*term5 + uirt*term6
                     tkxz = ukx*term4 + ukz*term5 + ukrt*term6
                     term5 = -yr*term1 + rr3*urc3(2)
                     term6 = yr*zr*term2 - rr5*zr*urc5(2)
                     tiyz = uay(j)*term4 + uaz(j)*term5 + uirt*term6
                     tkyz = uky*term4 + ukz*term5 + ukrt*term6
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*uaxp(j) + tkxy*uayp(j)
     &                         + tkxz*uazp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*uaxp(j) + tkyy*uayp(j)
     &                         + tkyz*uazp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*uaxp(j) + tkyz*uayp(j)
     &                         + tkzz*uazp(j)
                     frcx = frcx + depx
                     frcy = frcy + depy
                     frcz = frcz + depz
                     ukx = uad(1,k,j)
                     uky = uad(2,k,j)
                     ukz = uad(3,k,j)
                     ukxp = uap(1,k,j)
                     ukyp = uap(2,k,j)
                     ukzp = uap(3,k,j)
                     uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = dmpe(5) - usc3*rr5
                     term2 = dmpe(7) - usc5*rr7
                     term3 = usr5 + term1
                     term4 = rr3 * uscale(k)
                     term5 = -xr*term3 + rc3(1)*term4
                     term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1)
                     tixx = ubx(j)*term5 + uirt*term6
                     tkxx = ukx*term5 + ukrt*term6
                     term5 = -yr*term3 + rc3(2)*term4
                     term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2)
                     tiyy = uby(j)*term5 + uirt*term6
                     tkyy = uky*term5 + ukrt*term6
                     term5 = -zr*term3 + rc3(3)*term4
                     term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3)
                     tizz = ubz(j)*term5 + uirt*term6
                     tkzz = ukz*term5 + ukrt*term6
                     term4 = -usr5 * yr
                     term5 = -xr*term1 + rr3*urc3(1)
                     term6 = xr*yr*term2 - rr5*yr*urc5(1)
                     tixy = ubx(j)*term4 + uby(j)*term5 + uirt*term6
                     tkxy = ukx*term4 + uky*term5 + ukrt*term6
                     term4 = -usr5 * zr
                     term6 = xr*zr*term2 - rr5*zr*urc5(1)
                     tixz = ubx(j)*term4 + ubz(j)*term5 + uirt*term6
                     tkxz = ukx*term4 + ukz*term5 + ukrt*term6
                     term5 = -yr*term1 + rr3*urc3(2)
                     term6 = yr*zr*term2 - rr5*zr*urc5(2)
                     tiyz = uby(j)*term4 + ubz(j)*term5 + uirt*term6
                     tkyz = uky*term4 + ukz*term5 + ukrt*term6
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*ubxp(j) + tkxy*ubyp(j)
     &                         + tkxz*ubzp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*ubxp(j) + tkyy*ubyp(j)
     &                         + tkyz*ubzp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*ubxp(j) + tkyz*ubyp(j)
     &                         + tkzz*ubzp(j)
                     frcx = frcx + depx
                     frcy = frcy + depy
                     frcz = frcz + depz
                  end do
               end if
c
c     increment force-based gradient on the interaction sites
c
               dep(1,i) = dep(1,i) - frcx
               dep(2,i) = dep(2,i) - frcy
               dep(3,i) = dep(3,i) - frcz
               dep(1,k) = dep(1,k) + frcx
               dep(2,k) = dep(2,k) + frcy
               dep(3,k) = dep(3,k) + frcz
c
c     increment the virial due to pairwise Cartesian forces
c
               vxx = xr * frcx
               vxy = 0.5d0 * (yr*frcx+xr*frcy)
               vxz = 0.5d0 * (zr*frcx+xr*frcz)
               vyy = yr * frcy
               vyz = 0.5d0 * (zr*frcy+yr*frcz)
               vzz = zr * frcz
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
               uscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP DO reduction(+:dep,vir)
c
c     torque is induced field and gradient cross permanent moments
c
      do ii = 1, npole
         i = ipole(ii)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         tep(1) = diz*ufld(2,i) - diy*ufld(3,i)
     &               + qixz*dufld(2,i) - qixy*dufld(4,i)
     &               + 2.0d0*qiyz*(dufld(3,i)-dufld(6,i))
     &               + (qizz-qiyy)*dufld(5,i)
         tep(2) = dix*ufld(3,i) - diz*ufld(1,i)
     &               - qiyz*dufld(2,i) + qixy*dufld(5,i)
     &               + 2.0d0*qixz*(dufld(6,i)-dufld(1,i))
     &               + (qixx-qizz)*dufld(4,i)
         tep(3) = diy*ufld(1,i) - dix*ufld(2,i)
     &               + qiyz*dufld(4,i) - qixz*dufld(5,i)
     &               + 2.0d0*qixy*(dufld(1,i)-dufld(3,i))
     &               + (qiyy-qixx)*dufld(2,i)
         call torque (i,tep,fix,fiy,fiz,dep)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3))
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
c
c     modify the gradient and virial for charge flux
c
      if (use_chgflx) then
         call dcflux (pot,decfx,decfy,decfz)
!$OMP    DO reduction(+:dep,vir)
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            frcx = decfx(i)
            frcy = decfy(i)
            frcz = decfz(i)
            dep(1,i) = dep(1,i) + frcx
            dep(2,i) = dep(2,i) + frcy
            dep(3,i) = dep(3,i) + frcz
            vxx = xi * frcx
            vxy = yi * frcx
            vxz = zi * frcx
            vyy = yi * frcy
            vyz = zi * frcy
            vzz = zi * frcz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vxy
            vir(3,1) = vir(3,1) + vxz
            vir(1,2) = vir(1,2) + vxy
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vyz
            vir(1,3) = vir(1,3) + vxz
            vir(2,3) = vir(2,3) + vyz
            vir(3,3) = vir(3,3) + vzz
         end do
!$OMP    END DO
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      deallocate (dscale)
      deallocate (uscale)
      deallocate (wscale)
      deallocate (ufld)
      deallocate (dufld)
      deallocate (pot)
      deallocate (decfx)
      deallocate (decfy)
      deallocate (decfz)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine epolar1e  --  single-loop polarization energy  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "epreal1e" calculates the induced dipole polarization energy
c     from the induced dipoles times the electric field
c
c
      subroutine epolar1e
      use atoms
      use boxes
      use chgpot
      use energi
      use ewald
      use limits
      use math
      use mpole
      use polar
      use polpot
      implicit none
      integer i,j,ii
      real*8 e,f,fi,term
      real*8 xd,yd,zd
      real*8 xu,yu,zu
      real*8 dix,diy,diz
      real*8 uix,uiy,uiz
c
c
c     set the energy unit conversion factor
c
      f = -0.5d0 * electric / dielec
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private(ii,j,fi,e)
!$OMP DO reduction(+:ep)
c
c     get polarization energy via induced dipoles times field
c
      do ii = 1, npole
         i = ipole(ii)
         if (douind(i)) then
            fi = f / polarity(i)
            e = 0.0d0
            do j = 1, 3
               e = e + fi*uind(j,i)*udirp(j,i)
            end do
            ep = ep + e
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     compute the cell dipole boundary correction term
c
      if (use_ewald) then
         if (boundary .eq. 'VACUUM') then
            f = electric / dielec
            xd = 0.0d0
            yd = 0.0d0
            zd = 0.0d0
            xu = 0.0d0
            yu = 0.0d0
            zu = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               dix = rpole(2,i)
               diy = rpole(3,i)
               diz = rpole(4,i)
               uix = uind(1,i)
               uiy = uind(2,i)
               uiz = uind(3,i)
               xd = xd + dix + rpole(1,i)*x(i)
               yd = yd + diy + rpole(1,i)*y(i)
               zd = zd + diz + rpole(1,i)*z(i)
               xu = xu + uix
               yu = yu + uiy
               zu = zu + uiz
            end do
            term = (2.0d0/3.0d0) * f * (pi/volbox)
            e = term * (xd*xu+yd*yu+zd*zu)
            ep = ep + e
         end if
      end if
      return
      end
c
c
c     ###################################################################
c     ##                                                               ##
c     ##  subroutine eprecip1  --  PME recip polarize energy & derivs  ##
c     ##                                                               ##
c     ###################################################################
c
c
c     "eprecip1" evaluates the reciprocal space portion of the particle
c     mesh Ewald summation energy and gradient due to dipole polarization
c
c     literature reference:
c
c     C. Sagui, L. G. Pedersen and T. A. Darden, "Towards an Accurate
c     Representation of Electrostatics in Classical Force Fields:
c     Efficient Implementation of Multipolar Interactions in
c     Biomolecular Simulations", Journal of Chemical Physics, 120,
c     73-87 (2004)
c
c     modifications for nonperiodic systems suggested by Tom Darden
c     during May 2007
c
c
      subroutine eprecip1
      use atoms
      use bound
      use boxes
      use chgpot
      use deriv
      use ewald
      use math
      use mpole
      use mrecip
      use pme
      use polar
      use polopt
      use polpot
      use poltcg
      use potent
      use virial
      implicit none
      integer i,j,k,m,ii
      integer j1,j2,j3
      integer k1,k2,k3
      integer m1,m2,m3
      integer ix,iy,iz
      integer ntot,nff
      integer nf1,nf2,nf3
      integer deriv1(10)
      integer deriv2(10)
      integer deriv3(10)
      real*8 eterm,f
      real*8 r1,r2,r3
      real*8 h1,h2,h3
      real*8 f1,f2,f3
      real*8 xi,yi,zi
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 frcx,frcy,frcz
      real*8 volterm,denom
      real*8 hsq,expterm
      real*8 term,pterm
      real*8 vterm,struc2
      real*8 tep(3),fix(3)
      real*8 fiy(3),fiz(3)
      real*8 cphid(4),cphip(4)
      real*8 a(3,3),ftc(10,10)
      real*8, allocatable :: fuind(:,:)
      real*8, allocatable :: fuinp(:,:)
      real*8, allocatable :: fphid(:,:)
      real*8, allocatable :: fphip(:,:)
      real*8, allocatable :: fphidp(:,:)
      real*8, allocatable :: cphidp(:,:)
      real*8, allocatable :: qgrip(:,:,:,:)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
c
c     indices into the electrostatic field array
c
      data deriv1  / 2, 5,  8,  9, 11, 16, 18, 14, 15, 20 /
      data deriv2  / 3, 8,  6, 10, 14, 12, 19, 16, 20, 17 /
      data deriv3  / 4, 9, 10,  7, 15, 17, 13, 20, 18, 19 /
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      f = electric / dielec
c
c     initialize variables required for the scalar summation
c
      pterm = (pi/aewald)**2
      volterm = pi * volbox
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      nff = nfft1 * nfft2
      ntot = nff * nfft3
c
c     remove scalar sum virial from prior multipole FFT
c
      if (use_mpole .and. aewald.eq.aeewald) then
         vxx = -vmxx
         vxy = -vmxy
         vxz = -vmxz
         vyy = -vmyy
         vyz = -vmyz
         vzz = -vmzz
c
c     perform dynamic allocation of some global arrays
c
      else
         if (allocated(cmp)) then
            if (size(cmp) .lt. 10*n)  deallocate (cmp)
         end if
         if (allocated(fmp)) then
            if (size(fmp) .lt. 10*n)  deallocate (fmp)
         end if
         if (allocated(cphi)) then
            if (size(cphi) .lt. 10*n) deallocate (cphi)
         end if
         if (allocated(fphi)) then
            if (size(fphi) .lt. 20*n)  deallocate (fphi)
         end if
         if (.not. allocated(cmp))  allocate (cmp(10,n))
         if (.not. allocated(fmp))  allocate (fmp(10,n))
         if (.not. allocated(cphi))  allocate (cphi(10,n))
         if (.not. allocated(fphi))  allocate (fphi(20,n))
c
c     perform dynamic allocation of some global arrays
c
         ntot = nfft1 * nfft2 * nfft3
         if (allocated(qgrid)) then
            if (size(qgrid) .ne. 2*ntot)  call fftclose
         end if
         if (.not. allocated(qgrid))  call fftsetup
         if (allocated(qfac)) then
            if (size(qfac) .ne. ntot)  deallocate (qfac)
         end if
         if (.not. allocated(qfac))  allocate (qfac(nfft1,nfft2,nfft3))
c
c     setup spatial decomposition and B-spline coefficients
c
         call getchunk
         call moduli
         call bspline_fill
         call table_fill
c
c     assign only the permanent multipoles to the PME grid
c     and perform the 3-D FFT forward transformation
c
         do ii = 1, npole
            i = ipole(ii)
            cmp(1,i) = rpole(1,i)
            cmp(2,i) = rpole(2,i)
            cmp(3,i) = rpole(3,i)
            cmp(4,i) = rpole(4,i)
            cmp(5,i) = rpole(5,i)
            cmp(6,i) = rpole(9,i)
            cmp(7,i) = rpole(13,i)
            cmp(8,i) = 2.0d0 * rpole(6,i)
            cmp(9,i) = 2.0d0 * rpole(7,i)
            cmp(10,i) = 2.0d0 * rpole(10,i)
         end do
         call cmp_to_fmp (cmp,fmp)
         call grid_mpole (fmp)
         call fftfront
c
c     zero out the temporary virial accumulation variables
c
         vxx = 0.0d0
         vxy = 0.0d0
         vxz = 0.0d0
         vyy = 0.0d0
         vyz = 0.0d0
         vzz = 0.0d0
c
c     make the scalar summation over reciprocal lattice
c
         qfac(1,1,1) = 0.0d0
         do i = 1, ntot-1
            k3 = i/nff + 1
            j = i - (k3-1)*nff
            k2 = j/nfft1 + 1
            k1 = j - (k2-1)*nfft1 + 1
            m1 = k1 - 1
            m2 = k2 - 1
            m3 = k3 - 1
            if (k1 .gt. nf1)  m1 = m1 - nfft1
            if (k2 .gt. nf2)  m2 = m2 - nfft2
            if (k3 .gt. nf3)  m3 = m3 - nfft3
            r1 = dble(m1)
            r2 = dble(m2)
            r3 = dble(m3)
            h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
            h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
            h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
            hsq = h1*h1 + h2*h2 + h3*h3
            term = -pterm * hsq
            expterm = 0.0d0
            if (term .gt. -50.0d0) then
               denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
               expterm = exp(term) / denom
               if (.not. use_bounds) then
                  expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
               else if (nonprism) then
                  if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
               end if
               struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2
               eterm = 0.5d0 * f * expterm * struc2
               vterm = (2.0d0/hsq) * (1.0d0-term) * eterm
               vxx = vxx - h1*h1*vterm + eterm
               vxy = vxy - h1*h2*vterm
               vxz = vxz - h1*h3*vterm
               vyy = vyy - h2*h2*vterm + eterm
               vyz = vyz - h2*h3*vterm
               vzz = vzz - h3*h3*vterm + eterm
            end if
            qfac(k1,k2,k3) = expterm
            qgrid(1,k1,k2,k3) = expterm * qgrid(1,k1,k2,k3)
            qgrid(2,k1,k2,k3) = expterm * qgrid(2,k1,k2,k3)
         end do
c
c     account for zeroth grid point for nonperiodic system
c
         qfac(1,1,1) = 0.0d0
         qgrid(1,1,1,1) = 0.0d0
         qgrid(2,1,1,1) = 0.0d0
         if (.not. use_bounds) then
            expterm = 0.5d0 * pi / xbox
            qfac(1,1,1) = expterm
            qgrid(1,1,1,1) = expterm * qgrid(1,1,1,1)
            qgrid(2,1,1,1) = expterm * qgrid(2,1,1,1)
         end if
c
c     perform 3-D FFT backward transform and get potential
c
         call fftback
         call fphi_mpole (fphi)
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 20
               fphi(j,i) = f * fphi(j,i)
            end do
         end do
         call fphi_to_cphi (fphi,cphi)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (fuind(3,n))
      allocate (fuinp(3,n))
      allocate (fphid(10,n))
      allocate (fphip(10,n))
      allocate (fphidp(20,n))
      allocate (cphidp(10,n))
c
c     convert Cartesian induced dipoles to fractional coordinates
c
      do i = 1, 3
         a(1,i) = dble(nfft1) * recip(i,1)
         a(2,i) = dble(nfft2) * recip(i,2)
         a(3,i) = dble(nfft3) * recip(i,3)
      end do
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            fuind(j,i) = a(j,1)*uind(1,i) + a(j,2)*uind(2,i)
     &                      + a(j,3)*uind(3,i)
            fuinp(j,i) = a(j,1)*uinp(1,i) + a(j,2)*uinp(2,i)
     &                      + a(j,3)*uinp(3,i)
         end do
      end do
c
c     assign PME grid and perform 3-D FFT forward transform
c
      call grid_uind (fuind,fuinp)
      call fftfront
c
c     complete the transformation of the PME grid
c
      do k = 1, nfft3
         do j = 1, nfft2
            do i = 1, nfft1
               term = qfac(i,j,k)
               qgrid(1,i,j,k) = term * qgrid(1,i,j,k)
               qgrid(2,i,j,k) = term * qgrid(2,i,j,k)
            end do
         end do
      end do
c
c     perform 3-D FFT backward transform and get potential
c
      call fftback
      call fphi_uind (fphid,fphip,fphidp)
      do ii = 1, npole
         i = ipole(ii)
         do j = 2, 10
            fphid(j,i) = f * fphid(j,i)
            fphip(j,i) = f * fphip(j,i)
         end do
         do j = 1, 20
            fphidp(j,i) = f * fphidp(j,i)
         end do
      end do
c
c     increment the dipole polarization gradient contributions
c
      do ii = 1, npole
         i = ipole(ii)
         f1 = 0.0d0
         f2 = 0.0d0
         f3 = 0.0d0
         do k = 1, 3
            j1 = deriv1(k+1)
            j2 = deriv2(k+1)
            j3 = deriv3(k+1)
            f1 = f1 + (fuind(k,i)+fuinp(k,i))*fphi(j1,i)
            f2 = f2 + (fuind(k,i)+fuinp(k,i))*fphi(j2,i)
            f3 = f3 + (fuind(k,i)+fuinp(k,i))*fphi(j3,i)
            if (poltyp .eq. 'MUTUAL') then
               f1 = f1 + fuind(k,i)*fphip(j1,i) + fuinp(k,i)*fphid(j1,i)
               f2 = f2 + fuind(k,i)*fphip(j2,i) + fuinp(k,i)*fphid(j2,i)
               f3 = f3 + fuind(k,i)*fphip(j3,i) + fuinp(k,i)*fphid(j3,i)
            end if
         end do
         do k = 1, 10
            f1 = f1 + fmp(k,i)*fphidp(deriv1(k),i)
            f2 = f2 + fmp(k,i)*fphidp(deriv2(k),i)
            f3 = f3 + fmp(k,i)*fphidp(deriv3(k),i)
         end do
         f1 = 0.5d0 * dble(nfft1) * f1
         f2 = 0.5d0 * dble(nfft2) * f2
         f3 = 0.5d0 * dble(nfft3) * f3
         h1 = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3
         h2 = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3
         h3 = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3
         dep(1,i) = dep(1,i) + h1
         dep(2,i) = dep(2,i) + h2
         dep(3,i) = dep(3,i) + h3
      end do
c
c     set the potential to be the induced dipole average
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 10
            fphidp(j,i) = 0.5d0 * fphidp(j,i)
         end do
      end do
      call fphi_to_cphi (fphidp,cphidp)
c
c     get the fractional to Cartesian transformation matrix
c
      call frac_to_cart (ftc)
c
c     increment the dipole polarization virial contributions
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 2, 4
            cphid(j) = 0.0d0
            cphip(j) = 0.0d0
            do k = 2, 4
               cphid(j) = cphid(j) + ftc(j,k)*fphid(k,i)
               cphip(j) = cphip(j) + ftc(j,k)*fphip(k,i)
            end do
         end do
         vxx = vxx - cmp(2,i)*cphidp(2,i)
     &            - 0.5d0*((uind(1,i)+uinp(1,i))*cphi(2,i))
         vxy = vxy - 0.5d0*(cphidp(2,i)*cmp(3,i)+cphidp(3,i)*cmp(2,i))
     &            - 0.25d0*((uind(2,i)+uinp(2,i))*cphi(2,i)
     &                     +(uind(1,i)+uinp(1,i))*cphi(3,i))
         vxz = vxz - 0.5d0*(cphidp(2,i)*cmp(4,i)+cphidp(4,i)*cmp(2,i))
     &            - 0.25d0*((uind(3,i)+uinp(3,i))*cphi(2,i)
     &                     +(uind(1,i)+uinp(1,i))*cphi(4,i))
         vyy = vyy - cmp(3,i)*cphidp(3,i)
     &            - 0.5d0*((uind(2,i)+uinp(2,i))*cphi(3,i))
         vyz = vyz - 0.5d0*(cphidp(3,i)*cmp(4,i)+cphidp(4,i)*cmp(3,i))
     &            - 0.25d0*((uind(3,i)+uinp(3,i))*cphi(3,i)
     &                     +(uind(2,i)+uinp(2,i))*cphi(4,i))
         vzz = vzz - cmp(4,i)*cphidp(4,i)
     &            - 0.5d0*((uind(3,i)+uinp(3,i))*cphi(4,i))
         vxx = vxx - 2.0d0*cmp(5,i)*cphidp(5,i)
     &            - cmp(8,i)*cphidp(8,i) - cmp(9,i)*cphidp(9,i)
         vxy = vxy - (cmp(5,i)+cmp(6,i))*cphidp(8,i)
     &            - 0.5d0*(cmp(8,i)*(cphidp(6,i)+cphidp(5,i))
     &                 +cmp(9,i)*cphidp(10,i)+cmp(10,i)*cphidp(9,i))
         vxz = vxz - (cmp(5,i)+cmp(7,i))*cphidp(9,i)
     &            - 0.5d0*(cmp(9,i)*(cphidp(5,i)+cphidp(7,i))
     &                 +cmp(8,i)*cphidp(10,i)+cmp(10,i)*cphidp(8,i))
         vyy = vyy - 2.0d0*cmp(6,i)*cphidp(6,i)
     &            - cmp(8,i)*cphidp(8,i) - cmp(10,i)*cphidp(10,i)
         vyz = vyz - (cmp(6,i)+cmp(7,i))*cphidp(10,i)
     &            - 0.5d0*(cmp(10,i)*(cphidp(6,i)+cphidp(7,i))
     &                 +cmp(8,i)*cphidp(9,i)+cmp(9,i)*cphidp(8,i))
         vzz = vzz - 2.0d0*cmp(7,i)*cphidp(7,i)
     &            - cmp(9,i)*cphidp(9,i) - cmp(10,i)*cphidp(10,i)
         if (poltyp .eq. 'MUTUAL') then
            vxx = vxx - 0.5d0*(cphid(2)*uinp(1,i)+cphip(2)*uind(1,i))
            vxy = vxy - 0.25d0*(cphid(2)*uinp(2,i)+cphip(2)*uind(2,i)
     &                         +cphid(3)*uinp(1,i)+cphip(3)*uind(1,i))
            vxz = vxz - 0.25d0*(cphid(2)*uinp(3,i)+cphip(2)*uind(3,i)
     &                         +cphid(4)*uinp(1,i)+cphip(4)*uind(1,i))
            vyy = vyy - 0.5d0*(cphid(3)*uinp(2,i)+cphip(3)*uind(2,i))
            vyz = vyz - 0.25d0*(cphid(3)*uinp(3,i)+cphip(3)*uind(3,i)
     &                         +cphid(4)*uinp(2,i)+cphip(4)*uind(2,i))
            vzz = vzz - 0.5d0*(cphid(4)*uinp(3,i)+cphip(4)*uind(3,i))
         end if
      end do
c
c     resolve site torques then increment forces and virial
c
      do ii = 1, npole
         i = ipole(ii)
         tep(1) = cmp(4,i)*cphidp(3,i) - cmp(3,i)*cphidp(4,i)
     &               + 2.0d0*(cmp(7,i)-cmp(6,i))*cphidp(10,i)
     &               + cmp(9,i)*cphidp(8,i) + cmp(10,i)*cphidp(6,i)
     &               - cmp(8,i)*cphidp(9,i) - cmp(10,i)*cphidp(7,i)
         tep(2) = cmp(2,i)*cphidp(4,i) - cmp(4,i)*cphidp(2,i)
     &               + 2.0d0*(cmp(5,i)-cmp(7,i))*cphidp(9,i)
     &               + cmp(8,i)*cphidp(10,i) + cmp(9,i)*cphidp(7,i)
     &               - cmp(9,i)*cphidp(5,i) - cmp(10,i)*cphidp(8,i)
         tep(3) = cmp(3,i)*cphidp(2,i) - cmp(2,i)*cphidp(3,i)
     &               + 2.0d0*(cmp(6,i)-cmp(5,i))*cphidp(8,i)
     &               + cmp(8,i)*cphidp(5,i) + cmp(10,i)*cphidp(9,i)
     &               - cmp(8,i)*cphidp(6,i) - cmp(9,i)*cphidp(10,i)
         call torque (i,tep,fix,fiy,fiz,dep)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = ii
         if (ix .eq. 0)  ix = ii
         if (iy .eq. 0)  iy = ii
         xiz = x(iz) - x(ii)
         yiz = y(iz) - y(ii)
         ziz = z(iz) - z(ii)
         xix = x(ix) - x(ii)
         yix = y(ix) - y(ii)
         zix = z(ix) - z(ii)
         xiy = x(iy) - x(ii)
         yiy = y(iy) - y(ii)
         ziy = z(iy) - z(ii)
         vxx = vxx + xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = vxy + 0.5d0*(yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = vxz + 0.5d0*(zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3))
         vyy = vyy + yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = vyz + 0.5d0*(zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = vzz + zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
      end do
c
c     account for dipole response terms in the OPT method
c
      if (poltyp .eq. 'OPT') then
         do ii = 1, npole
            i = ipole(ii)
            do k = 0, optorder-1
               do j = 2, 10
                  fphid(j,i) = f * fopt(k,j,i)
                  fphip(j,i) = f * foptp(k,j,i)
               end do
               do m = 0, optorder-k-1
                  do j = 1, 3
                     fuind(j,i) = a(j,1)*uopt(m,1,i)
     &                               + a(j,2)*uopt(m,2,i)
     &                               + a(j,3)*uopt(m,3,i)
                     fuinp(j,i) = a(j,1)*uoptp(m,1,i)
     &                               + a(j,2)*uoptp(m,2,i)
     &                               + a(j,3)*uoptp(m,3,i)
                  end do
                  f1 = 0.0d0
                  f2 = 0.0d0
                  f3 = 0.0d0
                  do j = 1, 3
                     j1 = deriv1(j+1)
                     j2 = deriv2(j+1)
                     j3 = deriv3(j+1)
                     f1 = f1 + fuind(j,i)*fphip(j1,i)
     &                       + fuinp(j,i)*fphid(j1,i)
                     f2 = f2 + fuind(j,i)*fphip(j2,i)
     &                       + fuinp(j,i)*fphid(j2,i)
                     f3 = f3 + fuind(j,i)*fphip(j3,i)
     &                       + fuinp(j,i)*fphid(j3,i)
                  end do
                  f1 = 0.5d0 * dble(nfft1) * f1
                  f2 = 0.5d0 * dble(nfft2) * f2
                  f3 = 0.5d0 * dble(nfft3) * f3
                  h1 = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3
                  h2 = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3
                  h3 = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3
                  dep(1,ii) = dep(1,ii) + copm(k+m+1)*h1
                  dep(2,ii) = dep(2,ii) + copm(k+m+1)*h2
                  dep(3,ii) = dep(3,ii) + copm(k+m+1)*h3
                  do j = 2, 4
                     cphid(j) = 0.0d0
                     cphip(j) = 0.0d0
                     do j1 = 2, 4
                        cphid(j) = cphid(j) + ftc(j,j1)*fphid(j1,i)
                        cphip(j) = cphip(j) + ftc(j,j1)*fphip(j1,i)
                     end do
                  end do
                  vxx = vxx - 0.5d0*copm(k+m+1)
     &                           *(cphid(2)*uoptp(m,1,i)
     &                            +cphip(2)*uopt(m,1,i))
                  vxy = vxy - 0.25d0*copm(k+m+1)
     &                           *(cphid(2)*uoptp(m,2,i)
     &                            +cphip(2)*uopt(m,2,i)
     &                            +cphid(3)*uoptp(m,1,i)
     &                            +cphip(3)*uopt(m,1,i))
                  vxz = vxz - 0.25d0*copm(k+m+1)
     &                           *(cphid(2)*uoptp(m,3,i)
     &                            +cphip(2)*uopt(m,3,i)
     &                            +cphid(4)*uoptp(m,1,i)
     &                            +cphip(4)*uopt(m,1,i))
                  vyy = vyy - 0.5d0*copm(k+m+1)
     &                           *(cphid(3)*uoptp(m,2,i)
     &                            +cphip(3)*uopt(m,2,i))
                  vyz = vyz - 0.25d0*copm(k+m+1)
     &                           *(cphid(3)*uoptp(m,3,i)
     &                            +cphip(3)*uopt(m,3,i)
     &                            +cphid(4)*uoptp(m,2,i)
     &                            +cphip(4)*uopt(m,2,i))
                  vzz = vzz - 0.5d0*copm(k+m+1)
     &                           *(cphid(4)*uoptp(m,3,i)
     &                            +cphip(4)*uopt(m,3,i))
               end do
            end do
         end do
      end if
c
c     account for dipole response terms in the TCG method
c
      if (poltyp .eq. 'TCG') then
         do m = 1, tcgnab
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  fuind(j,i) = a(j,1)*uad(1,i,m) + a(j,2)*uad(2,i,m)
     &                            + a(j,3)*uad(3,i,m)
                  fuinp(j,i) = a(j,1)*ubp(1,i,m) + a(j,2)*ubp(2,i,m)
     &                            + a(j,3)*ubp(3,i,m)
               end do
            end do
            call grid_uind (fuind,fuinp)
            call fftfront
            do k = 1, nfft3
               do j = 1, nfft2
                  do i = 1, nfft1
                     term = qfac(i,j,k)
                     qgrid(1,i,j,k) = term * qgrid(1,i,j,k)
                     qgrid(2,i,j,k) = term * qgrid(2,i,j,k)
                  end do
               end do
            end do
            call fftback
            call fphi_uind (fphid,fphip,fphidp)
            do ii = 1, npole
               i = ipole(ii)
               do j = 2, 10
                  fphid(j,i) = f * fphid(j,i)
                  fphip(j,i) = f * fphip(j,i)
               end do
            end do
            do ii = 1, npole
               i = ipole(ii)
               f1 = 0.0d0
               f2 = 0.0d0
               f3 = 0.0d0
               do k = 1, 3
                  j1 = deriv1(k+1)
                  j2 = deriv2(k+1)
                  j3 = deriv3(k+1)
                  f1 = f1+fuind(k,i)*fphip(j1,i)+fuinp(k,i)*fphid(j1,i)
                  f2 = f2+fuind(k,i)*fphip(j2,i)+fuinp(k,i)*fphid(j2,i)
                  f3 = f3+fuind(k,i)*fphip(j3,i)+fuinp(k,i)*fphid(j3,i)
               end do
               f1 = 0.5d0 * dble(nfft1) * f1
               f2 = 0.5d0 * dble(nfft2) * f2
               f3 = 0.5d0 * dble(nfft3) * f3
               h1 = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3
               h2 = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3
               h3 = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3
               dep(1,i) = dep(1,i) + h1
               dep(2,i) = dep(2,i) + h2
               dep(3,i) = dep(3,i) + h3
               do j = 2, 4
                  cphid(j) = 0.0d0
                  cphip(j) = 0.0d0
                  do k = 2, 4
                     cphid(j) = cphid(j) + ftc(j,k)*fphid(k,i)
                     cphip(j) = cphip(j) + ftc(j,k)*fphip(k,i)
                  end do
               end do
               vxx = vxx - 0.5d0*(cphid(2)*ubp(1,i,m)
     &                              +cphip(2)*uad(1,i,m))
               vxy = vxy - 0.25d0*(cphid(2)*ubp(2,i,m)
     &                               +cphip(2)*uad(2,i,m)
     &                               +cphid(3)*ubp(1,i,m)
     &                               +cphip(3)*uad(1,i,m))
               vxz = vxz - 0.25d0*(cphid(2)*ubp(3,i,m)
     &                               +cphip(2)*uad(3,i,m)
     &                               +cphid(4)*ubp(1,i,m)
     &                               +cphip(4)*uad(1,i,m))
               vyy = vyy - 0.5d0*(cphid(3)*ubp(2,i,m)
     &                              +cphip(3)*uad(2,i,m))
               vyz = vyz - 0.25d0*(cphid(3)*ubp(3,i,m)
     &                               +cphip(3)*uad(3,i,m)
     &                               +cphid(4)*ubp(2,i,m)
     &                               +cphip(4)*uad(2,i,m))
               vzz = vzz - 0.5d0*(cphid(4)*ubp(3,i,m)
     &                              +cphip(4)*uad(3,i,m))
            end do
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  fuind(j,i) = a(j,1)*ubd(1,i,m) + a(j,2)*ubd(2,i,m)
     &                            + a(j,3)*ubd(3,i,m)
                  fuinp(j,i) = a(j,1)*uap(1,i,m) + a(j,2)*uap(2,i,m)
     &                            + a(j,3)*uap(3,i,m)
               end do
            end do
            call grid_uind (fuind,fuinp)
            call fftfront
            do k = 1, nfft3
               do j = 1, nfft2
                  do i = 1, nfft1
                     term = qfac(i,j,k)
                     qgrid(1,i,j,k) = term * qgrid(1,i,j,k)
                     qgrid(2,i,j,k) = term * qgrid(2,i,j,k)
                  end do
               end do
            end do
            call fftback
            call fphi_uind (fphid,fphip,fphidp)
            do ii = 1, npole
               i = ipole(ii)
               do j = 2, 10
                  fphid(j,i) = f * fphid(j,i)
                  fphip(j,i) = f * fphip(j,i)
               end do
            end do
            do ii = 1, npole
               i = ipole(ii)
               f1 = 0.0d0
               f2 = 0.0d0
               f3 = 0.0d0
               do k = 1, 3
                  j1 = deriv1(k+1)
                  j2 = deriv2(k+1)
                  j3 = deriv3(k+1)
                  f1 = f1+fuind(k,i)*fphip(j1,i)+fuinp(k,i)*fphid(j1,i)
                  f2 = f2+fuind(k,i)*fphip(j2,i)+fuinp(k,i)*fphid(j2,i)
                  f3 = f3+fuind(k,i)*fphip(j3,i)+fuinp(k,i)*fphid(j3,i)
               end do
               f1 = 0.5d0 * dble(nfft1) * f1
               f2 = 0.5d0 * dble(nfft2) * f2
               f3 = 0.5d0 * dble(nfft3) * f3
               h1 = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3
               h2 = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3
               h3 = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3
               dep(1,i) = dep(1,i) + h1
               dep(2,i) = dep(2,i) + h2
               dep(3,i) = dep(3,i) + h3
               do j = 2, 4
                  cphid(j) = 0.0d0
                  cphip(j) = 0.0d0
                  do k = 2, 4
                     cphid(j) = cphid(j) + ftc(j,k)*fphid(k,i)
                     cphip(j) = cphip(j) + ftc(j,k)*fphip(k,i)
                  end do
               end do
               vxx = vxx - 0.5d0*(cphid(2)*uap(1,i,m)
     &                              +cphip(2)*ubd(1,i,m))
               vxy = vxy - 0.25d0*(cphid(2)*uap(2,i,m)
     &                               +cphip(2)*ubd(2,i,m)
     &                               +cphid(3)*uap(1,i,m)
     &                               +cphip(3)*ubd(1,i,m))
               vxz = vxz - 0.25d0*(cphid(2)*uap(3,i,m)
     &                               +cphip(2)*ubd(3,i,m)
     &                               +cphid(4)*uap(1,i,m)
     &                               +cphip(4)*ubd(1,i,m))
               vyy = vyy - 0.5d0*(cphid(3)*uap(2,i,m)
     &                              +cphip(3)*ubd(2,i,m))
               vyz = vyz - 0.25d0*(cphid(3)*uap(3,i,m)
     &                               +cphip(3)*ubd(3,i,m)
     &                               +cphid(4)*uap(2,i,m)
     &                               +cphip(4)*ubd(2,i,m))
               vzz = vzz - 0.5d0*(cphid(4)*uap(3,i,m)
     &                              +cphip(4)*ubd(3,i,m))
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (fuind)
      deallocate (fuinp)
      deallocate (fphid)
      deallocate (fphip)
      deallocate (fphidp)
c
c     perform dynamic allocation of some local arrays
c
      allocate (qgrip(2,nfft1,nfft2,nfft3))
c
c     assign permanent and induced multipoles to the PME grid
c     and perform the 3-D FFT forward transformation
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 2, 4
            cmp(j,i) = cmp(j,i) + uinp(j-1,i)
         end do
      end do
      call cmp_to_fmp (cmp,fmp)
      call grid_mpole (fmp)
      call fftfront
      do k = 1, nfft3
         do j = 1, nfft2
            do i = 1, nfft1
               qgrip(1,i,j,k) = qgrid(1,i,j,k)
               qgrip(2,i,j,k) = qgrid(2,i,j,k)
            end do
         end do
      end do
      do ii = 1, npole
         i = ipole(ii)
         do j = 2, 4
            cmp(j,i) = cmp(j,i) + uind(j-1,i) - uinp(j-1,i)
         end do
      end do
      call cmp_to_fmp (cmp,fmp)
      call grid_mpole (fmp)
      call fftfront
c
c     make the scalar summation over reciprocal lattice
c
      do i = 1, ntot-1
         k3 = i/nff + 1
         j = i - (k3-1)*nff
         k2 = j/nfft1 + 1
         k1 = j - (k2-1)*nfft1 + 1
         m1 = k1 - 1
         m2 = k2 - 1
         m3 = k3 - 1
         if (k1 .gt. nf1)  m1 = m1 - nfft1
         if (k2 .gt. nf2)  m2 = m2 - nfft2
         if (k3 .gt. nf3)  m3 = m3 - nfft3
         r1 = dble(m1)
         r2 = dble(m2)
         r3 = dble(m3)
         h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
         h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
         h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
         hsq = h1*h1 + h2*h2 + h3*h3
         term = -pterm * hsq
         expterm = 0.0d0
         if (term .gt. -50.0d0) then
            denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
            expterm = exp(term) / denom
            if (.not. use_bounds) then
               expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
            else if (nonprism) then
               if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
            end if
            struc2 = qgrid(1,k1,k2,k3)*qgrip(1,k1,k2,k3)
     &                  + qgrid(2,k1,k2,k3)*qgrip(2,k1,k2,k3)
            eterm = 0.5d0 * f * expterm * struc2
            vterm = (2.0d0/hsq) * (1.0d0-term) * eterm
            vxx = vxx + h1*h1*vterm - eterm
            vxy = vxy + h1*h2*vterm
            vxz = vxz + h1*h3*vterm
            vyy = vyy + h2*h2*vterm - eterm
            vyz = vyz + h2*h3*vterm
            vzz = vzz + h3*h3*vterm - eterm
         end if
      end do
c
c     assign only the induced dipoles to the PME grid
c     and perform the 3-D FFT forward transformation
c
      if (poltyp.eq.'DIRECT' .or. poltyp.eq.'TCG') then
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 10
               cmp(j,i) = 0.0d0
            end do
            do j = 2, 4
               cmp(j,i) = uinp(j-1,i)
            end do
         end do
         call cmp_to_fmp (cmp,fmp)
         call grid_mpole (fmp)
         call fftfront
         do k = 1, nfft3
            do j = 1, nfft2
               do i = 1, nfft1
                  qgrip(1,i,j,k) = qgrid(1,i,j,k)
                  qgrip(2,i,j,k) = qgrid(2,i,j,k)
               end do
            end do
         end do
         do ii = 1, npole
            i = ipole(ii)
            do j = 2, 4
               cmp(j,i) = uind(j-1,i)
            end do
         end do
         call cmp_to_fmp (cmp,fmp)
         call grid_mpole (fmp)
         call fftfront
c
c     make the scalar summation over reciprocal lattice
c
         do i = 1, ntot-1
            k3 = i/nff + 1
            j = i - (k3-1)*nff
            k2 = j/nfft1 + 1
            k1 = j - (k2-1)*nfft1 + 1
            m1 = k1 - 1
            m2 = k2 - 1
            m3 = k3 - 1
            if (k1 .gt. nf1)  m1 = m1 - nfft1
            if (k2 .gt. nf2)  m2 = m2 - nfft2
            if (k3 .gt. nf3)  m3 = m3 - nfft3
            r1 = dble(m1)
            r2 = dble(m2)
            r3 = dble(m3)
            h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
            h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
            h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
            hsq = h1*h1 + h2*h2 + h3*h3
            term = -pterm * hsq
            expterm = 0.0d0
            if (term .gt. -50.0d0) then
               denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
               expterm = exp(term) / denom
               if (.not. use_bounds) then
                  expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
               else if (nonprism) then
                  if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
               end if
               struc2 = qgrid(1,k1,k2,k3)*qgrip(1,k1,k2,k3)
     &                     + qgrid(2,k1,k2,k3)*qgrip(2,k1,k2,k3)
               eterm = 0.5d0 * f * expterm * struc2
               vterm = (2.0d0/hsq) * (1.0d0-term) * eterm
               vxx = vxx - h1*h1*vterm + eterm
               vxy = vxy - h1*h2*vterm
               vxz = vxz - h1*h3*vterm
               vyy = vyy - h2*h2*vterm + eterm
               vyz = vyz - h2*h3*vterm
               vzz = vzz - h3*h3*vterm + eterm
            end if
         end do
      end if
c
c     add back missing terms for the TCG polarization method;
c     first do the term for "UAD" dotted with "UBP"
c
      if (poltyp .eq. 'TCG') then
         do m = 1, tcgnab
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 10
                  cmp(j,i) = 0.0d0
               end do
               do j = 2, 4
                  cmp(j,i) = ubp(j-1,i,m)
               end do
            end do
            call cmp_to_fmp (cmp,fmp)
            call grid_mpole (fmp)
            call fftfront
            do k = 1, nfft3
               do j = 1, nfft2
                  do i = 1, nfft1
                     qgrip(1,i,j,k) = qgrid(1,i,j,k)
                     qgrip(2,i,j,k) = qgrid(2,i,j,k)
                  end do
               end do
            end do
            do ii = 1, npole
               i = ipole(ii)
               do j = 2, 4
                  cmp(j,i) = uad(j-1,i,m)
               end do
            end do
            call cmp_to_fmp (cmp,fmp)
            call grid_mpole (fmp)
            call fftfront
c
c     make the scalar summation over reciprocal lattice
c
            do i = 1, ntot-1
               k3 = i/nff + 1
               j = i - (k3-1)*nff
               k2 = j/nfft1 + 1
               k1 = j - (k2-1)*nfft1 + 1
               m1 = k1 - 1
               m2 = k2 - 1
               m3 = k3 - 1
               if (k1 .gt. nf1)  m1 = m1 - nfft1
               if (k2 .gt. nf2)  m2 = m2 - nfft2
               if (k3 .gt. nf3)  m3 = m3 - nfft3
               r1 = dble(m1)
               r2 = dble(m2)
               r3 = dble(m3)
               h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
               h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
               h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
               hsq = h1*h1 + h2*h2 + h3*h3
               term = -pterm * hsq
               expterm = 0.0d0
               if (term .gt. -50.0d0) then
                  denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
                  expterm = exp(term) / denom
                  if (.not. use_bounds) then
                     expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
                  else if (nonprism) then
                     if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
                  end if
                  struc2 = qgrid(1,k1,k2,k3)*qgrip(1,k1,k2,k3)
     &                        + qgrid(2,k1,k2,k3)*qgrip(2,k1,k2,k3)
                  eterm = 0.5d0 * f * expterm * struc2
                  vterm = (2.0d0/hsq) * (1.0d0-term) * eterm
                  vxx = vxx + h1*h1*vterm - eterm
                  vxy = vxy + h1*h2*vterm
                  vxz = vxz + h1*h3*vterm
                  vyy = vyy + h2*h2*vterm - eterm
                  vyz = vyz + h2*h3*vterm
                  vzz = vzz + h3*h3*vterm - eterm
               end if
            end do
c
c     now do the TCG terms with "UBD" dotted with "UAP"
c
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 10
                  cmp(j,i) = 0.0d0
               end do
               do j = 2, 4
                  cmp(j,i) = uap(j-1,i,m)
               end do
            end do
            call cmp_to_fmp (cmp,fmp)
            call grid_mpole (fmp)
            call fftfront
            do k = 1, nfft3
               do j = 1, nfft2
                  do i = 1, nfft1
                     qgrip(1,i,j,k) = qgrid(1,i,j,k)
                     qgrip(2,i,j,k) = qgrid(2,i,j,k)
                  end do
               end do
            end do
            do ii = 1, npole
               i = ipole(ii)
               do j = 2, 4
                  cmp(j,i) = ubd(j-1,i,m)
               end do
            end do
            call cmp_to_fmp (cmp,fmp)
            call grid_mpole (fmp)
            call fftfront
c
c     make the scalar summation over reciprocal lattice
c
            do i = 1, ntot-1
               k3 = i/nff + 1
               j = i - (k3-1)*nff
               k2 = j/nfft1 + 1
               k1 = j - (k2-1)*nfft1 + 1
               m1 = k1 - 1
               m2 = k2 - 1
               m3 = k3 - 1
               if (k1 .gt. nf1)  m1 = m1 - nfft1
               if (k2 .gt. nf2)  m2 = m2 - nfft2
               if (k3 .gt. nf3)  m3 = m3 - nfft3
               r1 = dble(m1)
               r2 = dble(m2)
               r3 = dble(m3)
               h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
               h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
               h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
               hsq = h1*h1 + h2*h2 + h3*h3
               term = -pterm * hsq
               expterm = 0.0d0
               if (term .gt. -50.0d0) then
                  denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
                  expterm = exp(term) / denom
                  if (.not. use_bounds) then
                     expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
                  else if (nonprism) then
                     if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
                  end if
                  struc2 = qgrid(1,k1,k2,k3)*qgrip(1,k1,k2,k3)
     &                        + qgrid(2,k1,k2,k3)*qgrip(2,k1,k2,k3)
                  eterm = 0.5d0 * f * expterm * struc2
                  vterm = (2.0d0/hsq) * (1.0d0-term) * eterm
                  vxx = vxx + h1*h1*vterm - eterm
                  vxy = vxy + h1*h2*vterm
                  vxz = vxz + h1*h3*vterm
                  vyy = vyy + h2*h2*vterm - eterm
                  vyz = vyz + h2*h3*vterm
                  vzz = vzz + h3*h3*vterm - eterm
               end if
            end do
         end do
      end if
c
c     perform dynamic allocation of some local arrays
c
      if (use_chgflx) then
         allocate (pot(n))
         allocate (decfx(n))
         allocate (decfy(n))
         allocate (decfz(n))
c
c     modify the gradient and virial for charge flux
c
         do i = 1, n
            pot(i) = 0.0d0
         end do
         do ii = 1, npole
            i = ipole(ii)
            pot(i) = cphidp(1,i)
         end do
         call dcflux (pot,decfx,decfy,decfz)
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            frcx = decfx(i)
            frcy = decfy(i)
            frcz = decfz(i)
            dep(1,i) = dep(1,i) + frcx
            dep(2,i) = dep(2,i) + frcy
            dep(3,i) = dep(3,i) + frcz
            vxx = vxx + xi*frcx
            vxy = vxy + yi*frcx
            vxz = vxz + zi*frcx
            vyy = vyy + yi*frcy
            vyz = vyz + zi*frcy
            vzz = vzz + zi*frcz
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (pot)
         deallocate (decfx)
         deallocate (decfy)
         deallocate (decfz)
      end if
c
c     increment the total internal virial tensor components
c
      vir(1,1) = vir(1,1) + vxx
      vir(2,1) = vir(2,1) + vxy
      vir(3,1) = vir(3,1) + vxz
      vir(1,2) = vir(1,2) + vxy
      vir(2,2) = vir(2,2) + vyy
      vir(3,2) = vir(3,2) + vyz
      vir(1,3) = vir(1,3) + vxz
      vir(2,3) = vir(2,3) + vyz
      vir(3,3) = vir(3,3) + vzz
c
c     perform deallocation of some local arrays
c
      deallocate (cphidp)
      deallocate (qgrip)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2015  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###################################################################
c     ##                                                               ##
c     ##  subroutine epolar2  --  induced dipole polarization Hessian  ##
c     ##                                                               ##
c     ###################################################################
c
c
c     "epolar2" calculates second derivatives of the dipole polarization
c     energy for a single atom at a time
c
c     it is incorrect to neglect interactions with atoms not directly
c     involved as the multipole site; to get better accuracy, "list"
c     should include all atoms by setting "biglist" to "true"
c
c     the "twosided" flag controls use of one-sided vs. two-sided
c     numerical derivatives; setting the flag to "true" gives a more
c     accurate Hessian at the expense of increased computation time
c
c     also, the "reinduce" flag controls whether the induced dipoles
c     are recomputed every time an atom is moved during computation
c     of the numerical Hessian; setting the flag to "true" produces a
c     much slower calculation, but aids convergence of minimizations,
c     accuracy of vibrational frequencies, etc.
c
c
      subroutine epolar2 (i)
      use atoms
      use deriv
      use hessn
      use limits
      use mpole
      use polpot
      implicit none
      integer i,j,k,kk
      integer nlist
      integer, allocatable :: list(:)
      real*8 eps,old
      real*8, allocatable :: d0(:,:)
      logical prior
      logical biglist
      logical twosided
      logical reinduce
c
c
c     set the default stepsize and accuracy control flags
c
      eps = 1.0d-5
      biglist = .false.
      twosided = .false.
      reinduce = .false.
      if (n .le. 300) then
         biglist = .true.
         twosided = .true.
         reinduce = .true.
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
      allocate (d0(3,n))
c
c     perform dynamic allocation of some global arrays
c
      prior = .false.
      if (allocated(dep)) then
         prior = .true.
         if (size(dep) .lt. 3*n)  deallocate (dep)
      end if
      if (.not. allocated(dep))  allocate (dep(3,n))
c
c     find the multipole definition involving the current atom;
c     results in a faster but approximate Hessian calculation
c
      nlist = 0
      do kk = 1, npole
         k = ipole(kk)
         if (biglist .or. k.eq.i) then
            nlist = nlist + 1
            list(nlist) = k
         end if
      end do
c
c     get multipole first derivatives for the base structure
c
      if (.not. twosided) then
         call epolar2a (nlist,list,reinduce)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = dep(j,k)
            end do
         end do
      end if
c
c     find numerical x-components via perturbed structures
c
      old = x(i)
      if (twosided) then
         x(i) = x(i) - 0.5d0*eps
         call epolar2a (nlist,list,reinduce)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = dep(j,k)
            end do
         end do
      end if
      x(i) = x(i) + eps
      call epolar2a (nlist,list,reinduce)
      x(i) = old
      do k = 1, n
         do j = 1, 3
            hessx(j,k) = hessx(j,k) + 0.5d0*(dep(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical y-components via perturbed structures
c
      old = y(i)
      if (twosided) then
         y(i) = y(i) - 0.5d0*eps
         call epolar2a (nlist,list,reinduce)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = dep(j,k)
            end do
         end do
      end if
      y(i) = y(i) + eps
      call epolar2a (nlist,list,reinduce)
      y(i) = old
      do k = 1, n
         do j = 1, 3
            hessy(j,k) = hessy(j,k) + 0.5d0*(dep(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical z-components via perturbed structures
c
      old = z(i)
      if (twosided) then
         z(i) = z(i) - 0.5d0*eps
         call epolar2a (nlist,list,reinduce)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = dep(j,k)
            end do
         end do
      end if
      z(i) = z(i) + eps
      call epolar2a (nlist,list,reinduce)
      z(i) = old
      do k = 1, n
         do j = 1, 3
            hessz(j,k) = hessz(j,k) + 0.5d0*(dep(j,k)-d0(j,k))/eps
         end do
      end do
c
c     perform deallocation of some global arrays
c
      if (.not. prior) then
         deallocate (dep)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (d0)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine epolar2a  --  polarization derivatives utility  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "epolar2a" computes polarization first derivatives for a single
c     atom with respect to Cartesian coordinates; used to get finite
c     difference second derivatives
c
c
      subroutine epolar2a (nlist,list,reinduce)
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use deriv
      use mplpot
      use mpole
      use polar
      use polgrp
      use polopt
      use polpot
      use poltcg
      use potent
      use shunt
      implicit none
      integer i,j,k,m
      integer ii,kk,iii
      integer it,kt
      integer nlist,jcell
      integer list(*)
      real*8 f,pgamma
      real*8 pdi,pti,ddi
      real*8 damp,expdamp
      real*8 temp3,temp5,temp7
      real*8 sc3,sc5,sc7
      real*8 sr3,sr5,sr7
      real*8 psr3,psr5,psr7
      real*8 dsr3,dsr5,dsr7
      real*8 dsr3i,dsr5i,dsr7i
      real*8 dsr3k,dsr5k,dsr7k
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 uixp,uiyp,uizp
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 ukxp,ukyp,ukzp
      real*8 dir,uir,uirp
      real*8 dkr,ukr,ukrp
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 uirm,ukrm
      real*8 uirt,ukrt
      real*8 tuir,tukr
      real*8 tixx,tiyy,tizz
      real*8 tixy,tixz,tiyz
      real*8 tkxx,tkyy,tkzz
      real*8 tkxy,tkxz,tkyz
      real*8 tix3,tiy3,tiz3
      real*8 tix5,tiy5,tiz5
      real*8 tkx3,tky3,tkz3
      real*8 tkx5,tky5,tkz5
      real*8 term1,term2,term3
      real*8 term4,term5,term6
      real*8 term7,term8
      real*8 term1core
      real*8 term1i,term2i,term3i
      real*8 term4i,term5i,term6i
      real*8 term7i,term8i
      real*8 term1k,term2k,term3k
      real*8 term4k,term5k,term6k
      real*8 term7k,term8k
      real*8 poti,potk
      real*8 depx,depy,depz
      real*8 frcx,frcy,frcz
      real*8 rc3(3),rc5(3),rc7(3)
      real*8 tep(3),fix(3)
      real*8 fiy(3),fiz(3)
      real*8 uax(3),uay(3),uaz(3)
      real*8 ubx(3),uby(3),ubz(3)
      real*8 uaxp(3),uayp(3),uazp(3)
      real*8 ubxp(3),ubyp(3),ubzp(3)
      real*8 dmpi(9),dmpk(9)
      real*8 dmpik(9)
      real*8, allocatable :: pscale(:)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: wscale(:)
      real*8, allocatable :: ufld(:,:)
      real*8, allocatable :: dufld(:,:)
      real*8, allocatable :: pot(:)
      real*8, allocatable :: decfx(:)
      real*8, allocatable :: decfy(:)
      real*8, allocatable :: decfz(:)
      logical reinduce
      character*6 mode
c
c
c     zero out the polarization derivative components
c
      do i = 1, n
         do j = 1, 3
            dep(j,i) = 0.0d0
         end do
      end do
      if (npole .eq. 0)  return
c
c     alter partial charges and multipoles for charge flux
c
      if (use_chgflx)  call alterchg
c
c     alter partial charges and multipoles for charge flux
c
      if (use_chgflx)  call alterchg
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      if (reinduce)  call induce
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
      allocate (dscale(n))
      allocate (uscale(n))
      allocate (wscale(n))
      allocate (ufld(3,n))
      allocate (dufld(6,n))
      allocate (pot(n))
      allocate (decfx(n))
      allocate (decfy(n))
      allocate (decfz(n))
c
c     set exclusion coefficients and arrays to store fields
c
      do i = 1, n
         pscale(i) = 1.0d0
         dscale(i) = 1.0d0
         uscale(i) = 1.0d0
         wscale(i) = 1.0d0
         do j = 1, 3
            ufld(j,i) = 0.0d0
         end do
         do j = 1, 6
            dufld(j,i) = 0.0d0
         end do
         pot(i) = 0.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     compute the dipole polarization gradient components
c
      do iii = 1, nlist
         ii = list(iii)
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         uixp = uinp(1,i)
         uiyp = uinp(2,i)
         uizp = uinp(3,i)
         do j = 1, tcgnab
            uax(j) = uad(1,i,j)
            uay(j) = uad(2,i,j)
            uaz(j) = uad(3,i,j)
            uaxp(j) = uap(1,i,j)
            uayp(j) = uap(2,i,j)
            uazp(j) = uap(3,i,j)
            ubx(j) = ubd(1,i,j)
            uby(j) = ubd(2,i,j)
            ubz(j) = ubd(3,i,j)
            ubxp(j) = ubp(1,i,j)
            ubyp(j) = ubp(2,i,j)
            ubzp(j) = ubp(3,i,j)
         end do
         if (use_thole) then
            pdi = pdamp(i)
            pti = thole(i)
            ddi = tholed(i)
         else if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
               uscale(ip14(j,i)) = u4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, npole
            if (ii .eq. kk)  goto 10
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
               ukxp = uinp(1,k)
               ukyp = uinp(2,k)
               ukzp = uinp(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               uir = uix*xr + uiy*yr + uiz*zr
               uirp = uixp*xr + uiyp*yr + uizp*zr
               ukr = ukx*xr + uky*yr + ukz*zr
               ukrp = ukxp*xr + ukyp*yr + ukzp*zr
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
c
c     set initial values for tha damping scale factors
c
               sc3 = 1.0d0
               sc5 = 1.0d0
               sc7 = 1.0d0
               do j = 1, 3
                  rc3(j) = 0.0d0
                  rc5(j) = 0.0d0
                  rc7(j) = 0.0d0
               end do
c
c     apply Thole polarization damping to scale factors
c
               if (use_thole) then
                  damp = pdi * pdamp(k)
                  it = jpolar(i)
                  kt = jpolar(k)
                  if (use_tholed) then
                     pgamma = thdval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**(1.5d0)
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp) 
                           sc3 = 1.0d0 - expdamp 
                           sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp
     &                                      +0.15d0*damp**2)
                           temp3 = 0.5d0 * damp * expdamp 
                           temp5 = 1.5d0 * (1.0d0+damp)
                           temp7 = 5.0d0*(1.5d0*damp*expdamp
     &                                *(0.35d0+0.35d0*damp
     &                                   +0.15d0*damp**2))/(temp3*temp5)
                           temp3 = temp3 * rr5
                           temp5 = temp5 / r2
                           temp7 = temp7 / r2
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  else
                     pgamma = thlval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**3
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp)
                           sc3 = 1.0d0 - expdamp
                           sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+damp
     &                                      +0.6d0*damp**2)
                           temp3 = damp * expdamp * rr5
                           temp5 = 3.0d0 * damp / r2
                           temp7 = (-1.0d0+3.0d0*damp) / r2
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  end if
                  sr3 = rr3 * sc3
                  sr5 = rr5 * sc5
                  sr7 = rr7 * sc7
                  dsr3 = sr3 * dscale(k)
                  dsr5 = sr5 * dscale(k)
                  dsr7 = sr7 * dscale(k)
                  psr3 = sr3 * pscale(k)
                  psr5 = sr5 * pscale(k)
                  psr7 = sr7 * pscale(k)
c
c     apply charge penetration damping to scale factors
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik)
                  dsr3i = 2.0d0 * rr3 * dmpi(3) * dscale(k)
                  dsr5i = 2.0d0 * rr5 * dmpi(5) * dscale(k)
                  dsr7i = 2.0d0 * rr7 * dmpi(7) * dscale(k)
                  dsr3k = 2.0d0 * rr3 * dmpk(3) * dscale(k)
                  dsr5k = 2.0d0 * rr5 * dmpk(5) * dscale(k)
                  dsr7k = 2.0d0 * rr7 * dmpk(7) * dscale(k)
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_thole) then
                     poti = -ukr*psr3 - ukrp*dsr3
                     potk = uir*psr3 + uirp*dsr3
                  else if (use_chgpen) then
                     poti = -ukr * dsr3i
                     potk = uir * dsr3k
                  end if
                  pot(i) = pot(i) + poti 
                  pot(k) = pot(k) + potk 
               end if
c
c     get the induced dipole field used for dipole torques
c
               if (use_thole) then
                  tix3 = psr3*ukx + dsr3*ukxp
                  tiy3 = psr3*uky + dsr3*ukyp
                  tiz3 = psr3*ukz + dsr3*ukzp
                  tkx3 = psr3*uix + dsr3*uixp
                  tky3 = psr3*uiy + dsr3*uiyp
                  tkz3 = psr3*uiz + dsr3*uizp
                  tuir = -psr5*ukr - dsr5*ukrp
                  tukr = -psr5*uir - dsr5*uirp
               else if (use_chgpen) then
                  tix3 = dsr3i*ukx
                  tiy3 = dsr3i*uky
                  tiz3 = dsr3i*ukz
                  tkx3 = dsr3k*uix
                  tky3 = dsr3k*uiy
                  tkz3 = dsr3k*uiz
                  tuir = -dsr5i*ukr
                  tukr = -dsr5k*uir
               end if
               ufld(1,i) = ufld(1,i) + tix3 + xr*tuir
               ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir
               ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir
               ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr
               ufld(2,k) = ufld(2,k) + tky3 + yr*tukr
               ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr
c
c     get induced dipole field gradient used for quadrupole torques
c
               if (use_thole) then
                  tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp)
                  tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp)
                  tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp)
                  tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp)
                  tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp)
                  tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp)
                  tuir = -psr7*ukr - dsr7*ukrp
                  tukr = -psr7*uir - dsr7*uirp
               else if (use_chgpen) then
                  tix5 = 2.0d0 * (dsr5i*ukx)
                  tiy5 = 2.0d0 * (dsr5i*uky)
                  tiz5 = 2.0d0 * (dsr5i*ukz)
                  tkx5 = 2.0d0 * (dsr5k*uix)
                  tky5 = 2.0d0 * (dsr5k*uiy)
                  tkz5 = 2.0d0 * (dsr5k*uiz)
                  tuir = -dsr7i*ukr
                  tukr = -dsr7k*uir
               end if
               dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir
               dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5
     &                         + 2.0d0*xr*yr*tuir
               dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir
               dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5
     &                         + 2.0d0*xr*zr*tuir
               dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5
     &                         + 2.0d0*yr*zr*tuir
               dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir
               dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr
               dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5
     &                         - 2.0d0*xr*yr*tukr
               dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr
               dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5
     &                         - 2.0d0*xr*zr*tukr
               dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5
     &                         - 2.0d0*yr*zr*tukr
               dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr
c
c     get the field gradient for direct polarization force
c
               if (use_thole) then
                  term1 = sc3*(rr3-rr5*xr*xr) + rc3(1)*xr
                  term2 = (sc3+sc5)*rr5*xr - rc3(1)
                  term3 = sc5*(rr7*xr*xr-rr5) - rc5(1)*xr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*xr-rc5(1)+1.5d0*sc7*rr7*xr)
                  term6 = xr * (sc7*rr9*xr-rc7(1))
                  tixx = ci*term1 + dix*term2 - dir*term3
     &                      - qixx*term4 + qix*term5 - qir*term6
     &                      + (qiy*yr+qiz*zr)*sc7*rr7
                  tkxx = ck*term1 - dkx*term2 + dkr*term3
     &                      - qkxx*term4 + qkx*term5 - qkr*term6
     &                      + (qky*yr+qkz*zr)*sc7*rr7
                  term1 = sc3*(rr3-rr5*yr*yr) + rc3(2)*yr
                  term2 = (sc3+sc5)*rr5*yr - rc3(2)
                  term3 = sc5*(rr7*yr*yr-rr5) - rc5(2)*yr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*yr-rc5(2)+1.5d0*sc7*rr7*yr)
                  term6 = yr * (sc7*rr9*yr-rc7(2))
                  tiyy = ci*term1 + diy*term2 - dir*term3
     &                      - qiyy*term4 + qiy*term5 - qir*term6
     &                      + (qix*xr+qiz*zr)*sc7*rr7
                  tkyy = ck*term1 - dky*term2 + dkr*term3
     &                      - qkyy*term4 + qky*term5 - qkr*term6
     &                      + (qkx*xr+qkz*zr)*sc7*rr7
                  term1 = sc3*(rr3-rr5*zr*zr) + rc3(3)*zr
                  term2 = (sc3+sc5)*rr5*zr - rc3(3)
                  term3 = sc5*(rr7*zr*zr-rr5) - rc5(3)*zr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*zr-rc5(3)+1.5d0*sc7*rr7*zr)
                  term6 = zr * (sc7*rr9*zr-rc7(3))
                  tizz = ci*term1 + diz*term2 - dir*term3
     &                      - qizz*term4 + qiz*term5 - qir*term6
     &                      + (qix*xr+qiy*yr)*sc7*rr7
                  tkzz = ck*term1 - dkz*term2 + dkr*term3
     &                      - qkzz*term4 + qkz*term5 - qkr*term6
     &                      + (qkx*xr+qky*yr)*sc7*rr7
                  term2 = sc3*rr5*xr - rc3(1)
                  term1 = yr * term2
                  term3 = sc5 * rr5 * yr
                  term4 = yr * (sc5*rr7*xr-rc5(1))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*xr-rc5(1))
                  term7 = 2.0d0 * sc7 * rr7 * yr
                  term8 = yr * (sc7*rr9*xr-rc7(1))
                  tixy = -ci*term1 + diy*term2 + dix*term3
     &                      - dir*term4 - qixy*term5 + qiy*term6
     &                      + qix*term7 - qir*term8
                  tkxy = -ck*term1 - dky*term2 - dkx*term3
     &                      + dkr*term4 - qkxy*term5 + qky*term6
     &                      + qkx*term7 - qkr*term8
                  term2 = sc3*rr5*xr - rc3(1)
                  term1 = zr * term2
                  term3 = sc5 * rr5 * zr
                  term4 = zr * (sc5*rr7*xr-rc5(1))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*xr-rc5(1))
                  term7 = 2.0d0 * sc7 * rr7 * zr
                  term8 = zr * (sc7*rr9*xr-rc7(1))
                  tixz = -ci*term1 + diz*term2 + dix*term3
     &                      - dir*term4 - qixz*term5 + qiz*term6
     &                      + qix*term7 - qir*term8
                  tkxz = -ck*term1 - dkz*term2 - dkx*term3
     &                      + dkr*term4 - qkxz*term5 + qkz*term6
     &                      + qkx*term7 - qkr*term8
                  term2 = sc3*rr5*yr - rc3(2)
                  term1 = zr * term2
                  term3 = sc5 * rr5 * zr
                  term4 = zr * (sc5*rr7*yr-rc5(2))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*yr-rc5(2))
                  term7 = 2.0d0 * sc7 * rr7 * zr
                  term8 = zr * (sc7*rr9*yr-rc7(2))
                  tiyz = -ci*term1 + diz*term2 + diy*term3
     &                      - dir*term4 - qiyz*term5 + qiz*term6
     &                      + qiy*term7 - qir*term8
                  tkyz = -ck*term1 - dkz*term2 - dky*term3
     &                      + dkr*term4 - qkyz*term5 + qkz*term6
     &                      + qky*term7 - qkr*term8
c
c     get the field gradient for direct polarization force
c
               else if (use_chgpen) then
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*xr*xr
                  term1core = rr3 - rr5*xr*xr
                  term2i = 2.0d0*rr5*dmpi(5)*xr 
                  term3i = rr7*dmpi(7)*xr*xr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*xr
                  term6i = rr9*dmpi(9)*xr*xr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*xr*xr
                  term2k = 2.0d0*rr5*dmpk(5)*xr
                  term3k = rr7*dmpk(7)*xr*xr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*xr
                  term6k = rr9*dmpk(9)*xr*xr
                  tixx = vali*term1i + corei*term1core  
     &                      + dix*term2i - dir*term3i
     &                      - qixx*term4i + qix*term5i - qir*term6i
     &                      + (qiy*yr+qiz*zr)*rr7*dmpi(7)
                  tkxx = valk*term1k + corek*term1core
     &                      - dkx*term2k + dkr*term3k
     &                      - qkxx*term4k + qkx*term5k - qkr*term6k
     &                      + (qky*yr+qkz*zr)*rr7*dmpk(7)
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*yr*yr
                  term1core = rr3 - rr5*yr*yr
                  term2i = 2.0d0*rr5*dmpi(5)*yr
                  term3i = rr7*dmpi(7)*yr*yr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*yr
                  term6i = rr9*dmpi(9)*yr*yr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*yr*yr
                  term2k = 2.0d0*rr5*dmpk(5)*yr
                  term3k = rr7*dmpk(7)*yr*yr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*yr
                  term6k = rr9*dmpk(9)*yr*yr
                  tiyy = vali*term1i + corei*term1core
     &                      + diy*term2i - dir*term3i
     &                      - qiyy*term4i + qiy*term5i - qir*term6i
     &                      + (qix*xr+qiz*zr)*rr7*dmpi(7)
                  tkyy = valk*term1k + corek*term1core
     &                      - dky*term2k + dkr*term3k
     &                      - qkyy*term4k + qky*term5k - qkr*term6k
     &                      + (qkx*xr+qkz*zr)*rr7*dmpk(7)
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*zr*zr
                  term1core = rr3 - rr5*zr*zr
                  term2i = 2.0d0*rr5*dmpi(5)*zr
                  term3i = rr7*dmpi(7)*zr*zr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*zr
                  term6i = rr9*dmpi(9)*zr*zr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*zr*zr
                  term2k = 2.0d0*rr5*dmpk(5)*zr
                  term3k = rr7*dmpk(7)*zr*zr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*zr
                  term6k = rr9*dmpk(9)*zr*zr
                  tizz = vali*term1i + corei*term1core
     &                      + diz*term2i - dir*term3i
     &                      - qizz*term4i + qiz*term5i - qir*term6i
     &                      + (qix*xr+qiy*yr)*rr7*dmpi(7)
                  tkzz = valk*term1k + corek*term1core
     &                      - dkz*term2k + dkr*term3k
     &                      - qkzz*term4k + qkz*term5k - qkr*term6k
     &                      + (qkx*xr+qky*yr)*rr7*dmpk(7)
                  term2i = rr5*dmpi(5)*xr 
                  term1i = yr * term2i
                  term1core = rr5*xr*yr
                  term3i = rr5*dmpi(5)*yr
                  term4i = yr * (rr7*dmpi(7)*xr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*xr
                  term7i = 2.0d0*rr7*dmpi(7)*yr
                  term8i = yr*rr9*dmpi(9)*xr
                  term2k = rr5*dmpk(5)*xr
                  term1k = yr * term2k
                  term3k = rr5*dmpk(5)*yr
                  term4k = yr * (rr7*dmpk(7)*xr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*xr
                  term7k = 2.0d0*rr7*dmpk(7)*yr
                  term8k = yr*rr9*dmpk(9)*xr
                  tixy = -vali*term1i - corei*term1core 
     &                      + diy*term2i + dix*term3i
     &                      - dir*term4i - qixy*term5i + qiy*term6i
     &                      + qix*term7i - qir*term8i
                  tkxy = -valk*term1k - corek*term1core 
     &                      - dky*term2k - dkx*term3k
     &                      + dkr*term4k - qkxy*term5k + qky*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5*dmpi(5)*xr
                  term1i = zr * term2i
                  term1core = rr5*xr*zr
                  term3i = rr5*dmpi(5)*zr
                  term4i = zr * (rr7*dmpi(7)*xr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*xr
                  term7i = 2.0d0*rr7*dmpi(7)*zr
                  term8i = zr*rr9*dmpi(9)*xr
                  term2k = rr5*dmpk(5)*xr
                  term1k = zr * term2k
                  term3k = rr5*dmpk(5)*zr
                  term4k = zr * (rr7*dmpk(7)*xr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*xr
                  term7k = 2.0d0*rr7*dmpk(7)*zr
                  term8k = zr*rr9*dmpk(9)*xr
                  tixz = -vali*term1i - corei*term1core
     &                      + diz*term2i + dix*term3i
     &                      - dir*term4i - qixz*term5i + qiz*term6i
     &                      + qix*term7i - qir*term8i
                  tkxz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dkx*term3k
     &                      + dkr*term4k - qkxz*term5k + qkz*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5*dmpi(5)*yr
                  term1i = zr * term2i
                  term1core = rr5*yr*zr
                  term3i = rr5*dmpi(5)*zr
                  term4i = zr * (rr7*dmpi(7)*yr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*yr
                  term7i = 2.0d0*rr7*dmpi(7)*zr
                  term8i = zr*rr9*dmpi(9)*yr
                  term2k = rr5*dmpk(5)*yr
                  term1k = zr * term2k
                  term3k = rr5*dmpk(5)*zr
                  term4k = zr * (rr7*dmpk(7)*yr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*yr
                  term7k = 2.0d0*rr7*dmpk(7)*zr
                  term8k = zr*rr9*dmpk(9)*yr
                  tiyz = -vali*term1i - corei*term1core
     &                      + diz*term2i + diy*term3i
     &                      - dir*term4i - qiyz*term5i + qiz*term6i
     &                      + qiy*term7i - qir*term8i
                  tkyz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dky*term3k
     &                      + dkr*term4k - qkyz*term5k + qkz*term6k
     &                      + qky*term7k - qkr*term8k
               end if
c
c     get the dEd/dR terms for Thole direct polarization force
c
               if (use_thole) then
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      - tkxx*uixp - tkxy*uiyp - tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      - tkxy*uixp - tkyy*uiyp - tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      - tkxz*uixp - tkyz*uiyp - tkzz*uizp
                  frcx = dscale(k) * depx
                  frcy = dscale(k) * depy
                  frcz = dscale(k) * depz
c
c     get the dEp/dR terms for Thole direct polarization force
c
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = frcx + pscale(k)*depx
                  frcy = frcy + pscale(k)*depy
                  frcz = frcz + pscale(k)*depz
c
c     get the dEp/dR terms for chgpen direct polarization force
c
               else if (use_chgpen) then
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = 2.0d0*dscale(k)*depx
                  frcy = 2.0d0*dscale(k)*depy
                  frcz = 2.0d0*dscale(k)*depz
               end if
c
c     reset Thole values if alternate direct damping was used
c
               if (use_tholed) then
                  sc3 = 1.0d0
                  sc5 = 1.0d0
                  do j = 1, 3
                     rc3(j) = 0.0d0
                     rc5(j) = 0.0d0
                  end do
                  damp = pdi * pdamp(k)
                  if (damp .ne. 0.0d0) then
                     pgamma = min(pti,thole(k))
                     damp = pgamma * (r/damp)**3
                     if (damp .lt. 50.0d0) then
                        expdamp = exp(-damp)
                        sc3 = 1.0d0 - expdamp
                        sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                        temp3 = damp * expdamp * rr5
                        temp5 = 3.0d0 * damp / r2
                        rc3(1) = xr * temp3
                        rc3(2) = yr * temp3
                        rc3(3) = zr * temp3
                        rc5(1) = rc3(1) * temp5
                        rc5(2) = rc3(2) * temp5
                        rc5(3) = rc3(3) * temp5
                     end if
                  end if
               end if
c
c     get the dtau/dr terms used for mutual polarization force
c
               if (poltyp.eq.'MUTUAL' .and. use_thole) then
                  term1 = (sc3+sc5) * rr5
                  term2 = term1*xr - rc3(1)
                  term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr - rc3(2)
                  term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr - rc3(3)
                  term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = sc5 * rr5 * yr
                  term2 = sc3*rr5*xr - rc3(1)
                  term3 = yr * (sc5*rr7*xr-rc5(1))
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = sc5 * rr5 * zr
                  term3 = zr * (sc5*rr7*xr-rc5(1))
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = sc3*rr5*yr - rc3(2)
                  term3 = zr * (sc5*rr7*yr-rc5(2))
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + uscale(k)*depx
                  frcy = frcy + uscale(k)*depy
                  frcz = frcz + uscale(k)*depz
c
c     get the dtau/dr terms used for mutual polarization force
c
               else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then
                  term1 = 2.0d0 * dmpik(5) * rr5
                  term2 = term1*xr
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr 
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr 
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr 
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr 
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr 
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = rr5*dmpik(5)*yr
                  term2 = rr5*dmpik(5)*xr 
                  term3 = yr * (rr7*dmpik(7)*xr)
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = rr5 *dmpik(5) * zr
                  term3 = zr * (rr7*dmpik(7)*xr)
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = rr5*dmpik(5)*yr 
                  term3 = zr * (rr7*dmpik(7)*yr)
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + wscale(k)*depx
                  frcy = frcy + wscale(k)*depy
                  frcz = frcz + wscale(k)*depz
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_thole) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = (sc3+sc5) * rr5
                        term2 = term1*xr - rc3(1)
                        term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                        tixx = uopt(j,1,ii)*term2 + uirm*term3
                        tkxx = uopt(m,1,kk)*term2 + ukrm*term3
                        term2 = term1*yr - rc3(2)
                        term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                        tiyy = uopt(j,2,ii)*term2 + uirm*term3
                        tkyy = uopt(m,2,kk)*term2 + ukrm*term3
                        term2 = term1*zr - rc3(3)
                        term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                        tizz = uopt(j,3,ii)*term2 + uirm*term3
                        tkzz = uopt(m,3,kk)*term2 + ukrm*term3
                        term1 = sc5 * rr5 * yr
                        term2 = sc3*rr5*xr - rc3(1)
                        term3 = yr * (sc5*rr7*xr-rc5(1))
                        tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2
     &                            - uirm*term3
                        tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2
     &                            - ukrm*term3
                        term1 = sc5 * rr5 * zr
                        term3 = zr * (sc5*rr7*xr-rc5(1))
                        tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        term2 = sc3*rr5*yr - rc3(2)
                        term3 = zr * (sc5*rr7*yr-rc5(2))
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*uscale(k)*depx
                        frcy = frcy + copm(j+m+1)*uscale(k)*depy
                        frcz = frcz + copm(j+m+1)*uscale(k)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_chgpen) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = 2.0d0 * dmpik(5) * rr5
                        term2 = term1*xr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr
                        tixx = uopt(j,1,i)*term2 + uirm*term3
                        tkxx = uopt(m,1,k)*term2 + ukrm*term3
                        term2 = term1*yr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr
                        tiyy = uopt(j,2,i)*term2 + uirm*term3
                        tkyy = uopt(m,2,k)*term2 + ukrm*term3
                        term2 = term1*zr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr
                        tizz = uopt(j,3,i)*term2 + uirm*term3
                        tkzz = uopt(m,3,k)*term2 + ukrm*term3
                        term1 = rr5*dmpik(5)*yr
                        term2 = rr5*dmpik(5)*xr
                        term3 = yr * (rr7*dmpik(7)*xr)
                        tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2
     &                            - uirm*term3
                        tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2
     &                            - ukrm*term3
                        term1 = rr5 *dmpik(5) * zr
                        term3 = zr * (rr7*dmpik(7)*xr)
                        tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        term2 = rr5*dmpik(5)*yr
                        term3 = zr * (rr7*dmpik(7)*yr)
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*wscale(k)*depx
                        frcy = frcy + copm(j+m+1)*wscale(k)*depy
                        frcz = frcz + copm(j+m+1)*wscale(k)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for TCG polarization force
c
               else if (poltyp.eq.'TCG' .and. use_thole) then
                  do j = 1, tcgnab
                     ukx = ubd(1,k,j)
                     uky = ubd(2,k,j)
                     ukz = ubd(3,k,j)
                     ukxp = ubp(1,k,j)
                     ukyp = ubp(2,k,j)
                     ukzp = ubp(3,k,j)
                     uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = (sc3+sc5) * rr5
                     term2 = term1*xr - rc3(1)
                     term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                     tixx = uax(j)*term2 + uirt*term3
                     tkxx = ukx*term2 + ukrt*term3
                     term2 = term1*yr - rc3(2)
                     term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                     tiyy = uay(j)*term2 + uirt*term3
                     tkyy = uky*term2 + ukrt*term3
                     term2 = term1*zr - rc3(3)
                     term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                     tizz = uaz(j)*term2 + uirt*term3
                     tkzz = ukz*term2 + ukrt*term3
                     term1 = sc5 * rr5 * yr
                     term2 = sc3*rr5*xr - rc3(1)
                     term3 = yr * (sc5*rr7*xr-rc5(1))
                     tixy = uax(j)*term1 + uay(j)*term2 - uirt*term3
                     tkxy = ukx*term1 + uky*term2 - ukrt*term3
                     term1 = sc5 * rr5 * zr
                     term3 = zr * (sc5*rr7*xr-rc5(1))
                     tixz = uax(j)*term1 + uaz(j)*term2 - uirt*term3
                     tkxz = ukx*term1 + ukz*term2 - ukrt*term3
                     term2 = sc3*rr5*yr - rc3(2)
                     term3 = zr * (sc5*rr7*yr-rc5(2))
                     tiyz = uay(j)*term1 + uaz(j)*term2 - uirt*term3
                     tkyz = uky*term1 + ukz*term2 - ukrt*term3
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*uaxp(j) + tkxy*uayp(j)
     &                         + tkxz*uazp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*uaxp(j) + tkyy*uayp(j)
     &                         + tkyz*uazp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*uaxp(j) + tkyz*uayp(j)
     &                         + tkzz*uazp(j)
                     frcx = frcx + uscale(k)*depx
                     frcy = frcy + uscale(k)*depy
                     frcz = frcz + uscale(k)*depz
                     ukx = uad(1,k,j)
                     uky = uad(2,k,j)
                     ukz = uad(3,k,j)
                     ukxp = uap(1,k,j)
                     ukyp = uap(2,k,j)
                     ukzp = uap(3,k,j)
                     uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = (sc3+sc5) * rr5
                     term2 = term1*xr - rc3(1)
                     term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                     tixx = ubx(j)*term2 + uirt*term3
                     tkxx = ukx*term2 + ukrt*term3
                     term2 = term1*yr - rc3(2)
                     term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                     tiyy = uby(j)*term2 + uirt*term3
                     tkyy = uky*term2 + ukrt*term3
                     term2 = term1*zr - rc3(3)
                     term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                     tizz = ubz(j)*term2 + uirt*term3
                     tkzz = ukz*term2 + ukrt*term3
                     term1 = sc5 * rr5 * yr
                     term2 = sc3*rr5*xr - rc3(1)
                     term3 = yr * (sc5*rr7*xr-rc5(1))
                     tixy = ubx(j)*term1 + uby(j)*term2 - uirt*term3
                     tkxy = ukx*term1 + uky*term2 - ukrt*term3
                     term1 = sc5 * rr5 * zr
                     term3 = zr * (sc5*rr7*xr-rc5(1))
                     tixz = ubx(j)*term1 + ubz(j)*term2 - uirt*term3
                     tkxz = ukx*term1 + ukz*term2 - ukrt*term3
                     term2 = sc3*rr5*yr - rc3(2)
                     term3 = zr * (sc5*rr7*yr-rc5(2))
                     tiyz = uby(j)*term1 + ubz(j)*term2 - uirt*term3
                     tkyz = uky*term1 + ukz*term2 - ukrt*term3
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*ubxp(j) + tkxy*ubyp(j)
     &                         + tkxz*ubzp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*ubxp(j) + tkyy*ubyp(j)
     &                         + tkyz*ubzp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*ubxp(j) + tkyz*ubyp(j)
     &                         + tkzz*ubzp(j)
                     frcx = frcx + uscale(k)*depx
                     frcy = frcy + uscale(k)*depy
                     frcz = frcz + uscale(k)*depz
                  end do
               end if
c
c     increment force-based gradient on the interaction sites
c
               dep(1,i) = dep(1,i) + frcx
               dep(2,i) = dep(2,i) + frcy
               dep(3,i) = dep(3,i) + frcz
               dep(1,k) = dep(1,k) - frcx
               dep(2,k) = dep(2,k) - frcy
               dep(3,k) = dep(3,k) - frcz
            end if
   10       continue
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
               uscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction with other unit cells
c
      do iii = 1, nlist
         ii = list(iii)
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         uixp = uinp(1,i)
         uiyp = uinp(2,i)
         uizp = uinp(3,i)
         do j = 1, tcgnab
            uax(j) = uad(1,i,j)
            uay(j) = uad(2,i,j)
            uaz(j) = uad(3,i,j)
            uaxp(j) = uap(1,i,j)
            uayp(j) = uap(2,i,j)
            uazp(j) = uap(3,i,j)
            ubx(j) = ubd(1,i,j)
            uby(j) = ubd(2,i,j)
            ubz(j) = ubd(3,i,j)
            ubxp(j) = ubp(1,i,j)
            ubyp(j) = ubp(2,i,j)
            ubzp(j) = ubp(3,i,j)
         end do
         if (use_thole) then
            pdi = pdamp(i)
            pti = thole(i)
            ddi = tholed(i)
         else if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
               uscale(ip14(j,i)) = u4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, npole
            k = ipole(kk)
            do jcell = 2, ncell
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call imager (xr,yr,zr,jcell)
            r2 = xr*xr + yr*yr + zr*zr
            if (.not. (use_polymer .and. r2.le.polycut2)) then
               dscale(k) = 1.0d0
               pscale(k) = 1.0d0
               uscale(k) = 1.0d0
            end if
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
               ukxp = uinp(1,k)
               ukyp = uinp(2,k)
               ukzp = uinp(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               uir = uix*xr + uiy*yr + uiz*zr
               uirp = uixp*xr + uiyp*yr + uizp*zr
               ukr = ukx*xr + uky*yr + ukz*zr
               ukrp = ukxp*xr + ukyp*yr + ukzp*zr
c
c     get reciprocal distance terms for this interaction
c
               rr1 = f / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
c
c     set initial values for tha damping scale factors
c
               sc3 = 1.0d0
               sc5 = 1.0d0
               sc7 = 1.0d0
               do j = 1, 3
                  rc3(j) = 0.0d0
                  rc5(j) = 0.0d0
                  rc7(j) = 0.0d0
               end do
c
c     apply Thole polarization damping to scale factors
c
               if (use_thole) then
                  damp = pdi * pdamp(k)
                  it = jpolar(i)
                  kt = jpolar(k)
                  if (use_tholed) then
                     pgamma = thdval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**(1.5d0)
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp) 
                           sc3 = 1.0d0 - expdamp 
                           sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp
     &                                      +0.15d0*damp**2)
                           temp3 = 0.5d0 * damp * expdamp 
                           temp5 = 1.5d0 * (1.0d0+damp)
                           temp7 = 5.0d0*(1.5d0*damp*expdamp
     &                                *(0.35d0+0.35d0*damp
     &                                   +0.15d0*damp**2))/(temp3*temp5)
                           temp3 = temp3 * rr5
                           temp5 = temp5 / r2
                           temp7 = temp7 / r2
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  else
                     pgamma = thlval(it,kt)
                     if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                        damp = pgamma * (r/damp)**3
                        if (damp .lt. 50.0d0) then
                           expdamp = exp(-damp)
                           sc3 = 1.0d0 - expdamp
                           sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                           sc7 = 1.0d0 - expdamp*(1.0d0+damp
     &                                      +0.6d0*damp**2)
                           temp3 = damp * expdamp * rr5
                           temp5 = 3.0d0 * damp / r2
                           temp7 = (-1.0d0+3.0d0*damp) / r2
                           rc3(1) = xr * temp3
                           rc3(2) = yr * temp3
                           rc3(3) = zr * temp3
                           rc5(1) = rc3(1) * temp5
                           rc5(2) = rc3(2) * temp5
                           rc5(3) = rc3(3) * temp5
                           rc7(1) = rc5(1) * temp7
                           rc7(2) = rc5(2) * temp7
                           rc7(3) = rc5(3) * temp7
                        end if
                     end if
                  end if
                  sr3 = rr3 * sc3
                  sr5 = rr5 * sc5
                  sr7 = rr7 * sc7
                  dsr3 = sr3 * dscale(k)
                  dsr5 = sr5 * dscale(k)
                  dsr7 = sr7 * dscale(k)
                  psr3 = sr3 * pscale(k)
                  psr5 = sr5 * pscale(k)
                  psr7 = sr7 * pscale(k)
c
c     apply charge penetration damping to scale factors
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik)
                  dsr3i = 2.0d0 * rr3 * dmpi(3) * dscale(k)
                  dsr5i = 2.0d0 * rr5 * dmpi(5) * dscale(k)
                  dsr7i = 2.0d0 * rr7 * dmpi(7) * dscale(k)
                  dsr3k = 2.0d0 * rr3 * dmpk(3) * dscale(k)
                  dsr5k = 2.0d0 * rr5 * dmpk(5) * dscale(k)
                  dsr7k = 2.0d0 * rr7 * dmpk(7) * dscale(k)
               end if
c
c     store the potential at each site for use in charge flux
c
               if (use_chgflx) then
                  if (use_thole) then
                     poti = -ukr*psr3 - ukrp*dsr3
                     potk = uir*psr3 + uirp*dsr3
                  else if (use_chgpen) then
                     poti = -ukr * dsr3i
                     potk = uir * dsr3k
                  end if
                  pot(i) = pot(i) + poti 
                  pot(k) = pot(k) + potk 
               end if
c
c     get the induced dipole field used for dipole torques
c
               if (use_thole) then
                  tix3 = psr3*ukx + dsr3*ukxp
                  tiy3 = psr3*uky + dsr3*ukyp
                  tiz3 = psr3*ukz + dsr3*ukzp
                  tkx3 = psr3*uix + dsr3*uixp
                  tky3 = psr3*uiy + dsr3*uiyp
                  tkz3 = psr3*uiz + dsr3*uizp
                  tuir = -psr5*ukr - dsr5*ukrp
                  tukr = -psr5*uir - dsr5*uirp
               else if (use_chgpen) then
                  tix3 = dsr3i*ukx
                  tiy3 = dsr3i*uky
                  tiz3 = dsr3i*ukz
                  tkx3 = dsr3k*uix
                  tky3 = dsr3k*uiy
                  tkz3 = dsr3k*uiz
                  tuir = -dsr5i*ukr
                  tukr = -dsr5k*uir
               end if
               ufld(1,i) = ufld(1,i) + tix3 + xr*tuir
               ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir
               ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir
               ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr
               ufld(2,k) = ufld(2,k) + tky3 + yr*tukr
               ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr
c
c     get induced dipole field gradient used for quadrupole torques
c
               if (use_thole) then
                  tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp)
                  tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp)
                  tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp)
                  tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp)
                  tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp)
                  tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp)
                  tuir = -psr7*ukr - dsr7*ukrp
                  tukr = -psr7*uir - dsr7*uirp
               else if (use_chgpen) then
                  tix5 = 2.0d0 * (dsr5i*ukx)
                  tiy5 = 2.0d0 * (dsr5i*uky)
                  tiz5 = 2.0d0 * (dsr5i*ukz)
                  tkx5 = 2.0d0 * (dsr5k*uix)
                  tky5 = 2.0d0 * (dsr5k*uiy)
                  tkz5 = 2.0d0 * (dsr5k*uiz)
                  tuir = -dsr7i*ukr
                  tukr = -dsr7k*uir
               end if
               dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir
               dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5
     &                         + 2.0d0*xr*yr*tuir
               dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir
               dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5
     &                         + 2.0d0*xr*zr*tuir
               dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5
     &                         + 2.0d0*yr*zr*tuir
               dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir
               dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr
               dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5
     &                         - 2.0d0*xr*yr*tukr
               dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr
               dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5
     &                         - 2.0d0*xr*zr*tukr
               dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5
     &                         - 2.0d0*yr*zr*tukr
               dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr
c
c     get the field gradient for direct polarization force
c
               if (use_thole) then
                  term1 = sc3*(rr3-rr5*xr*xr) + rc3(1)*xr
                  term2 = (sc3+sc5)*rr5*xr - rc3(1)
                  term3 = sc5*(rr7*xr*xr-rr5) - rc5(1)*xr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*xr-rc5(1)+1.5d0*sc7*rr7*xr)
                  term6 = xr * (sc7*rr9*xr-rc7(1))
                  tixx = ci*term1 + dix*term2 - dir*term3
     &                      - qixx*term4 + qix*term5 - qir*term6
     &                      + (qiy*yr+qiz*zr)*sc7*rr7
                  tkxx = ck*term1 - dkx*term2 + dkr*term3
     &                      - qkxx*term4 + qkx*term5 - qkr*term6
     &                      + (qky*yr+qkz*zr)*sc7*rr7
                  term1 = sc3*(rr3-rr5*yr*yr) + rc3(2)*yr
                  term2 = (sc3+sc5)*rr5*yr - rc3(2)
                  term3 = sc5*(rr7*yr*yr-rr5) - rc5(2)*yr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*yr-rc5(2)+1.5d0*sc7*rr7*yr)
                  term6 = yr * (sc7*rr9*yr-rc7(2))
                  tiyy = ci*term1 + diy*term2 - dir*term3
     &                      - qiyy*term4 + qiy*term5 - qir*term6
     &                      + (qix*xr+qiz*zr)*sc7*rr7
                  tkyy = ck*term1 - dky*term2 + dkr*term3
     &                      - qkyy*term4 + qky*term5 - qkr*term6
     &                      + (qkx*xr+qkz*zr)*sc7*rr7
                  term1 = sc3*(rr3-rr5*zr*zr) + rc3(3)*zr
                  term2 = (sc3+sc5)*rr5*zr - rc3(3)
                  term3 = sc5*(rr7*zr*zr-rr5) - rc5(3)*zr
                  term4 = 2.0d0 * sc5 * rr5
                  term5 = 2.0d0 * (sc5*rr7*zr-rc5(3)+1.5d0*sc7*rr7*zr)
                  term6 = zr * (sc7*rr9*zr-rc7(3))
                  tizz = ci*term1 + diz*term2 - dir*term3
     &                      - qizz*term4 + qiz*term5 - qir*term6
     &                      + (qix*xr+qiy*yr)*sc7*rr7
                  tkzz = ck*term1 - dkz*term2 + dkr*term3
     &                      - qkzz*term4 + qkz*term5 - qkr*term6
     &                      + (qkx*xr+qky*yr)*sc7*rr7
                  term2 = sc3*rr5*xr - rc3(1)
                  term1 = yr * term2
                  term3 = sc5 * rr5 * yr
                  term4 = yr * (sc5*rr7*xr-rc5(1))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*xr-rc5(1))
                  term7 = 2.0d0 * sc7 * rr7 * yr
                  term8 = yr * (sc7*rr9*xr-rc7(1))
                  tixy = -ci*term1 + diy*term2 + dix*term3
     &                      - dir*term4 - qixy*term5 + qiy*term6
     &                      + qix*term7 - qir*term8
                  tkxy = -ck*term1 - dky*term2 - dkx*term3
     &                      + dkr*term4 - qkxy*term5 + qky*term6
     &                      + qkx*term7 - qkr*term8
                  term2 = sc3*rr5*xr - rc3(1)
                  term1 = zr * term2
                  term3 = sc5 * rr5 * zr
                  term4 = zr * (sc5*rr7*xr-rc5(1))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*xr-rc5(1))
                  term7 = 2.0d0 * sc7 * rr7 * zr
                  term8 = zr * (sc7*rr9*xr-rc7(1))
                  tixz = -ci*term1 + diz*term2 + dix*term3
     &                      - dir*term4 - qixz*term5 + qiz*term6
     &                      + qix*term7 - qir*term8
                  tkxz = -ck*term1 - dkz*term2 - dkx*term3
     &                      + dkr*term4 - qkxz*term5 + qkz*term6
     &                      + qkx*term7 - qkr*term8
                  term2 = sc3*rr5*yr - rc3(2)
                  term1 = zr * term2
                  term3 = sc5 * rr5 * zr
                  term4 = zr * (sc5*rr7*yr-rc5(2))
                  term5 = 2.0d0 * sc5 * rr5
                  term6 = 2.0d0 * (sc5*rr7*yr-rc5(2))
                  term7 = 2.0d0 * sc7 * rr7 * zr
                  term8 = zr * (sc7*rr9*yr-rc7(2))
                  tiyz = -ci*term1 + diz*term2 + diy*term3
     &                      - dir*term4 - qiyz*term5 + qiz*term6
     &                      + qiy*term7 - qir*term8
                  tkyz = -ck*term1 - dkz*term2 - dky*term3
     &                      + dkr*term4 - qkyz*term5 + qkz*term6
     &                      + qky*term7 - qkr*term8
c
c     get the field gradient for direct polarization force
c
               else if (use_chgpen) then
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*xr*xr
                  term1core = rr3 - rr5*xr*xr
                  term2i = 2.0d0*rr5*dmpi(5)*xr 
                  term3i = rr7*dmpi(7)*xr*xr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*xr
                  term6i = rr9*dmpi(9)*xr*xr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*xr*xr
                  term2k = 2.0d0*rr5*dmpk(5)*xr
                  term3k = rr7*dmpk(7)*xr*xr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*xr
                  term6k = rr9*dmpk(9)*xr*xr
                  tixx = vali*term1i + corei*term1core  
     &                      + dix*term2i - dir*term3i
     &                      - qixx*term4i + qix*term5i - qir*term6i
     &                      + (qiy*yr+qiz*zr)*rr7*dmpi(7)
                  tkxx = valk*term1k + corek*term1core
     &                      - dkx*term2k + dkr*term3k
     &                      - qkxx*term4k + qkx*term5k - qkr*term6k
     &                      + (qky*yr+qkz*zr)*rr7*dmpk(7)
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*yr*yr
                  term1core = rr3 - rr5*yr*yr
                  term2i = 2.0d0*rr5*dmpi(5)*yr
                  term3i = rr7*dmpi(7)*yr*yr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*yr
                  term6i = rr9*dmpi(9)*yr*yr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*yr*yr
                  term2k = 2.0d0*rr5*dmpk(5)*yr
                  term3k = rr7*dmpk(7)*yr*yr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*yr
                  term6k = rr9*dmpk(9)*yr*yr
                  tiyy = vali*term1i + corei*term1core
     &                      + diy*term2i - dir*term3i
     &                      - qiyy*term4i + qiy*term5i - qir*term6i
     &                      + (qix*xr+qiz*zr)*rr7*dmpi(7)
                  tkyy = valk*term1k + corek*term1core
     &                      - dky*term2k + dkr*term3k
     &                      - qkyy*term4k + qky*term5k - qkr*term6k
     &                      + (qkx*xr+qkz*zr)*rr7*dmpk(7)
                  term1i = rr3*dmpi(3) - rr5*dmpi(5)*zr*zr
                  term1core = rr3 - rr5*zr*zr
                  term2i = 2.0d0*rr5*dmpi(5)*zr
                  term3i = rr7*dmpi(7)*zr*zr - rr5*dmpi(5)
                  term4i = 2.0d0*rr5*dmpi(5)
                  term5i = 5.0d0*rr7*dmpi(7)*zr
                  term6i = rr9*dmpi(9)*zr*zr
                  term1k = rr3*dmpk(3) - rr5*dmpk(5)*zr*zr
                  term2k = 2.0d0*rr5*dmpk(5)*zr
                  term3k = rr7*dmpk(7)*zr*zr - rr5*dmpk(5)
                  term4k = 2.0d0*rr5*dmpk(5)
                  term5k = 5.0d0*rr7*dmpk(7)*zr
                  term6k = rr9*dmpk(9)*zr*zr
                  tizz = vali*term1i + corei*term1core
     &                      + diz*term2i - dir*term3i
     &                      - qizz*term4i + qiz*term5i - qir*term6i
     &                      + (qix*xr+qiy*yr)*rr7*dmpi(7)
                  tkzz = valk*term1k + corek*term1core
     &                      - dkz*term2k + dkr*term3k
     &                      - qkzz*term4k + qkz*term5k - qkr*term6k
     &                      + (qkx*xr+qky*yr)*rr7*dmpk(7)
                  term2i = rr5*dmpi(5)*xr 
                  term1i = yr * term2i
                  term1core = rr5*xr*yr
                  term3i = rr5*dmpi(5)*yr
                  term4i = yr * (rr7*dmpi(7)*xr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*xr
                  term7i = 2.0d0*rr7*dmpi(7)*yr
                  term8i = yr*rr9*dmpi(9)*xr
                  term2k = rr5*dmpk(5)*xr
                  term1k = yr * term2k
                  term3k = rr5*dmpk(5)*yr
                  term4k = yr * (rr7*dmpk(7)*xr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*xr
                  term7k = 2.0d0*rr7*dmpk(7)*yr
                  term8k = yr*rr9*dmpk(9)*xr
                  tixy = -vali*term1i - corei*term1core 
     &                      + diy*term2i + dix*term3i
     &                      - dir*term4i - qixy*term5i + qiy*term6i
     &                      + qix*term7i - qir*term8i
                  tkxy = -valk*term1k - corek*term1core 
     &                      - dky*term2k - dkx*term3k
     &                      + dkr*term4k - qkxy*term5k + qky*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5*dmpi(5)*xr
                  term1i = zr * term2i
                  term1core = rr5*xr*zr
                  term3i = rr5*dmpi(5)*zr
                  term4i = zr * (rr7*dmpi(7)*xr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*xr
                  term7i = 2.0d0*rr7*dmpi(7)*zr
                  term8i = zr*rr9*dmpi(9)*xr
                  term2k = rr5*dmpk(5)*xr
                  term1k = zr * term2k
                  term3k = rr5*dmpk(5)*zr
                  term4k = zr * (rr7*dmpk(7)*xr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*xr
                  term7k = 2.0d0*rr7*dmpk(7)*zr
                  term8k = zr*rr9*dmpk(9)*xr
                  tixz = -vali*term1i - corei*term1core
     &                      + diz*term2i + dix*term3i
     &                      - dir*term4i - qixz*term5i + qiz*term6i
     &                      + qix*term7i - qir*term8i
                  tkxz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dkx*term3k
     &                      + dkr*term4k - qkxz*term5k + qkz*term6k
     &                      + qkx*term7k - qkr*term8k
                  term2i = rr5*dmpi(5)*yr
                  term1i = zr * term2i
                  term1core = rr5*yr*zr
                  term3i = rr5*dmpi(5)*zr
                  term4i = zr * (rr7*dmpi(7)*yr)
                  term5i = 2.0d0*rr5*dmpi(5)
                  term6i = 2.0d0*rr7*dmpi(7)*yr
                  term7i = 2.0d0*rr7*dmpi(7)*zr
                  term8i = zr*rr9*dmpi(9)*yr
                  term2k = rr5*dmpk(5)*yr
                  term1k = zr * term2k
                  term3k = rr5*dmpk(5)*zr
                  term4k = zr * (rr7*dmpk(7)*yr)
                  term5k = 2.0d0*rr5*dmpk(5)
                  term6k = 2.0d0*rr7*dmpk(7)*yr
                  term7k = 2.0d0*rr7*dmpk(7)*zr
                  term8k = zr*rr9*dmpk(9)*yr
                  tiyz = -vali*term1i - corei*term1core
     &                      + diz*term2i + diy*term3i
     &                      - dir*term4i - qiyz*term5i + qiz*term6i
     &                      + qiy*term7i - qir*term8i
                  tkyz = -valk*term1k - corek*term1core
     &                      - dkz*term2k - dky*term3k
     &                      + dkr*term4k - qkyz*term5k + qkz*term6k
     &                      + qky*term7k - qkr*term8k
               end if
c
c     get the dEd/dR terms for Thole direct polarization force
c
               if (use_thole) then
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      - tkxx*uixp - tkxy*uiyp - tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      - tkxy*uixp - tkyy*uiyp - tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      - tkxz*uixp - tkyz*uiyp - tkzz*uizp
                  frcx = dscale(k) * depx
                  frcy = dscale(k) * depy
                  frcz = dscale(k) * depz
c
c     get the dEp/dR terms for Thole direct polarization force
c
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = frcx + pscale(k)*depx
                  frcy = frcy + pscale(k)*depy
                  frcz = frcz + pscale(k)*depz
c
c     get the dEp/dR terms for chgpen direct polarization force
c
               else if (use_chgpen) then
                  depx = tixx*ukx + tixy*uky + tixz*ukz
     &                      - tkxx*uix - tkxy*uiy - tkxz*uiz
                  depy = tixy*ukx + tiyy*uky + tiyz*ukz
     &                      - tkxy*uix - tkyy*uiy - tkyz*uiz
                  depz = tixz*ukx + tiyz*uky + tizz*ukz
     &                      - tkxz*uix - tkyz*uiy - tkzz*uiz
                  frcx = 2.0d0*dscale(k)*depx
                  frcy = 2.0d0*dscale(k)*depy
                  frcz = 2.0d0*dscale(k)*depz
               end if
c
c     reset Thole values if alternate direct damping was used
c
               if (use_tholed) then
                  sc3 = 1.0d0
                  sc5 = 1.0d0
                  do j = 1, 3
                     rc3(j) = 0.0d0
                     rc5(j) = 0.0d0
                  end do
                  damp = pdi * pdamp(k)
                  if (damp .ne. 0.0d0) then
                     pgamma = min(pti,thole(k))
                     damp = pgamma * (r/damp)**3
                     if (damp .lt. 50.0d0) then
                        expdamp = exp(-damp)
                        sc3 = 1.0d0 - expdamp
                        sc5 = 1.0d0 - expdamp*(1.0d0+damp)
                        temp3 = damp * expdamp * rr5
                        temp5 = 3.0d0 * damp / r2
                        rc3(1) = xr * temp3
                        rc3(2) = yr * temp3
                        rc3(3) = zr * temp3
                        rc5(1) = rc3(1) * temp5
                        rc5(2) = rc3(2) * temp5
                        rc5(3) = rc3(3) * temp5
                     end if
                  end if
               end if
c
c     get the dtau/dr terms used for mutual polarization force
c
               if (poltyp.eq.'MUTUAL' .and. use_thole) then
                  term1 = (sc3+sc5) * rr5
                  term2 = term1*xr - rc3(1)
                  term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr - rc3(2)
                  term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr - rc3(3)
                  term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = sc5 * rr5 * yr
                  term2 = sc3*rr5*xr - rc3(1)
                  term3 = yr * (sc5*rr7*xr-rc5(1))
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = sc5 * rr5 * zr
                  term3 = zr * (sc5*rr7*xr-rc5(1))
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = sc3*rr5*yr - rc3(2)
                  term3 = zr * (sc5*rr7*yr-rc5(2))
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + uscale(k)*depx
                  frcy = frcy + uscale(k)*depy
                  frcz = frcz + uscale(k)*depz
c
c     get the dtau/dr terms used for mutual polarization force
c
               else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then
                  term1 = 2.0d0 * dmpik(5) * rr5
                  term2 = term1*xr
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr 
                  tixx = uix*term2 + uir*term3
                  tkxx = ukx*term2 + ukr*term3
                  term2 = term1*yr 
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr 
                  tiyy = uiy*term2 + uir*term3
                  tkyy = uky*term2 + ukr*term3
                  term2 = term1*zr 
                  term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr 
                  tizz = uiz*term2 + uir*term3
                  tkzz = ukz*term2 + ukr*term3
                  term1 = rr5*dmpik(5)*yr
                  term2 = rr5*dmpik(5)*xr 
                  term3 = yr * (rr7*dmpik(7)*xr)
                  tixy = uix*term1 + uiy*term2 - uir*term3
                  tkxy = ukx*term1 + uky*term2 - ukr*term3
                  term1 = rr5 *dmpik(5) * zr
                  term3 = zr * (rr7*dmpik(7)*xr)
                  tixz = uix*term1 + uiz*term2 - uir*term3
                  tkxz = ukx*term1 + ukz*term2 - ukr*term3
                  term2 = rr5*dmpik(5)*yr 
                  term3 = zr * (rr7*dmpik(7)*yr)
                  tiyz = uiy*term1 + uiz*term2 - uir*term3
                  tkyz = uky*term1 + ukz*term2 - ukr*term3
                  depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                      + tkxx*uixp + tkxy*uiyp + tkxz*uizp
                  depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                      + tkxy*uixp + tkyy*uiyp + tkyz*uizp
                  depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                      + tkxz*uixp + tkyz*uiyp + tkzz*uizp
                  frcx = frcx + wscale(k)*depx
                  frcy = frcy + wscale(k)*depy
                  frcz = frcz + wscale(k)*depz
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_thole) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = (sc3+sc5) * rr5
                        term2 = term1*xr - rc3(1)
                        term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                        tixx = uopt(j,1,ii)*term2 + uirm*term3
                        tkxx = uopt(m,1,kk)*term2 + ukrm*term3
                        term2 = term1*yr - rc3(2)
                        term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                        tiyy = uopt(j,2,ii)*term2 + uirm*term3
                        tkyy = uopt(m,2,kk)*term2 + ukrm*term3
                        term2 = term1*zr - rc3(3)
                        term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                        tizz = uopt(j,3,ii)*term2 + uirm*term3
                        tkzz = uopt(m,3,kk)*term2 + ukrm*term3
                        term1 = sc5 * rr5 * yr
                        term2 = sc3*rr5*xr - rc3(1)
                        term3 = yr * (sc5*rr7*xr-rc5(1))
                        tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2
     &                            - uirm*term3
                        tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2
     &                            - ukrm*term3
                        term1 = sc5 * rr5 * zr
                        term3 = zr * (sc5*rr7*xr-rc5(1))
                        tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        term2 = sc3*rr5*yr - rc3(2)
                        term3 = zr * (sc5*rr7*yr-rc5(2))
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*uscale(k)*depx
                        frcy = frcy + copm(j+m+1)*uscale(k)*depy
                        frcz = frcz + copm(j+m+1)*uscale(k)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for OPT polarization force
c
               else if (poltyp.eq.'OPT' .and. use_chgpen) then
                  do j = 0, optorder-1
                     uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr
     &                          + uopt(j,3,i)*zr
                     do m = 0, optorder-j-1
                        ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr
     &                             + uopt(m,3,k)*zr
                        term1 = 2.0d0 * dmpik(5) * rr5
                        term2 = term1*xr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr
                        tixx = uopt(j,1,i)*term2 + uirm*term3
                        tkxx = uopt(m,1,k)*term2 + ukrm*term3
                        term2 = term1*yr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr
                        tiyy = uopt(j,2,i)*term2 + uirm*term3
                        tkyy = uopt(m,2,k)*term2 + ukrm*term3
                        term2 = term1*zr
                        term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr
                        tizz = uopt(j,3,i)*term2 + uirm*term3
                        tkzz = uopt(m,3,k)*term2 + ukrm*term3
                        term1 = rr5*dmpik(5)*yr
                        term2 = rr5*dmpik(5)*xr
                        term3 = yr * (rr7*dmpik(7)*xr)
                        tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2
     &                            - uirm*term3
                        tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2
     &                            - ukrm*term3
                        term1 = rr5 *dmpik(5) * zr
                        term3 = zr * (rr7*dmpik(7)*xr)
                        tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        term2 = rr5*dmpik(5)*yr
                        term3 = zr * (rr7*dmpik(7)*yr)
                        tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2
     &                            - uirm*term3
                        tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2
     &                            - ukrm*term3
                        depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i)
     &                       + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i)
     &                       + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i)
                        depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i)
     &                       + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i)
     &                       + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i)
                        depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i)
     &                       + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i)
     &                       + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i)
                        frcx = frcx + copm(j+m+1)*wscale(k)*depx
                        frcy = frcy + copm(j+m+1)*wscale(k)*depy
                        frcz = frcz + copm(j+m+1)*wscale(k)*depz
                     end do
                  end do
c
c     get the dtau/dr terms used for TCG polarization force
c
               else if (poltyp.eq.'TCG' .and. use_thole) then
                  do j = 1, tcgnab
                     ukx = ubd(1,k,j)
                     uky = ubd(2,k,j)
                     ukz = ubd(3,k,j)
                     ukxp = ubp(1,k,j)
                     ukyp = ubp(2,k,j)
                     ukzp = ubp(3,k,j)
                     uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = (sc3+sc5) * rr5
                     term2 = term1*xr - rc3(1)
                     term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                     tixx = uax(j)*term2 + uirt*term3
                     tkxx = ukx*term2 + ukrt*term3
                     term2 = term1*yr - rc3(2)
                     term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                     tiyy = uay(j)*term2 + uirt*term3
                     tkyy = uky*term2 + ukrt*term3
                     term2 = term1*zr - rc3(3)
                     term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                     tizz = uaz(j)*term2 + uirt*term3
                     tkzz = ukz*term2 + ukrt*term3
                     term1 = sc5 * rr5 * yr
                     term2 = sc3*rr5*xr - rc3(1)
                     term3 = yr * (sc5*rr7*xr-rc5(1))
                     tixy = uax(j)*term1 + uay(j)*term2 - uirt*term3
                     tkxy = ukx*term1 + uky*term2 - ukrt*term3
                     term1 = sc5 * rr5 * zr
                     term3 = zr * (sc5*rr7*xr-rc5(1))
                     tixz = uax(j)*term1 + uaz(j)*term2 - uirt*term3
                     tkxz = ukx*term1 + ukz*term2 - ukrt*term3
                     term2 = sc3*rr5*yr - rc3(2)
                     term3 = zr * (sc5*rr7*yr-rc5(2))
                     tiyz = uay(j)*term1 + uaz(j)*term2 - uirt*term3
                     tkyz = uky*term1 + ukz*term2 - ukrt*term3
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*uaxp(j) + tkxy*uayp(j)
     &                         + tkxz*uazp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*uaxp(j) + tkyy*uayp(j)
     &                         + tkyz*uazp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*uaxp(j) + tkyz*uayp(j)
     &                         + tkzz*uazp(j)
                     frcx = frcx + uscale(k)*depx
                     frcy = frcy + uscale(k)*depy
                     frcz = frcz + uscale(k)*depz
                     ukx = uad(1,k,j)
                     uky = uad(2,k,j)
                     ukz = uad(3,k,j)
                     ukxp = uap(1,k,j)
                     ukyp = uap(2,k,j)
                     ukzp = uap(3,k,j)
                     uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr
                     ukrt = ukx*xr + uky*yr + ukz*zr
                     term1 = (sc3+sc5) * rr5
                     term2 = term1*xr - rc3(1)
                     term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr
                     tixx = ubx(j)*term2 + uirt*term3
                     tkxx = ukx*term2 + ukrt*term3
                     term2 = term1*yr - rc3(2)
                     term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr
                     tiyy = uby(j)*term2 + uirt*term3
                     tkyy = uky*term2 + ukrt*term3
                     term2 = term1*zr - rc3(3)
                     term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr
                     tizz = ubz(j)*term2 + uirt*term3
                     tkzz = ukz*term2 + ukrt*term3
                     term1 = sc5 * rr5 * yr
                     term2 = sc3*rr5*xr - rc3(1)
                     term3 = yr * (sc5*rr7*xr-rc5(1))
                     tixy = ubx(j)*term1 + uby(j)*term2 - uirt*term3
                     tkxy = ukx*term1 + uky*term2 - ukrt*term3
                     term1 = sc5 * rr5 * zr
                     term3 = zr * (sc5*rr7*xr-rc5(1))
                     tixz = ubx(j)*term1 + ubz(j)*term2 - uirt*term3
                     tkxz = ukx*term1 + ukz*term2 - ukrt*term3
                     term2 = sc3*rr5*yr - rc3(2)
                     term3 = zr * (sc5*rr7*yr-rc5(2))
                     tiyz = uby(j)*term1 + ubz(j)*term2 - uirt*term3
                     tkyz = uky*term1 + ukz*term2 - ukrt*term3
                     depx = tixx*ukxp + tixy*ukyp + tixz*ukzp
     &                         + tkxx*ubxp(j) + tkxy*ubyp(j)
     &                         + tkxz*ubzp(j)
                     depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp
     &                         + tkxy*ubxp(j) + tkyy*ubyp(j)
     &                         + tkyz*ubzp(j)
                     depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp
     &                         + tkxz*ubxp(j) + tkyz*ubyp(j)
     &                         + tkzz*ubzp(j)
                     frcx = frcx + uscale(k)*depx
                     frcy = frcy + uscale(k)*depy
                     frcz = frcz + uscale(k)*depz
                  end do
               end if
c
c     force and torque components scaled for self-interactions
c
               if (i .eq. k) then
                  frcx = 0.5d0 * frcx
                  frcy = 0.5d0 * frcy
                  frcz = 0.5d0 * frcz
                  psr3 = 0.5d0 * psr3
                  psr5 = 0.5d0 * psr5
                  psr7 = 0.5d0 * psr7
                  dsr3 = 0.5d0 * dsr3
                  dsr5 = 0.5d0 * dsr5
                  dsr7 = 0.5d0 * dsr7
               end if
c
c     increment force-based gradient on the interaction sites
c
               dep(1,i) = dep(1,i) + frcx
               dep(2,i) = dep(2,i) + frcy
               dep(3,i) = dep(3,i) + frcz
               dep(1,k) = dep(1,k) - frcx
               dep(2,k) = dep(2,k) - frcy
               dep(3,k) = dep(3,k) - frcz
            end if
            end do
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
               uscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
      end if
c
c     torque is induced field and gradient cross permanent moments
c
      do ii = 1, npole
         i = ipole(ii)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         tep(1) = diz*ufld(2,i) - diy*ufld(3,i)
     &               + qixz*dufld(2,i) - qixy*dufld(4,i)
     &               + 2.0d0*qiyz*(dufld(3,i)-dufld(6,i))
     &               + (qizz-qiyy)*dufld(5,i)
         tep(2) = dix*ufld(3,i) - diz*ufld(1,i)
     &               - qiyz*dufld(2,i) + qixy*dufld(5,i)
     &               + 2.0d0*qixz*(dufld(6,i)-dufld(1,i))
     &               + (qixx-qizz)*dufld(4,i)
         tep(3) = diy*ufld(1,i) - dix*ufld(2,i)
     &               + qiyz*dufld(4,i) - qixz*dufld(5,i)
     &               + 2.0d0*qixy*(dufld(1,i)-dufld(3,i))
     &               + (qiyy-qixx)*dufld(2,i)
         call torque (ii,tep,fix,fiy,fiz,dep)
      end do
c
c     modify the gradient components for charge flux
c
      if (use_chgflx) then
         call dcflux (pot,decfx,decfy,decfz)
         do ii = 1, npole
            i = ipole(ii)
            frcx = decfx(i)
            frcy = decfy(i)
            frcz = decfz(i)
            dep(1,i) = dep(1,i) + frcx
            dep(2,i) = dep(2,i) + frcy
            dep(3,i) = dep(3,i) + frcz
         end do
      end if
c
c     modify the gradient components for exchange polarization
c
      if (use_expol) then
         call dexpol
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      deallocate (dscale)
      deallocate (uscale)
      deallocate (wscale)
      deallocate (ufld)
      deallocate (dufld)
      deallocate (pot)
      deallocate (decfx)
      deallocate (decfy)
      deallocate (decfz)
      return
      end
c
c
c     ##################################################
c     ##  COPYRIGHT (C) 2015  by  Jay William Ponder  ##
c     ##              All Rights Reserved             ##
c     ##################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine epolar3  --  induced dipole energy & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "epolar3" calculates the induced dipole polarization energy,
c     and partitions the energy among atoms
c
c
      subroutine epolar3
      use limits
      implicit none
      logical pairwise
c
c
c     choose the method to sum over polarization interactions
c
      pairwise = .true.
      if (pairwise) then
         if (use_ewald) then
            if (use_mlist) then
               call epolar3d
            else
               call epolar3c
            end if
         else
            if (use_mlist) then
               call epolar3b
            else
               call epolar3a
            end if
         end if
      else
         call epolar3e
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine epolar3a  --  double loop polarization analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "epolar3a" calculates the induced dipole polarization energy
c     using a double loop, and partitions the energy among atoms
c
c
      subroutine epolar3a
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use energi
      use extfld
      use inform
      use inter
      use iounit
      use mplpot
      use molcul
      use mpole
      use polar
      use polgrp
      use polpot
      use potent
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk,jcell
      real*8 e,f,scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr3,rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 dir,diu,qiu,uir
      real*8 dkr,dku,qku,ukr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 dmpi(7),dmpk(7)
      real*8 dmpik(7)
      real*8, allocatable :: pscale(:)
      logical header,huge
      character*6 mode
c
c
c     zero out the total polarization energy and partitioning
c
      nep = 0
      ep = 0.0d0
      do i = 1, n
         aep(i) = 0.0d0
      end do
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. npole.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Dipole Polarization Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     compute the dipole polarization energy component
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               diu = dix*ukx + diy*uky + diz*ukz
               qiu = qix*ukx + qiy*uky + qiz*ukz
               uir = uix*xr + uiy*yr + uiz*zr
               dku = dkx*uix + dky*uiy + dkz*uiz
               qku = qkx*uix + qky*uiy + qkz*uiz
               ukr = ukx*xr + uky*yr + ukz*zr
c
c     find the energy value for Thole polarization damping
c
               if (use_thole) then
                  call damptholed (i,k,7,r,dmpik)
                  scalek = pscale(k)
                  rr3 = f * scalek / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3 = dmpik(3) * rr3
                  rr5 = dmpik(5) * rr5
                  rr7 = dmpik(7) * rr7
                  term1 = ck*uir - ci*ukr + diu + dku
                  term2 = 2.0d0*(qiu-qku) - uir*dkr - dir*ukr
                  term3 = uir*qkr - ukr*qir
                  e = term1*rr3 + term2*rr5 + term3*rr7
c
c     find the energy value for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampdir (r,alphai,alphak,dmpi,dmpk)
                  scalek = pscale(k)
                  rr3 = f * scalek / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpi(3) * rr3
                  rr5i = dmpi(5) * rr5
                  rr7i = dmpi(7) * rr7
                  rr3k = dmpk(3) * rr3
                  rr5k = dmpk(5) * rr5
                  rr7k = dmpk(7) * rr7
                  e = uir*(corek*rr3+valk*rr3k)
     &                   - ukr*(corei*rr3+vali*rr3i)
     &                   + diu*rr3i + dku*rr3k
     &                   + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                   - dkr*uir*rr5k - dir*ukr*rr5i
     &                   + qkr*uir*rr7k - qir*ukr*rr7i
               end if
c
c     increment the overall polarization energy components
c
               if (e .ne. 0.0d0) then
                  ep = ep + e
                  nep = nep + 1
                  aep(i) = aep(i) + 0.5d0*e
                  aep(k) = aep(k) + 0.5d0*e
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
               end if
c
c     print a message if the energy of this interaction is large
c
               huge = (abs(e) .gt. 10.0d0)
               if ((debug.and.e.ne.0.0d0)
     &               .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual Polarization',
     &                          ' Interactions :',
     &                       //,' Type',14x,'Atom Names',
     &                          15x,'Distance',8x,'Energy',/)
                  end if
                  write (iout,30)  i,name(i),k,name(k),r,e
   30             format (' Polar',5x,2(i7,'-',a3),9x,
     &                       f10.4,2x,f12.4)
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ci = rpole(1,i)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            qixx = rpole(5,i)
            qixy = rpole(6,i)
            qixz = rpole(7,i)
            qiyy = rpole(9,i)
            qiyz = rpole(10,i)
            qizz = rpole(13,i)
            uix = uind(1,i)
            uiy = uind(2,i)
            uiz = uind(3,i)
            if (use_chgpen) then
               corei = pcore(i)
               vali = pval(i)
               alphai = palpha(i)
            end if
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               do jcell = 2, ncell
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (.not. (use_polymer .and. r2.le.polycut2)) then
                     pscale(k) = 1.0d0
                  end if
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     ck = rpole(1,k)
                     dkx = rpole(2,k)
                     dky = rpole(3,k)
                     dkz = rpole(4,k)
                     qkxx = rpole(5,k)
                     qkxy = rpole(6,k)
                     qkxz = rpole(7,k)
                     qkyy = rpole(9,k)
                     qkyz = rpole(10,k)
                     qkzz = rpole(13,k)
                     ukx = uind(1,k)
                     uky = uind(2,k)
                     ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
                     dir = dix*xr + diy*yr + diz*zr
                     qix = qixx*xr + qixy*yr + qixz*zr
                     qiy = qixy*xr + qiyy*yr + qiyz*zr
                     qiz = qixz*xr + qiyz*yr + qizz*zr
                     qir = qix*xr + qiy*yr + qiz*zr
                     dkr = dkx*xr + dky*yr + dkz*zr
                     qkx = qkxx*xr + qkxy*yr + qkxz*zr
                     qky = qkxy*xr + qkyy*yr + qkyz*zr
                     qkz = qkxz*xr + qkyz*yr + qkzz*zr
                     qkr = qkx*xr + qky*yr + qkz*zr
                     diu = dix*ukx + diy*uky + diz*ukz
                     qiu = qix*ukx + qiy*uky + qiz*ukz
                     uir = uix*xr + uiy*yr + uiz*zr
                     dku = dkx*uix + dky*uiy + dkz*uiz
                     qku = qkx*uix + qky*uiy + qkz*uiz
                     ukr = ukx*xr + uky*yr + ukz*zr
c
c     find the energy value for Thole polarization damping
c
                     if (use_thole) then
                        call damptholed (i,k,7,r,dmpik)
                        scalek = pscale(k)
                        rr3 = f * scalek / (r*r2)
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr3 = dmpik(3) * rr3
                        rr5 = dmpik(5) * rr5
                        rr7 = dmpik(7) * rr7
                        term1 = ck*uir - ci*ukr + diu + dku
                        term2 = 2.0d0*(qiu-qku) - uir*dkr - dir*ukr
                        term3 = uir*qkr - ukr*qir
                        e = term1*rr3 + term2*rr5 + term3*rr7
c
c     find the energy value for charge penetration damping
c
                     else if (use_chgpen) then
                        corek = pcore(k)
                        valk = pval(k)
                        alphak = palpha(k)
                        call dampdir (r,alphai,alphak,dmpi,dmpk)
                        scalek = pscale(k)
                        rr3 = f * scalek / (r*r2)
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr3i = dmpi(3) * rr3
                        rr5i = dmpi(5) * rr5
                        rr7i = dmpi(7) * rr7
                        rr3k = dmpk(3) * rr3
                        rr5k = dmpk(5) * rr5
                        rr7k = dmpk(7) * rr7
                        e = uir*(corek*rr3+valk*rr3k)
     &                         - ukr*(corei*rr3+vali*rr3i)
     &                         + diu*rr3i + dku*rr3k
     &                         + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                         - dkr*uir*rr5k - dir*ukr*rr5i
     &                         + qkr*uir*rr7k - qir*ukr*rr7i
                     end if
c
c     increment the overall polarization energy components
c
                     if (i .eq. k)  e = 0.5d0 * e
                     if (e .ne. 0.0d0) then
                        ep = ep + e
                        nep = nep + 1
                        aep(i) = aep(i) + 0.5d0*e
                        aep(k) = aep(k) + 0.5d0*e
                        einter = einter + e
                     end if
c
c     print a message if the energy of this interaction is large
c
                     huge = (abs(e) .gt. 10.0d0)
                     if ((debug.and.e.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual Polarization',
     &                                ' Interactions :',
     &                             //,' Type',14x,'Atom Names',
     &                                15x,'Distance',8x,'Energy',/)
                        end if
                        write (iout,50)  i,name(i),k,name(k),r,e
   50                   format (' Polar',5x,2(i7,'-',a3),9x,
     &                             f10.4,2x,f12.4)
                     end if
                  end if
               end do
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     increment polarization energy due to external field
c
      if (use_exfld) then
         do i = 1, npole
            e = 0.0d0
            do j = 1, 3
               e = e - f*uind(j,i)*exfld(j)
            end do
            ep = ep + e
            nep = nep + 1
            aep(i) = aep(i) + e
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine epolar3b  --  polarization analysis via list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "epolar3b" calculates the induced dipole polarization energy
c     using a neighbor list, and partitions the energy among atoms
c
c
      subroutine epolar3b
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use chgpen
      use chgpot
      use couple
      use energi
      use extfld
      use inform
      use inter
      use iounit
      use molcul
      use mplpot
      use mpole
      use neigh
      use polar
      use polgrp
      use polpot
      use potent
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      real*8 e,f,scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr3,rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 dir,diu,qiu,uir
      real*8 dkr,dku,qku,ukr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 dmpi(7),dmpk(7)
      real*8 dmpik(7)
      real*8, allocatable :: pscale(:)
      logical header,huge
      character*6 mode
c
c
c     zero out the total polarization energy and partitioning
c
      nep = 0
      ep = 0.0d0
      do i = 1, n
         aep(i) = 0.0d0
      end do
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. npole.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Dipole Polarization Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,rpole,x,y,z,pcore,pval,palpha,uind,n12,i12,
!$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14,
!$OMP& p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale,
!$OMP& p5iscale,nelst,elst,use_thole,use_chgpen,use_bounds,off2,f,
!$OMP& exfld,use_exfld,molcule,name,verbose,debug,header,iout)
!$OMP& firstprivate(pscale) shared (ep,nep,aep,einter)
!$OMP DO reduction(+:ep,nep,aep,einter)
c
c     compute the dipole polarization energy component
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               diu = dix*ukx + diy*uky + diz*ukz
               qiu = qix*ukx + qiy*uky + qiz*ukz
               uir = uix*xr + uiy*yr + uiz*zr
               dku = dkx*uix + dky*uiy + dkz*uiz
               qku = qkx*uix + qky*uiy + qkz*uiz
               ukr = ukx*xr + uky*yr + ukz*zr
c
c     find the energy value for Thole polarization damping
c
               if (use_thole) then
                  call damptholed (i,k,7,r,dmpik)
                  scalek = pscale(k)
                  rr3 = f * scalek / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3 = dmpik(3) * rr3
                  rr5 = dmpik(5) * rr5
                  rr7 = dmpik(7) * rr7
                  term1 = ck*uir - ci*ukr + diu + dku
                  term2 = 2.0d0*(qiu-qku) - uir*dkr - dir*ukr
                  term3 = uir*qkr - ukr*qir
                  e = term1*rr3 + term2*rr5 + term3*rr7
c
c     find the energy value for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampdir (r,alphai,alphak,dmpi,dmpk)
                  scalek = pscale(k)
                  rr3 = f * scalek / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpi(3) * rr3
                  rr5i = dmpi(5) * rr5
                  rr7i = dmpi(7) * rr7
                  rr3k = dmpk(3) * rr3
                  rr5k = dmpk(5) * rr5
                  rr7k = dmpk(7) * rr7
                  e = uir*(corek*rr3+valk*rr3k)
     &                   - ukr*(corei*rr3+vali*rr3i)
     &                   + diu*rr3i + dku*rr3k
     &                   + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                   - dkr*uir*rr5k - dir*ukr*rr5i
     &                   + qkr*uir*rr7k - qir*ukr*rr7i
               end if
c
c     increment the overall polarization energy components
c
               if (e .ne. 0.0d0) then
                  ep = ep + e
                  nep = nep + 1
                  aep(i) = aep(i) + 0.5d0*e
                  aep(k) = aep(k) + 0.5d0*e
                  if (molcule(i) .ne. molcule(k))
     &               einter = einter + e
               end if
c
c     print a message if the energy of this interaction is large
c
               huge = (abs(e) .gt. 10.0d0)
               if ((debug.and.e.ne.0.0d0)
     &               .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual Dipole Polarization',
     &                          ' Interactions :',
     &                       //,' Type',14x,'Atom Names',
     &                          15x,'Distance',8x,'Energy',/)
                  end if
                  write (iout,30)  i,name(i),k,name(k),r,e
   30             format (' Polar',5x,2(i7,'-',a3),9x,
     &                       f10.4,2x,f12.4)
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
c
c     increment polarization energy due to external field
c
      if (use_exfld) then
!$OMP    DO reduction(+:ep,nep,aep)
         do i = 1, npole
            e = 0.0d0
            do j = 1, 3
               e = e - f*uind(j,i)*exfld(j)
            end do
            ep = ep + e
            nep = nep + 1
            aep(i) = aep(i) + e
         end do
!$OMP    END DO
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine epolar3c  --  Ewald polarization analysis; loop  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "epolar3c" calculates the polarization energy and analysis with
c     respect to Cartesian coordinates using particle mesh Ewald and
c     a double loop
c
c
      subroutine epolar3c
      use action
      use analyz
      use atoms
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use mpole
      use pme
      use polar
      use polpot
      use potent
      implicit none
      integer i,ii
      real*8 e,f
      real*8 term,fterm
      real*8 dix,diy,diz
      real*8 uix,uiy,uiz,uii
      real*8 xd,yd,zd
      real*8 xu,yu,zu
c
c
c     zero out the dipole polarization energy and components
c
      nep = 0
      ep = 0.0d0
      do i = 1, n
         aep(i) = 0.0d0
      end do
      if (npole .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bsporder
      aewald = apewald
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     compute the real space part of the Ewald summation
c
      call epreal3c
c
c     compute the reciprocal space part of the Ewald summation
c
      call eprecip3
c
c     compute the Ewald self-energy term over all the atoms
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / rootpi
      do ii = 1, npole
         i = ipole(ii)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         uii = dix*uix + diy*uiy + diz*uiz
         e = fterm * term * uii / 3.0d0
         ep = ep + e
         nep = nep + 1
         aep(i) = aep(i) + e
      end do
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         xu = 0.0d0
         yu = 0.0d0
         zu = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            xd = xd + rpole(2,i) + rpole(1,i)*x(i)
            yd = yd + rpole(3,i) + rpole(1,i)*y(i)
            zd = zd + rpole(4,i) + rpole(1,i)*z(i)
            xu = xu + uind(1,i)
            yu = yu + uind(2,i)
            zu = zu + uind(3,i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         ep = ep + term*(xd*xu+yd*yu+zd*zu)
         nep = nep + 1
         do ii = 1, npole
            i = ipole(ii)
            aep(i) = aep(i) + e/dble(npole)
         end do
      end if
      return
      end
c
c
c     ###################################################################
c     ##                                                               ##
c     ##  subroutine epreal3c  --  real space polar analysis via loop  ##
c     ##                                                               ##
c     ###################################################################
c
c
c     "epreal3c" calculates the induced dipole polarization energy and
c     analysis using particle mesh Ewald summation and a double loop
c
c
      subroutine epreal3c
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use cell
      use chgpen
      use chgpot
      use couple
      use energi
      use extfld
      use inform
      use inter
      use iounit
      use math
      use molcul
      use mplpot
      use mpole
      use polar
      use polgrp
      use polpot
      use potent
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk,jcell
      real*8 e,efull
      real*8 f,scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 sr3,sr5,sr7
      real*8 r,r2,rr3,rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 dir,diu,qiu,uir
      real*8 dkr,dku,qku,ukr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 dmpi(7),dmpk(7)
      real*8 dmpik(7),dmpe(7)
      real*8, allocatable :: pscale(:)
      logical header,huge
      character*6 mode
c
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. npole.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Dipole Polarization Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     compute the dipole polarization energy component
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               diu = dix*ukx + diy*uky + diz*ukz
               qiu = qix*ukx + qiy*uky + qiz*ukz
               uir = uix*xr + uiy*yr + uiz*zr
               dku = dkx*uix + dky*uiy + dkz*uiz
               qku = qkx*uix + qky*uiy + qkz*uiz
               ukr = ukx*xr + uky*yr + ukz*zr
c
c     calculate real space Ewald error function damping
c
               call dampewald (7,r,r2,f,dmpe)
c
c     find the energy value for Thole polarization damping
c
               if (use_thole) then
                  call damptholed (i,k,7,r,dmpik)
                  scalek = pscale(k)
                  rr3 = f / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  sr3 = scalek * dmpik(3) * rr3
                  sr5 = scalek * dmpik(5) * rr5
                  sr7 = scalek * dmpik(7) * rr7
                  term1 = ck*uir - ci*ukr + diu + dku
                  term2 = 2.0d0*(qiu-qku) - uir*dkr - dir*ukr
                  term3 = uir*qkr - ukr*qir
                  efull = term1*sr3 + term2*sr5 + term3*sr7
                  sr3 = dmpe(3) - rr3 + sr3
                  sr5 = dmpe(5) - rr5 + sr5
                  sr7 = dmpe(7) - rr7 + sr7
                  e = term1*sr3 + term2*sr5 + term3*sr7
c
c     find the energy value for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampdir (r,alphai,alphak,dmpi,dmpk)
                  scalek = pscale(k)
                  rr3 = f * scalek / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpi(3) * rr3
                  rr5i = dmpi(5) * rr5
                  rr7i = dmpi(7) * rr7
                  rr3k = dmpk(3) * rr3
                  rr5k = dmpk(5) * rr5
                  rr7k = dmpk(7) * rr7
                  efull = uir*(corek*rr3+valk*rr3k)
     &                       - ukr*(corei*rr3+vali*rr3i)
     &                       + diu*rr3i + dku*rr3k
     &                       + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                       - dkr*uir*rr5k - dir*ukr*rr5i
     &                       + qkr*uir*rr7k - qir*ukr*rr7i
                  rr3 = f / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpe(3) - rr3 + rr3i
                  rr5i = dmpe(5) - rr5 + rr5i
                  rr7i = dmpe(7) - rr7 + rr7i
                  rr3k = dmpe(3) - rr3 + rr3k
                  rr5k = dmpe(5) - rr5 + rr5k
                  rr7k = dmpe(7) - rr7 + rr7k
                  rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                  e = uir*(corek*rr3+valk*rr3k)
     &                   - ukr*(corei*rr3+vali*rr3i)
     &                   + diu*rr3i + dku*rr3k
     &                   + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                   - dkr*uir*rr5k - dir*ukr*rr5i
     &                   + qkr*uir*rr7k - qir*ukr*rr7i
               end if
c
c     compute the energy contribution for this interaction
c
               ep = ep + e
               aep(i) = aep(i) + 0.5d0*e
               aep(k) = aep(k) + 0.5d0*e
               if (efull .ne. 0.0d0) then
                  nep = nep + 1
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + efull
                  end if
               end if
c
c     print message if the energy of this interaction is large
c
               huge = (abs(efull) .gt. 10.0d0)
               if ((debug.and.efull.ne.0.0d0)
     &               .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual Dipole Polarization',
     &                          ' Interactions :',
     &                       //,' Type',14x,'Atom Names',
     &                          15x,'Distance',8x,'Energy',/)
                  end if
                  write (iout,30)  i,name(i),k,name(k),r,efull
   30             format (' Polar',5x,2(i7,'-',a3),9x,
     &                       f10.4,2x,f12.4)
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction with other unit cells
c
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ci = rpole(1,i)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            qixx = rpole(5,i)
            qixy = rpole(6,i)
            qixz = rpole(7,i)
            qiyy = rpole(9,i)
            qiyz = rpole(10,i)
            qizz = rpole(13,i)
            uix = uind(1,i)
            uiy = uind(2,i)
            uiz = uind(3,i)
            if (use_chgpen) then
               corei = pcore(i)
               vali = pval(i)
               alphai = palpha(i)
            end if
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = i, npole
               k = ipole(kk)
               do jcell = 2, ncell
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  call imager (xr,yr,zr,jcell)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (.not. (use_polymer .and. r2.le.polycut2)) then
                     pscale(k) = 1.0d0
                  end if
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     ck = rpole(1,k)
                     dkx = rpole(2,k)
                     dky = rpole(3,k)
                     dkz = rpole(4,k)
                     qkxx = rpole(5,k)
                     qkxy = rpole(6,k)
                     qkxz = rpole(7,k)
                     qkyy = rpole(9,k)
                     qkyz = rpole(10,k)
                     qkzz = rpole(13,k)
                     ukx = uind(1,k)
                     uky = uind(2,k)
                     ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
                     dir = dix*xr + diy*yr + diz*zr
                     qix = qixx*xr + qixy*yr + qixz*zr
                     qiy = qixy*xr + qiyy*yr + qiyz*zr
                     qiz = qixz*xr + qiyz*yr + qizz*zr
                     qir = qix*xr + qiy*yr + qiz*zr
                     dkr = dkx*xr + dky*yr + dkz*zr
                     qkx = qkxx*xr + qkxy*yr + qkxz*zr
                     qky = qkxy*xr + qkyy*yr + qkyz*zr
                     qkz = qkxz*xr + qkyz*yr + qkzz*zr
                     qkr = qkx*xr + qky*yr + qkz*zr
                     diu = dix*ukx + diy*uky + diz*ukz
                     qiu = qix*ukx + qiy*uky + qiz*ukz
                     uir = uix*xr + uiy*yr + uiz*zr
                     dku = dkx*uix + dky*uiy + dkz*uiz
                     qku = qkx*uix + qky*uiy + qkz*uiz
                     ukr = ukx*xr + uky*yr + ukz*zr
c
c     calculate real space Ewald error function damping
c
                     call dampewald (7,r,r2,f,dmpe)
c
c     find the energy value for Thole polarization damping
c
                     if (use_thole) then
                        call damptholed (i,k,7,r,dmpik)
                        scalek = pscale(k)
                        rr3 = f / (r*r2)
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        sr3 = scalek * dmpik(3) * rr3
                        sr5 = scalek * dmpik(5) * rr5
                        sr7 = scalek * dmpik(7) * rr7
                        term1 = ck*uir - ci*ukr + diu + dku
                        term2 = 2.0d0*(qiu-qku) - uir*dkr - dir*ukr
                        term3 = uir*qkr - ukr*qir
                        efull = term1*sr3 + term2*sr5 + term3*sr7
                        sr3 = dmpe(3) - rr3 + sr3
                        sr5 = dmpe(5) - rr5 + sr5
                        sr7 = dmpe(7) - rr7 + sr7
                        e = term1*sr3 + term2*sr5 + term3*sr7
c
c     find the energy value for charge penetration damping
c
                     else if (use_chgpen) then
                        corek = pcore(k)
                        valk = pval(k)
                        alphak = palpha(k)
                        call dampdir (r,alphai,alphak,dmpi,dmpk)
                        scalek = pscale(k)
                        rr3 = f * scalek / (r*r2)
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr3i = dmpi(3) * rr3
                        rr5i = dmpi(5) * rr5
                        rr7i = dmpi(7) * rr7
                        rr3k = dmpk(3) * rr3
                        rr5k = dmpk(5) * rr5
                        rr7k = dmpk(7) * rr7
                        efull = uir*(corek*rr3+valk*rr3k)
     &                             - ukr*(corei*rr3+vali*rr3i)
     &                             + diu*rr3i + dku*rr3k
     &                             + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                             - dkr*uir*rr5k - dir*ukr*rr5i
     &                             + qkr*uir*rr7k - qir*ukr*rr7i
                        rr3 = f / (r*r2)
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr3i = dmpe(3) - rr3 + rr3i
                        rr5i = dmpe(5) - rr5 + rr5i
                        rr7i = dmpe(7) - rr7 + rr7i
                        rr3k = dmpe(3) - rr3 + rr3k
                        rr5k = dmpe(5) - rr5 + rr5k
                        rr7k = dmpe(7) - rr7 + rr7k
                        rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                        e = uir*(corek*rr3+valk*rr3k)
     &                         - ukr*(corei*rr3+vali*rr3i)
     &                         + diu*rr3i + dku*rr3k
     &                         + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                         - dkr*uir*rr5k - dir*ukr*rr5i
     &                         + qkr*uir*rr7k - qir*ukr*rr7i
                     end if
c
c     compute the energy contribution for this interaction
c
                     if (i .eq. k) then
                        e = 0.5d0 * e
                        efull = 0.5d0 * efull
                     end if
                     ep = ep + e
                     aep(i) = aep(i) + 0.5d0*e
                     aep(k) = aep(k) + 0.5d0*e
                     if (efull .ne. 0.0d0) then
                        nep = nep + 1
                        if (molcule(i) .ne. molcule(k)) then
                           einter = einter + efull
                        end if
                     end if
c
c     print message if the energy of this interaction is large
c
                     huge = (abs(efull) .gt. 10.0d0)
                     if ((debug.and.efull.ne.0.0d0)
     &                     .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,40)
   40                      format (/,' Individual Dipole Polarization',
     &                                ' Interactions :',
     &                             //,' Type',14x,'Atom Names',
     &                                15x,'Distance',8x,'Energy',/)
                        end if
                        write (iout,50)  i,name(i),k,name(k),r,efull
   50                   format (' Polar',5x,2(i7,'-',a3),9x,
     &                             f10.4,2x,f12.4)
                     end if
                  end if
               end do
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     increment polarization energy due to external field
c
      if (use_exfld) then
         do i = 1, npole
            e = 0.0d0
            do j = 1, 3
               e = e - f*uind(j,i)*exfld(j)
            end do
            ep = ep + e
            nep = nep + 1
            aep(i) = aep(i) + e
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine epolar3d  --  Ewald polarization analysis; list  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "epolar3d" calculates the polarization energy and analysis with
c     respect to Cartesian coordinates using particle mesh Ewald and
c     a neighbor list
c
c
      subroutine epolar3d
      use action
      use analyz
      use atoms
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use mpole
      use pme
      use polar
      use polpot
      use potent
      implicit none
      integer i,ii
      real*8 e,f
      real*8 term,fterm
      real*8 dix,diy,diz
      real*8 uix,uiy,uiz,uii
      real*8 xd,yd,zd
      real*8 xu,yu,zu
c
c
c     zero out the dipole polarization energy and components
c
      nep = 0
      ep = 0.0d0
      do i = 1, n
         aep(i) = 0.0d0
      end do
      if (npole .eq. 0)  return
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bsporder
      aewald = apewald
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     compute the real space part of the Ewald summation
c
      call epreal3d
c
c     compute the reciprocal space part of the Ewald summation
c
      call eprecip3
c
c     compute the Ewald self-energy term over all the atoms
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / rootpi
      do ii = 1, npole
         i = ipole(ii)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         uii = dix*uix + diy*uiy + diz*uiz
         e = fterm * term * uii / 3.0d0
         ep = ep + e
         nep = nep + 1
         aep(i) = aep(i) + e
      end do
c
c     compute the cell dipole boundary correction term
c
      if (boundary .eq. 'VACUUM') then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         xu = 0.0d0
         yu = 0.0d0
         zu = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            xd = xd + rpole(2,i) + rpole(1,i)*x(i)
            yd = yd + rpole(3,i) + rpole(1,i)*y(i)
            zd = zd + rpole(4,i) + rpole(1,i)*z(i)
            xu = xu + uind(1,i)
            yu = yu + uind(2,i)
            zu = zu + uind(3,i)
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         ep = ep + term*(xd*xu+yd*yu+zd*zu)
         nep = nep + 1
         do ii = 1, npole
            i = ipole(ii)
            aep(i) = aep(i) + e/dble(npole)
         end do
      end if
      return
      end
c
c
c     ###################################################################
c     ##                                                               ##
c     ##  subroutine epreal3d  --  real space polar analysis via list  ##
c     ##                                                               ##
c     ###################################################################
c
c
c     "epreal3d" calculates the induced dipole polarization energy
c     and analysis using particle mesh Ewald and a neighbor list
c
c
      subroutine epreal3d
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use chgpen
      use chgpot
      use couple
      use energi
      use extfld
      use inform
      use inter
      use iounit
      use math
      use mplpot
      use molcul
      use mpole
      use neigh
      use polar
      use polgrp
      use polpot
      use potent
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      real*8 e,efull
      real*8 f,scalek
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 sr3,sr5,sr7
      real*8 r,r2,rr3,rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 uix,uiy,uiz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 ukx,uky,ukz
      real*8 dir,diu,qiu,uir
      real*8 dkr,dku,qku,ukr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 term1,term2,term3
      real*8 dmpi(7),dmpk(7)
      real*8 dmpik(7),dmpe(7)
      real*8, allocatable :: pscale(:)
      logical header,huge
      character*6 mode
c
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. npole.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Dipole Polarization Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     set conversion factor, cutoff and switching coefficients
c
      f = 0.5d0 * electric / dielec
      mode = 'EWALD'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,rpole,uind,x,y,z,pcore,pval,palpha,n12,i12,
!$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14,
!$OMP& p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale,
!$OMP& p5iscale,nelst,elst,use_thole,use_chgpen,use_bounds,off2,f,
!$OMP& exfld,use_exfld,molcule,name,verbose,debug,header,iout)
!$OMP& firstprivate(pscale) shared (ep,nep,aep,einter)
!$OMP DO reduction(+:ep,nep,aep,einter)
c
c     compute the dipole polarization energy component
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = ipole(kk)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
               diu = dix*ukx + diy*uky + diz*ukz
               qiu = qix*ukx + qiy*uky + qiz*ukz
               uir = uix*xr + uiy*yr + uiz*zr
               dku = dkx*uix + dky*uiy + dkz*uiz
               qku = qkx*uix + qky*uiy + qkz*uiz
               ukr = ukx*xr + uky*yr + ukz*zr
c
c     calculate real space Ewald error function damping
c
               call dampewald (7,r,r2,f,dmpe)
c
c     find the energy value for Thole polarization damping
c
               if (use_thole) then
                  call damptholed (i,k,7,r,dmpik)
                  scalek = pscale(k)
                  rr3 = f / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  sr3 = scalek * dmpik(3) * rr3
                  sr5 = scalek * dmpik(5) * rr5
                  sr7 = scalek * dmpik(7) * rr7
                  term1 = ck*uir - ci*ukr + diu + dku
                  term2 = 2.0d0*(qiu-qku) - uir*dkr - dir*ukr
                  term3 = uir*qkr - ukr*qir
                  efull = term1*sr3 + term2*sr5 + term3*sr7
                  sr3 = dmpe(3) - rr3 + sr3
                  sr5 = dmpe(5) - rr5 + sr5
                  sr7 = dmpe(7) - rr7 + sr7
                  e = term1*sr3 + term2*sr5 + term3*sr7
c
c     find the energy value for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampdir (r,alphai,alphak,dmpi,dmpk)
                  scalek = pscale(k)
                  rr3 = f * scalek / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpi(3) * rr3
                  rr5i = dmpi(5) * rr5
                  rr7i = dmpi(7) * rr7
                  rr3k = dmpk(3) * rr3
                  rr5k = dmpk(5) * rr5
                  rr7k = dmpk(7) * rr7
                  efull = uir*(corek*rr3+valk*rr3k)
     &                       - ukr*(corei*rr3+vali*rr3i)
     &                       + diu*rr3i + dku*rr3k
     &                       + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                       - dkr*uir*rr5k - dir*ukr*rr5i
     &                       + qkr*uir*rr7k - qir*ukr*rr7i
                  rr3 = f / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpe(3) - rr3 + rr3i
                  rr5i = dmpe(5) - rr5 + rr5i
                  rr7i = dmpe(7) - rr7 + rr7i
                  rr3k = dmpe(3) - rr3 + rr3k
                  rr5k = dmpe(5) - rr5 + rr5k
                  rr7k = dmpe(7) - rr7 + rr7k
                  rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                  e = uir*(corek*rr3+valk*rr3k)
     &                   - ukr*(corei*rr3+vali*rr3i)
     &                   + diu*rr3i + dku*rr3k
     &                   + 2.0d0*(qiu*rr5i-qku*rr5k)
     &                   - dkr*uir*rr5k - dir*ukr*rr5i
     &                   + qkr*uir*rr7k - qir*ukr*rr7i
               end if
c
c     compute the energy contribution for this interaction
c
               ep = ep + e
               aep(i) = aep(i) + 0.5d0*e
               aep(k) = aep(k) + 0.5d0*e
               if (efull .ne. 0.0d0) then
                  nep = nep + 1
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + efull
                  end if
               end if
c
c     print message if the energy of this interaction is large
c
               huge = (abs(efull) .gt. 10.0d0)
               if ((debug.and.efull.ne.0.0d0)
     &               .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual Dipole Polarization',
     &                          ' Interactions :',
     &                       //,' Type',14x,'Atom Names',
     &                          15x,'Distance',8x,'Energy',/)
                  end if
                  write (iout,30)  i,name(i),k,name(k),r,efull
   30             format (' Polar',5x,2(i7,'-',a3),9x,
     &                       f10.4,2x,f12.4)
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
c
c     increment polarization energy due to external field
c
      if (use_exfld) then
!$OMP    DO reduction(+:ep,nep,aep)
         do i = 1, npole
            e = 0.0d0
            do j = 1, 3
               e = e - f*uind(j,i)*exfld(j)
            end do
            ep = ep + e
            nep = nep + 1
            aep(i) = aep(i) + e
         end do
!$OMP    END DO
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine epolar3e  --  single-loop polarization analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "epreal3e" calculates the induced dipole polarization energy
c     and analysis from the induced dipoles times the electric field
c
c
      subroutine epolar3e
      use action
      use analyz
      use atoms
      use atomid
      use boxes
      use chgpot
      use energi
      use ewald
      use inform
      use iounit
      use limits
      use math
      use mpole
      use polar
      use polpot
      use potent
      use units
      implicit none
      integer i,j,ii
      real*8 e,f,fi,term
      real*8 xd,yd,zd
      real*8 xu,yu,zu
      real*8 dix,diy,diz
      real*8 uix,uiy,uiz
      logical header,huge
c
c
c     zero out the total polarization energy and partitioning
c
      nep = 0
      ep = 0.0d0
      do i = 1, n
         aep(i) = 0.0d0
      end do
      if (npole .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      if (.not. use_mpole)  call chkpole
c
c     rotate the multipole components into the global frame
c
      if (.not. use_mpole)  call rotpole ('MPOLE')
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Dipole Polarization Interactions :',
     &           //,' Type',9x,'Atom Name',24x,'Alpha',8x,'Energy',/)
      end if
c
c     set the energy unit conversion factor
c
      f = -0.5d0 * electric / dielec
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private (i,j,fi,e,ii,huge)
!$OMP DO reduction(+:ep,nep,aep)
c
c     get polarization energy via induced dipoles times field
c
      do ii = 1, npole
         i = ipole(ii)
         if (douind(i)) then
            fi = f / polarity(i)
            e = 0.0d0
            do j = 1, 3
               e = e + fi*uind(j,i)*udirp(j,i)
            end do
            nep = nep + 1
            ep = ep + e
            aep(i) = aep(i) + e
c
c     print a message if the energy for this site is large
c
            huge = (abs(e) .gt. 10.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Individual Dipole Polarization',
     &                       ' Interactions :',
     &                    //,' Type',9x,'Atom Name',24x,'Alpha',
     &                       8x,'Energy',/)
               end if
               write (iout,30)  i,name(i),polarity(i),e
   30          format (' Polar',5x,i7,'-',a3,16x,2f14.4)
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     compute the cell dipole boundary correction term
c
      if (use_ewald) then
         if (boundary .eq. 'VACUUM') then
            f = electric / dielec
            xd = 0.0d0
            yd = 0.0d0
            zd = 0.0d0
            xu = 0.0d0
            yu = 0.0d0
            zu = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               dix = rpole(2,i)
               diy = rpole(3,i)
               diz = rpole(4,i)
               uix = uind(1,i)
               uiy = uind(2,i)
               uiz = uind(3,i)
               xd = xd + dix + rpole(1,i)*x(i)
               yd = yd + diy + rpole(1,i)*y(i)
               zd = zd + diz + rpole(1,i)*z(i)
               xu = xu + uix
               yu = yu + uiy
               zu = zu + uiz
            end do
            term = (2.0d0/3.0d0) * f * (pi/volbox)
            e = term * (xd*xu+yd*yu+zd*zu)
            nep = nep + 1
            ep = ep + e
            do ii = 1, npole
               i = ipole(ii)
               aep(i) = aep(i) + e/dble(npole)
            end do
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eprecip3  --  PME recip polarization analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "eprecip3" evaluates the reciprocal space portion of particle
c     mesh Ewald summation energy due to dipole polarization, and
c     partitions the energy among the atoms
c
c     literature reference:
c
c     C. Sagui, L. G. Pedersen and T. A. Darden, "Towards an Accurate
c     Representation of Electrostatics in Classical Force Fields:
c     Efficient Implementation of Multipolar Interactions in
c     Biomolecular Simulations", Journal of Chemical Physics, 120,
c     73-87 (2004)
c
c     modifications for nonperiodic systems suggested by Tom Darden
c     during May 2007
c
c
      subroutine eprecip3
      use analyz
      use atoms
      use bound
      use boxes
      use chgpot
      use energi
      use ewald
      use math
      use mpole
      use mrecip
      use pme
      use polar
      use polpot
      use potent
      implicit none
      integer i,j,ii
      integer k1,k2,k3
      integer m1,m2,m3
      integer ntot,nff
      integer nf1,nf2,nf3
      real*8 e,r1,r2,r3
      real*8 f,h1,h2,h3
      real*8 volterm,denom
      real*8 hsq,expterm
      real*8 term,pterm
      real*8 a(3,3)
      real*8, allocatable :: fuind(:,:)
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      f = 0.5d0 * electric / dielec
c
c     perform dynamic allocation of some global arrays
c
      if (.not.use_mpole .or. aewald.ne.aeewald) then
         if (allocated(cmp)) then
            if (size(cmp) .lt. 10*n)  deallocate (cmp)
         end if
         if (allocated(fmp)) then
            if (size(fmp) .lt. 10*n)  deallocate (fmp)
         end if
         if (allocated(fphi)) then
            if (size(fphi) .lt. 20*n)  deallocate (fphi)
         end if
         if (.not. allocated(cmp))  allocate (cmp(10,n))
         if (.not. allocated(fmp))  allocate (fmp(10,n))
         if (.not. allocated(fphi))  allocate (fphi(20,n))
c
c     perform dynamic allocation of some global arrays
c
         ntot = nfft1 * nfft2 * nfft3
         if (allocated(qgrid)) then
            if (size(qgrid) .ne. 2*ntot)  call fftclose
         end if
         if (.not. allocated(qgrid))  call fftsetup
c
c     setup spatial decomposition and B-spline coefficients
c
         call getchunk
         call moduli
         call bspline_fill
         call table_fill
c
c     assign only the permanent multipoles to the PME grid
c     and perform the 3-D FFT forward transformation
c
         do ii = 1, npole
            i = ipole(ii)
            cmp(1,i) = rpole(1,i)
            cmp(2,i) = rpole(2,i)
            cmp(3,i) = rpole(3,i)
            cmp(4,i) = rpole(4,i)
            cmp(5,i) = rpole(5,i)
            cmp(6,i) = rpole(9,i)
            cmp(7,i) = rpole(13,i)
            cmp(8,i) = 2.0d0 * rpole(6,i)
            cmp(9,i) = 2.0d0 * rpole(7,i)
            cmp(10,i) = 2.0d0 * rpole(10,i)
         end do
         call cmp_to_fmp (cmp,fmp)
         call grid_mpole (fmp)
         call fftfront
c
c     make the scalar summation over reciprocal lattice
c
         pterm = (pi/aewald)**2
         volterm = pi * volbox
         nf1 = (nfft1+1) / 2
         nf2 = (nfft2+1) / 2
         nf3 = (nfft3+1) / 2
         nff = nfft1 * nfft2
         ntot = nff * nfft3
         do i = 1, ntot-1
            k3 = i/nff + 1
            j = i - (k3-1)*nff
            k2 = j/nfft1 + 1
            k1 = j - (k2-1)*nfft1 + 1
            m1 = k1 - 1
            m2 = k2 - 1
            m3 = k3 - 1
            if (k1 .gt. nf1)  m1 = m1 - nfft1
            if (k2 .gt. nf2)  m2 = m2 - nfft2
            if (k3 .gt. nf3)  m3 = m3 - nfft3
            r1 = dble(m1)
            r2 = dble(m2)
            r3 = dble(m3)
            h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
            h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
            h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
            hsq = h1*h1 + h2*h2 + h3*h3
            term = -pterm * hsq
            expterm = 0.0d0
            if (term .gt. -50.0d0) then
               denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
               expterm = exp(term) / denom
               if (.not. use_bounds) then
                  expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
               else if (nonprism) then
                  if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
               end if
            end if
            qgrid(1,k1,k2,k3) = expterm * qgrid(1,k1,k2,k3)
            qgrid(2,k1,k2,k3) = expterm * qgrid(2,k1,k2,k3)
         end do
c
c     account for zeroth grid point for nonperiodic system
c
         qgrid(1,1,1,1) = 0.0d0
         qgrid(2,1,1,1) = 0.0d0
         if (.not. use_bounds) then
            expterm = 0.5d0 * pi / xbox
            qgrid(1,1,1,1) = expterm * qgrid(1,1,1,1)
            qgrid(2,1,1,1) = expterm * qgrid(2,1,1,1)
         end if
c
c     perform 3-D FFT backward transform and get potential
c
         call fftback
         call fphi_mpole (fphi)
      end if
c
c     set matrix for Cartesian to fractional induced dipoles
c
      do i = 1, 3
         a(1,i) = dble(nfft1) * recip(i,1)
         a(2,i) = dble(nfft2) * recip(i,2)
         a(3,i) = dble(nfft3) * recip(i,3)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (fuind(3,n))
c
c     increment the induced dipole polarization energy
c
      e = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            fuind(j,i) = a(j,1)*uind(1,i) + a(j,2)*uind(2,i)
     &                      + a(j,3)*uind(3,i)
            term = f * fuind(j,i) * fphi(j+1,i)
            e = e + term
            aep(i) = aep(i) + term
         end do
      end do
      ep = ep + e
c
c     perform deallocation of some local arrays
c
      deallocate (fuind)
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine erepel  --  Pauli exchange repulsion energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "erepel" calculates the Pauli exchange repulsion energy
c
c     literature reference:
c
c     J. A. Rackers and J. W. Ponder, "Classical Pauli Repulsion:
c     An Anisotropic, Atomic Multipole Model", Journal of Chemical
c     Physics, 150, 084104 (2019)
c
c
      subroutine erepel
      use limits
      implicit none
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_mlist) then
         call erepel0b
      else
         call erepel0a
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine erepel0a  --  Pauli repulsion energy via loop  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "erepel0a" calculates the Pauli repulsion interaction energy
c     using a double loop
c
c
      subroutine erepel0a
      use atoms
      use bound
      use cell
      use couple
      use energi
      use group
      use mpole
      use mutant
      use polar
      use repel
      use reppot
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 e,eterm
      real*8 fgrp,taper
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4,r5
      real*8 rr1,rr3,rr5
      real*8 rr7,rr9,rr11
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 vlambda3,vlambda4
      real*8 vlambda5
      real*8 sizi,sizk,sizik
      real*8 vali,valk
      real*8 dmpi,dmpk
      real*8 dmpik(9)
      real*8, allocatable :: rscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the Pauli repulsion energy contribution
c
      er = 0.0d0
      if (nrep .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('REPEL')
c
c     perform dynamic allocation of some local arrays
c
      allocate (rscale(n))
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         rscale(i) = 1.0d0
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vlambda3 = vlambda**3
         vlambda4 = vlambda3 * vlambda
         vlambda5 = vlambda4 * vlambda
      end if
c
c     set cutoff distances and switching coefficients
c
      mode = 'REPULS'
      call switch (mode)
c
c     calculate the Pauli repulsion interaction energy term
c
      do ii = 1, nrep-1
         i = irep(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         sizi = sizpr(i)
         dmpi = dmppr(i)
         vali = elepr(i)
         ci = rrepole(1,i)
         dix = rrepole(2,i)
         diy = rrepole(3,i)
         diz = rrepole(4,i)
         qixx = rrepole(5,i)
         qixy = rrepole(6,i)
         qixz = rrepole(7,i)
         qiyy = rrepole(9,i)
         qiyz = rrepole(10,i)
         qizz = rrepole(13,i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = r2scale
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = r3scale
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = r4scale
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = r5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, nrep
            k = irep(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  sizk = sizpr(k)
                  dmpk = dmppr(k)
                  valk = elepr(k)
                  ck = rrepole(1,k)
                  dkx = rrepole(2,k)
                  dky = rrepole(3,k)
                  dkz = rrepole(4,k)
                  qkxx = rrepole(5,k)
                  qkxy = rrepole(6,k)
                  qkxz = rrepole(7,k)
                  qkyy = rrepole(9,k)
                  qkyz = rrepole(10,k)
                  qkzz = rrepole(13,k)
c
c     intermediates involving moments and separation distance
c
                  dir = dix*xr + diy*yr + diz*zr
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qir = qix*xr + qiy*yr + qiz*zr
                  dkr = dkx*xr + dky*yr + dkz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
                  qkr = qkx*xr + qky*yr + qkz*zr
                  dik = dix*dkx + diy*dky + diz*dkz
                  qik = qix*qkx + qiy*qky + qiz*qkz
                  diqk = dix*qkx + diy*qky + diz*qkz
                  dkqi = dkx*qix + dky*qiy + dkz*qiz
                  qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                      + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                  rr1 = 1.0d0 / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
c
c     get damping coefficients for the Pauli repulsion energy
c
                  call damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11,
     &                             9,dmpi,dmpk,dmpik)                  
c
c     compute intermediate terms for the Pauli repulsion energy
c
                  term1 = vali*valk
                  term2 = valk*dir - vali*dkr + dik
                  term3 = vali*qkr + valk*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  eterm = term1*dmpik(1) + term2*dmpik(3)
     &                       + term3*dmpik(5) + term4*dmpik(7)
     &                       + term5*dmpik(9)
                  sizik = sizi * sizk * rscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     e = vlambda5 * sizik * eterm
     &                      / sqrt(vlambda3-vlambda4+r2)
                  else
                     e = sizik * eterm * rr1
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall Pauli repulsion energy component
c
                  er = er + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction energy with other unit cells
c
         do ii = 1, nrep
            i = irep(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            sizi = sizpr(i)
            dmpi = dmppr(i)
            vali = elepr(i)
            ci = rrepole(1,i)
            dix = rrepole(2,i)
            diy = rrepole(3,i)
            diz = rrepole(4,i)
            qixx = rrepole(5,i)
            qixy = rrepole(6,i)
            qixz = rrepole(7,i)
            qiyy = rrepole(9,i)
            qiyz = rrepole(10,i)
            qizz = rrepole(13,i)
            usei = use(i)
            muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               rscale(i12(j,i)) = r2scale
            end do
            do j = 1, n13(i)
               rscale(i13(j,i)) = r3scale
            end do
            do j = 1, n14(i)
               rscale(i14(j,i)) = r4scale
            end do
            do j = 1, n15(i)
               rscale(i15(j,i)) = r5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, nrep
               k = irep(kk)
               mutk = mut(k)
               proceed = .true.
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               if (.not. use_intra)  proceed = .true.
               if (proceed)  proceed = (usei .or. use(k))
               if (proceed) then
                  do jcell = 2, ncell
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     call imager (xr,yr,zr,jcell)
                     r2 = xr*xr + yr* yr + zr*zr
                     if (r2 .le. off2) then
                        r = sqrt(r2)
                        sizk = sizpr(k)
                        dmpk = dmppr(k)
                        valk = elepr(k)
                        ck = rrepole(1,k)
                        dkx = rrepole(2,k)
                        dky = rrepole(3,k)
                        dkz = rrepole(4,k)
                        qkxx = rrepole(5,k)
                        qkxy = rrepole(6,k)
                        qkxz = rrepole(7,k)
                        qkyy = rrepole(9,k)
                        qkyz = rrepole(10,k)
                        qkzz = rrepole(13,k)
c
c     intermediates involving moments and separation distance
c
                        dir = dix*xr + diy*yr + diz*zr
                        qix = qixx*xr + qixy*yr + qixz*zr
                        qiy = qixy*xr + qiyy*yr + qiyz*zr
                        qiz = qixz*xr + qiyz*yr + qizz*zr
                        qir = qix*xr + qiy*yr + qiz*zr
                        dkr = dkx*xr + dky*yr + dkz*zr
                        qkx = qkxx*xr + qkxy*yr + qkxz*zr
                        qky = qkxy*xr + qkyy*yr + qkyz*zr
                        qkz = qkxz*xr + qkyz*yr + qkzz*zr
                        qkr = qkx*xr + qky*yr + qkz*zr
                        dik = dix*dkx + diy*dky + diz*dkz
                        qik = qix*qkx + qiy*qky + qiz*qkz
                        diqk = dix*qkx + diy*qky + diz*qkz
                        dkqi = dkx*qix + dky*qiy + dkz*qiz
                        qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                            + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                        rr1 = 1.0d0 / r
                        rr3 = rr1 / r2
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr9 = 7.0d0 * rr7 / r2
c
c     get damping coefficients for the Pauli repulsion energy
c
                        call damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11,
     &                                   9,dmpi,dmpk,dmpik)                  
c
c     compute the Pauli repulsion energy for this interaction
c
                        term1 = vali*valk
                        term2 = valk*dir - vali*dkr + dik
                        term3 = vali*qkr + valk*qir - dir*dkr
     &                             + 2.0d0*(dkqi-diqk+qiqk)
                        term4 = dir*qkr - dkr*qir - 4.0d0*qik
                        term5 = qir*qkr
                        eterm = term1*dmpik(1) + term2*dmpik(3)
     &                             + term3*dmpik(5) + term4*dmpik(7)
     &                             + term5*dmpik(9)
                        sizik = sizi * sizk * rscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                        mutik = .false.
                        if (muti .or. mutk) then
                           if (vcouple .eq. 1) then
                              mutik = .true.
                           else if (.not.muti .or. .not.mutk) then
                              mutik = .true.
                           end if
                        end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                        if (mutik) then
                           e = vlambda5 * sizik * eterm
     &                            / sqrt(vlambda3-vlambda4+r2)
                        else
                           e = sizik * eterm * rr1
                        end if
c
c     use energy switching if near the cutoff distance
c
                        if (r2 .gt. cut2) then
                           r3 = r2 * r
                           r4 = r2 * r2
                           r5 = r2 * r3
                           taper = c5*r5 + c4*r4 + c3*r3
     &                                + c2*r2 + c1*r + c0
                           e = e * taper
                        end if
c
c     scale the interaction based on its group membership
c
                        if (use_group)  e = e * fgrp
c
c     increment the overall Pauli repulsion energy component;
c     interaction of an atom with its own image counts half
c
                        if (i .eq. k)  e = 0.5d0 * e
                        er = er + e
                     end if
                  end do
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               rscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               rscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               rscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               rscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (rscale)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine erepel0b  --  Pauli repulsion energy via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "erepel0b" calculates the Pauli repulsion interaction energy
c     using a pairwise neighbor list
c
c
      subroutine erepel0b
      use atoms
      use bound
      use couple
      use energi
      use group
      use inform
      use inter
      use mpole
      use mutant
      use neigh
      use polar
      use repel
      use reppot
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      real*8 e,eterm
      real*8 fgrp,taper
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4,r5
      real*8 rr1,rr3,rr5
      real*8 rr7,rr9,rr11
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 vlambda3,vlambda4
      real*8 vlambda5
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 sizi,sizk,sizik
      real*8 vali,valk
      real*8 dmpi,dmpk
      real*8 dmpik(9)
      real*8, allocatable :: rscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the Pauli repulsion energy contribution
c
      er = 0.0d0
      if (nrep .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('REPEL')
c
c     perform dynamic allocation of some local arrays
c
      allocate (rscale(n))
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vlambda3 = vlambda**3
         vlambda4 = vlambda3 * vlambda
         vlambda5 = vlambda4 * vlambda
      end if
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         rscale(i) = 1.0d0
      end do
c
c     set cutoff distances and switching coefficients
c
      mode = 'REPULS'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(nrep,irep,x,y,z,sizpr,dmppr,elepr,rrepole,uind,n12,
!$OMP& i12,n13,i13,n14,i14,n15,i15,r2scale,r3scale,r4scale,r5scale,
!$OMP& nelst,elst,use,use_group,use_intra,use_bounds,vcouple,vlambda3,
!$OMP& vlambda4,vlambda5,mut,cut2,off2,c0,c1,c2,c3,c4,c5)
!$OMP& firstprivate(rscale)
!$OMP& shared (er)
!$OMP DO reduction(+:er)
c
c     calculate the Pauli repulsion interaction energy term
c
      do ii = 1, nrep
         i = irep(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         sizi = sizpr(i)
         dmpi = dmppr(i)
         vali = elepr(i)
         ci = rrepole(1,i)
         dix = rrepole(2,i)
         diy = rrepole(3,i)
         diz = rrepole(4,i)
         qixx = rrepole(5,i)
         qixy = rrepole(6,i)
         qixz = rrepole(7,i)
         qiyy = rrepole(9,i)
         qiyz = rrepole(10,i)
         qizz = rrepole(13,i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = r2scale
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = r3scale
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = r4scale
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = r5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = irep(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  sizk = sizpr(k)
                  dmpk = dmppr(k)
                  valk = elepr(k)
                  ck = rrepole(1,k)
                  dkx = rrepole(2,k)
                  dky = rrepole(3,k)
                  dkz = rrepole(4,k)
                  qkxx = rrepole(5,k)
                  qkxy = rrepole(6,k)
                  qkxz = rrepole(7,k)
                  qkyy = rrepole(9,k)
                  qkyz = rrepole(10,k)
                  qkzz = rrepole(13,k)
c
c     intermediates involving moments and separation distance
c
                  dir = dix*xr + diy*yr + diz*zr
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qir = qix*xr + qiy*yr + qiz*zr
                  dkr = dkx*xr + dky*yr + dkz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
                  qkr = qkx*xr + qky*yr + qkz*zr
                  dik = dix*dkx + diy*dky + diz*dkz
                  qik = qix*qkx + qiy*qky + qiz*qkz
                  diqk = dix*qkx + diy*qky + diz*qkz
                  dkqi = dkx*qix + dky*qiy + dkz*qiz
                  qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                      + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                  rr1 = 1.0d0 / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
c
c     get damping coefficients for the Pauli repulsion energy
c     
                  call damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11,
     &                             9,dmpi,dmpk,dmpik)                  
c
c     compute the Pauli repulsion energy for this interaction
c
                  term1 = vali*valk
                  term2 = valk*dir - vali*dkr + dik
                  term3 = vali*qkr + valk*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  eterm = term1*dmpik(1) + term2*dmpik(3)
     &                       + term3*dmpik(5) + term4*dmpik(7)
     &                       + term5*dmpik(9)
                  sizik = sizi * sizk * rscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     e = vlambda5 * sizik * eterm
     &                      / sqrt(vlambda3-vlambda4+r2)
                  else
                     e = sizik * eterm * rr1
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall Pauli repulsion energy component
c
                  er = er + e
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (rscale)
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine erepel1  --  Pauli repulsion energy & derivs  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "erepel1" calculates the Pauli repulsion energy and first
c     derivatives with respect to Cartesian coordinates
c
c     literature reference:
c
c     J. A. Rackers and J. W. Ponder, "Classical Pauli Repulsion:
c     An Anisotropic, Atomic Multipole Model", Journal of Chemical
c     Physics, 150, 084104 (2019)
c
c
      subroutine erepel1
      use limits
      implicit none
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_mlist) then
         call erepel1b
      else
         call erepel1a
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine erepel1a  --  Pauli repulsion derivs via loop  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "erepel1a" calculates the Pauli repulsion energy and first
c     derivatives with respect to Cartesian coordinates using a
c     pairwise double loop
c
c
      subroutine erepel1a
      use atoms
      use bound
      use cell
      use couple
      use deriv
      use energi
      use group
      use mpole
      use mutant
      use repel
      use reppot
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,kk,jcell
      integer ix,iy,iz
      real*8 e,fgrp
      real*8 eterm,de
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 r,r2,r3,r4,r5
      real*8 rr1,rr3,rr5
      real*8 rr7,rr9,rr11
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 dirx,diry,dirz
      real*8 dkrx,dkry,dkrz
      real*8 dikx,diky,dikz
      real*8 qirx,qiry,qirz
      real*8 qkrx,qkry,qkrz
      real*8 qikx,qiky,qikz
      real*8 qixk,qiyk,qizk
      real*8 qkxi,qkyi,qkzi
      real*8 qikrx,qikry,qikrz
      real*8 qkirx,qkiry,qkirz
      real*8 diqkx,diqky,diqkz
      real*8 dkqix,dkqiy,dkqiz
      real*8 diqkrx,diqkry,diqkrz
      real*8 dkqirx,dkqiry,dkqirz
      real*8 dqikx,dqiky,dqikz
      real*8 term1,term2,term3
      real*8 term4,term5,term6
      real*8 vlambda3,vlambda4
      real*8 vlambda5
      real*8 sizi,sizk,sizik
      real*8 vali,valk
      real*8 dmpi,dmpk
      real*8 frcx,frcy,frcz
      real*8 term,soft,dsoft
      real*8 taper,dtaper
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 ttri(3),ttrk(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 dmpik(11)
      real*8, allocatable :: rscale(:)
      real*8, allocatable :: ter(:,:)
      logical proceed,usei
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the Pauli repulsion energy and derivatives
c
      er = 0.0d0
      do i = 1, n
         der(1,i) = 0.0d0
         der(2,i) = 0.0d0
         der(3,i) = 0.0d0
      end do
      if (nrep .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('REPEL')
c
c     perform dynamic allocation of some local arrays
c
      allocate (rscale(n))
      allocate (ter(3,n))
c
c     initialize connected atom scaling and torque arrays
c
      do i = 1, n
         rscale(i) = 1.0d0
         do j = 1, 3
            ter(j,i) = 0.0d0
         end do
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vlambda3 = vlambda**3
         vlambda4 = vlambda3 * vlambda
         vlambda5 = vlambda4 * vlambda
      end if
c
c     set cutoff distances and switching coefficients
c
      mode = 'REPULS'
      call switch (mode)
c
c     calculate the Pauli repulsion energy and derivatives
c
      do ii = 1, nrep-1
         i = irep(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         sizi = sizpr(i)
         dmpi = dmppr(i)
         vali = elepr(i)
         ci = rrepole(1,i)
         dix = rrepole(2,i)
         diy = rrepole(3,i)
         diz = rrepole(4,i)
         qixx = rrepole(5,i)
         qixy = rrepole(6,i)
         qixz = rrepole(7,i)
         qiyy = rrepole(9,i)
         qiyz = rrepole(10,i)
         qizz = rrepole(13,i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = r2scale
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = r3scale
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = r4scale
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = r5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, nrep
            k = irep(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  sizk = sizpr(k)
                  dmpk = dmppr(k)
                  valk = elepr(k)
                  ck = rrepole(1,k)
                  dkx = rrepole(2,k)
                  dky = rrepole(3,k)
                  dkz = rrepole(4,k)
                  qkxx = rrepole(5,k)
                  qkxy = rrepole(6,k)
                  qkxz = rrepole(7,k)
                  qkyy = rrepole(9,k)
                  qkyz = rrepole(10,k)
                  qkzz = rrepole(13,k)
c
c     intermediates involving moments and separation distance
c
                  dir = dix*xr + diy*yr + diz*zr
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qir = qix*xr + qiy*yr + qiz*zr
                  dkr = dkx*xr + dky*yr + dkz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
                  qkr = qkx*xr + qky*yr + qkz*zr
                  dik = dix*dkx + diy*dky + diz*dkz
                  qik = qix*qkx + qiy*qky + qiz*qkz
                  diqk = dix*qkx + diy*qky + diz*qkz
                  dkqi = dkx*qix + dky*qiy + dkz*qiz
                  qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                      + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
                  dirx = diy*zr - diz*yr
                  diry = diz*xr - dix*zr
                  dirz = dix*yr - diy*xr
                  dkrx = dky*zr - dkz*yr
                  dkry = dkz*xr - dkx*zr
                  dkrz = dkx*yr - dky*xr
                  dikx = diy*dkz - diz*dky
                  diky = diz*dkx - dix*dkz
                  dikz = dix*dky - diy*dkx
                  qirx = qiz*yr - qiy*zr
                  qiry = qix*zr - qiz*xr
                  qirz = qiy*xr - qix*yr
                  qkrx = qkz*yr - qky*zr
                  qkry = qkx*zr - qkz*xr
                  qkrz = qky*xr - qkx*yr
                  qikx = qky*qiz - qkz*qiy
                  qiky = qkz*qix - qkx*qiz
                  qikz = qkx*qiy - qky*qix
                  qixk = qixx*qkx + qixy*qky + qixz*qkz
                  qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
                  qizk = qixz*qkx + qiyz*qky + qizz*qkz
                  qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
                  qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
                  qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
                  qikrx = qizk*yr - qiyk*zr
                  qikry = qixk*zr - qizk*xr
                  qikrz = qiyk*xr - qixk*yr
                  qkirx = qkzi*yr - qkyi*zr
                  qkiry = qkxi*zr - qkzi*xr
                  qkirz = qkyi*xr - qkxi*yr
                  diqkx = dix*qkxx + diy*qkxy + diz*qkxz
                  diqky = dix*qkxy + diy*qkyy + diz*qkyz
                  diqkz = dix*qkxz + diy*qkyz + diz*qkzz
                  dkqix = dkx*qixx + dky*qixy + dkz*qixz
                  dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
                  dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
                  diqkrx = diqkz*yr - diqky*zr
                  diqkry = diqkx*zr - diqkz*xr
                  diqkrz = diqky*xr - diqkx*yr
                  dkqirx = dkqiz*yr - dkqiy*zr
                  dkqiry = dkqix*zr - dkqiz*xr
                  dkqirz = dkqiy*xr - dkqix*yr
                  dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                    - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                            -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
                  dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                    - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                            -qixx*qkxz-qixy*qkyz-qixz*qkzz)
                  dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                    - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                            -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
                  rr1 = 1.0d0 / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
                  rr11 = 9.0d0 * rr9 / r2
c
c     get damping coefficients for the Pauli repulsion energy
c
                  call damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11,
     &                             11,dmpi,dmpk,dmpik)                  
c
c     calculate intermediate terms needed for the energy
c
                  term1 = vali*valk
                  term2 = valk*dir - vali*dkr + dik
                  term3 = vali*qkr + valk*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  eterm = term1*dmpik(1) + term2*dmpik(3)
     &                       + term3*dmpik(5) + term4*dmpik(7)
     &                       + term5*dmpik(9)
c
c     compute the Pauli repulsion energy for this interaction
c
                  sizik = sizi * sizk * rscale(k)
                  e = sizik * eterm * rr1
c
c     calculate intermediate terms for force and torque
c
                  de = term1*dmpik(3) + term2*dmpik(5)
     &                    + term3*dmpik(7) + term4*dmpik(9)
     &                    + term5*dmpik(11)
                  term1 = -valk*dmpik(3) + dkr*dmpik(5)
     &                       - qkr*dmpik(7)
                  term2 = vali*dmpik(3) + dir*dmpik(5)
     &                       + qir*dmpik(7)
                  term3 = 2.0d0 * dmpik(5)
                  term4 = 2.0d0 * (-valk*dmpik(5) + dkr*dmpik(7)
     &                                - qkr*dmpik(9))
                  term5 = 2.0d0 * (-vali*dmpik(5) - dir*dmpik(7)
     &                                - qir*dmpik(9))
                  term6 = 4.0d0 * dmpik(7)
c     
c     compute the force components for this interaction
c     
                  frcx = de*xr + term1*dix + term2*dkx
     &                      + term3*(diqkx-dkqix) + term4*qix
     &                      + term5*qkx + term6*(qixk+qkxi)
                  frcy = de*yr + term1*diy + term2*dky
     &                      + term3*(diqky-dkqiy) + term4*qiy
     &                      + term5*qky + term6*(qiyk+qkyi)
                  frcz = de*zr + term1*diz + term2*dkz
     &                      + term3*(diqkz-dkqiz) + term4*qiz
     &                      + term5*qkz + term6*(qizk+qkzi)
                  frcx = frcx*rr1 + eterm*rr3*xr
                  frcy = frcy*rr1 + eterm*rr3*yr
                  frcz = frcz*rr1 + eterm*rr3*zr
                  frcx = sizik * frcx
                  frcy = sizik * frcy
                  frcz = sizik * frcz
c
c     compute the torque components for this interaction
c
                  ttri(1) = -dmpik(3)*dikx + term1*dirx
     &                         + term3*(dqikx+dkqirx)
     &                         - term4*qirx - term6*(qikrx+qikx)
                  ttri(2) = -dmpik(3)*diky + term1*diry
     &                         + term3*(dqiky+dkqiry)
     &                         - term4*qiry - term6*(qikry+qiky)
                  ttri(3) = -dmpik(3)*dikz + term1*dirz
     &                         + term3*(dqikz+dkqirz)
     &                         - term4*qirz - term6*(qikrz+qikz)
                  ttrk(1) = dmpik(3)*dikx + term2*dkrx
     &                         - term3*(dqikx+diqkrx)
     &                         - term5*qkrx - term6*(qkirx-qikx)
                  ttrk(2) = dmpik(3)*diky + term2*dkry
     &                         - term3*(dqiky+diqkry)
     &                         - term5*qkry - term6*(qkiry-qiky)
                  ttrk(3) = dmpik(3)*dikz + term2*dkrz
     &                         - term3*(dqikz+diqkrz)
     &                         - term5*qkrz - term6*(qkirz-qikz)
                  ttri(1) = sizik * ttri(1) * rr1
                  ttri(2) = sizik * ttri(2) * rr1
                  ttri(3) = sizik * ttri(3) * rr1
                  ttrk(1) = sizik * ttrk(1) * rr1
                  ttrk(2) = sizik * ttrk(2) * rr1
                  ttrk(3) = sizik * ttrk(3) * rr1
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = fgrp * e
                     frcx = fgrp * frcx
                     frcy = fgrp * frcy
                     frcz = fgrp * frcz
                     do j = 1, 3
                        ttri(j) = fgrp * ttri(j)
                        ttrk(j) = fgrp * ttrk(j)
                     end do
                  end if
c
c     set lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get energy and force via soft core lambda scaling
c
                  if (mutik) then
                     term = vlambda3 - vlambda4 + r2
                     soft = vlambda5 * r / sqrt(term)
                     dsoft = soft * (rr1-r/term)
                     dsoft = dsoft * rr1 * e
                     frcx = frcx*soft - dsoft*xr
                     frcy = frcy*soft - dsoft*yr
                     frcz = frcz*soft - dsoft*zr
                     do j = 1, 3
                        ttri(j) = ttri(j) * soft
                        ttrk(j) = ttrk(j) * soft
                     end do
                     e = soft * e
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     dtaper = dtaper * e * rr1
                     e = e * taper
                     frcx = frcx*taper - dtaper*xr
                     frcy = frcy*taper - dtaper*yr
                     frcz = frcz*taper - dtaper*zr
                     do j = 1, 3
                        ttri(j) = ttri(j) * taper
                        ttrk(j) = ttrk(j) * taper
                     end do
                  end if
c
c     increment the overall Pauli repulsion energy component
c
                  er = er + e
c
c     increment force-based gradient and torque on first site
c
                  der(1,i) = der(1,i) + frcx
                  der(2,i) = der(2,i) + frcy
                  der(3,i) = der(3,i) + frcz
                  ter(1,i) = ter(1,i) + ttri(1)
                  ter(2,i) = ter(2,i) + ttri(2)
                  ter(3,i) = ter(3,i) + ttri(3)
c
c     increment force-based gradient and torque on second site
c
                  der(1,k) = der(1,k) - frcx
                  der(2,k) = der(2,k) - frcy
                  der(3,k) = der(3,k) - frcz
                  ter(1,k) = ter(1,k) + ttrk(1)
                  ter(2,k) = ter(2,k) + ttrk(2)
                  ter(3,k) = ter(3,k) + ttrk(3)
c
c     increment the virial due to pairwise Cartesian forces
c
                  vxx = -xr * frcx
                  vxy = -0.5d0 * (yr*frcx+xr*frcy)
                  vxz = -0.5d0 * (zr*frcx+xr*frcz)
                  vyy = -yr * frcy
                  vyz = -0.5d0 * (zr*frcy+yr*frcz)
                  vzz = -zr * frcz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vxy
                  vir(3,1) = vir(3,1) + vxz
                  vir(1,2) = vir(1,2) + vxy
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vyz
                  vir(1,3) = vir(1,3) + vxz
                  vir(2,3) = vir(2,3) + vyz
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction components with other unit cells
c
         do ii = 1, nrep
            i = irep(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            sizi = sizpr(i)
            dmpi = dmppr(i)
            vali = elepr(i)
            ci = rrepole(1,i)
            dix = rrepole(2,i)
            diy = rrepole(3,i)
            diz = rrepole(4,i)
            qixx = rrepole(5,i)
            qixy = rrepole(6,i)
            qixz = rrepole(7,i)
            qiyy = rrepole(9,i)
            qiyz = rrepole(10,i)
            qizz = rrepole(13,i)
            usei = use(i)
            muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               rscale(i12(j,i)) = r2scale
            end do
            do j = 1, n13(i)
               rscale(i13(j,i)) = r3scale
            end do
            do j = 1, n14(i)
               rscale(i14(j,i)) = r4scale
            end do
            do j = 1, n15(i)
               rscale(i15(j,i)) = r5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, nrep
               k = irep(kk)
               mutk = mut(k)
               proceed = .true.
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               if (.not. use_intra)  proceed = .true.
               if (proceed)  proceed = (usei .or. use(k))
               if (proceed) then
                  do jcell = 2, ncell
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     call imager (xr,yr,zr,jcell)
                     r2 = xr*xr + yr* yr + zr*zr
                     if (r2 .le. off2) then
                        r = sqrt(r2)
                        sizk = sizpr(k)
                        dmpk = dmppr(k)
                        valk = elepr(k)
                        ck = rrepole(1,k)
                        dkx = rrepole(2,k)
                        dky = rrepole(3,k)
                        dkz = rrepole(4,k)
                        qkxx = rrepole(5,k)
                        qkxy = rrepole(6,k)
                        qkxz = rrepole(7,k)
                        qkyy = rrepole(9,k)
                        qkyz = rrepole(10,k)
                        qkzz = rrepole(13,k)
c
c     intermediates involving moments and separation distance
c
                        dir = dix*xr + diy*yr + diz*zr
                        qix = qixx*xr + qixy*yr + qixz*zr
                        qiy = qixy*xr + qiyy*yr + qiyz*zr
                        qiz = qixz*xr + qiyz*yr + qizz*zr
                        qir = qix*xr + qiy*yr + qiz*zr
                        dkr = dkx*xr + dky*yr + dkz*zr
                        qkx = qkxx*xr + qkxy*yr + qkxz*zr
                        qky = qkxy*xr + qkyy*yr + qkyz*zr
                        qkz = qkxz*xr + qkyz*yr + qkzz*zr
                        qkr = qkx*xr + qky*yr + qkz*zr
                        dik = dix*dkx + diy*dky + diz*dkz
                        qik = qix*qkx + qiy*qky + qiz*qkz
                        diqk = dix*qkx + diy*qky + diz*qkz
                        dkqi = dkx*qix + dky*qiy + dkz*qiz
                        qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                            + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
                        dirx = diy*zr - diz*yr
                        diry = diz*xr - dix*zr
                        dirz = dix*yr - diy*xr
                        dkrx = dky*zr - dkz*yr
                        dkry = dkz*xr - dkx*zr
                        dkrz = dkx*yr - dky*xr
                        dikx = diy*dkz - diz*dky
                        diky = diz*dkx - dix*dkz
                        dikz = dix*dky - diy*dkx
                        qirx = qiz*yr - qiy*zr
                        qiry = qix*zr - qiz*xr
                        qirz = qiy*xr - qix*yr
                        qkrx = qkz*yr - qky*zr
                        qkry = qkx*zr - qkz*xr
                        qkrz = qky*xr - qkx*yr
                        qikx = qky*qiz - qkz*qiy
                        qiky = qkz*qix - qkx*qiz
                        qikz = qkx*qiy - qky*qix
                        qixk = qixx*qkx + qixy*qky + qixz*qkz
                        qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
                        qizk = qixz*qkx + qiyz*qky + qizz*qkz
                        qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
                        qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
                        qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
                        qikrx = qizk*yr - qiyk*zr
                        qikry = qixk*zr - qizk*xr
                        qikrz = qiyk*xr - qixk*yr
                        qkirx = qkzi*yr - qkyi*zr
                        qkiry = qkxi*zr - qkzi*xr
                        qkirz = qkyi*xr - qkxi*yr
                        diqkx = dix*qkxx + diy*qkxy + diz*qkxz
                        diqky = dix*qkxy + diy*qkyy + diz*qkyz
                        diqkz = dix*qkxz + diy*qkyz + diz*qkzz
                        dkqix = dkx*qixx + dky*qixy + dkz*qixz
                        dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
                        dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
                        diqkrx = diqkz*yr - diqky*zr
                        diqkry = diqkx*zr - diqkz*xr
                        diqkrz = diqky*xr - diqkx*yr
                        dkqirx = dkqiz*yr - dkqiy*zr
                        dkqiry = dkqix*zr - dkqiz*xr
                        dkqirz = dkqiy*xr - dkqix*yr
                        dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                          - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                                  -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
                        dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                          - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                                  -qixx*qkxz-qixy*qkyz-qixz*qkzz)
                        dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                          - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                                  -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
                        rr1 = 1.0d0 / r
                        rr3 = rr1 / r2
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr9 = 7.0d0 * rr7 / r2
                        rr11 = 9.0d0 * rr9 / r2
c
c     get damping coefficients for the Pauli repulsion energy
c
                        call damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11,
     &                                   11,dmpi,dmpk,dmpik)                  
c
c     compute the Pauli repulsion energy for this interaction
c
                        term1 = vali*valk
                        term2 = valk*dir - vali*dkr + dik
                        term3 = vali*qkr + valk*qir - dir*dkr
     &                             + 2.0d0*(dkqi-diqk+qiqk)
                        term4 = dir*qkr - dkr*qir - 4.0d0*qik
                        term5 = qir*qkr
                        eterm = term1*dmpik(1) + term2*dmpik(3)
     &                             + term3*dmpik(5) + term4*dmpik(7)
     &                             + term5*dmpik(9)
c
c     compute the Pauli repulsion energy for this interaction
c
                        sizik = sizi * sizk * rscale(k)
                        e = sizik * eterm * rr1
c
c     calculate intermediate terms for force and torque
c
                        de = term1*dmpik(3) + term2*dmpik(5)
     &                          + term3*dmpik(7) + term4*dmpik(9)
     &                          + term5*dmpik(11)
                        term1 = -valk*dmpik(3) + dkr*dmpik(5)
     &                             - qkr*dmpik(7)
                        term2 = vali*dmpik(3) + dir*dmpik(5)
     &                             + qir*dmpik(7)
                        term3 = 2.0d0 * dmpik(5)
                        term4 = 2.0d0 * (-valk*dmpik(5) + dkr*dmpik(7)
     &                                      - qkr*dmpik(9))
                        term5 = 2.0d0 * (-vali*dmpik(5) - dir*dmpik(7)
     &                                      - qir*dmpik(9))
                        term6 = 4.0d0 * dmpik(7)
c
c     compute the force components for this interaction
c
                        frcx = de*xr + term1*dix + term2*dkx
     &                            + term3*(diqkx-dkqix) + term4*qix
     &                            + term5*qkx + term6*(qixk+qkxi)
                        frcy = de*yr + term1*diy + term2*dky
     &                            + term3*(diqky-dkqiy) + term4*qiy
     &                            + term5*qky + term6*(qiyk+qkyi)
                        frcz = de*zr + term1*diz + term2*dkz
     &                            + term3*(diqkz-dkqiz) + term4*qiz
     &                            + term5*qkz + term6*(qizk+qkzi)
                        frcx = frcx*rr1 + eterm*rr3*xr
                        frcy = frcy*rr1 + eterm*rr3*yr
                        frcz = frcz*rr1 + eterm*rr3*zr
                        frcx = sizik * frcx
                        frcy = sizik * frcy
                        frcz = sizik * frcz
c
c     compute the torque components for this interaction
c
                        ttri(1) = -dmpik(3)*dikx + term1*dirx
     &                               + term3*(dqikx+dkqirx)
     &                               - term4*qirx - term6*(qikrx+qikx)
                        ttri(2) = -dmpik(3)*diky + term1*diry
     &                               + term3*(dqiky+dkqiry)
     &                               - term4*qiry - term6*(qikry+qiky)
                        ttri(3) = -dmpik(3)*dikz + term1*dirz
     &                               + term3*(dqikz+dkqirz)
     &                               - term4*qirz - term6*(qikrz+qikz)
                        ttrk(1) = dmpik(3)*dikx + term2*dkrx
     &                               - term3*(dqikx+diqkrx)
     &                               - term5*qkrx - term6*(qkirx-qikx)
                        ttrk(2) = dmpik(3)*diky + term2*dkry
     &                               - term3*(dqiky+diqkry)
     &                               - term5*qkry - term6*(qkiry-qiky)
                        ttrk(3) = dmpik(3)*dikz + term2*dkrz
     &                               - term3*(dqikz+diqkrz)
     &                               - term5*qkrz - term6*(qkirz-qikz)
                        ttri(1) = sizik * ttri(1) * rr1
                        ttri(2) = sizik * ttri(2) * rr1
                        ttri(3) = sizik * ttri(3) * rr1
                        ttrk(1) = sizik * ttrk(1) * rr1
                        ttrk(2) = sizik * ttrk(2) * rr1
                        ttrk(3) = sizik * ttrk(3) * rr1
c
c     scale the interaction based on its group membership
c
                        if (use_group) then
                           e = fgrp * e
                           frcx = fgrp * frcx
                           frcy = fgrp * frcy
                           frcz = fgrp * frcz
                           do j = 1, 3
                              ttri(j) = fgrp * ttri(j)
                              ttrk(j) = fgrp * ttrk(j)
                           end do
                        end if
c
c     set lambda scaling for decoupling or annihilation
c
                        mutik = .false.
                        if (muti .or. mutk) then
                           if (vcouple .eq. 1) then
                              mutik = .true.
                           else if (.not.muti .or. .not.mutk) then
                              mutik = .true.
                           end if
                        end if
c
c     get energy and force via soft core lambda scaling
c
                        if (mutik) then
                           term = vlambda3 - vlambda4 + r2
                           soft = vlambda5 * r / sqrt(term)
                           dsoft = soft * (rr1-r/term)
                           dsoft = dsoft * rr1 * e
                           frcx = frcx*soft - dsoft*xr
                           frcy = frcy*soft - dsoft*yr
                           frcz = frcz*soft - dsoft*zr
                           do j = 1, 3
                              ttri(j) = ttri(j) * soft
                              ttrk(j) = ttrk(j) * soft
                           end do
                           e = soft * e
                        end if
c
c     use energy switching if near the cutoff distance
c
                        if (r2 .gt. cut2) then
                           r3 = r2 * r
                           r4 = r2 * r2
                           r5 = r2 * r3
                           taper = c5*r5 + c4*r4 + c3*r3
     &                                + c2*r2 + c1*r + c0
                           dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                                 + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                           dtaper = dtaper * e * rr1
                           e = e * taper
                           frcx = frcx*taper - dtaper*xr
                           frcy = frcy*taper - dtaper*yr
                           frcz = frcz*taper - dtaper*zr
                           do j = 1, 3
                              ttri(j) = ttri(j) * taper
                              ttrk(j) = ttrk(j) * taper
                           end do
                        end if
c
c     increment the overall Pauli repulsion energy component
c
                        if (i .eq. k) then
                           e = 0.5d0 * e
                           frcx = 0.5d0 * frcx
                           frcy = 0.5d0 * frcy
                           frcz = 0.5d0 * frcz
                           do j = 1, 3
                              ttri(j) = 0.5d0 * ttri(j)
                              ttrk(j) = 0.5d0 * ttrk(j)
                           end do
                        end if
                        er = er + e
c
c     increment force-based gradient and torque on first site
c
                        der(1,i) = der(1,i) + frcx
                        der(2,i) = der(2,i) + frcy
                        der(3,i) = der(3,i) + frcz
                        ter(1,i) = ter(1,i) + ttri(1)
                        ter(2,i) = ter(2,i) + ttri(2)
                        ter(3,i) = ter(3,i) + ttri(3)
c
c     increment force-based gradient and torque on second site
c
                        der(1,k) = der(1,k) - frcx
                        der(2,k) = der(2,k) - frcy
                        der(3,k) = der(3,k) - frcz
                        ter(1,k) = ter(1,k) + ttrk(1)
                        ter(2,k) = ter(2,k) + ttrk(2)
                        ter(3,k) = ter(3,k) + ttrk(3)
c
c     increment the virial due to pairwise Cartesian forces
c
                        vxx = -xr * frcx
                        vxy = -0.5d0 * (yr*frcx+xr*frcy)
                        vxz = -0.5d0 * (zr*frcx+xr*frcz)
                        vyy = -yr * frcy
                        vyz = -0.5d0 * (zr*frcy+yr*frcz)
                        vzz = -zr * frcz
                        vir(1,1) = vir(1,1) + vxx
                        vir(2,1) = vir(2,1) + vxy
                        vir(3,1) = vir(3,1) + vxz
                        vir(1,2) = vir(1,2) + vxy
                        vir(2,2) = vir(2,2) + vyy
                        vir(3,2) = vir(3,2) + vyz
                        vir(1,3) = vir(1,3) + vxz
                        vir(2,3) = vir(2,3) + vyz
                        vir(3,3) = vir(3,3) + vzz
                     end if
                  end do
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               rscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               rscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               rscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               rscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     resolve site torques then increment forces and virial
c
      do ii = 1, nrep
         i = irep(ii)
         call torque (i,ter(1,i),fix,fiy,fiz,der)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (rscale)
      deallocate (ter)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine erepel1b  --  Pauli repulsion derivs via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "erepel1b" calculates the Pauli repulsion energy and first
c     derivatives with respect to Cartesian coordinates using a
c     pariwise neighbor list
c
c
      subroutine erepel1b
      use atoms
      use bound
      use couple
      use deriv
      use energi
      use group
      use inform
      use mpole
      use mutant
      use neigh
      use repel
      use reppot
      use shunt
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      integer ix,iy,iz
      real*8 e,fgrp
      real*8 eterm,de
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 r,r2,r3,r4,r5
      real*8 rr1,rr3,rr5
      real*8 rr7,rr9,rr11
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 dirx,diry,dirz
      real*8 dkrx,dkry,dkrz
      real*8 dikx,diky,dikz
      real*8 qirx,qiry,qirz
      real*8 qkrx,qkry,qkrz
      real*8 qikx,qiky,qikz
      real*8 qixk,qiyk,qizk
      real*8 qkxi,qkyi,qkzi
      real*8 qikrx,qikry,qikrz
      real*8 qkirx,qkiry,qkirz
      real*8 diqkx,diqky,diqkz
      real*8 dkqix,dkqiy,dkqiz
      real*8 diqkrx,diqkry,diqkrz
      real*8 dkqirx,dkqiry,dkqirz
      real*8 dqikx,dqiky,dqikz
      real*8 term1,term2,term3
      real*8 term4,term5,term6
      real*8 vlambda3,vlambda4
      real*8 vlambda5
      real*8 sizi,sizk,sizik
      real*8 vali,valk
      real*8 dmpi,dmpk
      real*8 frcx,frcy,frcz
      real*8 term,soft,dsoft
      real*8 taper,dtaper
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 ttri(3),ttrk(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 dmpik(11)
      real*8, allocatable :: rscale(:)
      real*8, allocatable :: ter(:,:)
      logical proceed,usei
      logical muti,mutk,mutik
      character*6 mode
c
c
c     zero out the Pauli repulsion energy and derivatives
c
      er = 0.0d0
      do i = 1, n
         der(1,i) = 0.0d0
         der(2,i) = 0.0d0
         der(3,i) = 0.0d0
      end do
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('REPEL')
c
c     perform dynamic allocation of some local arrays
c
      allocate (rscale(n))
      allocate (ter(3,n))
c
c     initialize connected atom scaling and torque arrays
c
      do i = 1, n
         rscale(i) = 1.0d0
         do j = 1, 3
            ter(j,i) = 0.0d0
         end do
      end do
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vlambda3 = vlambda**3
         vlambda4 = vlambda3 * vlambda
         vlambda5 = vlambda4 * vlambda
      end if
c
c     set cutoff distances and switching coefficients
c
      mode = 'REPULS'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(nrep,irep,x,y,z,sizpr,dmppr,elepr,rrepole,n12,i12,
!$OMP& n13,i13,n14,i14,n15,i15,r2scale,r3scale,r4scale,r5scale,
!$OMP& nelst,elst,use,use_group,use_intra,use_bounds,vcouple,
!$OMP& vlambda3,vlambda4,vlambda5,mut,cut2,off2,xaxis,yaxis,zaxis,
!$OMP& c0,c1,c2,c3,c4,c5)
!$OMP& firstprivate(rscale) shared (er,der,ter,vir)
!$OMP DO reduction(+:er,der,ter,vir)
c
c     calculate the Pauli repulsion energy and derivatives
c
      do ii = 1, nrep
         i = irep(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         sizi = sizpr(i)
         dmpi = dmppr(i)
         vali = elepr(i)
         ci = rrepole(1,i)
         dix = rrepole(2,i)
         diy = rrepole(3,i)
         diz = rrepole(4,i)
         qixx = rrepole(5,i)
         qixy = rrepole(6,i)
         qixz = rrepole(7,i)
         qiyy = rrepole(9,i)
         qiyz = rrepole(10,i)
         qizz = rrepole(13,i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = r2scale
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = r3scale
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = r4scale
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = r5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = irep(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  sizk = sizpr(k)
                  dmpk = dmppr(k)
                  valk = elepr(k)
                  ck = rrepole(1,k)
                  dkx = rrepole(2,k)
                  dky = rrepole(3,k)
                  dkz = rrepole(4,k)
                  qkxx = rrepole(5,k)
                  qkxy = rrepole(6,k)
                  qkxz = rrepole(7,k)
                  qkyy = rrepole(9,k)
                  qkyz = rrepole(10,k)
                  qkzz = rrepole(13,k)
c
c     intermediates involving moments and separation distance
c
                  dir = dix*xr + diy*yr + diz*zr
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qir = qix*xr + qiy*yr + qiz*zr
                  dkr = dkx*xr + dky*yr + dkz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
                  qkr = qkx*xr + qky*yr + qkz*zr
                  dik = dix*dkx + diy*dky + diz*dkz
                  qik = qix*qkx + qiy*qky + qiz*qkz
                  diqk = dix*qkx + diy*qky + diz*qkz
                  dkqi = dkx*qix + dky*qiy + dkz*qiz
                  qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                      + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
                  dirx = diy*zr - diz*yr
                  diry = diz*xr - dix*zr
                  dirz = dix*yr - diy*xr
                  dkrx = dky*zr - dkz*yr
                  dkry = dkz*xr - dkx*zr
                  dkrz = dkx*yr - dky*xr
                  dikx = diy*dkz - diz*dky
                  diky = diz*dkx - dix*dkz
                  dikz = dix*dky - diy*dkx
                  qirx = qiz*yr - qiy*zr
                  qiry = qix*zr - qiz*xr
                  qirz = qiy*xr - qix*yr
                  qkrx = qkz*yr - qky*zr
                  qkry = qkx*zr - qkz*xr
                  qkrz = qky*xr - qkx*yr
                  qikx = qky*qiz - qkz*qiy
                  qiky = qkz*qix - qkx*qiz
                  qikz = qkx*qiy - qky*qix
                  qixk = qixx*qkx + qixy*qky + qixz*qkz
                  qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
                  qizk = qixz*qkx + qiyz*qky + qizz*qkz
                  qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
                  qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
                  qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
                  qikrx = qizk*yr - qiyk*zr
                  qikry = qixk*zr - qizk*xr
                  qikrz = qiyk*xr - qixk*yr
                  qkirx = qkzi*yr - qkyi*zr
                  qkiry = qkxi*zr - qkzi*xr
                  qkirz = qkyi*xr - qkxi*yr
                  diqkx = dix*qkxx + diy*qkxy + diz*qkxz
                  diqky = dix*qkxy + diy*qkyy + diz*qkyz
                  diqkz = dix*qkxz + diy*qkyz + diz*qkzz
                  dkqix = dkx*qixx + dky*qixy + dkz*qixz
                  dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
                  dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
                  diqkrx = diqkz*yr - diqky*zr
                  diqkry = diqkx*zr - diqkz*xr
                  diqkrz = diqky*xr - diqkx*yr
                  dkqirx = dkqiz*yr - dkqiy*zr
                  dkqiry = dkqix*zr - dkqiz*xr
                  dkqirz = dkqiy*xr - dkqix*yr
                  dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                    - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                            -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
                  dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                    - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                            -qixx*qkxz-qixy*qkyz-qixz*qkzz)
                  dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                    - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                            -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
                  rr1 = 1.0d0 / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
                  rr11 = 9.0d0 * rr9 / r2
c
c     get damping coefficients for the Pauli repulsion energy
c
                  call damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11,
     &                             11,dmpi,dmpk,dmpik)                  
c
c     calculate intermediate terms needed for the energy
c
                  term1 = vali*valk
                  term2 = valk*dir - vali*dkr + dik
                  term3 = vali*qkr + valk*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  eterm = term1*dmpik(1) + term2*dmpik(3)
     &                       + term3*dmpik(5) + term4*dmpik(7)
     &                       + term5*dmpik(9)
c
c     compute the Pauli repulsion energy for this interaction
c
                  sizik = sizi * sizk * rscale(k)
                  e = sizik * eterm * rr1
c
c     calculate intermediate terms for force and torque
c
                  de = term1*dmpik(3) + term2*dmpik(5)
     &                    + term3*dmpik(7) + term4*dmpik(9)
     &                    + term5*dmpik(11)
                  term1 = -valk*dmpik(3) + dkr*dmpik(5)
     &                       - qkr*dmpik(7)
                  term2 = vali*dmpik(3) + dir*dmpik(5)
     &                       + qir*dmpik(7)
                  term3 = 2.0d0 * dmpik(5)
                  term4 = 2.0d0 * (-valk*dmpik(5) + dkr*dmpik(7)
     &                                - qkr*dmpik(9))
                  term5 = 2.0d0 * (-vali*dmpik(5) - dir*dmpik(7)
     &                                - qir*dmpik(9))
                  term6 = 4.0d0 * dmpik(7)
c     
c     compute the force components for this interaction
c     
                  frcx = de*xr + term1*dix + term2*dkx
     &                      + term3*(diqkx-dkqix) + term4*qix
     &                      + term5*qkx + term6*(qixk+qkxi)
                  frcy = de*yr + term1*diy + term2*dky
     &                      + term3*(diqky-dkqiy) + term4*qiy
     &                      + term5*qky + term6*(qiyk+qkyi)
                  frcz = de*zr + term1*diz + term2*dkz
     &                      + term3*(diqkz-dkqiz) + term4*qiz
     &                      + term5*qkz + term6*(qizk+qkzi)
                  frcx = frcx*rr1 + eterm*rr3*xr
                  frcy = frcy*rr1 + eterm*rr3*yr
                  frcz = frcz*rr1 + eterm*rr3*zr
                  frcx = sizik * frcx
                  frcy = sizik * frcy
                  frcz = sizik * frcz
c
c     compute the torque components for this interaction
c
                  ttri(1) = -dmpik(3)*dikx + term1*dirx
     &                         + term3*(dqikx+dkqirx)
     &                         - term4*qirx - term6*(qikrx+qikx)
                  ttri(2) = -dmpik(3)*diky + term1*diry
     &                         + term3*(dqiky+dkqiry)
     &                         - term4*qiry - term6*(qikry+qiky)
                  ttri(3) = -dmpik(3)*dikz + term1*dirz
     &                         + term3*(dqikz+dkqirz)
     &                         - term4*qirz - term6*(qikrz+qikz)
                  ttrk(1) = dmpik(3)*dikx + term2*dkrx
     &                         - term3*(dqikx+diqkrx)
     &                         - term5*qkrx - term6*(qkirx-qikx)
                  ttrk(2) = dmpik(3)*diky + term2*dkry
     &                         - term3*(dqiky+diqkry)
     &                         - term5*qkry - term6*(qkiry-qiky)
                  ttrk(3) = dmpik(3)*dikz + term2*dkrz
     &                         - term3*(dqikz+diqkrz)
     &                         - term5*qkrz - term6*(qkirz-qikz)
                  ttri(1) = sizik * ttri(1) * rr1
                  ttri(2) = sizik * ttri(2) * rr1
                  ttri(3) = sizik * ttri(3) * rr1
                  ttrk(1) = sizik * ttrk(1) * rr1
                  ttrk(2) = sizik * ttrk(2) * rr1
                  ttrk(3) = sizik * ttrk(3) * rr1
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = fgrp * e
                     frcx = fgrp * frcx
                     frcy = fgrp * frcy
                     frcz = fgrp * frcz
                     do j = 1, 3
                        ttri(j) = fgrp * ttri(j)
                        ttrk(j) = fgrp * ttrk(j)
                     end do
                  end if
c
c     set lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get energy and force via soft core lambda scaling
c
                  if (mutik) then
                     term = vlambda3 - vlambda4 + r2
                     soft = vlambda5 * r / sqrt(term)
                     dsoft = soft * (rr1-r/term)
                     dsoft = dsoft * rr1 * e
                     frcx = frcx*soft - dsoft*xr
                     frcy = frcy*soft - dsoft*yr
                     frcz = frcz*soft - dsoft*zr
                     do j = 1, 3
                        ttri(j) = ttri(j) * soft
                        ttrk(j) = ttrk(j) * soft
                     end do
                     e = soft * e
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     dtaper = dtaper * e * rr1
                     e = e * taper
                     frcx = frcx*taper - dtaper*xr
                     frcy = frcy*taper - dtaper*yr
                     frcz = frcz*taper - dtaper*zr
                     do j = 1, 3
                        ttri(j) = ttri(j) * taper
                        ttrk(j) = ttrk(j) * taper
                     end do
                  end if
c
c     increment the overall Pauli repulsion energy component
c
                  er = er + e
c
c     increment force-based gradient and torque on first site
c
                  der(1,i) = der(1,i) + frcx
                  der(2,i) = der(2,i) + frcy
                  der(3,i) = der(3,i) + frcz
                  ter(1,i) = ter(1,i) + ttri(1)
                  ter(2,i) = ter(2,i) + ttri(2)
                  ter(3,i) = ter(3,i) + ttri(3)
c
c     increment force-based gradient and torque on second site
c
                  der(1,k) = der(1,k) - frcx
                  der(2,k) = der(2,k) - frcy
                  der(3,k) = der(3,k) - frcz
                  ter(1,k) = ter(1,k) + ttrk(1)
                  ter(2,k) = ter(2,k) + ttrk(2)
                  ter(3,k) = ter(3,k) + ttrk(3)
c
c     increment the virial due to pairwise Cartesian forces
c
                  vxx = -xr * frcx
                  vxy = -0.5d0 * (yr*frcx+xr*frcy)
                  vxz = -0.5d0 * (zr*frcx+xr*frcz)
                  vyy = -yr * frcy
                  vyz = -0.5d0 * (zr*frcy+yr*frcz)
                  vzz = -zr * frcz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vxy
                  vir(3,1) = vir(3,1) + vxz
                  vir(1,2) = vir(1,2) + vxy
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vyz
                  vir(1,3) = vir(1,3) + vxz
                  vir(2,3) = vir(2,3) + vyz
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP DO reduction(+:der,vir)
c
c     resolve site torques then increment forces and virial
c
      do ii = 1, nrep
         i = irep(ii)
         call torque (i,ter(1,i),fix,fiy,fiz,der)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (rscale)
      deallocate (ter)
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine erepel2  --  atomwise Pauli repulsion Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "erepel2" calculates the second derivatives of the Pauli
c     repulsion energy
c
c     literature reference:
c
c     J. A. Rackers and J. W. Ponder, "Classical Pauli Repulsion:
c     An Anisotropic, Atomic Multipole Model", Journal of Chemical
c     Physics, 150, 084104 (2019)
c
c
      subroutine erepel2 (i)
      use atoms
      use deriv
      use hessn
      use mpole
      use potent
      use repel
      implicit none
      integer i,j,k,kk
      integer nlist
      integer, allocatable :: list(:)
      real*8 eps,old
      real*8, allocatable :: d0(:,:)
      logical prior
      logical twosided
c
c
c     set the default stepsize and accuracy control flags
c
      eps = 1.0d-5
      twosided = .false.
      if (n .le. 300)  twosided = .true.
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
      allocate (d0(3,n))
c
c     perform dynamic allocation of some global arrays
c
      prior = .false.
      if (allocated(der)) then
         prior = .true.
         if (size(der) .lt. 3*n)  deallocate (der)
      end if
      if (.not. allocated(der))  allocate (der(3,n))
c
c     find the multipole definitions involving the current atom;
c     results in a faster but approximate Hessian calculation
c
      nlist = 0
      do kk = 1, nrep
         k = irep(kk)
         if (k.eq.i .or. zaxis(k).eq.i .or. xaxis(k).eq.i
     &          .or. abs(yaxis(k)).eq.i) then
            nlist = nlist + 1
            list(nlist) = k
         end if
      end do
c
c     get repulsion first derivatives for the base structure
c
      if (.not. twosided) then
         call erepel2a (nlist,list)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = der(j,k)
            end do
         end do
      end if
c
c     find numerical x-components via perturbed structures
c
      old = x(i)
      if (twosided) then
         x(i) = x(i) - 0.5d0*eps
         call erepel2a (nlist,list)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = der(j,k)
            end do
         end do
      end if
      x(i) = x(i) + eps
      call erepel2a (nlist,list)
      x(i) = old
      do k = 1, n
         do j = 1, 3
            hessx(j,k) = hessx(j,k) + (der(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical y-components via perturbed structures
c
      old = y(i)
      if (twosided) then
         y(i) = y(i) - 0.5d0*eps
         call erepel2a (nlist,list)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = der(j,k)
            end do
         end do
      end if
      y(i) = y(i) + eps
      call erepel2a (nlist,list)
      y(i) = old
      do k = 1, n
         do j = 1, 3
            hessy(j,k) = hessy(j,k) + (der(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical z-components via perturbed structures
c
      old = z(i)
      if (twosided) then
         z(i) = z(i) - 0.5d0*eps
         call erepel2a (nlist,list)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = der(j,k)
            end do
         end do
      end if
      z(i) = z(i) + eps
      call erepel2a (nlist,list)
      z(i) = old
      do k = 1, n
         do j = 1, 3
            hessz(j,k) = hessz(j,k) + (der(j,k)-d0(j,k))/eps
         end do
      end do
c
c     perform deallocation of some global arrays
c
      if (.not. prior)  deallocate (der)
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (d0)
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine erepel2a  --  numerical repulsion Hessian  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "erepel2a" computes Pauli repulsion first derivatives for a
c     single atom via a double loop; used to get finite difference
c     second derivatives
c
c
      subroutine erepel2a (nlist,list)
      use atoms
      use bound
      use cell
      use couple
      use deriv
      use group
      use mpole
      use potent
      use repel
      use reppot
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk,iii
      integer nlist,jcell
      integer list(*)
      real*8 e,fgrp
      real*8 eterm,de
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4,r5
      real*8 rr1,rr3,rr5
      real*8 rr7,rr9,rr11
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 dirx,diry,dirz
      real*8 dkrx,dkry,dkrz
      real*8 dikx,diky,dikz
      real*8 qirx,qiry,qirz
      real*8 qkrx,qkry,qkrz
      real*8 qikx,qiky,qikz
      real*8 qixk,qiyk,qizk
      real*8 qkxi,qkyi,qkzi
      real*8 qikrx,qikry,qikrz
      real*8 qkirx,qkiry,qkirz
      real*8 diqkx,diqky,diqkz
      real*8 dkqix,dkqiy,dkqiz
      real*8 diqkrx,diqkry,diqkrz
      real*8 dkqirx,dkqiry,dkqirz
      real*8 dqikx,dqiky,dqikz
      real*8 term1,term2,term3
      real*8 term4,term5,term6
      real*8 sizi,sizk,sizik
      real*8 vali,valk
      real*8 dmpi,dmpk
      real*8 frcx,frcy,frcz
      real*8 taper,dtaper
      real*8 ttri(3),ttrk(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 dmpik(11)
      real*8, allocatable :: rscale(:)
      real*8, allocatable :: ter(:,:)
      logical proceed,usei
      character*6 mode
c
c
c     zero out the Pauli repulsion first derivative components
c
      do i = 1, n
         der(1,i) = 0.0d0
         der(2,i) = 0.0d0
         der(3,i) = 0.0d0
      end do
      if (nrep .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('REPEL')
c
c     compute the induced dipoles at each polarizable atom
c
      if (.not. use_polar) then
         use_polar = .true.
         call induce
         use_polar = .false.
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (rscale(n))
      allocate (ter(3,n))
c
c     initialize connected atom scaling and torque arrays
c
      do i = 1, n
         rscale(i) = 1.0d0
         do j = 1, 3
            ter(j,i) = 0.0d0
         end do
      end do
c
c     set cutoff distances and switching coefficients
c
      mode = 'REPULS'
      call switch (mode)
c
c     compute the Pauli repulsion first derivatives
c
      do iii = 1, nlist
         ii = list(iii)
         i = irep(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         sizi = sizpr(i)
         dmpi = dmppr(i)
         vali = elepr(i)
         ci = rrepole(1,i)
         dix = rrepole(2,i)
         diy = rrepole(3,i)
         diz = rrepole(4,i)
         qixx = rrepole(5,i)
         qixy = rrepole(6,i)
         qixz = rrepole(7,i)
         qiyy = rrepole(9,i)
         qiyz = rrepole(10,i)
         qizz = rrepole(13,i)
         usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = r2scale
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = r3scale
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = r4scale
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = r5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, nrep
            k = irep(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (ii .eq. kk)  proceed = .false.
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  sizk = sizpr(k)
                  dmpk = dmppr(k)
                  valk = elepr(k)
                  ck = rrepole(1,k)
                  dkx = rrepole(2,k)
                  dky = rrepole(3,k)
                  dkz = rrepole(4,k)
                  qkxx = rrepole(5,k)
                  qkxy = rrepole(6,k)
                  qkxz = rrepole(7,k)
                  qkyy = rrepole(9,k)
                  qkyz = rrepole(10,k)
                  qkzz = rrepole(13,k)
c
c     intermediates involving moments and separation distance
c
                  dir = dix*xr + diy*yr + diz*zr
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qir = qix*xr + qiy*yr + qiz*zr
                  dkr = dkx*xr + dky*yr + dkz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
                  qkr = qkx*xr + qky*yr + qkz*zr
                  dik = dix*dkx + diy*dky + diz*dkz
                  qik = qix*qkx + qiy*qky + qiz*qkz
                  diqk = dix*qkx + diy*qky + diz*qkz
                  dkqi = dkx*qix + dky*qiy + dkz*qiz
                  qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                      + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
                  dirx = diy*zr - diz*yr
                  diry = diz*xr - dix*zr
                  dirz = dix*yr - diy*xr
                  dkrx = dky*zr - dkz*yr
                  dkry = dkz*xr - dkx*zr
                  dkrz = dkx*yr - dky*xr
                  dikx = diy*dkz - diz*dky
                  diky = diz*dkx - dix*dkz
                  dikz = dix*dky - diy*dkx
                  qirx = qiz*yr - qiy*zr
                  qiry = qix*zr - qiz*xr
                  qirz = qiy*xr - qix*yr
                  qkrx = qkz*yr - qky*zr
                  qkry = qkx*zr - qkz*xr
                  qkrz = qky*xr - qkx*yr
                  qikx = qky*qiz - qkz*qiy
                  qiky = qkz*qix - qkx*qiz
                  qikz = qkx*qiy - qky*qix
                  qixk = qixx*qkx + qixy*qky + qixz*qkz
                  qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
                  qizk = qixz*qkx + qiyz*qky + qizz*qkz
                  qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
                  qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
                  qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
                  qikrx = qizk*yr - qiyk*zr
                  qikry = qixk*zr - qizk*xr
                  qikrz = qiyk*xr - qixk*yr
                  qkirx = qkzi*yr - qkyi*zr
                  qkiry = qkxi*zr - qkzi*xr
                  qkirz = qkyi*xr - qkxi*yr
                  diqkx = dix*qkxx + diy*qkxy + diz*qkxz
                  diqky = dix*qkxy + diy*qkyy + diz*qkyz
                  diqkz = dix*qkxz + diy*qkyz + diz*qkzz
                  dkqix = dkx*qixx + dky*qixy + dkz*qixz
                  dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
                  dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
                  diqkrx = diqkz*yr - diqky*zr
                  diqkry = diqkx*zr - diqkz*xr
                  diqkrz = diqky*xr - diqkx*yr
                  dkqirx = dkqiz*yr - dkqiy*zr
                  dkqiry = dkqix*zr - dkqiz*xr
                  dkqirz = dkqiy*xr - dkqix*yr
                  dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                    - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                            -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
                  dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                    - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                            -qixx*qkxz-qixy*qkyz-qixz*qkzz)
                  dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                    - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                            -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
                  rr1 = 1.0d0 / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
                  rr11 = 9.0d0 * rr9 / r2
c
c     get damping coefficients for the Pauli repulsion energy
c
                  call damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11,
     &                             11,dmpi,dmpk,dmpik)                  
c
c     calculate intermediate terms needed for the energy
c
                  term1 = vali*valk
                  term2 = valk*dir - vali*dkr + dik
                  term3 = vali*qkr + valk*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  eterm = term1*dmpik(1) + term2*dmpik(3)
     &                       + term3*dmpik(5) + term4*dmpik(7)
     &                       + term5*dmpik(9)
c
c     compute the Pauli repulsion energy for this interaction
c
                  sizik = sizi * sizk * rscale(k)
                  e = sizik * eterm * rr1
c
c     calculate intermediate terms for force and torque
c
                  de = term1*dmpik(3) + term2*dmpik(5)
     &                    + term3*dmpik(7) + term4*dmpik(9)
     &                    + term5*dmpik(11)
                  term1 = -valk*dmpik(3) + dkr*dmpik(5)
     &                       - qkr*dmpik(7)
                  term2 = vali*dmpik(3) + dir*dmpik(5)
     &                       + qir*dmpik(7)
                  term3 = 2.0d0 * dmpik(5)
                  term4 = 2.0d0 * (-valk*dmpik(5) + dkr*dmpik(7)
     &                                - qkr*dmpik(9))
                  term5 = 2.0d0 * (-vali*dmpik(5) - dir*dmpik(7)
     &                                - qir*dmpik(9))
                  term6 = 4.0d0 * dmpik(7)
c     
c     compute the force components for this interaction
c     
                  frcx = de*xr + term1*dix + term2*dkx
     &                      + term3*(diqkx-dkqix) + term4*qix
     &                      + term5*qkx + term6*(qixk+qkxi)
                  frcy = de*yr + term1*diy + term2*dky
     &                      + term3*(diqky-dkqiy) + term4*qiy
     &                      + term5*qky + term6*(qiyk+qkyi)
                  frcz = de*zr + term1*diz + term2*dkz
     &                      + term3*(diqkz-dkqiz) + term4*qiz
     &                      + term5*qkz + term6*(qizk+qkzi)
                  frcx = frcx*rr1 + eterm*rr3*xr
                  frcy = frcy*rr1 + eterm*rr3*yr
                  frcz = frcz*rr1 + eterm*rr3*zr
                  frcx = sizik * frcx
                  frcy = sizik * frcy
                  frcz = sizik * frcz
c
c     compute the torque components for this interaction
c
                  ttri(1) = -dmpik(3)*dikx + term1*dirx
     &                         + term3*(dqikx+dkqirx)
     &                         - term4*qirx - term6*(qikrx+qikx)
                  ttri(2) = -dmpik(3)*diky + term1*diry
     &                         + term3*(dqiky+dkqiry)
     &                         - term4*qiry - term6*(qikry+qiky)
                  ttri(3) = -dmpik(3)*dikz + term1*dirz
     &                         + term3*(dqikz+dkqirz)
     &                         - term4*qirz - term6*(qikrz+qikz)
                  ttrk(1) = dmpik(3)*dikx + term2*dkrx
     &                         - term3*(dqikx+diqkrx)
     &                         - term5*qkrx - term6*(qkirx-qikx)
                  ttrk(2) = dmpik(3)*diky + term2*dkry
     &                         - term3*(dqiky+diqkry)
     &                         - term5*qkry - term6*(qkiry-qiky)
                  ttrk(3) = dmpik(3)*dikz + term2*dkrz
     &                         - term3*(dqikz+diqkrz)
     &                         - term5*qkrz - term6*(qkirz-qikz)
                  ttri(1) = sizik * ttri(1) * rr1
                  ttri(2) = sizik * ttri(2) * rr1
                  ttri(3) = sizik * ttri(3) * rr1
                  ttrk(1) = sizik * ttrk(1) * rr1
                  ttrk(2) = sizik * ttrk(2) * rr1
                  ttrk(3) = sizik * ttrk(3) * rr1
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = fgrp * e
                     frcx = fgrp * frcx
                     frcy = fgrp * frcy
                     frcz = fgrp * frcz
                     do j = 1, 3
                        ttri(j) = fgrp * ttri(j)
                        ttrk(j) = fgrp * ttrk(j)
                     end do
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     dtaper = dtaper * e * rr1
                     frcx = frcx*taper - dtaper*xr
                     frcy = frcy*taper - dtaper*yr
                     frcz = frcz*taper - dtaper*zr
                     do j = 1, 3
                        ttri(j) = ttri(j) * taper
                        ttrk(j) = ttrk(j) * taper
                     end do
                  end if
c
c     increment force-based gradient and torque on first site
c
                  der(1,i) = der(1,i) + frcx
                  der(2,i) = der(2,i) + frcy
                  der(3,i) = der(3,i) + frcz
                  ter(1,i) = ter(1,i) + ttri(1)
                  ter(2,i) = ter(2,i) + ttri(2)
                  ter(3,i) = ter(3,i) + ttri(3)
c
c     increment force-based gradient and torque on second site
c
                  der(1,k) = der(1,k) - frcx
                  der(2,k) = der(2,k) - frcy
                  der(3,k) = der(3,k) - frcz
                  ter(1,k) = ter(1,k) + ttrk(1)
                  ter(2,k) = ter(2,k) + ttrk(2)
                  ter(3,k) = ter(3,k) + ttrk(3)
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction components with other unit cells
c
         do iii = 1, nlist
            ii = list(iii)
            i = irep(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            sizi = sizpr(i)
            dmpi = dmppr(i)
            vali = elepr(i)
            ci = rrepole(1,i)
            dix = rrepole(2,i)
            diy = rrepole(3,i)
            diz = rrepole(4,i)
            qixx = rrepole(5,i)
            qixy = rrepole(6,i)
            qixz = rrepole(7,i)
            qiyy = rrepole(9,i)
            qiyz = rrepole(10,i)
            qizz = rrepole(13,i)
            usei = use(i)
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               rscale(i12(j,i)) = r2scale
            end do
            do j = 1, n13(i)
               rscale(i13(j,i)) = r3scale
            end do
            do j = 1, n14(i)
               rscale(i14(j,i)) = r4scale
            end do
            do j = 1, n15(i)
               rscale(i15(j,i)) = r5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = 1, nrep
               k = irep(kk)
               proceed = .true.
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               if (.not. use_intra)  proceed = .true.
               if (proceed)  proceed = (usei .or. use(k))
               if (proceed) then
                  do jcell = 2, ncell
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     call imager (xr,yr,zr,jcell)
                     r2 = xr*xr + yr* yr + zr*zr
                     if (r2 .le. off2) then
                        r = sqrt(r2)
                        sizk = sizpr(k)
                        dmpk = dmppr(k)
                        valk = elepr(k)
                        ck = rrepole(1,k)
                        dkx = rrepole(2,k)
                        dky = rrepole(3,k)
                        dkz = rrepole(4,k)
                        qkxx = rrepole(5,k)
                        qkxy = rrepole(6,k)
                        qkxz = rrepole(7,k)
                        qkyy = rrepole(9,k)
                        qkyz = rrepole(10,k)
                        qkzz = rrepole(13,k)
c
c     intermediates involving moments and separation distance
c
                        dir = dix*xr + diy*yr + diz*zr
                        qix = qixx*xr + qixy*yr + qixz*zr
                        qiy = qixy*xr + qiyy*yr + qiyz*zr
                        qiz = qixz*xr + qiyz*yr + qizz*zr
                        qir = qix*xr + qiy*yr + qiz*zr
                        dkr = dkx*xr + dky*yr + dkz*zr
                        qkx = qkxx*xr + qkxy*yr + qkxz*zr
                        qky = qkxy*xr + qkyy*yr + qkyz*zr
                        qkz = qkxz*xr + qkyz*yr + qkzz*zr
                        qkr = qkx*xr + qky*yr + qkz*zr
                        dik = dix*dkx + diy*dky + diz*dkz
                        qik = qix*qkx + qiy*qky + qiz*qkz
                        diqk = dix*qkx + diy*qky + diz*qkz
                        dkqi = dkx*qix + dky*qiy + dkz*qiz
                        qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                            + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     additional intermediates involving moments and distance
c
                        dirx = diy*zr - diz*yr
                        diry = diz*xr - dix*zr
                        dirz = dix*yr - diy*xr
                        dkrx = dky*zr - dkz*yr
                        dkry = dkz*xr - dkx*zr
                        dkrz = dkx*yr - dky*xr
                        dikx = diy*dkz - diz*dky
                        diky = diz*dkx - dix*dkz
                        dikz = dix*dky - diy*dkx
                        qirx = qiz*yr - qiy*zr
                        qiry = qix*zr - qiz*xr
                        qirz = qiy*xr - qix*yr
                        qkrx = qkz*yr - qky*zr
                        qkry = qkx*zr - qkz*xr
                        qkrz = qky*xr - qkx*yr
                        qikx = qky*qiz - qkz*qiy
                        qiky = qkz*qix - qkx*qiz
                        qikz = qkx*qiy - qky*qix
                        qixk = qixx*qkx + qixy*qky + qixz*qkz
                        qiyk = qixy*qkx + qiyy*qky + qiyz*qkz
                        qizk = qixz*qkx + qiyz*qky + qizz*qkz
                        qkxi = qkxx*qix + qkxy*qiy + qkxz*qiz
                        qkyi = qkxy*qix + qkyy*qiy + qkyz*qiz
                        qkzi = qkxz*qix + qkyz*qiy + qkzz*qiz
                        qikrx = qizk*yr - qiyk*zr
                        qikry = qixk*zr - qizk*xr
                        qikrz = qiyk*xr - qixk*yr
                        qkirx = qkzi*yr - qkyi*zr
                        qkiry = qkxi*zr - qkzi*xr
                        qkirz = qkyi*xr - qkxi*yr
                        diqkx = dix*qkxx + diy*qkxy + diz*qkxz
                        diqky = dix*qkxy + diy*qkyy + diz*qkyz
                        diqkz = dix*qkxz + diy*qkyz + diz*qkzz
                        dkqix = dkx*qixx + dky*qixy + dkz*qixz
                        dkqiy = dkx*qixy + dky*qiyy + dkz*qiyz
                        dkqiz = dkx*qixz + dky*qiyz + dkz*qizz
                        diqkrx = diqkz*yr - diqky*zr
                        diqkry = diqkx*zr - diqkz*xr
                        diqkrz = diqky*xr - diqkx*yr
                        dkqirx = dkqiz*yr - dkqiy*zr
                        dkqiry = dkqix*zr - dkqiz*xr
                        dkqirz = dkqiy*xr - dkqix*yr
                        dqikx = diy*qkz - diz*qky + dky*qiz - dkz*qiy
     &                          - 2.0d0*(qixy*qkxz+qiyy*qkyz+qiyz*qkzz
     &                                  -qixz*qkxy-qiyz*qkyy-qizz*qkyz)
                        dqiky = diz*qkx - dix*qkz + dkz*qix - dkx*qiz
     &                          - 2.0d0*(qixz*qkxx+qiyz*qkxy+qizz*qkxz
     &                                  -qixx*qkxz-qixy*qkyz-qixz*qkzz)
                        dqikz = dix*qky - diy*qkx + dkx*qiy - dky*qix
     &                          - 2.0d0*(qixx*qkxy+qixy*qkyy+qixz*qkyz
     &                                  -qixy*qkxx-qiyy*qkxy-qiyz*qkxz)
c
c     get reciprocal distance terms for this interaction
c
                        rr1 = 1.0d0 / r
                        rr3 = rr1 / r2
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr9 = 7.0d0 * rr7 / r2
                        rr11 = 9.0d0 * rr9 / r2
c
c     get damping coefficients for the Pauli repulsion energy
c
                        call damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11,
     &                                   11,dmpi,dmpk,dmpik)                  
c
c     compute the Pauli repulsion energy for this interaction
c
                        term1 = vali*valk
                        term2 = valk*dir - vali*dkr + dik
                        term3 = vali*qkr + valk*qir - dir*dkr
     &                             + 2.0d0*(dkqi-diqk+qiqk)
                        term4 = dir*qkr - dkr*qir - 4.0d0*qik
                        term5 = qir*qkr
                        eterm = term1*dmpik(1) + term2*dmpik(3)
     &                             + term3*dmpik(5) + term4*dmpik(7)
     &                             + term5*dmpik(9)
c
c     compute the Pauli repulsion energy for this interaction
c
                        sizik = sizi * sizk * rscale(k)
                        e = sizik * eterm * rr1
c
c     calculate intermediate terms for force and torque
c
                        de = term1*dmpik(3) + term2*dmpik(5)
     &                          + term3*dmpik(7) + term4*dmpik(9)
     &                          + term5*dmpik(11)
                        term1 = -valk*dmpik(3) + dkr*dmpik(5)
     &                             - qkr*dmpik(7)
                        term2 = vali*dmpik(3) + dir*dmpik(5)
     &                             + qir*dmpik(7)
                        term3 = 2.0d0 * dmpik(5)
                        term4 = 2.0d0 * (-valk*dmpik(5) + dkr*dmpik(7)
     &                                      - qkr*dmpik(9))
                        term5 = 2.0d0 * (-vali*dmpik(5) - dir*dmpik(7)
     &                                      - qir*dmpik(9))
                        term6 = 4.0d0 * dmpik(7)
c     
c     compute the force components for this interaction
c     
                        frcx = de*xr + term1*dix + term2*dkx
     &                            + term3*(diqkx-dkqix) + term4*qix
     &                            + term5*qkx + term6*(qixk+qkxi)
                        frcy = de*yr + term1*diy + term2*dky
     &                            + term3*(diqky-dkqiy) + term4*qiy
     &                            + term5*qky + term6*(qiyk+qkyi)
                        frcz = de*zr + term1*diz + term2*dkz
     &                            + term3*(diqkz-dkqiz) + term4*qiz
     &                            + term5*qkz + term6*(qizk+qkzi)
                        frcx = frcx*rr1 + eterm*rr3*xr
                        frcy = frcy*rr1 + eterm*rr3*yr
                        frcz = frcz*rr1 + eterm*rr3*zr
                        frcx = sizik * frcx
                        frcy = sizik * frcy
                        frcz = sizik * frcz
c
c     compute the torque components for this interaction
c
                        ttri(1) = -dmpik(3)*dikx + term1*dirx
     &                               + term3*(dqikx+dkqirx)
     &                               - term4*qirx - term6*(qikrx+qikx)
                        ttri(2) = -dmpik(3)*diky + term1*diry
     &                               + term3*(dqiky+dkqiry)
     &                               - term4*qiry - term6*(qikry+qiky)
                        ttri(3) = -dmpik(3)*dikz + term1*dirz
     &                               + term3*(dqikz+dkqirz)
     &                               - term4*qirz - term6*(qikrz+qikz)
                        ttrk(1) = dmpik(3)*dikx + term2*dkrx
     &                               - term3*(dqikx+diqkrx)
     &                               - term5*qkrx - term6*(qkirx-qikx)
                        ttrk(2) = dmpik(3)*diky + term2*dkry
     &                               - term3*(dqiky+diqkry)
     &                               - term5*qkry - term6*(qkiry-qiky)
                        ttrk(3) = dmpik(3)*dikz + term2*dkrz
     &                               - term3*(dqikz+diqkrz)
     &                               - term5*qkrz - term6*(qkirz-qikz)
                        ttri(1) = sizik * ttri(1) * rr1
                        ttri(2) = sizik * ttri(2) * rr1
                        ttri(3) = sizik * ttri(3) * rr1
                        ttrk(1) = sizik * ttrk(1) * rr1
                        ttrk(2) = sizik * ttrk(2) * rr1
                        ttrk(3) = sizik * ttrk(3) * rr1
c
c     scale the interaction based on its group membership
c
                        if (use_group) then
                           e = fgrp * e
                           frcx = fgrp * frcx
                           frcy = fgrp * frcy
                           frcz = fgrp * frcz
                           do j = 1, 3
                              ttri(j) = fgrp * ttri(j)
                              ttrk(j) = fgrp * ttrk(j)
                           end do
                        end if
c
c     use energy switching if near the cutoff distance
c
                        if (r2 .gt. cut2) then
                           r3 = r2 * r
                           r4 = r2 * r2
                           r5 = r2 * r3
                           taper = c5*r5 + c4*r4 + c3*r3
     &                                + c2*r2 + c1*r + c0
                           dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                                 + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                           dtaper = dtaper * e * rr1
                           frcx = frcx*taper - dtaper*xr
                           frcy = frcy*taper - dtaper*yr
                           frcz = frcz*taper - dtaper*zr
                           do j = 1, 3
                              ttri(j) = ttri(j) * taper
                              ttrk(j) = ttrk(j) * taper
                           end do
                        end if
c
c     increment the overall Pauli repulsion energy component
c
                        if (i .eq. k) then
                           frcx = 0.5d0 * frcx
                           frcy = 0.5d0 * frcy
                           frcz = 0.5d0 * frcz
                           do j = 1, 3
                              ttri(j) = 0.5d0 * ttri(j)
                              ttrk(j) = 0.5d0 * ttrk(j)
                           end do
                        end if
c
c     increment force-based gradient and torque on first site
c
                        der(1,i) = der(1,i) + frcx
                        der(2,i) = der(2,i) + frcy
                        der(3,i) = der(3,i) + frcz
                        ter(1,i) = ter(1,i) + ttri(1)
                        ter(2,i) = ter(2,i) + ttri(2)
                        ter(3,i) = ter(3,i) + ttri(3)
c
c     increment force-based gradient and torque on second site
c
                        der(1,k) = der(1,k) - frcx
                        der(2,k) = der(2,k) - frcy
                        der(3,k) = der(3,k) - frcz
                        ter(1,k) = ter(1,k) + ttrk(1)
                        ter(2,k) = ter(2,k) + ttrk(2)
                        ter(3,k) = ter(3,k) + ttrk(3)
                     end if
                  end do
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               rscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               rscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               rscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               rscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     resolve site torques then increment forces and virial
c
      do ii = 1, nrep
         i = irep(ii)
         call torque (i,ter(1,i),fix,fiy,fiz,der)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (rscale)
      deallocate (ter)
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine erepel3  --  Pauli repulsion energy & analysis  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "erepel3" calculates the Pauli repulsion energy and partitions
c     the energy among the atoms
c
c     literature reference:
c
c     J. A. Rackers and J. W. Ponder, "Classical Pauli Repulsion:
c     An Anisotropic, Atomic Multipole Model", Journal of Chemical
c     Physics, 150, 084104 (2019)
c
c
      subroutine erepel3
      use limits
      implicit none
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_mlist) then
         call erepel3b
      else
         call erepel3a
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine erepel3a  --  Pauli repulsion analysis via loop  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "erepel3a" calculates the Pauli repulsion energy and also
c     partitions the energy among the atoms using a double loop
c
c
      subroutine erepel3a
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use cell
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mpole
      use mutant
      use polar
      use repel
      use reppot
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer jcell
      real*8 e,eterm
      real*8 fgrp,taper
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4,r5
      real*8 rr1,rr3,rr5
      real*8 rr7,rr9,rr11
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 vlambda3,vlambda4
      real*8 vlambda5
      real*8 sizi,sizk,sizik
      real*8 vali,valk
      real*8 dmpi,dmpk
      real*8 dmpik(9)
      real*8, allocatable :: rscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      logical header,huge
      character*6 mode
c
c
c     zero out the repulsion energy and partitioning terms
c
      ner = 0
      er = 0.0d0
      do i = 1, n
         aer(i) = 0.0d0
      end do
      if (nrep .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('REPEL')
c
c     perform dynamic allocation of some local arrays
c
      allocate (rscale(n))
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vlambda3 = vlambda**3
         vlambda4 = vlambda3 * vlambda
         vlambda5 = vlambda4 * vlambda
      end if
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         rscale(i) = 1.0d0
      end do
c
c     set cutoff distances and switching coefficients
c
      mode = 'REPULS'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nrep.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Pauli Repulsion Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     calculate the Pauli repulsion interaction energy term
c
      do ii = 1, nrep-1
         i = irep(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         sizi = sizpr(i)
         dmpi = dmppr(i)
         vali = elepr(i)
         ci = rrepole(1,i)
         dix = rrepole(2,i)
         diy = rrepole(3,i)
         diz = rrepole(4,i)
         qixx = rrepole(5,i)
         qixy = rrepole(6,i)
         qixz = rrepole(7,i)
         qiyy = rrepole(9,i)
         qiyz = rrepole(10,i)
         qizz = rrepole(13,i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = r2scale
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = r3scale
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = r4scale
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = r5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, nrep
            k = irep(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  sizk = sizpr(k)
                  dmpk = dmppr(k)
                  valk = elepr(k)
                  ck = rrepole(1,k)
                  dkx = rrepole(2,k)
                  dky = rrepole(3,k)
                  dkz = rrepole(4,k)
                  qkxx = rrepole(5,k)
                  qkxy = rrepole(6,k)
                  qkxz = rrepole(7,k)
                  qkyy = rrepole(9,k)
                  qkyz = rrepole(10,k)
                  qkzz = rrepole(13,k)
c
c     intermediates involving moments and separation distance
c
                  dir = dix*xr + diy*yr + diz*zr
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qir = qix*xr + qiy*yr + qiz*zr
                  dkr = dkx*xr + dky*yr + dkz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
                  qkr = qkx*xr + qky*yr + qkz*zr
                  dik = dix*dkx + diy*dky + diz*dkz
                  qik = qix*qkx + qiy*qky + qiz*qkz
                  diqk = dix*qkx + diy*qky + diz*qkz
                  dkqi = dkx*qix + dky*qiy + dkz*qiz
                  qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                      + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                  rr1 = 1.0d0 / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
c
c     get damping coefficients for the Pauli repulsion energy
c
                  call damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11,
     &                             9,dmpi,dmpk,dmpik) 
c
c     compute the Pauli repulsion energy for this interaction
c
                  term1 = vali*valk
                  term2 = valk*dir - vali*dkr + dik
                  term3 = vali*qkr + valk*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  eterm = term1*dmpik(1) + term2*dmpik(3)
     &                       + term3*dmpik(5) + term4*dmpik(7)
     &                       + term5*dmpik(9)
                  sizik = sizi * sizk * rscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     e = vlambda5 * sizik * eterm
     &                      / sqrt(vlambda3-vlambda4+r2)
                  else
                     e = sizik * eterm * rr1
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall Pauli repulsion energy component
c
                  if (e .ne. 0.0d0) then
                     ner = ner + 1
                     er = er + e
                     aer(i) = aer(i) + 0.5d0*e
                     aer(k) = aer(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 20.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Pauli Repulsion',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             15x,'Distance',8x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),r,e
   30                format (' Repuls',4x,2(i7,'-',a3),
     &                          9x,f10.4,2x,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (use_replica) then
c
c     calculate interaction energy with other unit cells
c
         do ii = 1, nrep
            i = irep(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            sizi = sizpr(i)
            dmpi = dmppr(i)
            vali = elepr(i)
            ci = rrepole(1,i)
            dix = rrepole(2,i)
            diy = rrepole(3,i)
            diz = rrepole(4,i)
            qixx = rrepole(5,i)
            qixy = rrepole(6,i)
            qixz = rrepole(7,i)
            qiyy = rrepole(9,i)
            qiyz = rrepole(10,i)
            qizz = rrepole(13,i)
            usei = use(i)
            muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               rscale(i12(j,i)) = r2scale
            end do
            do j = 1, n13(i)
               rscale(i13(j,i)) = r3scale
            end do
            do j = 1, n14(i)
               rscale(i14(j,i)) = r4scale
            end do
            do j = 1, n15(i)
               rscale(i15(j,i)) = r5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, nrep
               k = irep(kk)
               mutk = mut(k)
               proceed = .true.
               if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
               if (.not. use_intra)  proceed = .true.
               if (proceed)  proceed = (usei .or. use(k))
               if (proceed) then
                  do jcell = 2, ncell
                     xr = x(k) - xi
                     yr = y(k) - yi
                     zr = z(k) - zi
                     call imager (xr,yr,zr,jcell)
                     r2 = xr*xr + yr* yr + zr*zr
                     if (r2 .le. off2) then
                        r = sqrt(r2)
                        sizk = sizpr(k)
                        dmpk = dmppr(k)
                        valk = elepr(k)
                        ck = rrepole(1,k)
                        dkx = rrepole(2,k)
                        dky = rrepole(3,k)
                        dkz = rrepole(4,k)
                        qkxx = rrepole(5,k)
                        qkxy = rrepole(6,k)
                        qkxz = rrepole(7,k)
                        qkyy = rrepole(9,k)
                        qkyz = rrepole(10,k)
                        qkzz = rrepole(13,k)
c
c     intermediates involving moments and separation distance
c
                        dir = dix*xr + diy*yr + diz*zr
                        qix = qixx*xr + qixy*yr + qixz*zr
                        qiy = qixy*xr + qiyy*yr + qiyz*zr
                        qiz = qixz*xr + qiyz*yr + qizz*zr
                        qir = qix*xr + qiy*yr + qiz*zr
                        dkr = dkx*xr + dky*yr + dkz*zr
                        qkx = qkxx*xr + qkxy*yr + qkxz*zr
                        qky = qkxy*xr + qkyy*yr + qkyz*zr
                        qkz = qkxz*xr + qkyz*yr + qkzz*zr
                        qkr = qkx*xr + qky*yr + qkz*zr
                        dik = dix*dkx + diy*dky + diz*dkz
                        qik = qix*qkx + qiy*qky + qiz*qkz
                        diqk = dix*qkx + diy*qky + diz*qkz
                        dkqi = dkx*qix + dky*qiy + dkz*qiz
                        qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                            + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                        rr1 = 1.0d0 / r
                        rr3 = rr1 / r2
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr9 = 7.0d0 * rr7 / r2
c
c     get damping coefficients for the Pauli repulsion energy
c
                        call damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11,
     &                                   9,dmpi,dmpk,dmpik)                  
c
c     compute the Pauli repulsion energy for this interaction
c
                        term1 = vali*valk
                        term2 = valk*dir - vali*dkr + dik
                        term3 = vali*qkr + valk*qir - dir*dkr
     &                             + 2.0d0*(dkqi-diqk+qiqk)
                        term4 = dir*qkr - dkr*qir - 4.0d0*qik
                        term5 = qir*qkr
                        eterm = term1*dmpik(1) + term2*dmpik(3)
     &                             + term3*dmpik(5) + term4*dmpik(7)
     &                             + term5*dmpik(9)
                        sizik = sizi * sizk * rscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                        mutik = .false.
                        if (muti .or. mutk) then
                           if (vcouple .eq. 1) then
                              mutik = .true.
                           else if (.not.muti .or. .not.mutk) then
                              mutik = .true.
                           end if
                        end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                        if (mutik) then
                           e = vlambda5 * sizik * eterm
     &                            / sqrt(vlambda3-vlambda4+r2)
                        else
                           e = sizik * eterm * rr1
                        end if
c
c     use energy switching if near the cutoff distance
c
                        if (r2 .gt. cut2) then
                           r3 = r2 * r
                           r4 = r2 * r2
                           r5 = r2 * r3
                           taper = c5*r5 + c4*r4 + c3*r3
     &                                + c2*r2 + c1*r + c0
                           e = e * taper
                        end if
c
c     scale the interaction based on its group membership
c
                        if (use_group)  e = e * fgrp
c
c     increment the overall Pauli repulsion energy component;
c     interaction of an atom with its own image counts half
c
                        if (e .ne. 0.0d0) then
                           ner = ner + 1
                           if (i .eq. k) then
                              er = er + 0.5d0*e
                              aer(i) = aer(i) + 0.5d0*e
                           else
                              er = er + e
                              aer(i) = aer(i) + 0.5d0*e
                              aer(k) = aer(k) + 0.5d0*e
                           end if
                        end if
c
c     increment the total intermolecular energy
c
                        einter = einter + e
c
c     print a message if the energy of this interaction is large
c
                        huge = (e .gt. 20.0d0)
                        if ((debug.and.e.ne.0.0d0)
     &                        .or. (verbose.and.huge)) then
                           if (header) then
                              header = .false.
                              write (iout,40)
   40                         format (/,' Individual Pauli Repulsion',
     &                                   ' Interactions :',
     &                                //,' Type',14x,'Atom Names',
     &                                   15x,'Distance',8x,'Energy',/)
                           end if
                           write (iout,50)  i,name(i),k,name(k),r,e
   50                      format (' Repuls',4x,2(i7,'-',a3),1x,
     &                                '(XTAL)',2x,f10.4,2x,f12.4)
                        end if
                     end if
                  end do
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, n12(i)
               rscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               rscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               rscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               rscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (rscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine erepel3b  --  Pauli repulsion analysis via list  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "erepel3b" calculates the Pauli repulsion energy and also
c     partitions the energy among the atoms using a neighbor list
c
c
      subroutine erepel3b
      use action
      use analyz
      use atoms
      use atomid
      use bound
      use couple
      use energi
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mpole
      use mutant
      use neigh
      use polar
      use repel
      use reppot
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk,kkk
      real*8 e,eterm
      real*8 fgrp,taper
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4,r5
      real*8 rr1,rr3,rr5
      real*8 rr7,rr9,rr11
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr,dik,qik
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 diqk,dkqi,qiqk
      real*8 term1,term2,term3
      real*8 term4,term5
      real*8 vlambda3,vlambda4
      real*8 vlambda5
      real*8 sizi,sizk,sizik
      real*8 vali,valk
      real*8 dmpi,dmpk
      real*8 dmpik(9)
      real*8, allocatable :: rscale(:)
      logical proceed,usei
      logical muti,mutk,mutik
      logical header,huge
      character*6 mode
c
c
c     zero out Pauli repulsion energy and partitioning terms
c
      ner = 0
      er = 0.0d0
      do i = 1, n
         aer(i) = 0.0d0
      end do
      if (nrep .eq. 0)  return
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('REPEL')
c
c     perform dynamic allocation of some local arrays
c
      allocate (rscale(n))
c
c     set lambda scaling values for mutated interactions
c
      if (nmut .ne. 0) then
         vlambda3 = vlambda**3
         vlambda4 = vlambda3 * vlambda
         vlambda5 = vlambda4 * vlambda
      end if
c
c     initialize connected atom exclusion coefficients
c
      do i = 1, n
         rscale(i) = 1.0d0
      end do
c
c     set cutoff distances and switching coefficients
c
      mode = 'REPULS'
      call switch (mode)
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. npole.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Pauli Repulsion Interactions :',
     &           //,' Type',14x,'Atom Names',15x,'Distance',
     &              8x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(nrep,irep,x,y,z,sizpr,dmppr,elepr,rrepole,uind,n12,
!$OMP& i12,n13,i13,n14,i14,n15,i15,r2scale,r3scale,r4scale,r5scale,
!$OMP& nelst,elst,use,use_group,use_intra,use_bounds,vcouple,vlambda3,
!$OMP& vlambda4,vlambda5,mut,cut2,off2,c0,c1,c2,c3,c4,c5,molcule,name,
!$OMP& verbose,debug,header,iout)
!$OMP& firstprivate(rscale)
!$OMP& shared (er,ner,aer,einter)
!$OMP DO reduction(+:er,ner,aer,einter)
c
c     calculate the Pauli repulsion interaction energy term
c
      do ii = 1, nrep
         i = irep(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         sizi = sizpr(i)
         dmpi = dmppr(i)
         vali = elepr(i)
         ci = rrepole(1,i)
         dix = rrepole(2,i)
         diy = rrepole(3,i)
         diz = rrepole(4,i)
         qixx = rrepole(5,i)
         qixy = rrepole(6,i)
         qixz = rrepole(7,i)
         qiyy = rrepole(9,i)
         qiyz = rrepole(10,i)
         qizz = rrepole(13,i)
         usei = use(i)
         muti = mut(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = r2scale
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = r3scale
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = r4scale
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = r5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kkk = 1, nelst(ii)
            kk = elst(kkk,ii)
            k = irep(kk)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. use(k))
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               if (use_bounds)  call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  sizk = sizpr(k)
                  dmpk = dmppr(k)
                  valk = elepr(k)
                  ck = rrepole(1,k)
                  dkx = rrepole(2,k)
                  dky = rrepole(3,k)
                  dkz = rrepole(4,k)
                  qkxx = rrepole(5,k)
                  qkxy = rrepole(6,k)
                  qkxz = rrepole(7,k)
                  qkyy = rrepole(9,k)
                  qkyz = rrepole(10,k)
                  qkzz = rrepole(13,k)
c
c     intermediates involving moments and separation distance
c
                  dir = dix*xr + diy*yr + diz*zr
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qir = qix*xr + qiy*yr + qiz*zr
                  dkr = dkx*xr + dky*yr + dkz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
                  qkr = qkx*xr + qky*yr + qkz*zr
                  dik = dix*dkx + diy*dky + diz*dkz
                  qik = qix*qkx + qiy*qky + qiz*qkz
                  diqk = dix*qkx + diy*qky + diz*qkz
                  dkqi = dkx*qix + dky*qiy + dkz*qiz
                  qiqk = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                      + qixx*qkxx + qiyy*qkyy + qizz*qkzz
c
c     get reciprocal distance terms for this interaction
c
                  rr1 = 1.0d0 / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
c
c     get damping coefficients for the Pauli repulsion energy
c     
                  call damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11,
     &                             9,dmpi,dmpk,dmpik)                  
c
c     compute the Pauli repulsion energy for this interaction
c
                  term1 = vali*valk
                  term2 = valk*dir - vali*dkr + dik
                  term3 = vali*qkr + valk*qir - dir*dkr
     &                       + 2.0d0*(dkqi-diqk+qiqk)
                  term4 = dir*qkr - dkr*qir - 4.0d0*qik
                  term5 = qir*qkr
                  eterm = term1*dmpik(1) + term2*dmpik(3)
     &                       + term3*dmpik(5) + term4*dmpik(7)
     &                       + term5*dmpik(9)
                  sizik = sizi * sizk * rscale(k)
c
c     set use of lambda scaling for decoupling or annihilation
c
                  mutik = .false.
                  if (muti .or. mutk) then
                     if (vcouple .eq. 1) then
                        mutik = .true.
                     else if (.not.muti .or. .not.mutk) then
                        mutik = .true.
                     end if
                  end if
c
c     get interaction energy, via soft core lambda scaling as needed
c
                  if (mutik) then
                     e = vlambda5 * sizik * eterm
     &                      / sqrt(vlambda3-vlambda4+r2)
                  else
                     e = sizik * eterm * rr1
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall Pauli repulsion energy component
c
                  if (e .ne. 0.0d0) then
                     ner = ner + 1
                     er = er + e
                     aer(i) = aer(i) + 0.5d0*e
                     aer(k) = aer(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (e .gt. 20.0d0)
                  if ((debug.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Pauli Repulsion',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             15x,'Distance',8x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),r,e
   30                format (' Repuls',4x,2(i7,'-',a3),
     &                          9x,f10.4,2x,f12.4)
                  end if
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            rscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            rscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            rscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            rscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (rscale)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1994  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  function erf  --  evaluate the standard error function  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "erf" computes a numerical approximation to the value of
c     the error function via a Chebyshev approximation
c
c
      function erf (x)
      implicit none
      integer mode
      real*8 erf,x
      real*8 result
c
c
c     compute the error function via Chebyshev fitting
c
      mode = 0
      call erfcore (x,result,mode)
      erf = result
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function erfc  --  evaluate complementary error function  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "erfc" computes a numerical approximation to the value of the
c     complementary error function via a Chebyshev approximation
c
c
      function erfc (x)
      implicit none
      integer mode
      real*8 erfc,x
      real*8 result
c
c
c     get the complementary error function via Chebyshev fitting
c
      mode = 1
      call erfcore (x,result,mode)
      erfc = result
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine erfcore  --  erf and erfc via Chebyshev approx  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "erfcore" evaluates erf(x) or erfc(x) for a real argument x;
c     when called with mode set to 0 it returns erf, a mode of 1
c     returns erfc; uses rational functions that approximate erf(x)
c     and erfc(x) to at least 18 significant decimal digits
c
c     literature reference:
c
c     W. J. Cody, "Rational Chebyshev Approximations for the Error
c     Function", Mathematics of Computation, 631-638, 1969
c
c     adapted from an original program written by W. J. Cody,
c     Mathematics and Computer Science Division, Argonne National
c     Laboratory, Argonne, IL 60439
c
c     machine-dependent constants:
c
c     xtiny   argument below which erf(x) may be represented by
c             2*x/sqrt(pi) and above which x*x won't underflow;
c             a conservative value is the largest machine number
c             X such that 1.0 + X = 1.0 to machine precision
c
c     xbig    largest argument acceptable for erfc; solution to
c             the equation:  W(x) * (1-0.5/x**2) = XMIN, where
c             W(x) = exp(-x*x)/[x*sqrt(pi)]
c
c
      subroutine erfcore (arg,result,mode)
      use math
      implicit none
      integer i,mode
      real*8 arg,result
      real*8 x,y,ysq,del
      real*8 xnum,xden
      real*8 xtiny,xbig
      real*8 a(5),b(4)
      real*8 c(9),d(8)
      real*8 p(6),q(5)
c
c     machine-dependent numerical constants
c
      data xtiny  / 1.11d-16 /
      data xbig   / 26.543d0 /
c
c     coefficients for approximation to erf in first interval
c
      data a  / 3.16112374387056560d0,  1.13864154151050156d2,
     &          3.77485237685302021d2,  3.20937758913846947d3,
     &          1.85777706184603153d-1 /
      data b  / 2.36012909523441209d1,  2.44024637934444173d2,
     &          1.28261652607737228d3,  2.84423683343917062d3 /
c
c     coefficients for approximation to erfc in second interval
c
      data c  / 5.64188496988670089d-1, 8.88314979438837594d0,
     &          6.61191906371416295d1,  2.98635138197400131d2,
     &          8.81952221241769090d2,  1.71204761263407058d3,
     &          2.05107837782607147d3,  1.23033935479799725d3,
     &          2.15311535474403846d-8 /
      data d  / 1.57449261107098347d1,  1.17693950891312499d2,
     &          5.37181101862009858d2,  1.62138957456669019d3,
     &          3.29079923573345963d3,  4.36261909014324716d3,
     &          3.43936767414372164d3,  1.23033935480374942d3 /
c
c     coefficients for approximation to erfc in third interval
c
      data p  / 3.05326634961232344d-1, 3.60344899949804439d-1,
     &          1.25781726111229246d-1, 1.60837851487422766d-2,
     &          6.58749161529837803d-4, 1.63153871373020978d-2 /
      data q  / 2.56852019228982242d0,  1.87295284992346047d0,
     &          5.27905102951428412d-1, 6.05183413124413191d-2,
     &          2.33520497626869185d-3 /
c
c
c     store the argument and its absolute value
c
      x = arg
      y = abs(x)
c
c     evaluate error function for |x| less than 0.46875
c
      if (y .le. 0.46875d0) then
         ysq = 0.0d0
         if (y .gt. xtiny)  ysq = y * y
         xnum = a(5) * ysq
         xden = ysq
         do i = 1, 3
            xnum = (xnum + a(i)) * ysq
            xden = (xden + b(i)) * ysq
         end do
         result = x * (xnum + a(4)) / (xden + b(4))
         if (mode .ne. 0)  result = 1.0d0 - result
c
c     get complementary error function for 0.46875 <= |x| <= 4.0
c
      else if (y .le. 4.0d0) then
         xnum = c(9) * y
         xden = y
         do i = 1, 7
            xnum = (xnum + c(i)) * y
            xden = (xden + d(i)) * y
         end do
         result = (xnum + c(8)) / (xden + d(8))
         ysq = aint(16.0d0*y) / 16.0d0
         del = (y-ysq) * (y+ysq)
c        result = exp(-ysq*ysq) * exp(-del) * result
         result = exp(-ysq*ysq-del) * result
         if (mode .eq. 0) then
            result = 1.0d0 - result
            if (x .lt. 0.0d0)  result = -result
         else
            if (x .lt. 0.0d0)  result = 2.0d0 - result
         end if
c
c     get complementary error function for |x| greater than 4.0
c
      else
         result = 0.0d0
         if (y .lt. xbig) then
            ysq = 1.0d0 / (y * y)
            xnum = p(6) * ysq
            xden = ysq
            do i = 1, 4
               xnum = (xnum + p(i)) * ysq
               xden = (xden + q(i)) * ysq
            end do
            result = ysq * (xnum + p(5)) / (xden + q(5))
            result = ((1.0d0/rootpi) - result) / y
            ysq = aint(16.0d0*y) / 16.0d0
            del = (y-ysq) * (y+ysq)
c           result = exp(-ysq*ysq) * exp(-del) * result
            result = exp(-ysq*ysq-del) * result
         end if
         if (mode .eq. 0) then
            result = 1.0d0 - result
            if (x .lt. 0.0d0)  result = -result
         else
            if (x .lt. 0.0d0)  result = 2.0d0 - result
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function erfinv  --  evaluate the error function inverse  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "erfinv" evaluates the inverse of the error function for
c     an argument in the range (-1,1) using a rational function
c     approximation followed by cycles of Newton-Raphson correction
c
c     adapted from the pseudocode for the Matlab function of the
c     same name; Matlab, version 4.2c, March 1995
c
c
      function erfinv (x)
      use iounit
      use math
      implicit none
      real*8 erfinv,erf
      real*8 x,y,z
      real*8 a(4),b(4)
      real*8 c(4),d(2)
      external erf
c
c     coefficients for approximation to erfinv in central range
c
      data a  /  0.886226899d0, -1.645349621d0,
     &           0.914624893d0, -0.140543331d0 /
      data b  / -2.118377725d0,  1.442710462d0,
     &          -0.329097515d0,  0.012229801d0 /
c
c     coefficients for approximation to erfinv near endpoints
c
      data c  / -1.970840454d0, -1.624906493d0,
     &           3.429567803d0,  1.641345311d0 /
      data d  /  3.543889200d0,  1.637067800d0 /
c
c
c     get an initial estimate for the inverse error function
c
      if (abs(x) .le. 0.7d0) then
         y = x * x
         z = x * (((a(4)*y+a(3))*y+a(2))*y+a(1))
     &              / ((((b(4)*y+b(3))*y+b(2))*y+b(1))*y+1.0d0)
      else if (x.gt.0.7d0 .and. x.lt.1.0d0) then
         y = sqrt(-log((1.0d0-x)/2.0d0))
         z = (((c(4)*y+c(3))*y+c(2))*y+c(1)) / ((d(2)*y+d(1))*y+1.0d0)
      else if (x.lt.-0.7d0 .and. x.gt.-1.0d0) then
         y = sqrt(-log((1.0d0+x)/2.0d0))
         z = -(((c(4)*y+c(3))*y+c(2))*y+c(1)) / ((d(2)*y+d(1))*y+1.0d0)
      else
         write (iout,10)
   10    format (/,' ERFINV  --  Illegal Argument to Inverse',
     &              ' Error Function')
         call fatal
      end if
c
c     use two steps of Newton-Raphson correction to increase accuracy
c
      z = z - (erf(z) - x) / (2.0d0/rootpi * exp(-z*z))
      z = z - (erf(z) - x) / (2.0d0/rootpi * exp(-z*z))
      erfinv = z
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 1996 by Yong Kong & Jay William Ponder  ##
c     ##                  All Rights Reserved                   ##
c     ############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine erxnfld  --  reaction field potential energy  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "erxnfld" calculates the macroscopic reaction field energy
c     arising from a set of atomic multipoles
c
c     literature reference:
c
c     Y. Kong and J. W. Ponder, "Reaction Field Methods for Off-Center
c     Multipoles", Journal of Chemical Physics, 107, 481-492 (1997)
c
c
      subroutine erxnfld
      use atoms
      use chgpot
      use energi
      use mpole
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer ix,iy,iz
      integer kx,ky,kz
      real*8 eik,r2
      real*8 xr,yr,zr
      real*8 rpi(13)
      real*8 rpk(13)
      logical usei,usek
      character*6 mode
c
c
c     zero out the macroscopic reaction field energy
c
      erxf = 0.0d0
c
c     set the switching function coefficients
c
      mode = 'MPOLE'
      call switch (mode)
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     compute the indices used in reaction field calculations
c
      call ijkpts
c
c     calculate the reaction field interaction energy term
c
      do ii = 1, npole
         i = ipole(ii)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
         do j = 1, polsiz(i)
            rpi(j) = rpole(j,i)
         end do
         do kk = ii, npole
            k = ipole(kk)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            if (usei .or. usek) then
               xr = x(k) - x(i)
               yr = y(k) - y(i)
               zr = z(k) - z(i)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  do j = 1, polsiz(k)
                     rpk(j) = rpole(j,k)
                  end do
                  call erfik (i,k,rpi,rpk,eik)
                  erxf = erxf + eik
               end if
            end if
         end do
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine erfik  --  reaction field energy of site pair   ##
c     ##                                                             ##
c     #################################################################
c
c
c     "erfik" compute the reaction field energy due to a single pair
c     of atomic multipoles
c
c
      subroutine erfik (i,k,rpi,rpk,eik)
      use atoms
      use chgpot
      use mpole
      use rxnfld
      use rxnpot
      implicit none
      integer i,k
      integer isiz,ksiz
      integer m,n1,n2,nn
      integer fii,fi,fj
      integer p_s1,p_s2,p_e1,p_e2
      integer ind1_x(13),ind2_x(13)
      integer ind1_y(13),ind2_y(13)
      integer ind1_z(13),ind2_z(13)
      real*8 eik,term,ratio,factor
      real*8 xi,yi,zi,xk,yk,zk
      real*8 size,size2,d,d2,ri2,rk2
      real*8 xi2,yi2,zi2,xk2,yk2,zk2
      real*8 rpi(13),rpk(13)
      real*8 rklij(13,13),d1d2
      real*8 m2t2(13)
c
c
c     get numbers of the atoms
c
      isiz = polsiz(i)
      ksiz = polsiz(k)
      xi = x(i)
      yi = y(i)
      zi = z(i)
      xk = x(k)
      yk = y(k)
      zk = z(k)
      d = xi*xk + yi*yk + zi*zk
      ri2 = xi*xi + yi*yi + zi*zi
      rk2 = xk*xk + yk*yk + zk*zk
c
c     set highest order of multipoles at each site (M=0, D=1, Q=2)
c
      eik = 0.0d0
      n1 = 2
      n2 = 2
      nn = rfterms
      ratio = rfbulkd / dielec
      factor = electric * (1.0d0-ratio)
      if (i .eq. k)  factor = 0.5d0 * factor
      size = 1.0d0 / rfsize
      size2 = size * size
c
c     get the values of the indices
c
      m = (3**(n1+1)-1)/2
      call rfindex (n1,m,ind1_x,ind1_y,ind1_z,p_s1,p_e1)
      m = (3**(n2+1)-1)/2
      call rfindex (n2,m,ind2_x,ind2_y,ind2_z,p_s2,p_e2)
c
c     initialize the stored matrix element arrays
c
      do fi = 1, p_e1
         do fj = 1, p_e2
            b1(fi,fj) = 0.0d0
            b2(fi,fj) = 0.0d0
         end do
      end do
c
c     explicit formula for the 0th summation term
c
      if (nn .ge. 0) then
         eik = size * rpi(1) * rpk(1) / ratio
         size = size * size2
      end if
c
c     explicit formula for the 1st summation term
c
      if (nn .ge. 1) then
         b2(1,1) = d
         b2(1,2) = xi
         b2(1,3) = yi
         b2(1,4) = zi
         b2(2,1) = xk
         b2(3,1) = yk
         b2(4,1) = zk
         b2(2,2) = 1.0d0
         b2(3,3) = 1.0d0
         b2(4,4) = 1.0d0
         do fi = 1, 4
            m2t2(fi) = 0.0d0
            do fj = 1, 4
               m2t2(fi) = m2t2(fi) + b2(fi,fj)*rpk(fj)
            end do
         end do
         term = 0.0d0
         do fi = 1, 4
            term = term + rpi(fi)*m2t2(fi)
         end do
         term = 2.0d0 * size * term / (2.0d0*ratio+1.0d0)
         eik = eik + term
         size = size * size2
      end if
c
c     explicit formula for the 2nd summation term
c
      if (nn .ge. 2) then
         b2(1,1) = (3.0d0*d*d-ri2*rk2) * 0.5d0
         b2(1,2) = 3.0d0*xi*d - xk*ri2
         b2(1,3) = 3.0d0*yi*d - yk*ri2
         b2(1,4) = 3.0d0*zi*d - zk*ri2
         b2(1,5) = 3.0d0*xi*xi - ri2
         b2(1,6) = 3.0d0*xi*yi
         b2(1,7) = 3.0d0*xi*zi
         b2(1,8) = b2(1,6)
         b2(1,9) = 3.0d0*yi*yi - ri2
         b2(1,10) = 3.0d0*yi*zi
         b2(1,11) = b2(1,7)
         b2(1,12) = b2(1,10)
         b2(1,13) = 3.0d0*zi*zi - ri2
         b2(2,1) = 3.0d0*xk*d - xi*rk2
         b2(2,2) = 3.0d0*d + xi*xk
         b2(2,3) = 3.0d0*xk*yi - 2.0d0*xi*yk
         b2(2,4) = 3.0d0*zi*xk - 2.0d0*xi*zk
         b2(2,5) = 4.0d0*xi
         b2(2,6) = 3.0d0*yi
         b2(2,7) = 3.0d0*zi
         b2(2,8) = b2(2,6)
         b2(2,9) = -2.0d0*xi
         b2(2,11) = b2(2,7)
         b2(2,13) = b2(2,9)
         b2(3,1) = 3.0d0*yk*d - yi*rk2
         b2(3,2) = 3.0d0*yk*xi - 2.0d0*yi*xk
         b2(3,3) = 3.0d0*d + yi*yk
         b2(3,4) = 3.0d0*yk*zi - 2.0d0*yi*zk
         b2(3,5) = -2.0d0*yi
         b2(3,6) = 3.0d0*xi
         b2(3,8) = b2(3,6)
         b2(3,9) = 4.0d0*yi
         b2(3,10) = 3.0d0*zi
         b2(3,12) = b2(3,10)
         b2(3,13) = b2(3,5)
         b2(4,1) = 3.0d0*zk*d - zi*rk2
         b2(4,2) = 3.0d0*zk*xi - 2.0d0*zi*xk
         b2(4,3) = 3.0d0*zk*yi - 2.0d0*zi*yk
         b2(4,4) = 3.0d0*d + zi*zk
         b2(4,5) = -2.0d0*zi
         b2(4,7) = 3.0d0*xi
         b2(4,9) = b2(4,5)
         b2(4,10) = 3.0d0*yi
         b2(4,11) = b2(4,7)
         b2(4,12) = b2(4,10)
         b2(4,13) = 4.0d0*zi
         b2(5,1) = 3.0d0*xk*xk - rk2
         b2(5,2) = 4.0d0*xk
         b2(5,3) = -2.0d0*yk
         b2(5,4) = -2.0d0*zk
         b2(5,5) = 4.0d0
         b2(5,9) = -2.0d0
         b2(5,13) = -2.0d0
         b2(6,1) = 3.0d0*xk*yk
         b2(6,2) = 3.0d0*yk
         b2(6,3) = 3.0d0*xk
         b2(6,6) = 3.0d0
         b2(6,8) = 3.0d0
         b2(7,1) = 3.0d0*xk*zk
         b2(7,2) = 3.0d0*zk
         b2(7,4) = 3.0d0*xk
         b2(7,7) = 3.0d0
         b2(7,11) = 3.0d0
         b2(8,1) = b2(6,1)
         b2(8,2) = b2(6,2)
         b2(8,3) = b2(6,3)
         b2(8,6) = 3.0d0
         b2(8,8) = 3.0d0
         b2(9,1) = 3.0d0*yk*yk - rk2
         b2(9,2) = -2.0d0*xk
         b2(9,3) = 4.0d0*yk
         b2(9,4) = -2.0d0*zk
         b2(9,5) = -2.0d0
         b2(9,9) = 4.0d0
         b2(9,13) = -2.0d0
         b2(10,1) = 3.0d0*yk*zk
         b2(10,3) = 3.0d0*zk
         b2(10,4) = 3.0d0*yk
         b2(10,10) = 3.0d0
         b2(10,12) = 3.0d0
         b2(11,1) = b2(7,1)
         b2(11,2) = b2(7,2)
         b2(11,4) = b2(7,4)
         b2(11,7) = 3.0d0
         b2(11,11) = 3.0d0
         b2(12,1) = b2(10,1)
         b2(12,3) = b2(10,3)
         b2(12,4) = b2(10,4)
         b2(12,10) = 3.0d0
         b2(12,12) = 3.0d0
         b2(13,1) = 3.0d0*zk*zk - rk2
         b2(13,2) = -2.0d0*xk
         b2(13,3) = -2.0d0*yk
         b2(13,4) = 4.0d0*zk
         b2(13,5) = -2.0d0
         b2(13,9) = -2.0d0
         b2(13,13) = 4.0d0
         do fi = 1, isiz
            m2t2(fi) = 0.0d0
            do fj = 1, ksiz
               m2t2(fi) = m2t2(fi) + b2(fi,fj)*rpk(fj)
            end do
         end do
         term = 0.0d0
         do fi = 1, isiz
            term = term + rpi(fi)*m2t2(fi)
         end do
         term = 3.0d0 * size * term / (3.0d0*ratio+2.0d0)
         eik = eik + term
         size = size * size2
      end if
c
c     explicit formula for the 3rd summation term
c
      if (nn .ge. 3) then
         d2 = d*d
         xi2 = xi*xi
         yi2 = yi*yi
         zi2 = zi*zi
         xk2 = xk*xk
         yk2 = yk*yk
         zk2 = zk*zk
         b1(1,1) = d*(2.5d0*d2-1.5d0*ri2*rk2)
         b1(1,2) = 7.5d0*d2*xi-3.0d0*xk*ri2*d-1.5d0*xi*ri2*rk2
         b1(1,3) = 7.5d0*d2*yi-3.0d0*yk*ri2*d-1.5d0*yi*ri2*rk2
         b1(1,4) = 7.5d0*d2*zi-3.0d0*zk*ri2*d-1.5d0*zi*ri2*rk2
         b1(1,5) = 15.0d0*d*xi2-3.0d0*ri2*(d+2.0d0*xi*xk)
         b1(1,6) = 15.0d0*xi*yi*d - 3.0d0*ri2*(xi*yk+xk*yi)
         b1(1,7) = 15.0d0*xi*zi*d - 3.0d0*ri2*(xi*zk+xk*zi)
         b1(1,8) = b1(1,6)
         b1(1,9) = 15.0d0*d*yi2-3.0d0*ri2*(d+2.0d0*yi*yk)
         b1(1,10) = 15.0d0*yi*zi*d - 3.0d0*ri2*(yi*zk+yk*zi)
         b1(1,11) = b1(1,7)
         b1(1,12) = b1(1,10)
         b1(1,13) = 15.0d0*d*zi2-3.0d0*ri2*(d+2.0d0*zi*zk)
         b1(2,1) = 7.5d0*d2*xk-3.0d0*xi*rk2*d-1.5d0*xk*ri2*rk2
         b1(2,2) = 7.5d0*d2+9.0d0*xi*xk*d-3.0d0*xi2*rk2-3.0d0*xk2*ri2
     &                -1.5d0*ri2*rk2
         b1(2,3) = 3.0d0*((5.0d0*xk*yi-2.0d0*xi*yk)*d
     &                -xi*yi*rk2-xk*yk*ri2)
         b1(2,4) = 3.0d0*((5.0d0*xk*zi-2.0d0*xi*zk)*d
     &                -xi*zi*rk2-xk*zk*ri2)
         b1(2,5) = 24.0d0*xi*yi*yk + 24.0d0*xi*zi*zk + 18.0d0*xi2*xk
     &                - 9.0d0*xk*yi2  - 9.0d0*xk*zi2
         b1(2,6) = (8.0d0*yi*xk*xi - 3.0d0*xi2*yk + 4.0d0*yi2*yk
     &                - yk*zi2  + 5.0d0*yi*zi*zk)*3.0d0
         b1(2,7) = 15.0d0*zi*yi*yk + 12.0d0*zi2*zk - 9.0d0*xi2*zk
     &                - 3.0d0*zk*yi2  + 24.0d0*zi*xk*xi
         b1(2,8) = b1(2,6)
         b1(2,9) = - 9.0d0*xi2*xk + 12.0d0*xk*yi2  - 3.0d0*xk*zi2
     &                - 18.0d0*xi*yi*yk - 6.0d0*xi*zi*zk
         b1(2,10) = 15.0d0*zi*xk*yi - 6.0d0*zi*xi*yk - 6.0d0*yi*xi*zk
         b1(2,11) = b1(2,7)
         b1(2,12) = b1(2,10)
         b1(2,13) = - 6.0d0*xi*yi*yk - 9.0d0*xi2*xk - 3.0d0*xk*yi2
     &                 + 12.0d0*xk*zi2  - 18.0d0*xi*zi*zk
         b1(3,1) = 7.5d0*d2*yk-3.0d0*yi*rk2*d-1.5d0*yk*ri2*rk2
         b1(3,2) = 3.0d0*((5.0d0*xi*yk-2.0d0*xk*yi)*d
     &                -xi*yi*rk2-xk*yk*ri2)
         b1(3,3) = 7.5d0*d2+9.0d0*yi*yk*d-3.0d0*yi2*rk2-3.0d0*yk2*ri2
     &                -1.5d0*ri2*rk2
         b1(3,4) = 3.0d0*((5.0d0*yk*zi-2.0d0*yi*zk)*d
     &                -yi*zi*rk2-yk*zk*ri2)
         b1(3,5) = - 9.0d0*yi2*yk - 6.0d0*yi*zi*zk - 18.0d0*yi*xk*xi
     &                + 12.0d0*xi2*yk - 3.0d0*yk*zi2
         b1(3,6) = 12.0d0*xi2*xk + 15.0d0*xi*zi*zk - 9.0d0*xk*yi2
     &                - 3.0d0*xk*zi2  + 24.0d0*xi*yi*yk
         b1(3,7) = 15.0d0*zi*xi*yk - 6.0d0*yi*xi*zk - 6.0d0*zi*xk*yi
         b1(3,8) = b1(3,6)
         b1(3,9) = - 9.0d0*xi2*yk + 18.0d0*yi2*yk - 9.0d0*yk*zi2
     &                + 24.0d0*yi*xk*xi + 24.0d0*yi*zi*zk
         b1(3,10) = 24.0d0*zi*yi*yk - 3.0d0*xi2*zk - 9.0d0*zk*yi2
     &                + 12.0d0*zi2*zk + 15.0d0*zi*xk*xi
         b1(3,11) = b1(3,7)
         b1(3,12) = b1(3,10)
         b1(3,13) = - 3.0d0*xi2*yk - 9.0d0*yi2*yk + 12.0d0*yk*zi2
     &                 - 18.0d0*yi*zi*zk - 6.0d0*yi*xk*xi
         b1(4,1) = 7.5d0*d2*zk-3.0d0*zi*rk2*d-1.5d0*zk*ri2*rk2
         b1(4,2) = 3.0d0*((5.0d0*xi*zk-2.0d0*xk*zi)*d
     &                -xi*zi*rk2-xk*zk*ri2)
         b1(4,3) = 3.0d0*((5.0d0*yi*zk-2.0d0*yk*zi)*d
     &                -yi*zi*rk2-yk*zk*ri2)
         b1(4,4) = 7.5d0*d2+9.0d0*zi*zk*d-3.0d0*zi2*rk2-3.0d0*zk2*ri2
     &                -1.5d0*ri2*rk2
         b1(4,5) = 12.0d0*xi2*zk - 3.0d0*zk*yi2 - 9.0d0*zi2*zk
     &                - 18.0d0*zi*xk*xi - 6.0d0*zi*yi*yk
         b1(4,6) = 15.0d0*yi*xi*zk - 6.0d0*zi*xi*yk - 6.0d0*zi*xk*yi
         b1(4,7) = 24.0d0*xi*zi*zk + 12.0d0*xi2*xk - 3.0d0*xk*yi2
     &                - 9.0d0*xk*zi2  + 15.0d0*xi*yi*yk
         b1(4,8) = b1(4,6)
         b1(4,9) = - 6.0d0*zi*xk*xi - 9.0d0*zi2*zk - 3.0d0*xi2*zk
     &                + 12.0d0*zk*yi2  - 18.0d0*zi*yi*yk
         b1(4,10) = 15.0d0*yi*xk*xi + 12.0d0*yi2*yk - 9.0d0*yk*zi2
     &                + 24.0d0*yi*zi*zk - 3.0d0*xi2*yk
         b1(4,11) = b1(4,7)
         b1(4,12) = b1(4,10)
         b1(4,13) = 24.0d0*zi*xk*xi + 18.0d0*zi2*zk - 9.0d0*xi2*zk
     &                - 9.0d0*zk*yi2  + 24.0d0*zi*yi*yk
         b1(5,1) = 15.0d0*d*xk2-3.0d0*rk2*(d+2.0d0*xi*xk)
         b1(5,2) = 18.0d0*xi*xk2  + 24.0d0*xk*yi*yk + 24.0d0*xk*zi*zk
     &                - 9.0d0*xi*yk2  - 9.0d0*xi*zk2
         b1(5,3) = 12.0d0*yi*xk2 - 9.0d0*yk2*yi - 3.0d0*yi*zk2
     &                - 18.0d0*xk*xi*yk - 6.0d0*yk*zi*zk
         b1(5,4) = - 9.0d0*zk2*zi - 6.0d0*zk*yi*yk - 18.0d0*xk*xi*zk
     &                + 12.0d0*zi*xk2  - 3.0d0*zi*yk2
         b1(5,5) = 24.0d0*zi*zk + 24.0d0*yi*yk + 36.0d0*xi*xk
         b1(5,6) = -18.0d0*xi*yk + 24.0d0*yi*xk
         b1(5,7) = -18.0d0*xi*zk + 24.0d0*zi*xk
         b1(5,8) = b1(5,6)
         b1(5,9) = -6.0d0*zi*zk - 18.0d0*yi*yk - 18.0d0*xi*xk
         b1(5,10) = -6.0d0*(yi*zk + zi*yk)
         b1(5,11) = b1(5,7)
         b1(5,12) = b1(5,10)
         b1(5,13) = -6.0d0*yi*yk - 18.0d0*xi*xk - 18.0d0*zi*zk
         b1(6,1) = 15.0d0*xk*yk*d - 3.0d0*rk2*(xi*yk+xk*yi)
         b1(6,2) = -9.0d0*yi*xk2 + 12.0d0*yk2*yi - 3.0d0*yi*zk2
     &                + 24.0d0*xk*xi*yk + 15.0d0*yk*zi*zk
         b1(6,3) = 12.0d0*xi*xk2 + 15.0d0*xk*zi*zk - 9.0d0*xi*yk2
     &                - 3.0d0*xi*zk2  + 24.0d0*xk*yi*yk
         b1(6,4) = -6.0d0*xk*yi*zk - 6.0d0*yk*xi*zk + 15.0d0*zi*xk*yk
         b1(6,5) = -18.0d0*yi*xk + 24.0d0*xi*yk
         b1(6,6) = 24.0d0*yi*yk + 24.0d0*xi*xk + 15.0d0*zi*zk
         b1(6,7) = -6.0d0*yi*zk + 15.0d0*zi*yk
         b1(6,8) = b1(6,6)
         b1(6,9) = -18.0d0*xi*yk + 24.0d0*yi*xk
         b1(6,10) = -6.0d0*xi*zk + 15.0d0*zi*xk
         b1(6,11) = b1(6,7)
         b1(6,12) = b1(6,10)
         b1(6,13) = -6.0d0*yi*xk - 6.0d0*xi*yk
         b1(7,1) = 15.0d0*xk*zk*d - 3.0d0*rk2*(xi*zk+xk*zi)
         b1(7,2) = 15.0d0*zk*yi*yk + 12.0d0*zk2*zi - 9.0d0*zi*xk2
     &                - 3.0d0*zi*yk2  + 24.0d0*xk*xi*zk
         b1(7,3) = - 6.0d0*zi*xk*yk - 6.0d0*yk*xi*zk + 15.0d0*xk*yi*zk
         b1(7,4) = 12.0d0*xi*xk2  - 3.0d0*xi*yk2  - 9.0d0*xi*zk2
     &                + 15.0d0*xk*yi*yk + 24.0d0*xk*zi*zk
         b1(7,5) = -18.0d0*zi*xk + 24.0d0*xi*zk
         b1(7,6) = -6.0d0*zi*yk + 15.0d0*yi*zk
         b1(7,7) = 24.0d0*xi*xk + 24.0d0*zi*zk + 15.0d0*yi*yk
         b1(7,8) = b1(7,6)
         b1(7,9) = -6.0d0*zi*xk - 6.0d0*xi*zk
         b1(7,10) = -6.0d0*xi*yk + 15.0d0*yi*xk
         b1(7,11) = b1(7,7)
         b1(7,12) = b1(7,10)
         b1(7,13) = -18.0d0*xi*zk + 24.0d0*zi*xk
         b1(9,1) = 15.0d0*d*yk2-3.0d0*rk2*(d+2.0d0*yi*yk)
         b1(9,2) = -9.0d0*xi*xk2 + 12.0d0*xi*yk2 - 3.0d0*xi*zk2
     &                - 18.0d0*xk*yi*yk - 6.0d0*xk*zi*zk
         b1(9,3) = -9.0d0*yi*xk2  + 18.0d0*yk2*yi - 9.0d0*yi*zk2
     &                + 24.0d0*yk*zi*zk + 24.0d0*xk*xi*yk
         b1(9,4) = 12.0d0*zi*yk2 - 18.0d0*zk*yi*yk - 3.0d0*zi*xk2
     &                - 9.0d0*zk2*zi - 6.0d0*xk*xi*zk
         b1(9,5) = -18.0d0*xi*xk - 6.0d0*zi*zk - 18.0d0*yi*yk
         b1(9,6) = -18.0d0*yi*xk + 24.0d0*xi*yk
         b1(9,7) = -6.0d0*zi*xk - 6.0d0*xi*zk
         b1(9,8) = b1(9,6)
         b1(9,9) = 24.0d0*xi*xk + 24.0d0*zi*zk + 36.0d0*yi*yk
         b1(9,10) = -18.0d0*yi*zk + 24.0d0*zi*yk
         b1(9,11) = b1(9,7)
         b1(9,12) = b1(9,10)
         b1(9,13) = -18.0d0*yi*yk - 6.0d0*xi*xk - 18.0d0*zi*zk
         b1(10,1) = 15.0d0*yk*zk*d - 3.0d0*rk2*(yi*zk+yk*zi)
         b1(10,2) = -6.0d0*zi*xk*yk -6.0d0*xk*yi*zk + 15.0d0*yk*xi*zk
         b1(10,3) = 12.0d0* zk2*zi + 15.0d0*xk*xi*zk - 3.0d0*zi*xk2
     &                 - 9.0d0*zi*yk2  + 24.0d0*zk*yi*yk
         b1(10,4) = 15.0d0*xk*xi*yk + 12.0d0*yk2*yi - 3.0d0*yi*xk2
     &                 - 9.0d0*yi*zk2  + 24.0d0*yk*zi*zk
         b1(10,5) = -6.0d0*yi*zk - 6.0d0*zi*yk
         b1(10,6) = -6.0d0*zi*xk + 15.0d0*xi*zk
         b1(10,7) = -6.0d0*yi*xk + 15.0d0*xi*yk
         b1(10,8) = b1(10,6)
         b1(10,9) = 24.0d0*yi*zk - 18.0d0*zi*yk
         b1(10,10) = 15.0d0*xi*xk + 24.0d0*zi*zk + 24.0d0*yi*yk
         b1(10,11) = b1(10,7)
         b1(10,12) = b1(10,10)
         b1(10,13) = -18.0d0*yi*zk + 24.0d0*zi*yk
         b1(13,1) = 15.0d0*d*zk2-3.0d0*rk2*(d+2.0d0*zi*zk)
         b1(13,2) = 12.0d0*xi*zk2 - 18.0d0*xk*zi*zk - 9.0d0*xi*xk2
     &                 - 3.0d0*xi*yk2 - 6.0d0*xk*yi*yk
         b1(13,3) = 12.0d0*yi*zk2 - 3.0d0*yi*xk2 - 9.0d0*yk2*yi
     &                 - 18.0d0*yk*zi*zk - 6.0d0*xk*xi*yk
         b1(13,4) = -9.0d0*zi*xk2 - 9.0d0*zi*yk2 + 18.0d0*zk2*zi
     &                 + 24.0d0*xk*xi*zk + 24.0d0*zk*yi*yk
         b1(13,5) = -6.0d0*yi*yk - 18.0d0*zi*zk - 18.0d0*xi*xk
         b1(13,6) = -6.0d0*yi*xk - 6.0d0*xi*yk
         b1(13,7) = 24.0d0*xi*zk - 18.0d0*zi*xk
         b1(13,8) = b1(13,6)
         b1(13,9) = -18.0d0*yi*yk - 6.0d0*xi*xk - 18.0d0*zi*zk
         b1(13,10) = 24.0d0*yi*zk - 18.0d0*zi*yk
         b1(13,11) = b1(13,7)
         b1(13,12) = b1(13,10)
         b1(13,13) = 36.0d0*zi*zk + 24.0d0*xi*xk + 24.0d0*yi*yk
         do fi = 1, isiz
            b1(8,fi) = b1(6,fi)
            b1(11,fi) = b1(7,fi)
            b1(12,fi) = b1(10,fi)
         end do
         do fi = 1, isiz
            m2t2(fi) = 0.0d0
            do fj = 1, ksiz
               m2t2(fi) = m2t2(fi) + b1(fi,fj)*rpk(fj)
            end do
         end do
         term = 0.0d0
         do fi = 1, isiz
            term = term + rpi(fi)*m2t2(fi)
         end do
         term = 4.0d0 * size * term / (4.0d0*ratio+3.0d0)
         eik = eik + term
         size = size * size2
      end if
c
c     recursive formulation of 4th through nth summation terms
c
      do fii = 4, nn
         do fi = 1, p_e1
            if (fi .eq. 8) then
               do fj = 1, p_e2
                  rklij(fi,fj) = rklij(6,fj)
               end do
            else if (fi .eq. 11) then
               do fj = 1, p_e2
                  rklij(fi,fj) = rklij(7,fj)
               end do
            else if (fi .eq. 12) then
               do fj = 1, p_e2
                  rklij(fi,fj) = rklij(10,fj)
               end do
            else
               do fj = 1, p_e2
                  if (fj .eq. 8) then
                     rklij(fi,fj) = rklij(fi,6)
                  else if (fj .eq. 11) then
                     rklij(fi,fj) = rklij(fi,7)
                  else if (fj .eq. 12) then
                     rklij(fi,fj) = rklij(fi,10)
                  else
                     rklij(fi,fj) = d1d2 (fii,xi,yi,zi,xk,yk,zk,
     &                                    d,ri2,rk2,ind1_x(fi),
     &                                    ind1_y(fi),ind1_z(fi),
     &                              ind2_x(fj),ind2_y(fj),ind2_z(fj))
                  end if
               end do
            end if
         end do
c
c     update storage of the last two sets of matrix elements
c
         do fi = 1, p_e1
           do fj = 1, p_e2
              b2(fj,fi) = b1(fj,fi)
              b1(fj,fi) = rklij(fj,fi)
           end do
         end do
c
c     compute interaction energy between the two multipole sites
c
         do fi = 1, isiz
            m2t2(fi) = 0.0d0
            do fj = 1, ksiz
               m2t2(fi) = m2t2(fi) + rklij(fi,fj)*rpk(fj)
            end do
         end do
         term = 0.0d0
         do fi = 1, isiz
            term = term + rpi(fi)*m2t2(fi)
         end do
         term = term * size * dble(fii+1)
     &             / (dble(fii+1)*ratio+dble(fii))
         eik = eik + term
         size = size * size2
      end do
      eik = factor * eik
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine rfindex  --  reaction field indices for sites  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "rfindex" finds indices for each multipole site for use
c     in computing reaction field energetics
c
c
      subroutine rfindex (n,m,ind_x,ind_y,ind_z,p_s,p_e)
      implicit none
      integer i,j,k,n,m
      integer p_s,p_e
      integer ind_x(*)
      integer ind_y(*)
      integer ind_z(*)
c
c
      p_s = 1
      p_e = 1
      do i = 1, m
         ind_x(i) = 0
         ind_y(i) = 0
         ind_z(i) = 0
      end do
      k = 1
      do i = 1, n
         do j = p_s, p_e
            k = k + 1
            ind_x(k) = ind_x(j) + 1
            ind_y(k) = ind_y(j)
            ind_z(k) = ind_z(j)
         end do
         do j = p_s, p_e
            k = k + 1
            ind_x(k) = ind_x(j)
            ind_y(k) = ind_y(j) + 1
            ind_z(k) = ind_z(j)
         end do
         do j = p_s, p_e
            k = k + 1
            ind_x(k) = ind_x(j)
            ind_y(k) = ind_y(j)
            ind_z(k) = ind_z(j) + 1
         end do
         p_s = p_e + 1
         p_e = k
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ijkpts  --  indices into "b1" and "b2" arrays  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ijkpts" stores a set of indices used during calculation
c     of macroscopic reaction field energetics
c
      subroutine ijkpts
      use rxnfld
      implicit none
      integer i,j,k
c
c
c     find and store indices into the "b1" and "b2" arrays
c
      do i = 0, 5
         do j = 0, 5
            do k = 0, 5
               ijk(i,j,k) = (3**(i+j+k) + 3**(j+k) + 3**k - 1) / 2
            end do
         end do
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function d1d2  --  recursive summation element utility  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "d1d2" is a utility function used in computation of the
c     reaction field recursive summation elements
c
c
      function d1d2 (n,x1,y1,z1,x2,y2,z2,d,r1sq,r2sq,i,j,k,s,t,u)
      use rxnfld
      implicit none
      integer n,i,j,k
      integer s,t,u
      integer is,it,iu
      integer js,jt,ju
      integer ks,kt,ku
      real*8 x1,y1,z1
      real*8 x2,y2,z2
      real*8 d1d2,d,f,g
      real*8 r1sq,r2sq
c
c
      if (n.lt.i+j+k  .or. n.lt.s+t+u) then
         d1d2 = 0.0d0
         return
      end if
      is = i*s
      it = i*t
      iu = i*u
      js = j*s
      jt = j*t
      ju = j*u
      ks = k*s
      kt = k*t
      ku = k*u
      f = d*b1(ijk(i,j,k),ijk(s,t,u))
      g = r1sq*r2sq*b2(ijk(i,j,k),ijk(s,t,u))
      if (i .ne. 0) then
         f = f + i*x2*b1(ijk(i-1,j,k),ijk(s,t,u))
         g = g + 2.0d0*i*x1*r2sq*b2(ijk(i-1,j,k),ijk(s,t,u))
         if (i .ne. 1)  g = g + i*(i-1)*r2sq*b2(ijk(i-2,j,k),ijk(s,t,u))
      end if
      if (j .ne. 0) then
         f = f + j*y2*b1(ijk(i,j-1,k),ijk(s,t,u))
         g = g + 2.0d0*j*y1*r2sq*b2(ijk(i,j-1,k),ijk(s,t,u))
         if (j .ne. 1)  g = g + j*(j-1)*r2sq*b2(ijk(i,j-2,k),ijk(s,t,u))
      end if
      if (k .ne. 0) then
         f = f + k*z2*b1(ijk(i,j,k-1),ijk(s,t,u))
         g = g + 2.0d0*k*z1*r2sq*b2(ijk(i,j,k-1),ijk(s,t,u))
         if (k .ne. 1)  g = g + k*(k-1)*r2sq*b2(ijk(i,j,k-2),ijk(s,t,u))
      end if
      if (s .ne. 0) then
         f = f + s*x1*b1(ijk(i,j,k),ijk(s-1,t,u))
         g = g + 2.0d0*s*x2*r1sq*b2(ijk(i,j,k),ijk(s-1,t,u))
         if (s .ne. 1)  g = g + s*(s-1)*r1sq*b2(ijk(i,j,k),ijk(s-2,t,u))
      end if
      if (t .ne. 0) then
         f = f + t*y1*b1(ijk(i,j,k),ijk(s,t-1,u))
         g = g + 2.0d0*t*y2*r1sq*b2(ijk(i,j,k),ijk(s,t-1,u))
         if (t .ne. 1)  g = g + t*(t-1)*r1sq*b2(ijk(i,j,k),ijk(s,t-2,u))
      end if
      if (u .ne. 0) then
         f = f + u*z1*b1(ijk(i,j,k),ijk(s,t,u-1))
         g = g + 2.0d0*u*z2*r1sq*b2(ijk(i,j,k),ijk(s,t,u-1))
         if (u .ne. 1)  g = g + u*(u-1)*r1sq*b2(ijk(i,j,k),ijk(s,t,u-2))
      end if
      if (is .ne. 0) then
         f = f + is*b1(ijk(i-1,j,k),ijk(s-1,t,u))
         g = g + 4.0d0*is*x1*x2*b2(ijk(i-1,j,k),ijk(s-1,t,u))
         if (i .ne. 1) then
            g = g + 2.0d0*(i-1)*is*x2*b2(ijk(i-2,j,k),ijk(s-1,t,u))
            if (s .ne. 1)
     &         g = g + (i-1)*(s-1)*is*b2(ijk(i-2,j,k),ijk(s-2,t,u))
         end if
         if (s .ne. 1)
     &      g = g + 2.0d0*(s-1)*is*x1*b2(ijk(i-1,j,k),ijk(s-2,t,u))
      end if
      if (jt .ne. 0) then
         f = f + jt*b1(ijk(i,j-1,k),ijk(s,t-1,u))
         g = g + 4.0d0*jt*y1*y2*b2(ijk(i,j-1,k),ijk(s,t-1,u))
         if (j .ne. 1) then
            g = g + 2.0d0*(j-1)*jt*y2*b2(ijk(i,j-2,k),ijk(s,t-1,u))
            if (t .ne. 1)
     &         g = g + (j-1)*(t-1)*jt*b2(ijk(i,j-2,k),ijk(s,t-2,u))
         end if
         if (t .ne. 1)
     &      g = g + 2.0d0*(t-1)*jt*y1*b2(ijk(i,j-1,k),ijk(s,t-2,u))
      end if
      if (ku .ne. 0) then
         f = f + ku*b1(ijk(i,j,k-1),ijk(s,t,u-1))
         g = g + 4.0d0*ku*z1*z2*b2(ijk(i,j,k-1),ijk(s,t,u-1))
         if (k .ne. 1) then
            g = g + 2.0d0*(k-1)*ku*z2*b2(ijk(i,j,k-2),ijk(s,t,u-1))
            if (u .ne. 1)
     &         g = g + (k-1)*(u-1)*ku*b2(ijk(i,j,k-2),ijk(s,t,u-2))
         end if
         if (u .ne. 1)
     &      g = g + 2.0d0*(u-1)*ku*z1*b2(ijk(i,j,k-1),ijk(s,t,u-2))
      end if
      if (it .ne. 0) then
         g = g + 4.0d0*it*x1*y2*b2(ijk(i-1,j,k),ijk(s,t-1,u))
         if (i .ne. 1) then
            g = g + 2.0d0*(i-1)*it*y2*b2(ijk(i-2,j,k),ijk(s,t-1,u))
            if (t .ne. 1)
     &         g = g + (i-1)*(t-1)*it*b2(ijk(i-2,j,k),ijk(s,t-2,u))
         end if
         if (t .ne. 1)
     &      g = g + 2.0d0*(t-1)*it*x1*b2(ijk(i-1,j,k),ijk(s,t-2,u))
      end if
      if (iu .ne. 0) then
         g = g + 4.0d0*iu*x1*z2*b2(ijk(i-1,j,k),ijk(s,t,u-1))
         if (i .ne. 1) then
            g = g + 2.0d0*(i-1)*iu*z2*b2(ijk(i-2,j,k),ijk(s,t,u-1))
            if (u .ne. 1)
     &         g = g + (i-1)*(u-1)*iu*b2(ijk(i-2,j,k),ijk(s,t,u-2))
         end if
         if (u .ne. 1)
     &      g = g + 2.0d0*(u-1)*iu*x1*b2(ijk(i-1,j,k),ijk(s,t,u-2))
      end if
      if (js .ne. 0) then
         g = g + 4.0d0*js*y1*x2*b2(ijk(i,j-1,k),ijk(s-1,t,u))
         if (j .ne. 1) then
            g = g + 2.0d0*(j-1)*js*x2*b2(ijk(i,j-2,k),ijk(s-1,t,u))
            if (s .ne. 1)
     &         g = g + (j-1)*(s-1)*js*b2(ijk(i,j-2,k),ijk(s-2,t,u))
         end if
         if (s .ne. 1)
     &      g = g + 2.0d0*(s-1)*js*y1*b2(ijk(i,j-1,k),ijk(s-2,t,u))
      end if
      if (ju .ne. 0) then
         g = g + 4.0d0*ju*y1*z2*b2(ijk(i,j-1,k),ijk(s,t,u-1))
         if (j .ne. 1) then
            g = g + 2.0d0*(j-1)*ju*z2*b2(ijk(i,j-2,k),ijk(s,t,u-1))
            if (u .ne. 1)
     &         g = g + (j-1)*(u-1)*ju*b2(ijk(i,j-2,k),ijk(s,t,u-2))
         end if
         if (u .ne. 1)
     &      g = g + 2.0d0*(u-1)*ju*y1*b2(ijk(i,j-1,k),ijk(s,t,u-2))
      end if
      if (ks .ne. 0) then
         g = g + 4.0d0*ks*z1*x2*b2(ijk(i,j,k-1),ijk(s-1,t,u))
         if (k .ne. 1) then
            g = g + 2.0d0*(k-1)*ks*x2*b2(ijk(i,j,k-2),ijk(s-1,t,u))
            if (s .ne. 1)
     &         g = g + (k-1)*(s-1)*ks*b2(ijk(i,j,k-2),ijk(s-2,t,u))
         end if
         if (s .ne. 1)
     &      g = g + 2.0d0*(s-1)*ks*z1*b2(ijk(i,j,k-1),ijk(s-2,t,u))
      end if
      if (kt .ne. 0) then
         g = g + 4.0d0*kt*z1*y2*b2(ijk(i,j,k-1),ijk(s,t-1,u))
         if (k .ne. 1) then
            g = g + 2.0d0*(k-1)*kt*y2*b2(ijk(i,j,k-2),ijk(s,t-1,u))
            if (t .ne. 1)
     &         g = g + (k-1)*(t-1)*kt*b2(ijk(i,j,k-2),ijk(s,t-2,u))
         end if
         if (t .ne. 1)
     &      g = g + 2.0d0*(t-1)*kt*z1*b2(ijk(i,j,k-1),ijk(s,t-2,u))
      end if
      f = dble(2*n-1) * f
      g = dble(n-1) * g
      d1d2 = (f-g) / dble(n)
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 1996 by Yong Kong & Jay William Ponder  ##
c     ##                  All Rights Reserved                   ##
c     ############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine erxnfld1  --  reaction field energy & derivs  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "erxnfld1" calculates the macroscopic reaction field energy
c     and derivatives with respect to Cartesian coordinates
c
c
      subroutine erxnfld1
      use atoms
      use deriv
      use energi
      implicit none
      integer i,j
c
c
c     zero out macroscopic reaction field energy and derivatives
c
      erxf = 0.0d0
      do i = 1, n
         do j = 1, 3
            derxf(j,i) = 0.0d0
         end do
      end do
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 1996 by Yong Kong & Jay William Ponder  ##
c     ##                  All Rights Reserved                   ##
c     ############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine erxnfld2  --  atomwise reaction field Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "erxnfld2" calculates second derivatives of the macroscopic
c     reaction field energy for a single atom at a time
c
c
      subroutine erxnfld2 (i)
      implicit none
      integer i
c
c
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 1996 by Yong Kong & Jay William Ponder  ##
c     ##                  All Rights Reserved                   ##
c     ############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine erxnfld3  --  reaction field energy & analysis  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "erxnfld3" calculates the macroscopic reaction field energy,
c     and also partitions the energy among the atoms
c
c     literature reference:
c
c     Y. Kong and J. W. Ponder, "Reaction Field Methods for Off-Center
c     Multipoles", Journal of Chemical Physics, 107, 481-492 (1997)
c
c
      subroutine erxnfld3
      use action
      use analyz
      use atomid
      use atoms
      use chgpot
      use energi
      use inform
      use iounit
      use mpole
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer ix,iy,iz
      integer kx,ky,kz
      real*8 eik,r2
      real*8 xr,yr,zr
      real*8 r,di,dk
      real*8 rpi(13)
      real*8 rpk(13)
      logical usei,usek
      logical header,huge
      character*6 mode
c
c
c     zero out the reaction field energy and partitioning
c
      nerxf = 0
      erxf = 0.0d0
      do i = 1, n
         aerxf(i) = 0.0d0
      end do
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. npole.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Reaction Field Interactions :',
     &           //,' Type',14x,'Atom Names',11x,'Dist from Origin',
     &              4x,'R(1-2)',6x,'Energy',/)
      end if
c
c     set the switching function coefficients
c
      mode = 'MPOLE'
      call switch (mode)
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     compute the indices used in reaction field calculations
c
      call ijkpts
c
c     calculate the reaction field interaction energy term
c
      do ii = 1, npole
         i = ipole(ii)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
         do j = 1, polsiz(i)
            rpi(j) = rpole(j,i)
         end do
         do kk = ii, npole
            k = ipole(kk)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            if (usei .or. usek) then
               xr = x(k) - x(i)
               yr = y(k) - y(i)
               zr = z(k) - z(i)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  do j = 1, polsiz(k)
                     rpk(j) = rpole(j,k)
                  end do
                  call erfik (i,k,rpi,rpk,eik)
                  nerxf = nerxf + 1
                  erxf = erxf + eik
                  aerxf(i) = aerxf(i) + 0.5d0*eik
                  aerxf(k) = aerxf(k) + 0.5d0*eik
c
c     print a message if the energy of this interaction is large
c
                  huge = (eik .gt. 10.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,20)
   20                   format (/,' Individual Reaction Field',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Atom Names',
     &                             11x,'Dist from Origin',4x,'R(1-2)',
     &                             6x,'Energy',/)
                     end if
                     r = sqrt(r2)
                     di = sqrt(x(i)*x(i)+y(i)*y(i)+z(i)*z(i))
                     dk = sqrt(x(k)*x(k)+y(k)*y(k)+z(k)*z(k))
                     write (iout,30)  i,name(i),k,name(k),di,dk,r,eik
   30                format (' RxnFld',4x,2(i7,'-',a3),3x,3f10.4,f12.4)
                  end if
               end if
            end if
         end do
      end do
      return
      end
c
c
c     ################################################################
c     ##         COPYRIGHT (C)  1993  by  Jay William Ponder        ##
c     ##  COPYRIGHT (C) 2006 by Michael Schnieders & Jay W. Ponder  ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine esolv  --  implicit solvation potential energy  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "esolv" calculates the implicit solvation energy for surface area,
c     generalized Born, generalized Kirkwood and Poisson-Boltzmann
c     solvation models
c
c
      subroutine esolv
      use atoms
      use energi
      use limits
      use math
      use mpole
      use potent
      use solpot
      use solute
      use warp
      implicit none
      integer i
      real*8 e,ai,ri,rb
      real*8 term,probe
      real*8 esurf,ehp,eace
      real*8 ecav,edisp
      real*8, allocatable :: aes(:)
c
c
c     zero out the implicit solvation energy components
c
      es = 0.0d0
      esurf = 0.0d0
      ecav = 0.0d0
      edisp = 0.0d0
      ehp = 0.0d0
      eace = 0.0d0
c
c     set a value for the solvent molecule probe radius
c
      probe = 1.4d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (aes(n))
c
c     total solvation energy for surface area only models
c
      if (solvtyp.eq.'ASP' .or. solvtyp.eq.'SASA') then
         call surface (rsolv,asolv,probe,es,aes)
c
c     nonpolar energy as hydrophobic potential of mean force
c
      else if (solvtyp.eq.'GB-HPMF' .or. solvtyp.eq.'GK-HPMF'
     &            .or. solvtyp.eq.'PB-HPMF') then
         call ehpmf (ehp)
         es = ehp
c
c     nonpolar energy for Onion GB method via exact area
c
      else if (solvtyp.eq.'GB' .and. borntyp.eq.'ONION') then
         call surface (rsolv,asolv,probe,esurf,aes)
         es = esurf
c
c     nonpolar energy as cavity formation plus dispersion
c
      else if (solvtyp.eq.'GK' .or. solvtyp.eq.'PB') then
         call enp (ecav,edisp)
         es = ecav + edisp
c
c     nonpolar energy for GB via ACE surface area approximation
c
      else
         term = 4.0d0 * pi
         do i = 1, n
            ai = asolv(i)
            ri = rsolv(i)
            rb = rborn(i)
            if (rb .ne. 0.0d0) then
               e = ai * term * (ri+probe)**2 * (ri/rb)**6
               eace = eace + e
            end if
         end do
         es = eace
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (aes)
c
c     get polarization energy term for the solvation methods
c
      if (solvtyp(1:2) .eq. 'GK') then
         if (.not.use_mpole .and. .not.use_polar) then
            call chkpole
            call rotpole ('MPOLE')
            call induce
         end if
         call egk
      else if (solvtyp(1:2) .eq. 'PB') then
         call epb
      else if (use_born) then
         if (use_smooth) then
            call egb0c
         else if (use_clist) then
            call egb0b
         else
            call egb0a
         end if
      end if
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine egb0a  --  GB polarization via double loop  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "egb0a" calculates the generalized Born polarization energy
c     for the GB/SA solvation models using a pairwise double loop
c
c
      subroutine egb0a
      use atoms
      use charge
      use chgpot
      use energi
      use group
      use shunt
      use solute
      use usage
      implicit none
      integer i,k,ii,kk
      real*8 e,f,fi,fik
      real*8 dwater,fgrp
      real*8 rb2,rm2,fgb,fgm
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7
      real*8 shift,taper,trans
      logical proceed,usei
      character*6 mode
c
c
c     set the solvent dielectric and energy conversion factor
c
      if (nion .eq. 0)  return
      dwater = 78.3d0
      f = -electric * (1.0d0 - 1.0d0/dwater)
c
c     set cutoff distances and switching function coefficients
c
      mode = 'CHARGE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,use,x,y,z,f,
!$OMP& pchg,rborn,use_group,off,off2,cut,cut2,c0,c1,c2,c3,c4,c5,
!$OMP& f0,f1,f2,f3,f4,f5,f6,f7)
!$OMP& shared(es)
!$OMP DO reduction(+:es)
c
c     calculate GB electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         usei = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
c
c     decide whether to compute the current interaction
c
         do kk = ii, nion
            k = iion(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  fik = fi * pchg(k)
                  rb2 = rborn(i) * rborn(k)
                  fgb = sqrt(r2 + rb2*exp(-0.25d0*r2/rb2))
                  e = fik / fgb
c
c     use shifted energy switching if near the cutoff distance
c
                  rm2 = (0.5d0 * (off+cut))**2
                  fgm = sqrt(rm2 + rb2*exp(-0.25d0*rm2/rb2))
                  shift = fik / fgm
                  e = e - shift
                  if (r2 .gt. cut2) then
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     r6 = r3 * r3
                     r7 = r3 * r4
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4
     &                               + f3*r3 + f2*r2 + f1*r + f0)
                     e = e*taper + trans
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall GB solvation energy component
c
                  if (i .eq. k)  e = 0.5d0 * e
                  es = es + e
               end if
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine egb0b  --  GB polarization via neighbor list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "egb0b" calculates the generalized Born polarization energy
c     for the GB/SA solvation models using a pairwise neighbor list
c
c
      subroutine egb0b
      use atoms
      use charge
      use chgpot
      use energi
      use group
      use neigh
      use shunt
      use solute
      use usage
      implicit none
      integer i,k,ii,kk
      real*8 e,f,fi,fik
      real*8 dwater,fgrp
      real*8 rbi,rb2,rm2
      real*8 fgb,fgm
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7
      real*8 shift,taper,trans
      logical proceed,usei
      character*6 mode
c
c
c     set the solvent dielectric and energy conversion factor
c
      if (nion .eq. 0)  return
      dwater = 78.3d0
      f = -electric * (1.0d0 - 1.0d0/dwater)
c
c     set cutoff distances and switching function coefficients
c
      mode = 'CHARGE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,use,x,y,z,
!$OMP& f,pchg,rborn,nelst,elst,use_group,off,off2,cut,cut2,
!$OMP& c0,c1,c2,c3,c4,c5,f0,f1,f2,f3,f4,f5,f6,f7)
!$OMP& shared(es)
!$OMP DO reduction(+:es)
c
c     calculate GB electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         usei = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         rbi = rborn(i)
c
c     calculate the self-energy term for the current atom
c
         fik = fi * pchg(i)
         rb2 = rbi * rbi
         e = fik / rbi
         rm2 = (0.5d0 * (off+cut))**2
         fgm = sqrt(rm2 + rb2*exp(-0.25d0*rm2/rb2))
         shift = fik / fgm
         e = e - shift
         es = es + 0.5d0*e
c
c     decide whether to compute the current interaction
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  fik = fi * pchg(k)
                  rb2 = rbi * rborn(k)
                  fgb = sqrt(r2 + rb2*exp(-0.25d0*r2/rb2))
                  e = fik / fgb
c
c     use shifted energy switching if near the cutoff distance
c
                  rm2 = (0.5d0 * (off+cut))**2
                  fgm = sqrt(rm2 + rb2*exp(-0.25d0*rm2/rb2))
                  shift = fik / fgm
                  e = e - shift
                  if (r2 .gt. cut2) then
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     r6 = r3 * r3
                     r7 = r3 * r4
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4
     &                               + f3*r3 + f2*r2 + f1*r + f0)
                     e = e*taper + trans
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall GB solvation energy component
c
                  es = es + e
               end if
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine egb0c  --  GB polarization energy for smoothing  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "egb0c" calculates the generalized Born polarization energy
c     for the GB/SA solvation models for use with potential smoothing
c     methods via analogy to the smoothing of Coulomb's law
c
c
      subroutine egb0c
      use atoms
      use charge
      use chgpot
      use energi
      use group
      use solute
      use usage
      use warp
      implicit none
      integer i,k,ii,kk
      real*8 e,fgrp
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 dwater,width
      real*8 erf,sterm
      real*8 r2,fgb,rb2
      logical proceed,usei
      external erf
c
c
c     set the solvent dielectric and energy conversion factor
c
      if (nion .eq. 0)  return
      dwater = 78.3d0
      f = -electric * (1.0d0 - 1.0d0/dwater)
c
c     set the extent of smoothing to be performed
c
      sterm = 0.5d0 / sqrt(diffc)
c
c     calculate GB electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         usei = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
c
c     decide whether to compute the current interaction
c
         do kk = ii, nion
            k = iion(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               fik = fi * pchg(k)
               rb2 = rborn(i) * rborn(k)
               fgb = sqrt(r2 + rb2*exp(-0.25d0*r2/rb2))
               e = fik / fgb
c
c     use a smoothable GB analogous to Coulomb's law solution
c
               if (deform .gt. 0.0d0) then
                  width = deform + 0.15d0*rb2*exp(-0.006d0*rb2/deform)
                  width = sterm / sqrt(width)
                  e = e * erf(width*fgb)
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the overall GB solvation energy component
c
               if (i .eq. k)  e = 0.5d0 * e
               es = es + e
            end if
         end do
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine egk  --  generalized Kirkwood solvation model  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "egk" calculates the generalized Kirkwood electrostatic
c     solvation free energy for the GK/NP implicit solvation model
c
c
      subroutine egk
      use mpole
      use potent
      implicit none
c
c
c     setup the multipoles for solvation only calculations
c
      if (.not. use_mpole) then
          call chkpole
          call rotpole ('MPOLE')
      end if
c
c     compute the generalized Kirkwood electrostatic energy
c
      call egk0a
c
c     correct solvation energy for vacuum to polarized state
c
      if (use_polar) then
         call ediff
      else if (.not.use_mpole .and. .not.use_polar) then
         call ediff
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine egk0a  --  find generalized Kirkwood energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "egk0a" calculates the electrostatic portion of the implicit
c     solvation energy via the generalized Kirkwood model
c
c
      subroutine egk0a
      use atoms
      use chgpot
      use energi
      use gkstuf
      use group
      use mpole
      use polar
      use shunt
      use solute
      use usage
      implicit none
      integer i,k,ii,kk
      real*8 e,ei
      real*8 fc,fd,fq
      real*8 dwater,fgrp
      real*8 r2,rb2
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xr2,yr2,zr2
      real*8 ci,ck
      real*8 uxi,uyi,uzi
      real*8 uxk,uyk,uzk
      real*8 dxi,dyi,dzi
      real*8 dxk,dyk,dzk
      real*8 qxxi,qxyi,qxzi
      real*8 qyyi,qyzi,qzzi
      real*8 qxxk,qxyk,qxzk
      real*8 qyyk,qyzk,qzzk
      real*8 rbi,rbk
      real*8 expterm
      real*8 gf,gf2,gf3
      real*8 gf5,gf7,gf9
      real*8 expc,dexpc
      real*8 expc1,expcdexpc
      real*8 esym,ewi,ewk
      real*8 esymi,ewii,ewki
      real*8 a(0:4,0:2)
      real*8 gc(10),gux(10)
      real*8 guy(10),guz(10)
      real*8 gqxx(10),gqxy(10)
      real*8 gqxz(10),gqyy(10)
      real*8 gqyz(10),gqzz(10)
      logical proceed,usei
      character*6 mode
c
c
c     set the bulk dielectric constant to the water value
c
      if (npole .eq. 0)  return
      dwater = 78.3d0
      fc = electric * 1.0d0 * (1.0d0-dwater)/(0.0d0+1.0d0*dwater)
      fd = electric * 2.0d0 * (1.0d0-dwater)/(1.0d0+2.0d0*dwater)
      fq = electric * 3.0d0 * (1.0d0-dwater)/(2.0d0+3.0d0*dwater)
c
c     set cutoff distances and switching function coefficients
c
      mode = 'MPOLE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,use,x,y,z,
!$OMP& rborn,rpole,uinds,use_group,off2,gkc,fc,fd,fq)
!$OMP& shared(es)
!$OMP DO reduction(+:es)
c
c     calculate GK electrostatic solvation free energy
c
      do ii = 1, npole
         i = ipole(ii)
         usei = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         rbi = rborn(i)
         ci = rpole(1,i)
         uxi = rpole(2,i)
         uyi = rpole(3,i)
         uzi = rpole(4,i)
         qxxi = rpole(5,i)
         qxyi = rpole(6,i)
         qxzi = rpole(7,i)
         qyyi = rpole(9,i)
         qyzi = rpole(10,i)
         qzzi = rpole(13,i)
         dxi = uinds(1,i)
         dyi = uinds(2,i)
         dzi = uinds(3,i)
c
c     decide whether to compute the current interaction
c
         do kk = ii, npole
            k = ipole(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               xr2 = xr * xr
               yr2 = yr * yr
               zr2 = zr * zr
               r2 = xr2 + yr2 + zr2
               if (r2 .le. off2) then
                  rbk = rborn(k)
                  ck = rpole(1,k)
                  uxk = rpole(2,k)
                  uyk = rpole(3,k)
                  uzk = rpole(4,k)
                  qxxk = rpole(5,k)
                  qxyk = rpole(6,k)
                  qxzk = rpole(7,k)
                  qyyk = rpole(9,k)
                  qyzk = rpole(10,k)
                  qzzk = rpole(13,k)
                  dxk = uinds(1,k)
                  dyk = uinds(2,k)
                  dzk = uinds(3,k)
                  rb2 = rbi * rbk
                  expterm = exp(-r2/(gkc*rb2))
                  expc = expterm / gkc
                  dexpc = -2.0d0 / (gkc*rbi*rbk)
                  gf2 = 1.0d0 / (r2 + rb2*expterm)
                  gf = sqrt(gf2)
                  gf3 = gf2 * gf
                  gf5 = gf3 * gf2
                  gf7 = gf5 * gf2
                  gf9 = gf7 * gf2
c
c     reaction potential auxiliary terms
c
                  a(0,0) = gf
                  a(1,0) = -gf3
                  a(2,0) = 3.0d0 * gf5
                  a(3,0) = -15.0d0 * gf7
                  a(4,0) = 105.0d0 * gf9
c
c     reaction potential gradient auxiliary terms
c
                  expc1 = 1.0d0 - expc
                  a(0,1) = expc1 * a(1,0)
                  a(1,1) = expc1 * a(2,0)
                  a(2,1) = expc1 * a(3,0)
                  a(3,1) = expc1 * a(4,0)
c
c     second reaction potential gradient auxiliary terms
c
                  expcdexpc = -expc * dexpc
                  a(0,2) = expc1*a(1,1) + expcdexpc*a(1,0)
                  a(1,2) = expc1*a(2,1) + expcdexpc*a(2,0)
                  a(2,2) = expc1*a(3,1) + expcdexpc*a(3,0)
c
c     multiply the auxillary terms by their dieletric functions
c
                  a(0,0) = fc * a(0,0)
                  a(0,1) = fc * a(0,1)
                  a(0,2) = fc * a(0,2)
                  a(1,0) = fd * a(1,0)
                  a(1,1) = fd * a(1,1)
                  a(1,2) = fd * a(1,2)
                  a(2,0) = fq * a(2,0)
                  a(2,1) = fq * a(2,1)
                  a(2,2) = fq * a(2,2)
c
c     unweighted reaction potential tensor
c
                  gc(1) = a(0,0)
                  gux(1) = xr * a(1,0)
                  guy(1) = yr * a(1,0)
                  guz(1) = zr * a(1,0)
                  gqxx(1) = xr2 * a(2,0)
                  gqyy(1) = yr2 * a(2,0)
                  gqzz(1) = zr2 * a(2,0)
                  gqxy(1) = xr * yr * a(2,0)
                  gqxz(1) = xr * zr * a(2,0)
                  gqyz(1) = yr * zr * a(2,0)
c
c     unweighted reaction potential gradient tensor
c
                  gc(2) = xr * a(0,1)
                  gc(3) = yr * a(0,1)
                  gc(4) = zr * a(0,1)
                  gux(2) = a(1,0) + xr2*a(1,1)
                  gux(3) = xr * yr * a(1,1)
                  gux(4) = xr * zr * a(1,1)
                  guy(2) = gux(3)
                  guy(3) = a(1,0) + yr2*a(1,1)
                  guy(4) = yr * zr * a(1,1)
                  guz(2) = gux(4)
                  guz(3) = guy(4)
                  guz(4) = a(1,0) + zr2*a(1,1)
                  gqxx(2) = xr * (2.0d0*a(2,0)+xr2*a(2,1))
                  gqxx(3) = yr * xr2 * a(2,1)
                  gqxx(4) = zr * xr2 * a(2,1)
                  gqyy(2) = xr * yr2 * a(2,1)
                  gqyy(3) = yr * (2.0d0*a(2,0)+yr2*a(2,1))
                  gqyy(4) = zr * yr2 * a(2,1)
                  gqzz(2) = xr * zr2 * a(2,1)
                  gqzz(3) = yr * zr2 * a(2,1)
                  gqzz(4) = zr * (2.0d0*a(2,0)+zr2*a(2,1))
                  gqxy(2) = yr * (a(2,0)+xr2*a(2,1))
                  gqxy(3) = xr * (a(2,0)+yr2*a(2,1))
                  gqxy(4) = zr * xr * yr * a(2,1)
                  gqxz(2) = zr * (a(2,0)+xr2*a(2,1))
                  gqxz(3) = gqxy(4)
                  gqxz(4) = xr * (a(2,0)+zr2*a(2,1))
                  gqyz(2) = gqxy(4)
                  gqyz(3) = zr * (a(2,0)+yr2*a(2,1))
                  gqyz(4) = yr * (a(2,0)+zr2*a(2,1))
c
c     unweighted second reaction potential gradient tensor
c
                  gc(5) = a(0,1) + xr2*a(0,2)
                  gc(6) = xr * yr * a(0,2)
                  gc(7) = xr * zr * a(0,2)
                  gc(8) = a(0,1) + yr2*a(0,2)
                  gc(9) = yr * zr * a(0,2)
                  gc(10) = a(0,1) + zr2*a(0,2)
                  gux(5) = xr * (a(1,1)+2.0d0*a(1,1)+xr2*a(1,2))
                  gux(6) = yr * (a(1,1)+xr2*a(1,2))
                  gux(7) = zr * (a(1,1)+xr2*a(1,2))
                  gux(8) = xr * (a(1,1)+yr2*a(1,2))
                  gux(9) = zr * xr * yr * a(1,2)
                  gux(10) = xr * (a(1,1)+zr2*a(1,2))
                  guy(5) = yr * (a(1,1)+xr2*a(1,2))
                  guy(6) = xr * (a(1,1)+yr2*a(1,2))
                  guy(7) = gux(9)
                  guy(8) = yr * (a(1,1)+2.0d0*a(1,1)+yr2*a(1,2))
                  guy(9) = zr * (a(1,1)+yr2*a(1,2))
                  guy(10) = yr * (a(1,1)+zr2*a(1,2))
                  guz(5) = zr * (a(1,1)+xr2*a(1,2))
                  guz(6) = gux(9)
                  guz(7) = xr * (a(1,1)+zr2*a(1,2))
                  guz(8) = zr * (a(1,1)+yr2*a(1,2))
                  guz(9) = yr * (a(1,1)+zr2*a(1,2))
                  guz(10) = zr * (a(1,1)+2.0d0*a(1,1)+zr2*a(1,2))
                  gqxx(5) = 2.0d0*a(2,0) + xr2*(5.0d0*a(2,1)+xr2*a(2,2))
                  gqxx(6) = yr * xr *(2.0d0*a(2,1)+xr2*a(2,2))
                  gqxx(7) = zr * xr *(2.0d0*a(2,1)+xr2*a(2,2))
                  gqxx(8) = xr2 * (a(2,1)+yr2*a(2,2))
                  gqxx(9) = zr * yr * xr2 * a(2,2)
                  gqxx(10) = xr2 * (a(2,1)+zr2*a(2,2))
                  gqyy(5) = yr2 * (a(2,1)+xr2*a(2,2))
                  gqyy(6) = xr * yr * (2.0d0*a(2,1)+yr2*a(2,2))
                  gqyy(7) = xr * zr * yr2 * a(2,2)
                  gqyy(8) = 2.0d0*a(2,0) + yr2*(5.0d0*a(2,1)+yr2*a(2,2))
                  gqyy(9) = yr * zr * (2.0d0*a(2,1)+yr2*a(2,2))
                  gqyy(10) = yr2 * (a(2,1)+zr2*a(2,2))
                  gqzz(5) = zr2 * (a(2,1)+xr2*a(2,2))
                  gqzz(6) = xr * yr * zr2 * a(2,2)
                  gqzz(7) = xr * zr * (2.0d0*a(2,1)+zr2*a(2,2))
                  gqzz(8) = zr2 * (a(2,1)+yr2*a(2,2))
                  gqzz(9) = yr * zr * (2.0d0*a(2,1)+zr2*a(2,2))
                  gqzz(10) = 2.0d0*a(2,0)
     &                          + zr2*(5.0d0*a(2,1)+zr2*a(2,2))
                  gqxy(5) = xr * yr * (3.0d0*a(2,1)+xr2*a(2,2))
                  gqxy(6) = a(2,0) + (xr2+yr2)*a(2,1) + xr2*yr2*a(2,2)
                  gqxy(7) = zr * yr * (a(2,1)+xr2*a(2,2))
                  gqxy(8) = xr * yr * (3.0d0*a(2,1)+yr2*a(2,2))
                  gqxy(9) = zr * xr * (a(2,1)+yr2*a(2,2))
                  gqxy(10) = xr * yr * (a(2,1)+zr2*a(2,2))
                  gqxz(5) = xr * zr * (3.0d0*a(2,1)+xr2*a(2,2))
                  gqxz(6) = yr * zr * (a(2,1)+xr2*a(2,2))
                  gqxz(7) = a(2,0) + (xr2+zr2)*a(2,1) + xr2*zr2*a(2,2)
                  gqxz(8) = xr * zr * (a(2,1)+yr2*a(2,2))
                  gqxz(9) = xr * yr * (a(2,1)+zr2*a(2,2))
                  gqxz(10) = xr * zr * (3.0d0*a(2,1)+zr2*a(2,2))
                  gqyz(5) = zr * yr * (a(2,1)+xr2*a(2,2))
                  gqyz(6) = xr * zr * (a(2,1)+yr2*a(2,2))
                  gqyz(7) = xr * yr * (a(2,1)+zr2*a(2,2))
                  gqyz(8) = yr * zr * (3.0d0*a(2,1)+yr2*a(2,2))
                  gqyz(9) = a(2,0) + (yr2+zr2)*a(2,1) + yr2*zr2*a(2,2)
                  gqyz(10) = yr * zr * (3.0d0*a(2,1)+zr2*a(2,2))
c
c     electrostatic solvation free energy of the permanent multipoles
c     in their own GK reaction potential
c
                  esym = ci*ck*gc(1)
     &                     - uxi*(uxk*gux(2)+uyk*guy(2)+uzk*guz(2))
     &                     - uyi*(uxk*gux(3)+uyk*guy(3)+uzk*guz(3))
     &                     - uzi*(uxk*gux(4)+uyk*guy(4)+uzk*guz(4))
                  ewi = ci*(uxk*gc(2)+uyk*gc(3)+uzk*gc(4))
     &                    - ck*(uxi*gux(1)+uyi*guy(1)+uzi*guz(1))
     &               + ci*(qxxk*gc(5)+qyyk*gc(8)+qzzk*gc(10)
     &                  +2.0d0*(qxyk*gc(6)+qxzk*gc(7)+qyzk*gc(9)))
     &               + ck*(qxxi*gqxx(1)+qyyi*gqyy(1)+qzzi*gqzz(1)
     &                  +2.0d0*(qxyi*gqxy(1)+qxzi*gqxz(1)+qyzi*gqyz(1)))
     &               - uxi*(qxxk*gux(5)+qyyk*gux(8)+qzzk*gux(10)
     &                  +2.0d0*(qxyk*gux(6)+qxzk*gux(7)+qyzk*gux(9)))
     &               - uyi*(qxxk*guy(5)+qyyk*guy(8)+qzzk*guy(10)
     &                  +2.0d0*(qxyk*guy(6)+qxzk*guy(7)+qyzk*guy(9)))
     &               - uzi*(qxxk*guz(5)+qyyk*guz(8)+qzzk*guz(10)
     &                  +2.0d0*(qxyk*guz(6)+qxzk*guz(7)+qyzk*guz(9)))
     &               + uxk*(qxxi*gqxx(2)+qyyi*gqyy(2)+qzzi*gqzz(2)
     &                  +2.0d0*(qxyi*gqxy(2)+qxzi*gqxz(2)+qyzi*gqyz(2)))
     &               + uyk*(qxxi*gqxx(3)+qyyi*gqyy(3)+qzzi*gqzz(3)
     &                  +2.0d0*(qxyi*gqxy(3)+qxzi*gqxz(3)+qyzi*gqyz(3)))
     &               + uzk*(qxxi*gqxx(4)+qyyi*gqyy(4)+qzzi*gqzz(4)
     &                  +2.0d0*(qxyi*gqxy(4)+qxzi*gqxz(4)+qyzi*gqyz(4)))
     &               + qxxi*(qxxk*gqxx(5)+qyyk*gqxx(8)+qzzk*gqxx(10)
     &                  +2.0d0*(qxyk*gqxx(6)+qxzk*gqxx(7)+qyzk*gqxx(9)))
     &               + qyyi*(qxxk*gqyy(5)+qyyk*gqyy(8)+qzzk*gqyy(10)
     &                  +2.0d0*(qxyk*gqyy(6)+qxzk*gqyy(7)+qyzk*gqyy(9)))
     &               + qzzi*(qxxk*gqzz(5)+qyyk*gqzz(8)+qzzk*gqzz(10)
     &                  +2.0d0*(qxyk*gqzz(6)+qxzk*gqzz(7)+qyzk*gqzz(9)))
     &          + 2.0d0 * (qxyi*(qxxk*gqxy(5)+qyyk*gqxy(8)+qzzk*gqxy(10)
     &               +2.0d0*(qxyk*gqxy(6)+qxzk*gqxy(7)+qyzk*gqxy(9)))
     &               + qxzi*(qxxk*gqxz(5)+qyyk*gqxz(8)+qzzk*gqxz(10)
     &               +2.0d0*(qxyk*gqxz(6)+qxzk*gqxz(7)+qyzk*gqxz(9)))
     &               + qyzi*(qxxk*gqyz(5)+qyyk*gqyz(8)+qzzk*gqyz(10)
     &               +2.0d0*(qxyk*gqyz(6)+qxzk*gqyz(7)+qyzk*gqyz(9))))
                  ewk = ci*(uxk*gux(1)+uyk*guy(1)+uzk*guz(1))
     &                    - ck*(uxi*gc(2)+uyi*gc(3)+uzi*gc(4))
     &               + ci*(qxxk*gqxx(1)+qyyk*gqyy(1)+qzzk*gqzz(1)
     &                  +2.0d0*(qxyk*gqxy(1)+qxzk*gqxz(1)+qyzk*gqyz(1)))
     &               + ck*(qxxi*gc(5)+qyyi*gc(8)+qzzi*gc(10)
     &                  +2.0d0*(qxyi*gc(6)+qxzi*gc(7)+qyzi*gc(9)))
     &               - uxi*(qxxk*gqxx(2)+qyyk*gqyy(2)+qzzk*gqzz(2)
     &                  +2.0d0*(qxyk*gqxy(2)+qxzk*gqxz(2)+qyzk*gqyz(2)))
     &               - uyi*(qxxk*gqxx(3)+qyyk*gqyy(3)+qzzk*gqzz(3)
     &                  +2.0d0*(qxyk*gqxy(3)+qxzk*gqxz(3)+qyzk*gqyz(3)))
     &               - uzi*(qxxk*gqxx(4)+qyyk*gqyy(4)+qzzk*gqzz(4)
     &                  +2.0d0*(qxyk*gqxy(4)+qxzk*gqxz(4)+qyzk*gqyz(4)))
     &               + uxk*(qxxi*gux(5)+qyyi*gux(8)+qzzi*gux(10)
     &                  +2.0d0*(qxyi*gux(6)+qxzi*gux(7)+qyzi*gux(9)))
     &               + uyk*(qxxi*guy(5)+qyyi*guy(8)+qzzi*guy(10)
     &                  +2.0d0*(qxyi*guy(6)+qxzi*guy(7)+qyzi*guy(9)))
     &               + uzk*(qxxi*guz(5)+qyyi*guz(8)+qzzi*guz(10)
     &                  +2.0d0*(qxyi*guz(6)+qxzi*guz(7)+qyzi*guz(9)))
     &               + qxxi*(qxxk*gqxx(5)+qyyk*gqyy(5)+qzzk*gqzz(5)
     &                  +2.0d0*(qxyk*gqxy(5)+qxzk*gqxz(5)+qyzk*gqyz(5)))
     &               + qyyi*(qxxk*gqxx(8)+qyyk*gqyy(8)+qzzk*gqzz(8)
     &                  +2.0d0*(qxyk*gqxy(8)+qxzk*gqxz(8)+qyzk*gqyz(8)))
     &               + qzzi*(qxxk*gqxx(10)+qyyk*gqyy(10)+qzzk*gqzz(10)
     &               +2.0d0*(qxyk*gqxy(10)+qxzk*gqxz(10)+qyzk*gqyz(10)))
     &          + 2.0d0*(qxyi*(qxxk*gqxx(6)+qyyk*gqyy(6)+qzzk*gqzz(6)
     &               +2.0d0*(qxyk*gqxy(6)+qxzk*gqxz(6)+qyzk*gqyz(6)))
     &               + qxzi*(qxxk*gqxx(7)+qyyk*gqyy(7)+qzzk*gqzz(7)
     &               +2.0d0*(qxyk*gqxy(7)+qxzk*gqxz(7)+qyzk*gqyz(7)))
     &               + qyzi*(qxxk*gqxx(9)+qyyk*gqyy(9)+qzzk*gqzz(9)
     &               +2.0d0*(qxyk*gqxy(9)+qxzk*gqxz(9)+qyzk*gqyz(9))))
c
c     electrostatic solvation free energy of the permenant multipoles
c     in the GK reaction potential of the induced dipoles
c
                  esymi = -uxi*(dxk*gux(2)+dyk*guy(2)+dzk*guz(2))
     &                      - uyi*(dxk*gux(3)+dyk*guy(3)+dzk*guz(3))
     &                      - uzi*(dxk*gux(4)+dyk*guy(4)+dzk*guz(4))
     &                      - uxk*(dxi*gux(2)+dyi*guy(2)+dzi*guz(2))
     &                      - uyk*(dxi*gux(3)+dyi*guy(3)+dzi*guz(3))
     &                      - uzk*(dxi*gux(4)+dyi*guy(4)+dzi*guz(4))
                  ewii = ci*(dxk*gc(2)+dyk*gc(3)+dzk*gc(4))
     &                     - ck*(dxi*gux(1)+dyi*guy(1)+dzi*guz(1))
     &              - dxi*(qxxk*gux(5)+qyyk*gux(8)+qzzk*gux(10)
     &                 +2.0d0*(qxyk*gux(6)+qxzk*gux(7)+qyzk*gux(9)))
     &              - dyi*(qxxk*guy(5)+qyyk*guy(8)+qzzk*guy(10)
     &                 +2.0d0*(qxyk*guy(6)+qxzk*guy(7)+qyzk*guy(9)))
     &              - dzi*(qxxk*guz(5)+qyyk*guz(8)+qzzk*guz(10)
     &                 +2.0d0*(qxyk*guz(6)+qxzk*guz(7)+qyzk*guz(9)))
     &              + dxk*(qxxi*gqxx(2)+qyyi*gqyy(2)+qzzi*gqzz(2)
     &                 +2.0d0*(qxyi*gqxy(2)+qxzi*gqxz(2)+qyzi*gqyz(2)))
     &              + dyk*(qxxi*gqxx(3)+qyyi*gqyy(3)+qzzi*gqzz(3)
     &                 +2.0d0*(qxyi*gqxy(3)+qxzi*gqxz(3)+qyzi*gqyz(3)))
     &              + dzk*(qxxi*gqxx(4)+qyyi*gqyy(4)+qzzi*gqzz(4)
     &                 +2.0d0*(qxyi*gqxy(4)+qxzi*gqxz(4)+qyzi*gqyz(4)))
                  ewki = ci*(dxk*gux(1)+dyk*guy(1)+dzk*guz(1))
     &                     - ck*(dxi*gc(2)+dyi*gc(3)+dzi*gc(4))
     &              - dxi*(qxxk*gqxx(2)+qyyk*gqyy(2)+qzzk*gqzz(2)
     &                 +2.0d0*(qxyk*gqxy(2)+qxzk*gqxz(2)+qyzk*gqyz(2)))
     &              - dyi*(qxxk*gqxx(3)+qyyk*gqyy(3)+qzzk*gqzz(3)
     &                 +2.0d0*(qxyk*gqxy(3)+qxzk*gqxz(3)+qyzk*gqyz(3)))
     &              - dzi*(qxxk*gqxx(4)+qyyk*gqyy(4)+qzzk*gqzz(4)
     &                 +2.0d0*(qxyk*gqxy(4)+qxzk*gqxz(4)+qyzk*gqyz(4)))
     &              + dxk*(qxxi*gux(5)+qyyi*gux(8)+qzzi*gux(10)
     &                 +2.0d0*(qxyi*gux(6)+qxzi*gux(7)+qyzi*gux(9)))
     &              + dyk*(qxxi*guy(5)+qyyi*guy(8)+qzzi*guy(10)
     &                 +2.0d0*(qxyi*guy(6)+qxzi*guy(7)+qyzi*guy(9)))
     &              + dzk*(qxxi*guz(5)+qyyi*guz(8)+qzzi*guz(10)
     &                 +2.0d0*(qxyi*guz(6)+qxzi*guz(7)+qyzi*guz(9)))
c
c     total permanent and induced energies for this interaction
c
                  e = esym + 0.5d0*(ewi+ewk)
                  ei = 0.5d0 * (esymi + 0.5d0*(ewii+ewki))
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     ei = ei * fgrp
                  end if
c
c     increment the total GK electrostatic solvation energy
c
                  if (i .eq. k) then
                     e = 0.5d0 * e
                     ei = 0.5d0 * ei
                  end if
                  es = es + e + ei
               end if
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine epb  --  Poisson-Boltzmann solvation model  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "epb" calculates the implicit solvation energy via the
c     Poisson-Boltzmann plus nonpolar implicit solvation
c
c
      subroutine epb
      use chgpot
      use energi
      use mpole
      use pbstuf
      use polar
      use potent
      implicit none
      integer i,ii
      real*8 etot
c
c
c     compute the electrostatic energy via Poisson-Boltzmann
c
      if (use_polar) then
         etot = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            etot = etot + uinds(1,i)*pbep(1,i) + uinds(2,i)*pbep(2,i)
     &                + uinds(3,i)*pbep(3,i)
         end do
         etot = -0.5d0 * electric * etot
         pbe = pbe + etot
      else
         call pbempole
      end if
c
c     increment solvation energy by Poisson-Boltzmann results
c
      es = es + pbe
c
c     correct the solvation energy for vacuum to polarized state
c
      call ediff
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ediff  --  correction for vacuum to SCRF energy  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ediff" calculates the energy of polarizing the vacuum induced
c     dipoles to their SCRF polarized values
c
c
      subroutine ediff
      use atoms
      use bound
      use chgpot
      use couple
      use energi
      use group
      use mpole
      use polar
      use polgrp
      use polpot
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer ix,iy,iz
      integer kx,ky,kz
      real*8 ei,f
      real*8 fikp,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr,r,r2
      real*8 rr1,rr3,rr5,rr7
      real*8 ci,dix,diy,diz
      real*8 uix,uiy,uiz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 ukx,uky,ukz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 qix,qiy,qiz
      real*8 qkx,qky,qkz
      real*8 sc(6)
      real*8 sci(8)
      real*8 gli(3)
      real*8 dmpik(7)
      real*8, allocatable :: pscale(:)
      logical proceed,usei,usek
      character*6 mode
c
c
c     set conversion factor, cutoff and scaling coefficients
c
      if (npole .eq. 0)  return
      f = electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
c
c     set array needed to scale connected atom interactions
c
      do i = 1, n
         pscale(i) = 1.0d0
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,x,y,z,xaxis,yaxis,
!$OMP& zaxis,rpole,uind,uinds,use,n12,n13,n14,n15,np11,i12,i13,i14,i15,
!$OMP& ip11,p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale,
!$OMP& p5iscale,use_group,use_intra,off2,f)
!$OMP& firstprivate(pscale) shared(es)
!$OMP DO reduction(+:es)
c
c     calculate the multipole interaction energy term
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uinds(1,i) - uind(1,i)
         uiy = uinds(2,i) - uind(2,i)
         uiz = uinds(3,i) - uind(3,i)
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, npole
            k = ipole(kk)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  ck = rpole(1,k)
                  dkx = rpole(2,k)
                  dky = rpole(3,k)
                  dkz = rpole(4,k)
                  qkxx = rpole(5,k)
                  qkxy = rpole(6,k)
                  qkxz = rpole(7,k)
                  qkyy = rpole(9,k)
                  qkyz = rpole(10,k)
                  qkzz = rpole(13,k)
                  ukx = uinds(1,k) - uind(1,k)
                  uky = uinds(2,k) - uind(2,k)
                  ukz = uinds(3,k) - uind(3,k)
c
c     construct some intermediate quadrupole values
c
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
c
c     calculate the scalar products for permanent multipoles
c
                  sc(3) = dix*xr + diy*yr + diz*zr
                  sc(4) = dkx*xr + dky*yr + dkz*zr
                  sc(5) = qix*xr + qiy*yr + qiz*zr
                  sc(6) = qkx*xr + qky*yr + qkz*zr
c
c     calculate the scalar products for polarization components
c
                  sci(2) = uix*dkx + dix*ukx + uiy*dky
     &                        + diy*uky + uiz*dkz + diz*ukz
                  sci(3) = uix*xr + uiy*yr + uiz*zr
                  sci(4) = ukx*xr + uky*yr + ukz*zr
                  sci(7) = qix*ukx + qiy*uky + qiz*ukz
                  sci(8) = qkx*uix + qky*uiy + qkz*uiz
c
c     calculate the gl functions for polarization components
c
                  gli(1) = ck*sci(3) - ci*sci(4) + sci(2)
                  gli(2) = 2.0d0*(sci(7)-sci(8)) - sci(3)*sc(4)
     &                        - sc(3)*sci(4)
                  gli(3) = sci(3)*sc(6) - sci(4)*sc(5)
c
c     compute the energy contributions for this interaction
c
                  rr1 = 1.0d0 / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  call dampthole (ii,kk,7,r,dmpik)
                  ei = gli(1)*rr3*dmpik(3) + gli(2)*rr5*dmpik(5)
     &                    + gli(3)*rr7*dmpik(7)
c
c     make the adjustment for scaled interactions
c
                  fikp = f * pscale(k)
                  ei = 0.5d0 * fikp * ei
c
c     scale the interaction based on its group membership;
c     polarization cannot be group scaled as it is not pairwise
c
                  if (use_group) then
                     ei = ei * fgrp
                  end if
c
c     increment the total GK electrostatic solvation energy
c
                  es = es + ei
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine pbempole  --  permanent multipole PB energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "pbempole" calculates the permanent multipole PB energy,
c     field, forces and torques
c
c
      subroutine pbempole
      use atoms
      use mpole
      use pbstuf
      use solute
      implicit none
      integer i,j,ii
      real*8, allocatable :: pos(:,:)
      real*8, allocatable :: pbpole(:,:)
c
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(apbe))  allocate (apbe(n))
      if (.not. allocated(pbep))  allocate (pbep(3,n))
      if (.not. allocated(pbfp))  allocate (pbfp(3,n))
      if (.not. allocated(pbtp))  allocate (pbtp(3,n))
c
c     perform dynamic allocation of some local arrays
c
      allocate (pos(3,n))
      allocate (pbpole(13,n))
c
c     initialization of coordinates and multipoles for APBS
c
      do i = 1, n
         pos(1,i) = x(i)
         pos(2,i) = y(i)
         pos(3,i) = z(i)
         do j = 1, 13
            pbpole(j,i) = 0.0d0
         end do
      end do
c
c     copy the permanent moments into an array for APBS
c
      do ii = 1, npole
         i = ipole(ii)
         pbpole(1,i) = rpole(1,i)
         do j = 2, 4
            pbpole(j,i) = rpole(j,i)
         end do
         do j = 5, 13
            pbpole(j,i) = 3.0d0 * rpole(j,i)
         end do
      end do
c
c     numerical solution of the Poisson-Boltzmann equation
c
      call apbsempole (n,pos,rsolv,pbpole,pbe,apbe,pbep,pbfp,pbtp)
c
c     perform deallocation of some local arrays
c
      deallocate (pos)
      deallocate (pbpole)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine enp  --  cavity/dispersion nonpolar solvation  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "enp" calculates the nonpolar implicit solvation energy
c     as a sum of cavity and dispersion terms
c
c
      subroutine enp (ecav,edisp)
      use atomid
      use atoms
      use energi
      use kvdws
      use math
      use mpole
      use nonpol
      use shunt
      use solpot
      use solute
      implicit none
      integer i
      real*8 ecav,edisp
      real*8 probe,taper
      real*8 evol,esurf,etemp
      real*8 reff,reff2,reff3
      real*8 reff4,reff5
      real*8, allocatable :: aesurf(:)
      real*8, allocatable :: aevol(:)
      real*8, allocatable :: aetemp(:)
      real*8, allocatable :: weight(:)
      character*6 mode
c
c
c     zero out the nonpolar implicit solvation energy terms
c
      esurf = 0.0d0
      evol = 0.0d0
      ecav = 0.0d0
      edisp = 0.0d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (aesurf(n))
      allocate (aevol(n))
      allocate (aetemp(n))
c
c     solvent probe radius is included in cavity radii
c
      probe = 0.0d0
c
c     compute surface area and effective radius for cavity
c
      call surface (radcav,asolv,probe,esurf,aesurf)
      reff = 0.5d0 * sqrt(esurf/(pi*surften))
      reff2 = reff * reff
      reff3 = reff2 * reff
      reff4 = reff3 * reff
      reff5 = reff4 * reff
c
c     compute solvent excluded volume needed for small solutes
c
      if (reff .lt. spoff) then
         allocate (weight(n))
         do i = 1, n
            weight(i) = solvprs
         end do
         call volume (radcav,weight,probe,etemp,evol,aetemp,aevol)
         deallocate (weight)
      end if
c
c     include a full solvent excluded volume cavity term
c
      if (reff .le. spcut) then
         ecav = evol
c
c     include a tapered solvent excluded volume cavity term
c
      else if (reff .le. spoff) then
         mode = 'GKV'
         call switch (mode)
         taper = c5*reff5 + c4*reff4 + c3*reff3
     &              + c2*reff2 + c1*reff + c0
         ecav = evol * taper
      end if
c
c     include a full solvent accessible surface area term
c
      if (reff .gt. stcut) then
         ecav = esurf
c
c     include a tapered solvent accessible surface area term
c
      else if (reff .gt. stoff) then
         mode = 'GKSA'
         call switch (mode)
         taper = c5*reff5 + c4*reff4 + c3*reff3
     &              + c2*reff2 + c1*reff + c0
         taper = 1.0d0 - taper
         ecav = ecav + taper*esurf
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (aesurf)
      deallocate (aevol)
      deallocate (aetemp)
c
c     find the Weeks-Chandler-Andersen dispersion energy
c
      call ewca (edisp)
c     call ewcax (edisp)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ewca  --  Weeks-Chandler-Andersen dispersion  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ewca" find the Weeks-Chandler-Andersen dispersion energy
c     of a solute using an HCT-like method
c
c
      subroutine ewca (edisp)
      use atoms
      use atomid
      use deriv
      use kvdws
      use math
      use nonpol
      use solute
      use vdw
      implicit none
      integer i,k
      real*8 edisp
      real*8 e,idisp
      real*8 xi,yi,zi
      real*8 rk,sk,sk2
      real*8 xr,yr,zr,r,r2
      real*8 sum,term,iwca,irepl
      real*8 epsi,rmini,rio,rih,rmax
      real*8 ao,emixo,rmixo,rmixo7
      real*8 ah,emixh,rmixh,rmixh7
      real*8 lik,lik2,lik3,lik4
      real*8 lik5,lik10,lik11,lik12
      real*8 uik,uik2,uik3,uik4
      real*8 uik5,uik10,uik11,uik12
c
c
c     zero out the Weeks-Chandler-Andersen dispersion energy
c
      edisp = 0.0d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(n,class,epsdsp,
!$OMP& raddsp,x,y,z,cdsp)
!$OMP& shared(edisp)
!$OMP DO reduction(+:edisp)
c
c     find the Weeks-Chandler-Andersen dispersion energy
c
      do i = 1, n
         epsi = epsdsp(i)
         rmini = raddsp(i)
         emixo = 4.0d0 * epso * epsi / ((sqrt(epso)+sqrt(epsi))**2)
         rmixo = 2.0d0 * (rmino**3+rmini**3) / (rmino**2+rmini**2)
         rmixo7 = rmixo**7
         ao = emixo * rmixo7
         emixh = 4.0d0 * epsh * epsi / ((sqrt(epsh)+sqrt(epsi))**2)
         rmixh = 2.0d0 * (rminh**3+rmini**3) / (rminh**2+rmini**2)
         rmixh7 = rmixh**7
         ah = emixh * rmixh7
         xi = x(i)
         yi = y(i)
         zi = z(i)
         rio = 0.5d0*rmixo + dspoff
         rih = 0.5d0*rmixh + dspoff
c
c     remove contribution due to solvent displaced by solute atoms
c
         sum = 0.0d0
         do k = 1, n
            if (i .ne. k) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               r2 = xr*xr + yr*yr + zr*zr
               r = sqrt(r2)
               rk = raddsp(k)
               sk = rk * shctd
               sk2 = sk * sk
               if (rio .lt. r+sk) then
                  rmax = max(rio,r-sk)
                  lik = rmax
                  if (lik .lt. rmixo) then
                     lik2 = lik * lik
                     lik3 = lik2 * lik
                     lik4 = lik3 * lik
                     uik = min(r+sk,rmixo)
                     uik2 = uik * uik
                     uik3 = uik2 * uik
                     uik4 = uik3 * uik
                     term = 4.0d0 * pi / (48.0d0*r)
     &                    * (3.0d0*(lik4-uik4) - 8.0d0*r*(lik3-uik3)
     &                          + 6.0d0*(r2-sk2)*(lik2-uik2))
                     iwca = -emixo * term
                     sum = sum + iwca
                  end if
                  uik = r + sk
                  if (uik .gt. rmixo) then
                     uik2 = uik * uik
                     uik3 = uik2 * uik
                     uik4 = uik3 * uik
                     uik5 = uik4 * uik
                     uik10 = uik5 * uik5
                     uik11 = uik10 * uik
                     uik12 = uik11 * uik
                     lik = max(rmax,rmixo)
                     lik2 = lik * lik
                     lik3 = lik2 * lik
                     lik4 = lik3 * lik
                     lik5 = lik4 * lik
                     lik10 = lik5 * lik5
                     lik11 = lik10 * lik
                     lik12 = lik11 * lik
                     term = 4.0d0 * pi / (120.0d0*r*lik5*uik5)
     &                      * (15.0d0*uik*lik*r*(uik4-lik4)
     &                         - 10.0d0*uik2*lik2*(uik3-lik3)
     &                         + 6.0d0*(sk2-r2)*(uik5-lik5))
                     idisp = -2.0d0 * ao * term
                     term = 4.0d0 * pi / (2640.0d0*r*lik12*uik12)
     &                      * (120.0d0*uik*lik*r*(uik11-lik11)
     &                         - 66.0d0*uik2*lik2*(uik10-lik10)
     &                         + 55.0d0*(sk2-r2)*(uik12-lik12))
                     irepl = ao * rmixo7 * term
                     sum = sum + irepl + idisp
                  end if
               end if
               if (rih .lt. r+sk) then
                  rmax = max(rih,r-sk)
                  lik = rmax
                  if (lik .lt. rmixh) then
                     lik2 = lik * lik
                     lik3 = lik2 * lik
                     lik4 = lik3 * lik
                     uik = min(r+sk,rmixh)
                     uik2 = uik * uik
                     uik3 = uik2 * uik
                     uik4 = uik3 * uik
                     term = 4.0d0 * pi / (48.0d0*r)
     &                    * (3.0d0*(lik4-uik4) - 8.0d0*r*(lik3-uik3)
     &                          + 6.0d0*(r2-sk2)*(lik2-uik2))
                     iwca = -2.0d0 * emixh * term
                     sum = sum + iwca
                  end if
                  uik = r + sk
                  if (uik .gt. rmixh) then
                     uik2 = uik * uik
                     uik3 = uik2 * uik
                     uik4 = uik3 * uik
                     uik5 = uik4 * uik
                     uik10 = uik5 * uik5
                     uik11 = uik10 * uik
                     uik12 = uik11 * uik
                     lik = max(rmax,rmixh)
                     lik2 = lik * lik
                     lik3 = lik2 * lik
                     lik4 = lik3 * lik
                     lik5 = lik4 * lik
                     lik10 = lik5 * lik5
                     lik11 = lik10 * lik
                     lik12 = lik11 * lik
                     term = 4.0d0 * pi / (120.0d0*r*lik5*uik5)
     &                      * (15.0d0*uik*lik*r*(uik4-lik4)
     &                         - 10.0d0*uik2*lik2*(uik3-lik3)
     &                         + 6.0d0*(sk2-r2)*(uik5-lik5))
                     idisp = -4.0d0 * ah * term
                     term = 4.0d0 * pi / (2640.0d0*r*lik12*uik12)
     &                      * (120.0d0*uik*lik*r*(uik11-lik11)
     &                         - 66.0d0*uik2*lik2*(uik10-lik10)
     &                         + 55.0d0*(sk2-r2)*(uik12-lik12))
                     irepl = 2.0d0 * ah * rmixh7 * term
                     sum = sum + irepl + idisp
                  end if
               end if
            end if
         end do
c
c     increment the overall dispersion energy component
c
         e = cdsp(i) - slevy*awater*sum
         edisp = edisp + e
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ewcax  --  alternative WCA dispersion energy  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ewcax" finds the Weeks-Chandler-Anderson dispersion energy
c     of a solute using a numerical "onion shell" method
c
c
      subroutine ewcax (edisp)
      use atoms
      use atomid
      use couple
      use kvdws
      use math
      use nonpol
      use solute
      use vdw
      implicit none
      integer i,j,k
      real*8 edisp,e
      real*8 t,tinit
      real*8 delta,offset
      real*8 ratio,rinit
      real*8 rmult,rswitch
      real*8 rmax,shell
      real*8 inner,outer
      real*8 area,fraction
      real*8 epsi,rmini
      real*8 epsoi,rminoi
      real*8 epshi,rminhi
      real*8 oer7,oer14
      real*8 her7,her14
      real*8, allocatable :: roff(:)
      logical done
c
c
c     zero out the Weeks-Chandler-Andersen dispersion energy
c
      edisp = 0.0d0
c
c     set parameters for high accuracy numerical shells
c
c     tinit = 0.2d0
c     rinit = 1.0d0
c     rmult = 1.5d0
c     rswitch = 7.0d0
c     rmax = 12.0d0
c
c     set parameters for medium accuracy numerical shells
c
      tinit = 1.0d0
      rinit = 1.0d0
      rmult = 2.0d0
      rswitch = 5.0d0
      rmax = 9.0d0
c
c     set parameters for low accuracy numerical shells
c
c     tinit = 1.0d0
c     rinit = 1.0d0
c     rmult = 2.0d0
c     rswitch = 4.0d0
c     rmax = 7.0d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (roff(n))
c
c     set parameters for atomic radii and probe radii
c
      offset = 0.27d0
      delta = offset + 0.55d0
      do i = 1, n
         roff(i) = raddsp(i) + delta
      end do
c
c     compute the dispersion energy for each atom in the system
c
      do i = 1, n
         epsi = epsdsp(i)
         rmini = raddsp(i)
         epsoi = 4.0d0 * epso * epsi / ((sqrt(epso)+sqrt(epsi))**2)
         rminoi = 2.0d0 * (rmino**3+rmini**3) / (rmino**2+rmini**2)
         epshi = 4.0d0 * epsh * epsi / ((sqrt(epsh)+sqrt(epsi))**2)
         rminhi = 2.0d0 * (rminh**3+rmini**3) / (rminh**2+rmini**2)
         her7 = epshi * rminhi**7
         oer7 = epsoi * rminoi**7
         her14 = epshi * rminhi**14
         oer14 = epsoi * rminoi**14
c
c     alter radii values for atoms attached to current atom
c
         roff(i) = raddsp(i) + offset
         do j = 1, n12(i)
            k = i12(j,i)
            roff(k) = raddsp(k) + offset
         end do
         do j = 1, n13(i)
            k = i13(j,i)
            roff(k) = raddsp(k) + offset
         end do
         do j = 1, n14(i)
            k = i14(j,i)
            roff(k) = raddsp(k) + offset
         end do
         do j = 1, n15(i)
            k = i15(j,i)
            roff(k) = raddsp(k) + offset
         end do
c
c     get the dispersion energy via a series of "onion" shells
c
         t = tinit
         ratio = rinit
         e = 0.0d0
         done = .false.
         do while (.not. done)
            inner = roff(i)
            outer = inner + t
            roff(i) = 0.5d0 * (inner+outer)
            call surfatom (i,area,roff)
            fraction = area / (4.0d0*pi*roff(i)**2)
            if (outer .lt. rminoi) then
               shell = (outer**3-inner**3)/3.0d0
               e = e - epsoi*fraction*shell
            else if (inner .gt. rminoi) then
               shell = (1.0d0/(inner**4)-1.0d0/(outer**4)) / 4.0d0
               e = e - 2.0d0*oer7*fraction*shell
               shell = (1.0d0/(inner**11)-1.0d0/(outer**11)) / 11.0d0
               e = e + oer14*fraction*shell
            else
               shell = (rminoi**3-inner**3)/3.0d0
               e = e - epsoi*fraction*shell
               shell = (1.0d0/(rminoi**4)-1.0d0/(outer**4)) / 4.0d0
               e = e - 2.0d0*oer7*fraction*shell
               shell = (1.0d0/(rminoi**11)-1.0d0/(outer**11)) / 11.0d0
               e = e + oer14*fraction*shell
            end if
            if (outer .lt. rminhi) then
               shell = (outer**3-inner**3)/3.0d0
               e = e - 2.0d0*epshi*fraction*shell
            else if (inner .gt. rminhi) then
               shell = (1.0d0/(inner**4)-1.0d0/(outer**4)) / 4.0d0
               e = e - 4.0d0*her7*fraction*shell
               shell = (1.0d0/(inner**11)-1.0d0/(outer**11)) / 11.0d0
               e = e + 2.0d0*her14*fraction*shell
            else
               shell = (rminhi**3-inner**3)/3.0d0
               e = e - 2.0d0*epshi*fraction*shell
               shell = (1.0d0/(rminhi**4)-1.0d0/(outer**4)) / 4.0d0
               e = e - 4.0d0*her7*fraction*shell
               shell = (1.0d0/(rminhi**11)-1.0d0/(outer**11)) / 11.0d0
               e = e + 2.0d0*her14*fraction*shell
            end if
            if (outer .gt. rmax)  done = .true.
            if (fraction.gt.0.99d0 .and. outer.gt.rminoi)  done = .true.
            if (done) then
               e = e - 2.0d0*oer7*fraction/(4.0d0*outer**4)
               e = e + oer14*fraction/(11.0d0*outer**11)
               e = e - 4.0d0*her7*fraction/(4.0d0*outer**4)
               e = e + 2.0d0*her14*fraction/(11.0d0*outer**11)
            end if
            roff(i) = roff(i) + 0.5d0*t
            if (outer .gt. rswitch)  ratio = rmult
            t = ratio * t
         end do
c
c     increment the overall WCA dispersion energy component
c
         e = 4.0d0 * pi * slevy * awater * e
         edisp = edisp + e
c
c     reset the radii values for atoms attached to current atom
c
         roff(i) = raddsp(i) + delta
         do j = 1, n12(i)
            k = i12(j,i)
            roff(k) = raddsp(k) + delta
         end do
         do j = 1, n13(i)
            k = i13(j,i)
            roff(k) = raddsp(k) + delta
         end do
         do j = 1, n14(i)
            k = i14(j,i)
            roff(k) = raddsp(k) + delta
         end do
         do j = 1, n15(i)
            k = i15(j,i)
            roff(k) = raddsp(k) + delta
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (roff)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ehpmf  --  hydrophobic PMF nonpolar solvation  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ehpmf" calculates the hydrophobic potential of mean force
c     energy using a pairwise double loop
c
c     literature reference:
c
c     M. S. Lin, N. L. Fawzi and T. Head-Gordon, "Hydrophobic
c     Potential of Mean Force as a Solvation Function for Protein
c     Structure Prediction", Structure, 15, 727-740 (2007)
c
c
      subroutine ehpmf (ehp)
      use atomid
      use atoms
      use couple
      use hpmf
      use math
      implicit none
      integer i,j,k,m
      integer ii,jj,kk
      integer sschk
      integer, allocatable :: omit(:)
      real*8 xr,yr,zr,r,r2
      real*8 e,ehp
      real*8 rsurf,pisurf
      real*8 hpmfcut2
      real*8 saterm,sasa
      real*8 rbig,rsmall
      real*8 part,cutv
      real*8 e1,e2,e3,sum
      real*8 arg1,arg2,arg3
      real*8 arg12,arg22,arg32
      real*8, allocatable :: cutmtx(:)
c
c
c     zero out the hydrophobic potential of mean force energy
c
      ehp = 0.0d0
c
c     set some values needed during the HPMF calculation
c
      rsurf = rcarbon + 2.0d0*rwater
      pisurf = pi * (rcarbon+rwater)
      hpmfcut2 = hpmfcut * hpmfcut
c
c     perform dynamic allocation of some local arrays
c
      allocate (omit(n))
      allocate (cutmtx(n))
c
c     get the solvent accessible surface area for each atom
c
      do ii = 1, npmf
         i = ipmf(ii)
         saterm = acsa(i)
         sasa = 1.0d0
         do k = 1, n
            if (i .ne. k) then
               xr = x(i) - x(k)
               yr = y(i) - y(k)
               zr = z(i) - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               rbig = rpmf(k) + rsurf
               if (r2 .le. rbig*rbig) then
                  r = sqrt(r2)
                  rsmall = rpmf(k) - rcarbon
                  part = pisurf * (rbig-r) * (1.0d0+rsmall/r)
                  sasa = sasa * (1.0d0-saterm*part)
               end if
            end if
         end do
         sasa = acsurf * sasa
         cutv = tanh(tgrad*(sasa-toffset))
         cutmtx(i) = 0.5d0 * (1.0d0+cutv)
      end do
c
c     find the hydrophobic PMF energy via a double loop search
c
      do i = 1, n
         omit(i) = 0
      end do
      do ii = 1, npmf-1
         i = ipmf(ii)
         sschk = 0
         do j = 1, n12(i)
            k = i12(j,i)
            omit(k) = i
            if (atomic(k) .eq. 16)  sschk = k
         end do
         do j = 1, n13(i)
            k = i13(j,i)
            omit(k) = i
         end do
         do j = 1, n14(i)
            k = i14(j,i)
            omit(k) = i
            if (sschk .ne. 0) then
               do jj = 1, n12(k)
                  m = i12(jj,k)
                  if (atomic(m) .eq. 16) then
                     do kk = 1, n12(m)
                        if (i12(kk,m) .eq. sschk)  omit(k) = 0
                     end do
                  end if
               end do
            end if
         end do
         do kk = ii+1, npmf
            k = ipmf(kk)
            if (omit(k) .ne. i) then
               xr = x(i) - x(k)
               yr = y(i) - y(k)
               zr = z(i) - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. hpmfcut2) then
                  r = sqrt(r2)
                  arg1 = (r-hc1) * hw1
                  arg12 = arg1 * arg1
                  arg2 = (r-hc2) * hw2
                  arg22 = arg2 * arg2
                  arg3 = (r-hc3) * hw3
                  arg32 = arg3 * arg3
                  e1 = hd1 * exp(-arg12)
                  e2 = hd2 * exp(-arg22)
                  e3 = hd3 * exp(-arg32)
                  sum = e1 + e2 + e3
                  e = sum * cutmtx(i) * cutmtx(k)
                  ehp = ehp + e
               end if
            end if
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (omit)
      deallocate (cutmtx)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine esolv1  --  solvation energy and derivatives  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "esolv1" calculates the implicit solvation energy and
c     first derivatives with respect to Cartesian coordinates
c     for surface area, generalized Born, generalized Kirkwood
c     and Poisson-Boltzmann solvation models
c
c
      subroutine esolv1
      use atoms
      use deriv
      use energi
      use limits
      use math
      use mpole
      use potent
      use solpot
      use solute
      use warp
      implicit none
      integer i
      real*8 e,ai,ri,rb
      real*8 term,probe
      real*8 esurf,ehp,eace
      real*8 ecav,edisp
      real*8, allocatable :: aes(:)
c
c
c     zero out the implicit solvation energy and derivatives
c
      es = 0.0d0
      esurf = 0.0d0
      ecav = 0.0d0
      edisp = 0.0d0
      ehp = 0.0d0
      eace = 0.0d0
      do i = 1, n
         des(1,i) = 0.0d0
         des(2,i) = 0.0d0
         des(3,i) = 0.0d0
      end do
      if (solvtyp(1:2) .eq. 'GB') then
         do i = 1, n
            drb(i) = 0.0d0
         end do
      else if (solvtyp(1:2) .eq. 'GK') then
         do i = 1, n
            drb(i) = 0.0d0
            drbp(i) = 0.0d0
         end do
      end if
c
c     set a value for the solvent molecule probe radius
c
      probe = 1.4d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (aes(n))
c
c     solvation energy and derivs for surface area only models
c
      if (solvtyp.eq.'ASP' .or. solvtyp.eq.'SASA') then
         call surface1 (rsolv,asolv,probe,es,aes,des)
c
c     nonpolar energy and derivs as hydrophobic PMF term
c
      else if (solvtyp.eq.'GB-HPMF' .or. solvtyp.eq.'GK-HPMF'
     &            .or. solvtyp.eq.'PB-HPMF') then
         call ehpmf1 (ehp)
         es = ehp
c
c     nonpolar energy and derivs for Onion method via exact area
c
      else if (solvtyp.eq.'GB' .and. borntyp.eq.'ONION') then
         call surface1 (rsolv,asolv,probe,esurf,aes,des)
         es = esurf
c
c     nonpolar energy and derivs as cavity plus dispersion
c
      else if (solvtyp.eq.'GK' .or. solvtyp.eq.'PB') then
         call enp1 (ecav,edisp)
         es = ecav + edisp
c
c     nonpolar energy and derivs via ACE area approximation
c
      else
         term = 4.0d0 * pi
         do i = 1, n
            ai = asolv(i)
            ri = rsolv(i)
            rb = rborn(i)
            if (rb .ne. 0.0d0) then
               e = ai * term * (ri+probe)**2 * (ri/rb)**6
               eace = eace + e
               drb(i) = drb(i) - 6.0d0*e/rb
            end if
         end do
         es = eace
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (aes)
c
c     get polarization energy and derivatives for solvation methods
c
      if (solvtyp(1:2) .eq. 'GK') then
         if (.not.use_mpole .and. .not.use_polar) then
            call chkpole
            call rotpole ('MPOLE')
            call induce
         end if
         call egk1
      else if (solvtyp(1:2) .eq. 'PB') then
         call epb1
      else if (use_born) then
         if (use_smooth) then
            call egb1c
         else if (use_clist) then
            call egb1b
         else
            call egb1a
         end if
         call born1
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine egb1a  --  GB energy and derivs via double loop  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "egb1a" calculates the generalized Born electrostatic energy
c     and first derivatives of the GB/SA solvation models using a
c     double loop
c
c     note application of distance cutoff scaling directly to
c     the Born radii chain rule term "derb" is an approximation
c
c
      subroutine egb1a
      use atoms
      use charge
      use chgpot
      use deriv
      use energi
      use group
      use shunt
      use solute
      use usage
      use virial
      implicit none
      integer i,k,ii,kk
      real*8 e,de,fgrp
      real*8 f,fi,fik
      real*8 fgb,fgb2,fgm
      real*8 rb2,rm2
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7
      real*8 dwater,rbi,rbk
      real*8 dedx,dedy,dedz
      real*8 derb,drbi,drbk
      real*8 expterm,shift
      real*8 taper,dtaper
      real*8 trans,dtrans
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed,usei
      character*6 mode
c
c
c     set the solvent dielectric and energy conversion factor
c
      if (nion .eq. 0)  return
      dwater = 78.3d0
      f = -electric * (1.0d0 - 1.0d0/dwater)
c
c     set cutoff distances and switching function coefficients
c
      mode = 'CHARGE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,use,x,y,z,f,
!$OMP& pchg,rborn,use_group,off,off2,cut,cut2,c0,c1,c2,c3,c4,c5,
!$OMP& f0,f1,f2,f3,f4,f5,f6,f7)
!$OMP& shared(es,des,drb,vir)
!$OMP DO reduction(+:es,des,drb,vir)
c
c     calculate GB electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         usei = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         rbi = rborn(i)
c
c     decide whether to compute the current interaction
c
         do kk = ii, nion
            k = iion(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rbk = rborn(k)
                  fik = fi * pchg(k)
                  rb2 = rbi * rbk
                  expterm = exp(-0.25d0*r2/rb2)
                  fgb2 = r2 + rb2*expterm
                  fgb = sqrt(fgb2)
                  e = fik / fgb
                  de = -e * (r-0.25d0*r*expterm) / fgb2
                  derb = -e * expterm*(0.5d0+0.125d0*r2/rb2) / fgb2
c
c     use energy switching if near the cutoff distance
c
                  rm2 = (0.5d0 * (off+cut))**2
                  fgm = sqrt(rm2 + rb2*exp(-0.25d0*rm2/rb2))
                  shift = fik / fgm
                  e = e - shift
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     r6 = r3 * r3
                     r7 = r3 * r4
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4
     &                               + f3*r3 + f2*r2 + f1*r + f0)
                     dtrans = fik * (7.0d0*f7*r6 + 6.0d0*f6*r5
     &                               + 5.0d0*f5*r4 + 4.0d0*f4*r3
     &                             + 3.0d0*f3*r2 + 2.0d0*f2*r + f1)
                     derb = derb * taper
                     de = e*dtaper + de*taper + dtrans
                     e = e*taper + trans
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                     derb = derb * fgrp
                  end if
c
c     increment the overall energy and derivative expressions
c
                  if (i .eq. k) then
                     e = 0.5d0 * e
                     es = es + e
                     drbi = derb * rbk
                     drb(i) = drb(i) + drbi
                  else
                     es = es + e
                     de = de / r
                     dedx = de * xr
                     dedy = de * yr
                     dedz = de * zr
                     des(1,i) = des(1,i) + dedx
                     des(2,i) = des(2,i) + dedy
                     des(3,i) = des(3,i) + dedz
                     des(1,k) = des(1,k) - dedx
                     des(2,k) = des(2,k) - dedy
                     des(3,k) = des(3,k) - dedz
                     drbi = derb * rbk
                     drbk = derb * rbi
                     drb(i) = drb(i) + drbi
                     drb(k) = drb(k) + drbk
c
c     increment the internal virial tensor components
c
                     vxx = xr * dedx
                     vyx = yr * dedx
                     vzx = zr * dedx
                     vyy = yr * dedy
                     vzy = zr * dedy
                     vzz = zr * dedz
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end if
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine egb1b  --  GB energy and derivs via pair list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "egb1b" calculates the generalized Born electrostatic energy
c     and first derivatives of the GB/SA solvation models using a
c     neighbor list
c
c     note application of distance cutoff scaling directly to
c     the Born radii chain rule term "derb" is an approximation
c
c
      subroutine egb1b
      use atoms
      use charge
      use chgpot
      use deriv
      use energi
      use group
      use neigh
      use shunt
      use solute
      use usage
      use virial
      implicit none
      integer i,k,ii,kk
      real*8 e,de,fgrp
      real*8 f,fi,fik
      real*8 fgb,fgb2,fgm
      real*8 rb2,rm2
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7
      real*8 dwater,rbi,rbk
      real*8 dedx,dedy,dedz
      real*8 derb,drbi,drbk
      real*8 expterm,shift
      real*8 taper,dtaper
      real*8 trans,dtrans
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed,usei
      character*6 mode
c
c
c     set the solvent dielectric and energy conversion factor
c
      if (nion .eq. 0)  return
      dwater = 78.3d0
      f = -electric * (1.0d0 - 1.0d0/dwater)
c
c     set cutoff distances and switching function coefficients
c
      mode = 'CHARGE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,use,x,y,z,
!$OMP& f,pchg,rborn,nelst,elst,use_group,off,off2,cut,cut2,
!$OMP& c0,c1,c2,c3,c4,c5,f0,f1,f2,f3,f4,f5,f6,f7)
!$OMP& shared(es,des,drb,vir)
!$OMP DO reduction(+:es,des,drb,vir)
c
c     calculate GB electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         usei = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         rbi = rborn(i)
c
c     calculate the self-energy term for the current atom
c
         fik = fi * pchg(i)
         rb2 = rbi * rbi
         e = fik / rbi
         derb = -0.5d0 * e / rb2
         rm2 = (0.5d0 * (off+cut))**2
         fgm = sqrt(rm2 + rb2*exp(-0.25d0*rm2/rb2))
         shift = fik / fgm
         e = e - shift
         es = es + 0.5d0*e
         drbi = derb * rbi
         drb(i) = drb(i) + drbi
c
c     decide whether to compute the current interaction
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  rbk = rborn(k)
                  fik = fi * pchg(k)
                  rb2 = rbi * rbk
                  expterm = exp(-0.25d0*r2/rb2)
                  fgb2 = r2 + rb2*expterm
                  fgb = sqrt(fgb2)
                  e = fik / fgb
                  de = -e * (r-0.25d0*r*expterm) / fgb2
                  derb = -e * expterm*(0.5d0+0.125d0*r2/rb2) / fgb2
c
c     use energy switching if near the cutoff distance
c
                  rm2 = (0.5d0 * (off+cut))**2
                  fgm = sqrt(rm2 + rb2*exp(-0.25d0*rm2/rb2))
                  shift = fik / fgm
                  e = e - shift
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     r6 = r3 * r3
                     r7 = r3 * r4
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                           + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4
     &                               + f3*r3 + f2*r2 + f1*r + f0)
                     dtrans = fik * (7.0d0*f7*r6 + 6.0d0*f6*r5
     &                               + 5.0d0*f5*r4 + 4.0d0*f4*r3
     &                             + 3.0d0*f3*r2 + 2.0d0*f2*r + f1)
                     derb = derb * taper
                     de = e*dtaper + de*taper + dtrans
                     e = e*taper + trans
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     de = de * fgrp
                     derb = derb * fgrp
                  end if
c
c     increment the overall energy and derivative expressions
c
                  es = es + e
                  de = de / r
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
                  des(1,i) = des(1,i) + dedx
                  des(2,i) = des(2,i) + dedy
                  des(3,i) = des(3,i) + dedz
                  des(1,k) = des(1,k) - dedx
                  des(2,k) = des(2,k) - dedy
                  des(3,k) = des(3,k) - dedz
                  drbi = derb * rbk
                  drbk = derb * rbi
                  drb(i) = drb(i) + drbi
                  drb(k) = drb(k) + drbk
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine egb1c  --  GB energy and derivs for smoothing  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "egb1c" calculates the generalized Born energy and first
c     derivatives of the GB/SA solvation models for use with
c     potential smoothing methods
c
c
      subroutine egb1c
      use atoms
      use charge
      use chgpot
      use deriv
      use energi
      use group
      use math
      use solute
      use usage
      use virial
      use warp
      implicit none
      integer i,k,ii,kk
      real*8 e,de,fgrp
      real*8 f,fi,fik
      real*8 fgb,fgb2
      real*8 rb2,width
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,sterm
      real*8 expterm
      real*8 dwater,rbi,rbk
      real*8 dedx,dedy,dedz
      real*8 derb,drbi,drbk
      real*8 erf,erfterm,term
      real*8 wterm,rterm,bterm
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed,usei
      external erf
c
c
c     set the solvent dielectric and energy conversion factor
c
      if (nion .eq. 0)  return
      dwater = 78.3d0
      f = -electric * (1.0d0 - 1.0d0/dwater)
c
c     set the extent of smoothing to be performed
c
      sterm = 0.5d0 / sqrt(diffc)
c
c     calculate GB electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         usei = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         rbi = rborn(i)
c
c     decide whether to compute the current interaction
c
         do kk = ii, nion
            k = iion(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               r = sqrt(r2)
               rbk = rborn(k)
               fik = fi * pchg(k)
               rb2 = rbi * rbk
               expterm = exp(-0.25d0*r2/rb2)
               fgb2 = r2 + rb2*expterm
               fgb = sqrt(fgb2)
               e = fik / fgb
               de = -e * (r-0.25d0*r*expterm) / fgb2
               derb = -e * expterm*(0.5d0+0.125d0*r2/rb2) / fgb2
c
c     use a smoothable GB analogous to the Coulomb solution
c
               if (deform .gt. 0.0d0) then
                  wterm = exp(-0.006d0*rb2/deform)
                  width = sterm / sqrt(deform+0.15d0*rb2*wterm)
                  erfterm = erf(width*fgb)
                  term = width * exp(-(width*fgb)**2) / rootpi
                  rterm = term * (2.0d0*r-0.5d0*r*expterm)/fgb
                  bterm = term * ((expterm*(1.0d0+0.25d0*r2/rb2)/fgb)
     &                              - (fgb*(width/sterm)**2) * wterm
     &                                 * (0.15d0-0.0009d0*rb2/deform))
                  derb = derb*erfterm + e*bterm
                  de = de*erfterm + e*rterm
                  e = e * erfterm
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  e = e * fgrp
                  de = de * fgrp
                  derb = derb * fgrp
               end if
c
c     increment the overall energy and derivative expressions
c
               if (i .eq. k) then
                  e = 0.5d0 * e
                  es = es + e
                  drbi = derb * rbk
                  drb(i) = drb(i) + drbi
               else
                  es = es + e
                  de = de / r
                  dedx = de * xr
                  dedy = de * yr
                  dedz = de * zr
                  des(1,i) = des(1,i) + dedx
                  des(2,i) = des(2,i) + dedy
                  des(3,i) = des(3,i) + dedz
                  des(1,k) = des(1,k) - dedx
                  des(2,k) = des(2,k) - dedy
                  des(3,k) = des(3,k) - dedz
                  drbi = derb * rbk
                  drbk = derb * rbi
                  drb(i) = drb(i) + drbi
                  drb(k) = drb(k) + drbk
c
c     increment the internal virial tensor components
c
                  vxx = xr * dedx
                  vyx = yr * dedx
                  vzx = zr * dedx
                  vyy = yr * dedy
                  vzy = zr * dedy
                  vzz = zr * dedz
                  vir(1,1) = vir(1,1) + vxx
                  vir(2,1) = vir(2,1) + vyx
                  vir(3,1) = vir(3,1) + vzx
                  vir(1,2) = vir(1,2) + vyx
                  vir(2,2) = vir(2,2) + vyy
                  vir(3,2) = vir(3,2) + vzy
                  vir(1,3) = vir(1,3) + vzx
                  vir(2,3) = vir(2,3) + vzy
                  vir(3,3) = vir(3,3) + vzz
               end if
            end if
         end do
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine egk1  --  generalized Kirkwood energy & derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "egk1" calculates the implicit solvation energy and derivatives
c     via the generalized Kirkwood plus nonpolar implicit solvation
c
c
      subroutine egk1
      use energi
      use limits
      use mpole
      use potent
c
c
c     setup the multipoles for solvation only calculations
c
      if (.not. use_mpole) then
          call chkpole
          call rotpole ('MPOLE')
      end if
c
c     compute the generalized Kirkwood energy and gradient
c
      call egk1a
      call born1
c
c     correct energy and derivatives for vacuum to polarized state
c
      if (use_polar) then
         if (use_mlist) then
            call ediff1b
         else
            call ediff1a
         end if
      else if (.not.use_mpole .and. .not.use_polar) then
         if (use_mlist) then
            call ediff1b
         else
            call ediff1a
         end if
      end if
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine egk1a  --  find GK energy and derivatives  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "egk1a" calculates the electrostatic portion of the implicit
c     solvation energy and derivatives via the generalized Kirkwood
c     model
c
c
      subroutine egk1a
      use atoms
      use charge
      use chgpot
      use deriv
      use energi
      use gkstuf
      use group
      use mpole
      use polar
      use polpot
      use shunt
      use solute
      use usage
      use virial
      implicit none
      integer i,j,k,ii,kk
      integer ix,iy,iz
      real*8 e,ei,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 xr2,yr2,zr2
      real*8 ci,ck
      real*8 uxi,uyi,uzi
      real*8 uxk,uyk,uzk
      real*8 qxxi,qxyi,qxzi
      real*8 qyyi,qyzi,qzzi
      real*8 qxxk,qxyk,qxzk
      real*8 qyyk,qyzk,qzzk
      real*8 dxi,dyi,dzi
      real*8 dxk,dyk,dzk
      real*8 pxi,pyi,pzi
      real*8 pxk,pyk,pzk
      real*8 sxi,syi,szi
      real*8 sxk,syk,szk
      real*8 r2,rb2
      real*8 dedx,dedy,dedz
      real*8 drbi,drbk
      real*8 dpdx,dpdy,dpdz
      real*8 dpbi,dpbk
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8 vxy,vxz,vyz
      real*8 dwater
      real*8 fc,fd,fq
      real*8 rbi,rbk
      real*8 expterm
      real*8 gf,gf2,gf3,gf5
      real*8 gf7,gf9,gf11
      real*8 expc,dexpc
      real*8 expc1,expcdexpc
      real*8 expcr,dexpcr
      real*8 dgfdr
      real*8 esym,ewi,ewk
      real*8 desymdx,dewidx,dewkdx
      real*8 desymdy,dewidy,dewkdy
      real*8 desymdz,dewidz,dewkdz
      real*8 dsumdr,desymdr
      real*8 dewidr,dewkdr
      real*8 dsymdr
      real*8 esymi,ewii,ewki
      real*8 dpsymdx,dpwidx,dpwkdx
      real*8 dpsymdy,dpwidy,dpwkdy
      real*8 dpsymdz,dpwidz,dpwkdz
      real*8 dwipdr,dwkpdr,duvdr
      real*8 a(0:5,0:3)
      real*8 b(0:4,0:2)
      real*8 fid(3),fkd(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 fidg(3,3),fkdg(3,3)
      real*8 gc(30),gux(30)
      real*8 guy(30),guz(30)
      real*8 gqxx(30),gqxy(30)
      real*8 gqxz(30),gqyy(30)
      real*8 gqyz(30),gqzz(30)
      real*8, allocatable :: trq(:,:)
      real*8, allocatable :: trqi(:,:)
      logical proceed,usei
      character*6 mode
c
c
c     set the bulk dielectric constant to the water value
c
      if (npole .eq. 0)  return
      dwater = 78.3d0
      fc = electric * 1.0d0 * (1.0d0-dwater)/(0.0d0+1.0d0*dwater)
      fd = electric * 2.0d0 * (1.0d0-dwater)/(1.0d0+2.0d0*dwater)
      fq = electric * 3.0d0 * (1.0d0-dwater)/(2.0d0+3.0d0*dwater)
c
c     set cutoff distances and switching function coefficients
c
      mode = 'MPOLE'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (trq(3,n))
      allocate (trqi(3,n))
c
c     initialize local variables for OpenMP calculation
c
      do i = 1, n
         do j = 1, 3
            trq(j,i) = 0.0d0
            trqi(j,i) = 0.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,use,x,y,z,rborn,
!$OMP& rpole,uinds,uinps,use_group,off2,gkc,fc,fd,fq,poltyp)
!$OMP& shared(es,des,drb,drbp,trq,trqi,vir)
!$OMP DO reduction(+:es,des,drb,drbp,trq,trqi,vir)
!$OMP&
c
c     calculate GK electrostatic solvation free energy
c
      do ii = 1, npole
         i = ipole(ii)
         usei = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         rbi = rborn(i)
         ci = rpole(1,i)
         uxi = rpole(2,i)
         uyi = rpole(3,i)
         uzi = rpole(4,i)
         qxxi = rpole(5,i)
         qxyi = rpole(6,i)
         qxzi = rpole(7,i)
         qyyi = rpole(9,i)
         qyzi = rpole(10,i)
         qzzi = rpole(13,i)
         dxi = uinds(1,i)
         dyi = uinds(2,i)
         dzi = uinds(3,i)
         pxi = uinps(1,i)
         pyi = uinps(2,i)
         pzi = uinps(3,i)
         sxi = dxi + pxi
         syi = dyi + pyi
         szi = dzi + pzi
c
c     decide whether to compute the current interaction
c
         do kk = ii, npole
            k = ipole(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               xr2 = xr*xr
               yr2 = yr*yr
               zr2 = zr*zr
               r2 = xr2 + yr2 + zr2
               if (r2 .le. off2) then
                  rbk = rborn(k)
                  ck = rpole(1,k)
                  uxk = rpole(2,k)
                  uyk = rpole(3,k)
                  uzk = rpole(4,k)
                  qxxk = rpole(5,k)
                  qxyk = rpole(6,k)
                  qxzk = rpole(7,k)
                  qyyk = rpole(9,k)
                  qyzk = rpole(10,k)
                  qzzk = rpole(13,k)
                  dxk = uinds(1,k)
                  dyk = uinds(2,k)
                  dzk = uinds(3,k)
                  pxk = uinps(1,k)
                  pyk = uinps(2,k)
                  pzk = uinps(3,k)
                  sxk = dxk + pxk
                  syk = dyk + pyk
                  szk = dzk + pzk
                  rb2 = rbi * rbk
                  expterm = exp(-r2/(gkc*rb2))
                  expc = expterm / gkc
                  expcr = r2*expterm / (gkc*gkc*rb2*rb2)
                  dexpc = -2.0d0 / (gkc*rb2)
                  dexpcr = 2.0d0 / (gkc*rb2*rb2)
                  dgfdr = 0.5d0 * expterm * (1.0d0+r2/(rb2*gkc))
                  gf2 = 1.0d0 / (r2+rb2*expterm)
                  gf = sqrt(gf2)
                  gf3 = gf2 * gf
                  gf5 = gf3 * gf2
                  gf7 = gf5 * gf2
                  gf9 = gf7 * gf2
                  gf11 = gf9 * gf2
c
c     reaction potential auxiliary terms
c
                  a(0,0) = gf
                  a(1,0) = -gf3
                  a(2,0) = 3.0d0 * gf5
                  a(3,0) = -15.0d0 * gf7
                  a(4,0) = 105.0d0 * gf9
                  a(5,0) = -945.0d0 * gf11
c
c     Born radii derivatives of reaction potential auxiliary terms
c
                  b(0,0) = dgfdr * a(1,0)
                  b(1,0) = dgfdr * a(2,0)
                  b(2,0) = dgfdr * a(3,0)
                  b(3,0) = dgfdr * a(4,0)
                  b(4,0) = dgfdr * a(5,0)
c
c     get reaction potential gradient auxiliary terms
c
                  expc1 = 1.0d0 - expc
                  a(0,1) = expc1 * a(1,0)
                  a(1,1) = expc1 * a(2,0)
                  a(2,1) = expc1 * a(3,0)
                  a(3,1) = expc1 * a(4,0)
                  a(4,1) = expc1 * a(5,0)
c
c     Born radii derivs of reaction potential gradient auxiliary terms
c
                  b(0,1) = b(1,0) - expcr*a(1,0) - expc*b(1,0)
                  b(1,1) = b(2,0) - expcr*a(2,0) - expc*b(2,0)
                  b(2,1) = b(3,0) - expcr*a(3,0) - expc*b(3,0)
                  b(3,1) = b(4,0) - expcr*a(4,0) - expc*b(4,0)
c
c     get 2nd reaction potential gradient auxiliary terms
c
                  expcdexpc = -expc * dexpc
                  a(0,2) = expc1*a(1,1) + expcdexpc*a(1,0)
                  a(1,2) = expc1*a(2,1) + expcdexpc*a(2,0)
                  a(2,2) = expc1*a(3,1) + expcdexpc*a(3,0)
                  a(3,2) = expc1*a(4,1) + expcdexpc*a(4,0)
c
c     Born radii derivatives of the 2nd reaction potential
c     gradient auxiliary terms
c
                  b(0,2) = b(1,1) - (expcr*(a(1,1) + dexpc*a(1,0))
     &                     + expc*(b(1,1)+dexpcr*a(1,0)+dexpc*b(1,0)))
                  b(1,2) = b(2,1) - (expcr*(a(2,1) + dexpc*a(2,0))
     &                     + expc*(b(2,1)+dexpcr*a(2,0)+dexpc*b(2,0)))
                  b(2,2) = b(3,1) - (expcr*(a(3,1) + dexpc*a(3,0))
     &                     + expc*(b(3,1)+dexpcr*a(3,0)+dexpc*b(3,0)))
c
c     get 3rd reaction potential gradient auxiliary terms
c
                  expcdexpc = 2.0d0 * expcdexpc
                  a(0,3) = expc1*a(1,2) + expcdexpc*a(1,1)
                  a(1,3) = expc1*a(2,2) + expcdexpc*a(2,1)
                  a(2,3) = expc1*a(3,2) + expcdexpc*a(3,1)
                  expcdexpc = -expc * dexpc * dexpc
                  a(0,3) = a(0,3) + expcdexpc*a(1,0)
                  a(1,3) = a(1,3) + expcdexpc*a(2,0)
                  a(2,3) = a(2,3) + expcdexpc*a(3,0)
c
c     multiply the auxillary terms by their dielectric functions
c
                  a(0,0) = fc * a(0,0)
                  a(0,1) = fc * a(0,1)
                  a(0,2) = fc * a(0,2)
                  a(0,3) = fc * a(0,3)
                  b(0,0) = fc * b(0,0)
                  b(0,1) = fc * b(0,1)
                  b(0,2) = fc * b(0,2)
                  a(1,0) = fd * a(1,0)
                  a(1,1) = fd * a(1,1)
                  a(1,2) = fd * a(1,2)
                  a(1,3) = fd * a(1,3)
                  b(1,0) = fd * b(1,0)
                  b(1,1) = fd * b(1,1)
                  b(1,2) = fd * b(1,2)
                  a(2,0) = fq * a(2,0)
                  a(2,1) = fq * a(2,1)
                  a(2,2) = fq * a(2,2)
                  a(2,3) = fq * a(2,3)
                  b(2,0) = fq * b(2,0)
                  b(2,1) = fq * b(2,1)
                  b(2,2) = fq * b(2,2)
c
c     unweighted reaction potential tensor
c
                  gc(1) = a(0,0)
                  gux(1) = xr * a(1,0)
                  guy(1) = yr * a(1,0)
                  guz(1) = zr * a(1,0)
                  gqxx(1) = xr2 * a(2,0)
                  gqyy(1) = yr2 * a(2,0)
                  gqzz(1) = zr2 * a(2,0)
                  gqxy(1) = xr * yr * a(2,0)
                  gqxz(1) = xr * zr * a(2,0)
                  gqyz(1) = yr * zr * a(2,0)
c
c     Born radii derivs of unweighted reaction potential tensor
c
                  gc(21) = b(0,0)
                  gux(21) = xr * b(1,0)
                  guy(21) = yr * b(1,0)
                  guz(21) = zr * b(1,0)
                  gqxx(21) = xr2 * b(2,0)
                  gqyy(21) = yr2 * b(2,0)
                  gqzz(21) = zr2 * b(2,0)
                  gqxy(21) = xr * yr * b(2,0)
                  gqxz(21) = xr * zr * b(2,0)
                  gqyz(21) = yr * zr * b(2,0)
c
c     unweighted reaction potential gradient tensor
c
                  gc(2) = xr * a(0,1)
                  gc(3) = yr * a(0,1)
                  gc(4) = zr * a(0,1)
                  gux(2) = a(1,0) + xr2*a(1,1)
                  gux(3) = xr * yr * a(1,1)
                  gux(4) = xr * zr * a(1,1)
                  guy(2) = gux(3)
                  guy(3) = a(1,0) + yr2*a(1,1)
                  guy(4) = yr * zr * a(1,1)
                  guz(2) = gux(4)
                  guz(3) = guy(4)
                  guz(4) = a(1,0) + zr2*a(1,1)
                  gqxx(2) = xr * (2.0d0*a(2,0)+xr2*a(2,1))
                  gqxx(3) = yr * xr2 * a(2,1)
                  gqxx(4) = zr * xr2 * a(2,1)
                  gqyy(2) = xr * yr2 * a(2,1)
                  gqyy(3) = yr * (2.0d0*a(2,0)+yr2*a(2,1))
                  gqyy(4) = zr * yr2 * a(2,1)
                  gqzz(2) = xr * zr2 * a(2,1)
                  gqzz(3) = yr * zr2 * a(2,1)
                  gqzz(4) = zr * (2.0d0*a(2,0)+zr2*a(2,1))
                  gqxy(2) = yr * (a(2,0)+xr2*a(2,1))
                  gqxy(3) = xr * (a(2,0)+yr2*a(2,1))
                  gqxy(4) = zr * xr * yr * a(2,1)
                  gqxz(2) = zr * (a(2,0)+xr2*a(2,1))
                  gqxz(3) = gqxy(4)
                  gqxz(4) = xr * (a(2,0)+zr2*a(2,1))
                  gqyz(2) = gqxy(4)
                  gqyz(3) = zr * (a(2,0)+yr2*a(2,1))
                  gqyz(4) = yr * (a(2,0)+zr2*a(2,1))
c
c     Born derivs of the unweighted reaction potential gradient tensor
c
                  gc(22) = xr * b(0,1)
                  gc(23) = yr * b(0,1)
                  gc(24) = zr * b(0,1)
                  gux(22) = b(1,0) + xr2*b(1,1)
                  gux(23) = xr * yr * b(1,1)
                  gux(24) = xr * zr * b(1,1)
                  guy(22) = gux(23)
                  guy(23) = b(1,0) + yr2*b(1,1)
                  guy(24) = yr * zr * b(1,1)
                  guz(22) = gux(24)
                  guz(23) = guy(24)
                  guz(24) = b(1,0) + zr2*b(1,1)
                  gqxx(22) = xr * (2.0d0*b(2,0)+xr2*b(2,1))
                  gqxx(23) = yr * xr2 * b(2,1)
                  gqxx(24) = zr * xr2 * b(2,1)
                  gqyy(22) = xr * yr2 * b(2,1)
                  gqyy(23) = yr * (2.0d0*b(2,0)+yr2*b(2,1))
                  gqyy(24) = zr * yr2 * b(2,1)
                  gqzz(22) = xr * zr2 * b(2,1)
                  gqzz(23) = yr * zr2 * b(2,1)
                  gqzz(24) = zr * (2.0d0*b(2,0) + zr2*b(2,1))
                  gqxy(22) = yr * (b(2,0)+xr2*b(2,1))
                  gqxy(23) = xr * (b(2,0)+yr2*b(2,1))
                  gqxy(24) = zr * xr * yr * b(2,1)
                  gqxz(22) = zr * (b(2,0)+xr2*b(2,1))
                  gqxz(23) = gqxy(24)
                  gqxz(24) = xr * (b(2,0)+zr2*b(2,1))
                  gqyz(22) = gqxy(24)
                  gqyz(23) = zr * (b(2,0)+yr2*b(2,1))
                  gqyz(24) = yr * (b(2,0)+zr2*b(2,1))
c
c     unweighted 2nd reaction potential gradient tensor
c
                  gc(5) = a(0,1) + xr2*a(0,2)
                  gc(6) = xr * yr * a(0,2)
                  gc(7) = xr * zr * a(0,2)
                  gc(8) = a(0,1) + yr2*a(0,2)
                  gc(9) = yr * zr * a(0,2)
                  gc(10) = a(0,1) + zr2*a(0,2)
                  gux(5) = xr * (3.0d0*a(1,1)+xr2*a(1,2))
                  gux(6) = yr * (a(1,1)+xr2*a(1,2))
                  gux(7) = zr * (a(1,1)+xr2*a(1,2))
                  gux(8) = xr * (a(1,1)+yr2*a(1,2))
                  gux(9) = zr * xr * yr * a(1,2)
                  gux(10) = xr * (a(1,1)+zr2*a(1,2))
                  guy(5) = yr * (a(1,1)+xr2*a(1,2))
                  guy(6) = xr * (a(1,1)+yr2*a(1,2))
                  guy(7) = gux(9)
                  guy(8) = yr * (3.0d0*a(1,1)+yr2*a(1,2))
                  guy(9) = zr * (a(1,1)+yr2*a(1,2))
                  guy(10) = yr * (a(1,1)+zr2*a(1,2))
                  guz(5) = zr * (a(1,1)+xr2*a(1,2))
                  guz(6) = gux(9)
                  guz(7) = xr * (a(1,1)+zr2*a(1,2))
                  guz(8) = zr * (a(1,1)+yr2*a(1,2))
                  guz(9) = yr * (a(1,1)+zr2*a(1,2))
                  guz(10) = zr * (3.0d0*a(1,1)+zr2*a(1,2))
                  gqxx(5) = 2.0d0*a(2,0) + xr2*(5.0d0*a(2,1)+xr2*a(2,2))
                  gqxx(6) = yr * xr * (2.0d0*a(2,1)+xr2*a(2,2))
                  gqxx(7) = zr * xr * (2.0d0*a(2,1)+xr2*a(2,2))
                  gqxx(8) = xr2 * (a(2,1)+yr2*a(2,2))
                  gqxx(9) = zr * yr * xr2 * a(2,2)
                  gqxx(10) = xr2 * (a(2,1)+zr2*a(2,2))
                  gqyy(5) = yr2 * (a(2,1)+xr2*a(2,2))
                  gqyy(6) = xr * yr * (2.0d0*a(2,1)+yr2*a(2,2))
                  gqyy(7) = xr * zr * yr2 * a(2,2)
                  gqyy(8) = 2.0d0*a(2,0) + yr2*(5.0d0*a(2,1)+yr2*a(2,2))
                  gqyy(9) = yr * zr * (2.0d0*a(2,1)+yr2*a(2,2))
                  gqyy(10) = yr2 * (a(2,1)+zr2*a(2,2))
                  gqzz(5) = zr2 * (a(2,1)+xr2*a(2,2))
                  gqzz(6) = xr * yr * zr2 * a(2,2)
                  gqzz(7) = xr * zr * (2.0d0*a(2,1)+zr2*a(2,2))
                  gqzz(8) = zr2 * (a(2,1)+yr2*a(2,2))
                  gqzz(9) = yr * zr * (2.0d0*a(2,1)+zr2*a(2,2))
                  gqzz(10) = 2.0d0*a(2,0)
     &                          + zr2*(5.0d0*a(2,1)+zr2*a(2,2))
                  gqxy(5) = xr * yr * (3.0d0*a(2,1)+xr2*a(2,2))
                  gqxy(6) = a(2,0) + (xr2+yr2)*a(2,1) + xr2*yr2*a(2,2)
                  gqxy(7) = zr * yr * (a(2,1)+xr2*a(2,2))
                  gqxy(8) = xr * yr * (3.0d0*a(2,1)+yr2*a(2,2))
                  gqxy(9) = zr * xr * (a(2,1)+yr2*a(2,2))
                  gqxy(10) = xr * yr * (a(2,1)+zr2*a(2,2))
                  gqxz(5) = xr * zr * (3.0d0*a(2,1)+xr2*a(2,2))
                  gqxz(6) = yr * zr * (a(2,1)+xr2*a(2,2))
                  gqxz(7) = a(2,0) + (xr2+zr2)*a(2,1) + xr2*zr2*a(2,2)
                  gqxz(8) = xr * zr * (a(2,1)+yr2*a(2,2))
                  gqxz(9) = xr * yr * (a(2,1)+zr2*a(2,2))
                  gqxz(10) = xr * zr * (3.0d0*a(2,1)+zr2*a(2,2))
                  gqyz(5) = zr * yr * (a(2,1)+xr2*a(2,2))
                  gqyz(6) = xr * zr * (a(2,1)+yr2*a(2,2))
                  gqyz(7) = xr * yr * (a(2,1)+zr2*a(2,2))
                  gqyz(8) = yr * zr * (3.0d0*a(2,1)+yr2*a(2,2))
                  gqyz(9) = a(2,0) + (yr2+zr2)*a(2,1) + yr2*zr2*a(2,2)
                  gqyz(10) = yr * zr * (3.0d0*a(2,1)+zr2*a(2,2))
c
c     Born radii derivatives of the unweighted 2nd reaction
c     potential gradient tensor
c
                  gc(25) = b(0,1) + xr2*b(0,2)
                  gc(26) = xr * yr * b(0,2)
                  gc(27) = xr * zr * b(0,2)
                  gc(28) = b(0,1) + yr2*b(0,2)
                  gc(29) = yr * zr * b(0,2)
                  gc(30) = b(0,1) + zr2*b(0,2)
                  gux(25) = xr * (3.0d0*b(1,1)+xr2*b(1,2))
                  gux(26) = yr * (b(1,1)+xr2*b(1,2))
                  gux(27) = zr * (b(1,1)+xr2*b(1,2))
                  gux(28) = xr * (b(1,1)+yr2*b(1,2))
                  gux(29) = zr * xr * yr * b(1,2)
                  gux(30) = xr * (b(1,1)+zr2*b(1,2))
                  guy(25) = yr * (b(1,1)+xr2*b(1,2))
                  guy(26) = xr * (b(1,1)+yr2*b(1,2))
                  guy(27) = gux(29)
                  guy(28) = yr * (3.0d0*b(1,1)+yr2*b(1,2))
                  guy(29) = zr * (b(1,1)+yr2*b(1,2))
                  guy(30) = yr * (b(1,1)+zr2*b(1,2))
                  guz(25) = zr * (b(1,1)+xr2*b(1,2))
                  guz(26) = gux(29)
                  guz(27) = xr * (b(1,1)+zr2*b(1,2))
                  guz(28) = zr * (b(1,1)+yr2*b(1,2))
                  guz(29) = yr * (b(1,1)+zr2*b(1,2))
                  guz(30) = zr * (3.0d0*b(1,1)+zr2*b(1,2))
                  gqxx(25) = 2.0d0*b(2,0)
     &                          + xr2*(5.0d0*b(2,1)+xr2*b(2,2))
                  gqxx(26) = yr * xr * (2.0d0*b(2,1)+xr2*b(2,2))
                  gqxx(27) = zr * xr * (2.0d0*b(2,1)+xr2*b(2,2))
                  gqxx(28) = xr2 * (b(2,1)+yr2*b(2,2))
                  gqxx(29) = zr * yr * xr2 * b(2,2)
                  gqxx(30) = xr2 * (b(2,1)+zr2*b(2,2))
                  gqyy(25) = yr2 * (b(2,1)+xr2*b(2,2))
                  gqyy(26) = xr * yr * (2.0d0*b(2,1)+yr2*b(2,2))
                  gqyy(27) = xr * zr * yr2 * b(2,2)
                  gqyy(28) = 2.0d0*b(2,0)
     &                          + yr2*(5.0d0*b(2,1)+yr2*b(2,2))
                  gqyy(29) = yr * zr * (2.0d0*b(2,1)+yr2*b(2,2))
                  gqyy(30) = yr2 * (b(2,1)+zr2*b(2,2))
                  gqzz(25) = zr2 * (b(2,1)+xr2*b(2,2))
                  gqzz(26) = xr * yr * zr2 * b(2,2)
                  gqzz(27) = xr * zr * (2.0d0*b(2,1)+zr2*b(2,2))
                  gqzz(28) = zr2 * (b(2,1)+yr2*b(2,2))
                  gqzz(29) = yr * zr * (2.0d0*b(2,1)+zr2*b(2,2))
                  gqzz(30) = 2.0d0*b(2,0)
     &                          + zr2*(5.0d0*b(2,1)+zr2*b(2,2))
                  gqxy(25) = xr * yr * (3.0d0*b(2,1) + xr2*b(2,2))
                  gqxy(26) = b(2,0) + (xr2+yr2)*b(2,1) + xr2*yr2*b(2,2)
                  gqxy(27) = zr * yr * (b(2,1)+xr2*b(2,2))
                  gqxy(28) = xr * yr * (3.0d0*b(2,1)+yr2*b(2,2))
                  gqxy(29) = zr * xr * (b(2,1)+yr2*b(2,2))
                  gqxy(30) = xr * yr * (b(2,1)+zr2*b(2,2))
                  gqxz(25) = xr * zr * (3.0d0*b(2,1)+xr2*b(2,2))
                  gqxz(26) = yr * zr * (b(2,1)+xr2*b(2,2))
                  gqxz(27) = b(2,0) + (xr2+zr2)*b(2,1) + xr2*zr2*b(2,2)
                  gqxz(28) = xr * zr * (b(2,1)+yr2*b(2,2))
                  gqxz(29) = xr * yr * (b(2,1)+zr2*b(2,2))
                  gqxz(30) = xr * zr * (3.0d0*b(2,1)+zr2*b(2,2))
                  gqyz(25) = zr * yr * (b(2,1)+xr2*b(2,2))
                  gqyz(26) = xr * zr * (b(2,1)+yr2*b(2,2))
                  gqyz(27) = xr * yr * (b(2,1)+zr2*b(2,2))
                  gqyz(28) = yr * zr * (3.0d0*b(2,1)+yr2*b(2,2))
                  gqyz(29) = b(2,0) + (yr2+zr2)*b(2,1) + yr2*zr2*b(2,2)
                  gqyz(30) = yr * zr * (3.0d0*b(2,1)+zr2*b(2,2))
c
c     unweighted 3rd reaction potential gradient tensor
c
                  gc(11) = xr * (3.0d0*a(0,2)+xr2*a(0,3))
                  gc(12) = yr * (a(0,2)+xr2*a(0,3))
                  gc(13) = zr * (a(0,2)+xr2*a(0,3))
                  gc(14) = xr * (a(0,2)+yr2*a(0,3))
                  gc(15) = xr * yr * zr * a(0,3)
                  gc(16) = xr * (a(0,2)+zr2*a(0,3))
                  gc(17) = yr * (3.0d0*a(0,2)+yr2*a(0,3))
                  gc(18) = zr * (a(0,2)+yr2*a(0,3))
                  gc(19) = yr * (a(0,2)+zr2*a(0,3))
                  gc(20) = zr * (3.0d0*a(0,2)+zr2*a(0,3))
                  gux(11) = 3.0d0*a(1,1) + xr2*(6.0d0*a(1,2)+xr2*a(1,3))
                  gux(12) = xr * yr * (3.0d0*a(1,2)+xr2*a(1,3))
                  gux(13) = xr * zr * (3.0d0*a(1,2)+xr2*a(1,3))
                  gux(14) = a(1,1) + (xr2+yr2)*a(1,2) + xr2*yr2*a(1,3)
                  gux(15) = yr * zr * (a(1,2)+xr2*a(1,3))
                  gux(16) = a(1,1) + (xr2+zr2)*a(1,2) + xr2*zr2*a(1,3)
                  gux(17) = xr * yr * (3.0d0*a(1,2)+yr2*a(1,3))
                  gux(18) = xr * zr * (a(1,2)+yr2*a(1,3))
                  gux(19) = xr * yr * (a(1,2)+zr2*a(1,3))
                  gux(20) = xr * zr * (3.0d0*a(1,2)+zr2*a(1,3))
                  guy(11) = gux(12)
                  guy(12) = gux(14)
                  guy(13) = gux(15)
                  guy(14) = gux(17)
                  guy(15) = gux(18)
                  guy(16) = gux(19)
                  guy(17) = 3.0d0*a(1,1) + yr2*(6.0d0*a(1,2)+yr2*a(1,3))
                  guy(18) = yr * zr * (3.0d0*a(1,2)+yr2*a(1,3))
                  guy(19) = a(1,1) + (yr2+zr2)*a(1,2) + yr2*zr2*a(1,3)
                  guy(20) = yr * zr * (3.0d0*a(1,2)+zr2*a(1,3))
                  guz(11) = gux(13)
                  guz(12) = gux(15)
                  guz(13) = gux(16)
                  guz(14) = gux(18)
                  guz(15) = gux(19)
                  guz(16) = gux(20)
                  guz(17) = guy(18)
                  guz(18) = guy(19)
                  guz(19) = guy(20)
                  guz(20) = 3.0d0*a(1,1) + zr2*(6.0d0*a(1,2)+zr2*a(1,3))
                  gqxx(11) = xr * (12.0d0*a(2,1)+xr2*(9.0d0*a(2,2)
     &                                +xr2*a(2,3)))
                  gqxx(12) = yr * (2.0d0*a(2,1)+xr2*(5.0d0*a(2,2)
     &                                +xr2*a(2,3)))
                  gqxx(13) = zr * (2.0d0*a(2,1)+xr2*(5.0d0*a(2,2)
     &                                +xr2*a(2,3)))
                  gqxx(14) = xr * (2.0d0*a(2,1)+yr2*2.0d0*a(2,2)
     &                                +xr2*(a(2,2)+yr2*a(2,3)))
                  gqxx(15) = xr * yr * zr * (2.0d0*a(2,2)+xr2*a(2,3))
                  gqxx(16) = xr * (2.0d0*a(2,1)+zr2*2.0d0*a(2,2)
     &                                +xr2*(a(2,2)+zr2*a(2,3)))
                  gqxx(17) = yr * xr2 * (3.0d0*a(2,2)+yr2*a(2,3))
                  gqxx(18) = zr * xr2 * (a(2,2)+yr2*a(2,3))
                  gqxx(19) = yr * xr2 * (a(2,2)+zr2*a(2,3))
                  gqxx(20) = zr * xr2 * (3.0d0*a(2,2)+zr2*a(2,3))
                  gqxy(11) = yr * (3.0d0*a(2,1)+xr2*(6.0d0*a(2,2)
     &                                +xr2*a(2,3)))
                  gqxy(12) = xr * (3.0d0*(a(2,1)+yr2*a(2,2))
     &                                +xr2*(a(2,2)+yr2*a(2,3)))
                  gqxy(13) = xr * yr * zr * (3.0d0*a(2,2)+xr2*a(2,3))
                  gqxy(14) = yr * (3.0d0*(a(2,1)+xr2*a(2,2))
     &                                +yr2*(a(2,2)+xr2*a(2,3)))
                  gqxy(15) = zr * (a(2,1)+(yr2+xr2)*a(2,2)
     &                                +yr2*xr2*a(2,3))
                  gqxy(16) = yr * (a(2,1)+(xr2+zr2)*a(2,2)
     &                                +xr2*zr2*a(2,3))
                  gqxy(17) = xr * (3.0d0*(a(2,1)+yr2*a(2,2))
     &                                +yr2*(3.0d0*a(2,2)+yr2*a(2,3)))
                  gqxy(18) = xr * yr * zr * (3.0d0*a(2,2)+yr2*a(2,3))
                  gqxy(19) = xr * (a(2,1)+(yr2+zr2)*a(2,2)
     &                                +yr2*zr2*a(2,3))
                  gqxy(20) = xr * yr * zr * (3.0d0*a(2,2)+zr2*a(2,3))
                  gqxz(11) = zr * (3.0d0*a(2,1)+xr2*(6.0d0*a(2,2)
     &                                +xr2*a(2,3)))
                  gqxz(12) = xr * yr * zr * (3.0d0*a(2,2)+xr2*a(2,3))
                  gqxz(13) = xr * (3.0d0*(a(2,1)+zr2*a(2,2))
     &                                +xr2*(a(2,2)+zr2*a(2,3)))
                  gqxz(14) = zr * (a(2,1)+(xr2+yr2)*a(2,2)
     &                                +xr2*yr2*a(2,3))
                  gqxz(15) = yr * (a(2,1)+(xr2+zr2)*a(2,2)
     &                                +zr2*xr2*a(2,3))
                  gqxz(16) = zr * (3.0d0*(a(2,1)+xr2*a(2,2))
     &                                +zr2*(a(2,2)+xr2*a(2,3)))
                  gqxz(17) = xr * yr * zr * (3.0d0*a(2,2)+yr2*a(2,3))
                  gqxz(18) = xr * (a(2,1)+(zr2+yr2)*a(2,2)
     &                                +zr2*yr2*a(2,3))
                  gqxz(19) = xr * yr * zr * (3.0d0*a(2,2)+zr2*a(2,3))
                  gqxz(20) = xr * (3.0d0*a(2,1)+zr2*(6.0d0*a(2,2)
     &                                +zr2*a(2,3)))
                  gqyy(11) = xr * yr2 * (3.0d0*a(2,2)+xr2*a(2,3))
                  gqyy(12) = yr * (2.0d0*a(2,1)+xr2*2.0d0*a(2,2)
     &                                +yr2*(a(2,2)+xr2*a(2,3)))
                  gqyy(13) = zr * yr2 * (a(2,2)+xr2*a(2,3))
                  gqyy(14) = xr * (2.0d0*a(2,1)+yr2*(5.0d0*a(2,2)
     &                                +yr2*a(2,3)))
                  gqyy(15) = xr * yr * zr * (2.0d0*a(2,2)+yr2*a(2,3))
                  gqyy(16) = xr * yr2 * (a(2,2)+zr2*a(2,3))
                  gqyy(17) = yr * (12.0d0*a(2,1)+yr2*(9.0d0*a(2,2)
     &                                +yr2*a(2,3)))
                  gqyy(18) = zr * (2.0d0*a(2,1)+yr2*(5.0d0*a(2,2)
     &                                +yr2*a(2,3)))
                  gqyy(19) = yr * (2.0d0*a(2,1)+zr2*2.0d0*a(2,2)
     &                                +yr2*(a(2,2)+zr2*a(2,3)))
                  gqyy(20) = zr * yr2 * (3.0d0*a(2,2)+zr2*a(2,3))
                  gqyz(11) = xr * yr * zr * (3.0d0*a(2,2)+xr2*a(2,3))
                  gqyz(12) = zr * (a(2,1)+(xr2+yr2)*a(2,2)
     &                                +xr2*yr2*a(2,3))
                  gqyz(13) = yr * (a(2,1)+(xr2+zr2)*a(2,2)
     &                                +xr2*zr2*a(2,3))
                  gqyz(14) = xr * yr * zr * (3.0d0*a(2,2)+yr2*a(2,3))
                  gqyz(15) = xr * (a(2,1)+(yr2+zr2)*a(2,2)
     &                                +yr2*zr2*a(2,3))
                  gqyz(16) = xr * yr * zr * (3.0d0*a(2,2)+zr2*a(2,3))
                  gqyz(17) = zr * (3.0d0*a(2,1)+yr2*(6.0d0*a(2,2)
     &                                +yr2*a(2,3)))
                  gqyz(18) = yr * (3.0d0*(a(2,1)+zr2*a(2,2))
     &                                +yr2*(a(2,2)+zr2*a(2,3)))
                  gqyz(19) = zr * (3.0d0*(a(2,1)+yr2*a(2,2))
     &                                +zr2*(a(2,2)+yr2*a(2,3)))
                  gqyz(20) = yr * (3.0d0*a(2,1)+zr2*(6.0d0*a(2,2)
     &                                +zr2*a(2,3)))
                  gqzz(11) = xr * zr2 * (3.0d0*a(2,2)+xr2*a(2,3))
                  gqzz(12) = yr * (zr2*a(2,2)+xr2*(zr2*a(2,3)))
                  gqzz(13) = zr * (2.0d0*a(2,1)+xr2*2.0d0*a(2,2)
     &                                +zr2*(a(2,2)+xr2*a(2,3)))
                  gqzz(14) = xr * zr2 * (a(2,2)+yr2*a(2,3))
                  gqzz(15) = xr * yr * zr * (2.0d0*a(2,2)+zr2*a(2,3))
                  gqzz(16) = xr * (2.0d0*a(2,1)+zr2*(5.0d0*a(2,2)
     &                                +zr2*a(2,3)))
                  gqzz(17) = yr * zr2 * (3.0d0*a(2,2)+yr2*a(2,3))
                  gqzz(18) = zr * (2.0d0*a(2,1)+yr2*2.0d0*a(2,2)
     &                                +zr2*(a(2,2)+yr2*a(2,3)))
                  gqzz(19) = yr * (2.0d0*a(2,1)+zr2*(5.0d0*a(2,2)
     &                                +zr2*a(2,3)))
                  gqzz(20) = zr * (12.0d0*a(2,1)+zr2*(9.0d0*a(2,2)
     &                                +zr2*a(2,3)))
c
c     electrostatic solvation energy of the permanent multipoles
c     in their own GK reaction potential
c
                  esym = ci * ck * gc(1)
     &                   - (uxi*(uxk*gux(2)+uyk*guy(2)+uzk*guz(2))
     &                     +uyi*(uxk*gux(3)+uyk*guy(3)+uzk*guz(3))
     &                     +uzi*(uxk*gux(4)+uyk*guy(4)+uzk*guz(4)))
                  ewi = ci*(uxk*gc(2)+uyk*gc(3)+uzk*gc(4))
     &                 -ck*(uxi*gux(1)+uyi*guy(1)+uzi*guz(1))
     &                 +ci*(qxxk*gc(5)+qyyk*gc(8)+qzzk*gc(10)
     &                 +2.0d0*(qxyk*gc(6)+qxzk*gc(7)+qyzk*gc(9)))
     &                 +ck*(qxxi*gqxx(1)+qyyi*gqyy(1)+qzzi*gqzz(1)
     &                 +2.0d0*(qxyi*gqxy(1)+qxzi*gqxz(1)+qyzi*gqyz(1)))
     &                 - uxi*(qxxk*gux(5)+qyyk*gux(8)+qzzk*gux(10)
     &                 +2.0d0*(qxyk*gux(6)+qxzk*gux(7)+qyzk*gux(9)))
     &                 - uyi*(qxxk*guy(5)+qyyk*guy(8)+qzzk*guy(10)
     &                 +2.0d0*(qxyk*guy(6)+qxzk*guy(7)+qyzk*guy(9)))
     &                 - uzi*(qxxk*guz(5)+qyyk*guz(8)+qzzk*guz(10)
     &                 +2.0d0*(qxyk*guz(6)+qxzk*guz(7)+qyzk*guz(9)))
     &                 + uxk*(qxxi*gqxx(2)+qyyi*gqyy(2)+qzzi*gqzz(2)
     &                 +2.0d0*(qxyi*gqxy(2)+qxzi*gqxz(2)+qyzi*gqyz(2)))
     &                 + uyk*(qxxi*gqxx(3)+qyyi*gqyy(3)+qzzi*gqzz(3)
     &                 +2.0d0*(qxyi*gqxy(3)+qxzi*gqxz(3)+qyzi*gqyz(3)))
     &                 + uzk*(qxxi*gqxx(4)+qyyi*gqyy(4)+qzzi*gqzz(4)
     &                 +2.0d0*(qxyi*gqxy(4)+qxzi*gqxz(4)+qyzi*gqyz(4)))
     &                 + qxxi*(qxxk*gqxx(5)+qyyk*gqxx(8)+qzzk*gqxx(10)
     &                 +2.0d0*(qxyk*gqxx(6)+qxzk*gqxx(7)+qyzk*gqxx(9)))
     &                 + qyyi*(qxxk*gqyy(5)+qyyk*gqyy(8)+qzzk*gqyy(10)
     &                 +2.0d0*(qxyk*gqyy(6)+qxzk*gqyy(7)+qyzk*gqyy(9)))
     &                 + qzzi*(qxxk*gqzz(5)+qyyk*gqzz(8)+qzzk*gqzz(10)
     &                 +2.0d0*(qxyk*gqzz(6)+qxzk*gqzz(7)+qyzk*gqzz(9)))
     &           + 2.0d0*(qxyi*(qxxk*gqxy(5)+qyyk*gqxy(8)+qzzk*gqxy(10)
     &                 +2.0d0*(qxyk*gqxy(6)+qxzk*gqxy(7)+qyzk*gqxy(9)))
     &                 + qxzi*(qxxk*gqxz(5)+qyyk*gqxz(8)+qzzk*gqxz(10)
     &                 +2.0d0*(qxyk*gqxz(6)+qxzk*gqxz(7)+qyzk*gqxz(9)))
     &                 + qyzi*(qxxk*gqyz(5)+qyyk*gqyz(8)+qzzk*gqyz(10)
     &                 +2.0d0*(qxyk*gqyz(6)+qxzk*gqyz(7)+qyzk*gqyz(9))))
                  ewk = ci*(uxk*gux(1)+uyk*guy(1)+uzk*guz(1))
     &                 -ck*(uxi*gc(2)+uyi*gc(3)+uzi*gc(4))
     &                 +ci*(qxxk*gqxx(1)+qyyk*gqyy(1)+qzzk*gqzz(1)
     &                 +2.0d0*(qxyk*gqxy(1)+qxzk*gqxz(1)+qyzk*gqyz(1)))
     &                 +ck*(qxxi*gc(5)+qyyi*gc(8)+qzzi*gc(10)
     &                 +2.0d0*(qxyi*gc(6)+qxzi*gc(7)+qyzi*gc(9)))
     &                 - uxi*(qxxk*gqxx(2)+qyyk*gqyy(2)+qzzk*gqzz(2)
     &                 +2.0d0*(qxyk*gqxy(2)+qxzk*gqxz(2)+qyzk*gqyz(2)))
     &                 - uyi*(qxxk*gqxx(3)+qyyk*gqyy(3)+qzzk*gqzz(3)
     &                 +2.0d0*(qxyk*gqxy(3)+qxzk*gqxz(3)+qyzk*gqyz(3)))
     &                 - uzi*(qxxk*gqxx(4)+qyyk*gqyy(4)+qzzk*gqzz(4)
     &                 +2.0d0*(qxyk*gqxy(4)+qxzk*gqxz(4)+qyzk*gqyz(4)))
     &                 + uxk*(qxxi*gux(5)+qyyi*gux(8)+qzzi*gux(10)
     &                 +2.0d0*(qxyi*gux(6)+qxzi*gux(7)+qyzi*gux(9)))
     &                 + uyk*(qxxi*guy(5)+qyyi*guy(8)+qzzi*guy(10)
     &                 +2.0d0*(qxyi*guy(6)+qxzi*guy(7)+qyzi*guy(9)))
     &                 + uzk*(qxxi*guz(5)+qyyi*guz(8)+qzzi*guz(10)
     &                 +2.0d0*(qxyi*guz(6)+qxzi*guz(7)+qyzi*guz(9)))
     &                 + qxxi*(qxxk*gqxx(5)+qyyk*gqyy(5)+qzzk*gqzz(5)
     &                 +2.0d0*(qxyk*gqxy(5)+qxzk*gqxz(5)+qyzk*gqyz(5)))
     &                 + qyyi*(qxxk*gqxx(8)+qyyk*gqyy(8)+qzzk*gqzz(8)
     &                 +2.0d0*(qxyk*gqxy(8)+qxzk*gqxz(8)+qyzk*gqyz(8)))
     &                 + qzzi*(qxxk*gqxx(10)+qyyk*gqyy(10)+qzzk*gqzz(10)
     &           +2.0d0*(qxyk*gqxy(10)+qxzk*gqxz(10)+qyzk*gqyz(10)))
     &           + 2.0d0*(qxyi*(qxxk*gqxx(6)+qyyk*gqyy(6)+qzzk*gqzz(6)
     &                 +2.0d0*(qxyk*gqxy(6)+qxzk*gqxz(6)+qyzk*gqyz(6)))
     &                 + qxzi*(qxxk*gqxx(7)+qyyk*gqyy(7)+qzzk*gqzz(7)
     &                 +2.0d0*(qxyk*gqxy(7)+qxzk*gqxz(7)+qyzk*gqyz(7)))
     &                 + qyzi*(qxxk*gqxx(9)+qyyk*gqyy(9)+qzzk*gqzz(9)
     &                 +2.0d0*(qxyk*gqxy(9)+qxzk*gqxz(9)+qyzk*gqyz(9))))
c
                  desymdx = ci * ck * gc(2)
     &                      - (uxi*(uxk*gux(5)+uyk*guy(5)+uzk*guz(5))
     &                        +uyi*(uxk*gux(6)+uyk*guy(6)+uzk*guz(6))
     &                        +uzi*(uxk*gux(7)+uyk*guy(7)+uzk*guz(7)))
                  dewidx = ci*(uxk*gc(5)+uyk*gc(6)+uzk*gc(7))
     &                    -ck*(uxi*gux(2)+uyi*guy(2)+uzi*guz(2))
     &                 +ci*(qxxk*gc(11)+qyyk*gc(14)+qzzk*gc(16)
     &              +2.0d0*(qxyk*gc(12)+qxzk*gc(13)+qyzk*gc(15)))
     &                 +ck*(qxxi*gqxx(2)+qyyi*gqyy(2)+qzzi*gqzz(2)
     &              +2.0d0*(qxyi*gqxy(2)+qxzi*gqxz(2)+qyzi*gqyz(2)))
     &                 - uxi*(qxxk*gux(11)+qyyk*gux(14)+qzzk*gux(16)
     &              +2.0d0*(qxyk*gux(12)+qxzk*gux(13)+qyzk*gux(15)))
     &                 - uyi*(qxxk*guy(11)+qyyk*guy(14)+qzzk*guy(16)
     &              +2.0d0*(qxyk*guy(12)+qxzk*guy(13)+qyzk*guy(15)))
     &                 - uzi*(qxxk*guz(11)+qyyk*guz(14)+qzzk*guz(16)
     &              +2.0d0*(qxyk*guz(12)+qxzk*guz(13)+qyzk*guz(15)))
     &                 + uxk*(qxxi*gqxx(5)+qyyi*gqyy(5)+qzzi*gqzz(5)
     &              +2.0d0*(qxyi*gqxy(5)+qxzi*gqxz(5)+qyzi*gqyz(5)))
     &                 + uyk*(qxxi*gqxx(6)+qyyi*gqyy(6)+qzzi*gqzz(6)
     &              +2.0d0*(qxyi*gqxy(6)+qxzi*gqxz(6)+qyzi*gqyz(6)))
     &                 + uzk*(qxxi*gqxx(7)+qyyi*gqyy(7)+qzzi*gqzz(7)
     &              +2.0d0*(qxyi*gqxy(7)+qxzi*gqxz(7)+qyzi*gqyz(7)))
     &                 + qxxi*(qxxk*gqxx(11)+qyyk*gqxx(14)+qzzk*gqxx(16)
     &              +2.0d0*(qxyk*gqxx(12)+qxzk*gqxx(13)+qyzk*gqxx(15)))
     &                 + qyyi*(qxxk*gqyy(11)+qyyk*gqyy(14)+qzzk*gqyy(16)
     &              +2.0d0*(qxyk*gqyy(12)+qxzk*gqyy(13)+qyzk*gqyy(15)))
     &                 + qzzi*(qxxk*gqzz(11)+qyyk*gqzz(14)+qzzk*gqzz(16)
     &              +2.0d0*(qxyk*gqzz(12)+qxzk*gqzz(13)+qyzk*gqzz(15)))
     &        + 2.0d0*(qxyi*(qxxk*gqxy(11)+qyyk*gqxy(14)+qzzk*gqxy(16)
     &              +2.0d0*(qxyk*gqxy(12)+qxzk*gqxy(13)+qyzk*gqxy(15)))
     &                 + qxzi*(qxxk*gqxz(11)+qyyk*gqxz(14)+qzzk*gqxz(16)
     &              +2.0d0*(qxyk*gqxz(12)+qxzk*gqxz(13)+qyzk*gqxz(15)))
     &                 + qyzi*(qxxk*gqyz(11)+qyyk*gqyz(14)+qzzk*gqyz(16)
     &              +2.0d0*(qxyk*gqyz(12)+qxzk*gqyz(13)+qyzk*gqyz(15))))
                  dewkdx = ci*(uxk*gux(2)+uyk*guy(2)+uzk*guz(2))
     &                    -ck*(uxi*gc(5)+uyi*gc(6)+uzi*gc(7))
     &                 +ci*(qxxk*gqxx(2)+qyyk*gqyy(2)+qzzk*gqzz(2)
     &              +2.0d0*(qxyk*gqxy(2)+qxzk*gqxz(2)+qyzk*gqyz(2)))
     &                 +ck*(qxxi*gc(11)+qyyi*gc(14)+qzzi*gc(16)
     &              +2.0d0*(qxyi*gc(12)+qxzi*gc(13)+qyzi*gc(15)))
     &                 - uxi*(qxxk*gqxx(5)+qyyk*gqyy(5)+qzzk*gqzz(5)
     &              +2.0d0*(qxyk*gqxy(5)+qxzk*gqxz(5)+qyzk*gqyz(5)))
     &                 - uyi*(qxxk*gqxx(6)+qyyk*gqyy(6)+qzzk*gqzz(6)
     &              +2.0d0*(qxyk*gqxy(6)+qxzk*gqxz(6)+qyzk*gqyz(6)))
     &                 - uzi*(qxxk*gqxx(7)+qyyk*gqyy(7)+qzzk*gqzz(7)
     &              +2.0d0*(qxyk*gqxy(7)+qxzk*gqxz(7)+qyzk*gqyz(7)))
     &                 + uxk*(qxxi*gux(11)+qyyi*gux(14)+qzzi*gux(16)
     &              +2.0d0*(qxyi*gux(12)+qxzi*gux(13)+qyzi*gux(15)))
     &                 + uyk*(qxxi*guy(11)+qyyi*guy(14)+qzzi*guy(16)
     &              +2.0d0*(qxyi*guy(12)+qxzi*guy(13)+qyzi*guy(15)))
     &                 + uzk*(qxxi*guz(11)+qyyi*guz(14)+qzzi*guz(16)
     &              +2.0d0*(qxyi*guz(12)+qxzi*guz(13)+qyzi*guz(15)))
     &                 + qxxi*(qxxk*gqxx(11)+qyyk*gqyy(11)+qzzk*gqzz(11)
     &              +2.0d0*(qxyk*gqxy(11)+qxzk*gqxz(11)+qyzk*gqyz(11)))
     &                 + qyyi*(qxxk*gqxx(14)+qyyk*gqyy(14)+qzzk*gqzz(14)
     &              +2.0d0*(qxyk*gqxy(14)+qxzk*gqxz(14)+qyzk*gqyz(14)))
     &                 + qzzi*(qxxk*gqxx(16)+qyyk*gqyy(16)+qzzk*gqzz(16)
     &              +2.0d0*(qxyk*gqxy(16)+qxzk*gqxz(16)+qyzk*gqyz(16)))
     &        + 2.0d0*(qxyi*(qxxk*gqxx(12)+qyyk*gqyy(12)+qzzk*gqzz(12)
     &              +2.0d0*(qxyk*gqxy(12)+qxzk*gqxz(12)+qyzk*gqyz(12)))
     &                 + qxzi*(qxxk*gqxx(13)+qyyk*gqyy(13)+qzzk*gqzz(13)
     &              +2.0d0*(qxyk*gqxy(13)+qxzk*gqxz(13)+qyzk*gqyz(13)))
     &                 + qyzi*(qxxk*gqxx(15)+qyyk*gqyy(15)+qzzk*gqzz(15)
     &              +2.0d0*(qxyk*gqxy(15)+qxzk*gqxz(15)+qyzk*gqyz(15))))
                  dedx = desymdx + 0.5d0*(dewidx+dewkdx)
c
                  desymdy = ci * ck * gc(3)
     &                      - (uxi*(uxk*gux(6)+uyk*guy(6)+uzk*guz(6))
     &                        +uyi*(uxk*gux(8)+uyk*guy(8)+uzk*guz(8))
     &                        +uzi*(uxk*gux(9)+uyk*guy(9)+uzk*guz(9)))
                  dewidy = ci*(uxk*gc(6)+uyk*gc(8)+uzk*gc(9))
     &                    -ck*(uxi*gux(3)+uyi*guy(3)+uzi*guz(3))
     &                 +ci*(qxxk*gc(12)+qyyk*gc(17)+qzzk*gc(19)
     &              +2.0d0*(qxyk*gc(14)+qxzk*gc(15)+qyzk*gc(18)))
     &                 +ck*(qxxi*gqxx(3)+qyyi*gqyy(3)+qzzi*gqzz(3)
     &              +2.0d0*(qxyi*gqxy(3)+qxzi*gqxz(3)+qyzi*gqyz(3)))
     &                 - uxi*(qxxk*gux(12)+qyyk*gux(17)+qzzk*gux(19)
     &              +2.0d0*(qxyk*gux(14)+qxzk*gux(15)+qyzk*gux(18)))
     &                 - uyi*(qxxk*guy(12)+qyyk*guy(17)+qzzk*guy(19)
     &              +2.0d0*(qxyk*guy(14)+qxzk*guy(15)+qyzk*guy(18)))
     &                 - uzi*(qxxk*guz(12)+qyyk*guz(17)+qzzk*guz(19)
     &              +2.0d0*(qxyk*guz(14)+qxzk*guz(15)+qyzk*guz(18)))
     &                 + uxk*(qxxi*gqxx(6)+qyyi*gqyy(6)+qzzi*gqzz(6)
     &              +2.0d0*(qxyi*gqxy(6)+qxzi*gqxz(6)+qyzi*gqyz(6)))
     &                 + uyk*(qxxi*gqxx(8)+qyyi*gqyy(8)+qzzi*gqzz(8)
     &              +2.0d0*(qxyi*gqxy(8)+qxzi*gqxz(8)+qyzi*gqyz(8)))
     &                 + uzk*(qxxi*gqxx(9)+qyyi*gqyy(9)+qzzi*gqzz(9)
     &              +2.0d0*(qxyi*gqxy(9)+qxzi*gqxz(9)+qyzi*gqyz(9)))
     &                 + qxxi*(qxxk*gqxx(12)+qyyk*gqxx(17)+qzzk*gqxx(19)
     &              +2.0d0*(qxyk*gqxx(14)+qxzk*gqxx(15)+qyzk*gqxx(18)))
     &                 + qyyi*(qxxk*gqyy(12)+qyyk*gqyy(17)+qzzk*gqyy(19)
     &              +2.0d0*(qxyk*gqyy(14)+qxzk*gqyy(15)+qyzk*gqyy(18)))
     &                 + qzzi*(qxxk*gqzz(12)+qyyk*gqzz(17)+qzzk*gqzz(19)
     &              +2.0d0*(qxyk*gqzz(14)+qxzk*gqzz(15)+qyzk*gqzz(18)))
     &        + 2.0d0*(qxyi*(qxxk*gqxy(12)+qyyk*gqxy(17)+qzzk*gqxy(19)
     &              +2.0d0*(qxyk*gqxy(14)+qxzk*gqxy(15)+qyzk*gqxy(18)))
     &                 + qxzi*(qxxk*gqxz(12)+qyyk*gqxz(17)+qzzk*gqxz(19)
     &              +2.0d0*(qxyk*gqxz(14)+qxzk*gqxz(15)+qyzk*gqxz(18)))
     &                 + qyzi*(qxxk*gqyz(12)+qyyk*gqyz(17)+qzzk*gqyz(19)
     &              +2.0d0*(qxyk*gqyz(14)+qxzk*gqyz(15)+qyzk*gqyz(18))))
                  dewkdy = ci*(uxk*gux(3)+uyk*guy(3)+uzk*guz(3))
     &                    -ck*(uxi*gc(6)+uyi*gc(8)+uzi*gc(9))
     &                 +ci*(qxxk*gqxx(3)+qyyk*gqyy(3)+qzzk*gqzz(3)
     &              +2.0d0*(qxyk*gqxy(3)+qxzk*gqxz(3)+qyzk*gqyz(3)))
     &                 +ck*(qxxi*gc(12)+qyyi*gc(17)+qzzi*gc(19)
     &              +2.0d0*(qxyi*gc(14)+qxzi*gc(15)+qyzi*gc(18)))
     &                 - uxi*(qxxk*gqxx(6)+qyyk*gqyy(6)+qzzk*gqzz(6)
     &              +2.0d0*(qxyk*gqxy(6)+qxzk*gqxz(6)+qyzk*gqyz(6)))
     &                 - uyi*(qxxk*gqxx(8)+qyyk*gqyy(8)+qzzk*gqzz(8)
     &              +2.0d0*(qxyk*gqxy(8)+qxzk*gqxz(8)+qyzk*gqyz(8)))
     &                 - uzi*(qxxk*gqxx(9)+qyyk*gqyy(9)+qzzk*gqzz(9)
     &              +2.0d0*(qxyk*gqxy(9)+qxzk*gqxz(9)+qyzk*gqyz(9)))
     &                 + uxk*(qxxi*gux(12)+qyyi*gux(17)+qzzi*gux(19)
     &              +2.0d0*(qxyi*gux(14)+qxzi*gux(15)+qyzi*gux(18)))
     &                 + uyk*(qxxi*guy(12)+qyyi*guy(17)+qzzi*guy(19)
     &              +2.0d0*(qxyi*guy(14)+qxzi*guy(15)+qyzi*guy(18)))
     &                 + uzk*(qxxi*guz(12)+qyyi*guz(17)+qzzi*guz(19)
     &              +2.0d0*(qxyi*guz(14)+qxzi*guz(15)+qyzi*guz(18)))
     &                 + qxxi*(qxxk*gqxx(12)+qyyk*gqyy(12)+qzzk*gqzz(12)
     &              +2.0d0*(qxyk*gqxy(12)+qxzk*gqxz(12)+qyzk*gqyz(12)))
     &                 + qyyi*(qxxk*gqxx(17)+qyyk*gqyy(17)+qzzk*gqzz(17)
     &              +2.0d0*(qxyk*gqxy(17)+qxzk*gqxz(17)+qyzk*gqyz(17)))
     &                 + qzzi*(qxxk*gqxx(19)+qyyk*gqyy(19)+qzzk*gqzz(19)
     &              +2.0d0*(qxyk*gqxy(19)+qxzk*gqxz(19)+qyzk*gqyz(19)))
     &        + 2.0d0*(qxyi*(qxxk*gqxx(14)+qyyk*gqyy(14)+qzzk*gqzz(14)
     &              +2.0d0*(qxyk*gqxy(14)+qxzk*gqxz(14)+qyzk*gqyz(14)))
     &                 + qxzi*(qxxk*gqxx(15)+qyyk*gqyy(15)+qzzk*gqzz(15)
     &              +2.0d0*(qxyk*gqxy(15)+qxzk*gqxz(15)+qyzk*gqyz(15)))
     &                 + qyzi*(qxxk*gqxx(18)+qyyk*gqyy(18)+qzzk*gqzz(18)
     &              +2.0d0*(qxyk*gqxy(18)+qxzk*gqxz(18)+qyzk*gqyz(18))))
                  dedy = desymdy + 0.5d0*(dewidy+dewkdy)
c
                  desymdz = ci * ck * gc(4)
     &                      - (uxi*(uxk*gux(7)+uyk*guy(7)+uzk*guz(7))
     &                        +uyi*(uxk*gux(9)+uyk*guy(9)+uzk*guz(9))
     &                       +uzi*(uxk*gux(10)+uyk*guy(10)+uzk*guz(10)))
                  dewidz = ci*(uxk*gc(7)+uyk*gc(9)+uzk*gc(10))
     &                    -ck*(uxi*gux(4)+uyi*guy(4)+uzi*guz(4))
     &                 +ci*(qxxk*gc(13)+qyyk*gc(18)+qzzk*gc(20)
     &              +2.0d0*(qxyk*gc(15)+qxzk*gc(16)+qyzk*gc(19)))
     &                 +ck*(qxxi*gqxx(4)+qyyi*gqyy(4)+qzzi*gqzz(4)
     &              +2.0d0*(qxyi*gqxy(4)+qxzi*gqxz(4)+qyzi*gqyz(4)))
     &                 - uxi*(qxxk*gux(13)+qyyk*gux(18)+qzzk*gux(20)
     &              +2.0d0*(qxyk*gux(15)+qxzk*gux(16)+qyzk*gux(19)))
     &                 - uyi*(qxxk*guy(13)+qyyk*guy(18)+qzzk*guy(20)
     &              +2.0d0*(qxyk*guy(15)+qxzk*guy(16)+qyzk*guy(19)))
     &                 - uzi*(qxxk*guz(13)+qyyk*guz(18)+qzzk*guz(20)
     &              +2.0d0*(qxyk*guz(15)+qxzk*guz(16)+qyzk*guz(19)))
     &                 + uxk*(qxxi*gqxx(7)+qyyi*gqyy(7)+qzzi*gqzz(7)
     &              +2.0d0*(qxyi*gqxy(7)+qxzi*gqxz(7)+qyzi*gqyz(7)))
     &                 + uyk*(qxxi*gqxx(9)+qyyi*gqyy(9)+qzzi*gqzz(9)
     &              +2.0d0*(qxyi*gqxy(9)+qxzi*gqxz(9)+qyzi*gqyz(9)))
     &                 + uzk*(qxxi*gqxx(10)+qyyi*gqyy(10)+qzzi*gqzz(10)
     &              +2.0d0*(qxyi*gqxy(10)+qxzi*gqxz(10)+qyzi*gqyz(10)))
     &                 + qxxi*(qxxk*gqxx(13)+qyyk*gqxx(18)+qzzk*gqxx(20)
     &              +2.0d0*(qxyk*gqxx(15)+qxzk*gqxx(16)+qyzk*gqxx(19)))
     &                 + qyyi*(qxxk*gqyy(13)+qyyk*gqyy(18)+qzzk*gqyy(20)
     &              +2.0d0*(qxyk*gqyy(15)+qxzk*gqyy(16)+qyzk*gqyy(19)))
     &                 + qzzi*(qxxk*gqzz(13)+qyyk*gqzz(18)+qzzk*gqzz(20)
     &              +2.0d0*(qxyk*gqzz(15)+qxzk*gqzz(16)+qyzk*gqzz(19)))
     &        + 2.0d0*(qxyi*(qxxk*gqxy(13)+qyyk*gqxy(18)+qzzk*gqxy(20)
     &              +2.0d0*(qxyk*gqxy(15)+qxzk*gqxy(16)+qyzk*gqxy(19)))
     &                 + qxzi*(qxxk*gqxz(13)+qyyk*gqxz(18)+qzzk*gqxz(20)
     &              +2.0d0*(qxyk*gqxz(15)+qxzk*gqxz(16)+qyzk*gqxz(19)))
     &                 + qyzi*(qxxk*gqyz(13)+qyyk*gqyz(18)+qzzk*gqyz(20)
     &              +2.0d0*(qxyk*gqyz(15)+qxzk*gqyz(16)+qyzk*gqyz(19))))
                  dewkdz = ci*(uxk*gux(4)+uyk*guy(4)+uzk*guz(4))
     &                    -ck*(uxi*gc(7)+uyi*gc(9)+uzi*gc(10))
     &                 +ci*(qxxk*gqxx(4)+qyyk*gqyy(4)+qzzk*gqzz(4)
     &              +2.0d0*(qxyk*gqxy(4)+qxzk*gqxz(4)+qyzk*gqyz(4)))
     &                 +ck*(qxxi*gc(13)+qyyi*gc(18)+qzzi*gc(20)
     &              +2.0d0*(qxyi*gc(15)+qxzi*gc(16)+qyzi*gc(19)))
     &                 - uxi*(qxxk*gqxx(7)+qyyk*gqyy(7)+qzzk*gqzz(7)
     &              +2.0d0*(qxyk*gqxy(7)+qxzk*gqxz(7)+qyzk*gqyz(7)))
     &                 - uyi*(qxxk*gqxx(9)+qyyk*gqyy(9)+qzzk*gqzz(9)
     &              +2.0d0*(qxyk*gqxy(9)+qxzk*gqxz(9)+qyzk*gqyz(9)))
     &                 - uzi*(qxxk*gqxx(10)+qyyk*gqyy(10)+qzzk*gqzz(10)
     &              +2.0d0*(qxyk*gqxy(10)+qxzk*gqxz(10)+qyzk*gqyz(10)))
     &                 + uxk*(qxxi*gux(13)+qyyi*gux(18)+qzzi*gux(20)
     &              +2.0d0*(qxyi*gux(15)+qxzi*gux(16)+qyzi*gux(19)))
     &                 + uyk*(qxxi*guy(13)+qyyi*guy(18)+qzzi*guy(20)
     &              +2.0d0*(qxyi*guy(15)+qxzi*guy(16)+qyzi*guy(19)))
     &                 + uzk*(qxxi*guz(13)+qyyi*guz(18)+qzzi*guz(20)
     &              +2.0d0*(qxyi*guz(15)+qxzi*guz(16)+qyzi*guz(19)))
     &                 + qxxi*(qxxk*gqxx(13)+qyyk*gqyy(13)+qzzk*gqzz(13)
     &              +2.0d0*(qxyk*gqxy(13)+qxzk*gqxz(13)+qyzk*gqyz(13)))
     &                 + qyyi*(qxxk*gqxx(18)+qyyk*gqyy(18)+qzzk*gqzz(18)
     &              +2.0d0*(qxyk*gqxy(18)+qxzk*gqxz(18)+qyzk*gqyz(18)))
     &                 + qzzi*(qxxk*gqxx(20)+qyyk*gqyy(20)+qzzk*gqzz(20)
     &              +2.0d0*(qxyk*gqxy(20)+qxzk*gqxz(20)+qyzk*gqyz(20)))
     &        + 2.0d0*(qxyi*(qxxk*gqxx(15)+qyyk*gqyy(15)+qzzk*gqzz(15)
     &              +2.0d0*(qxyk*gqxy(15)+qxzk*gqxz(15)+qyzk*gqyz(15)))
     &                 + qxzi*(qxxk*gqxx(16)+qyyk*gqyy(16)+qzzk*gqzz(16)
     &              +2.0d0*(qxyk*gqxy(16)+qxzk*gqxz(16)+qyzk*gqyz(16)))
     &                 + qyzi*(qxxk*gqxx(19)+qyyk*gqyy(19)+qzzk*gqzz(19)
     &              +2.0d0*(qxyk*gqxy(19)+qxzk*gqxz(19)+qyzk*gqyz(19))))
                  dedz = desymdz + 0.5d0*(dewidz+dewkdz)
c
                  desymdr = ci * ck * gc(21)
     &                      - (uxi*(uxk*gux(22)+uyk*guy(22)+uzk*guz(22))
     &                        +uyi*(uxk*gux(23)+uyk*guy(23)+uzk*guz(23))
     &                       +uzi*(uxk*gux(24)+uyk*guy(24)+uzk*guz(24)))
                  dewidr = ci*(uxk*gc(22)+uyk*gc(23)+uzk*gc(24))
     &                    -ck*(uxi*gux(21)+uyi*guy(21)+uzi*guz(21))
     &                 +ci*(qxxk*gc(25)+qyyk*gc(28)+qzzk*gc(30)
     &              +2.0d0*(qxyk*gc(26)+qxzk*gc(27)+qyzk*gc(29)))
     &                 +ck*(qxxi*gqxx(21)+qyyi*gqyy(21)+qzzi*gqzz(21)
     &              +2.0d0*(qxyi*gqxy(21)+qxzi*gqxz(21)+qyzi*gqyz(21)))
     &                 - uxi*(qxxk*gux(25)+qyyk*gux(28)+qzzk*gux(30)
     &              +2.0d0*(qxyk*gux(26)+qxzk*gux(27)+qyzk*gux(29)))
     &                 - uyi*(qxxk*guy(25)+qyyk*guy(28)+qzzk*guy(30)
     &              +2.0d0*(qxyk*guy(26)+qxzk*guy(27)+qyzk*guy(29)))
     &                 - uzi*(qxxk*guz(25)+qyyk*guz(28)+qzzk*guz(30)
     &              +2.0d0*(qxyk*guz(26)+qxzk*guz(27)+qyzk*guz(29)))
     &                 + uxk*(qxxi*gqxx(22)+qyyi*gqyy(22)+qzzi*gqzz(22)
     &              +2.0d0*(qxyi*gqxy(22)+qxzi*gqxz(22)+qyzi*gqyz(22)))
     &                 + uyk*(qxxi*gqxx(23)+qyyi*gqyy(23)+qzzi*gqzz(23)
     &              +2.0d0*(qxyi*gqxy(23)+qxzi*gqxz(23)+qyzi*gqyz(23)))
     &                 + uzk*(qxxi*gqxx(24)+qyyi*gqyy(24)+qzzi*gqzz(24)
     &              +2.0d0*(qxyi*gqxy(24)+qxzi*gqxz(24)+qyzi*gqyz(24)))
     &                 + qxxi*(qxxk*gqxx(25)+qyyk*gqxx(28)+qzzk*gqxx(30)
     &              +2.0d0*(qxyk*gqxx(26)+qxzk*gqxx(27)+qyzk*gqxx(29)))
     &                 + qyyi*(qxxk*gqyy(25)+qyyk*gqyy(28)+qzzk*gqyy(30)
     &              +2.0d0*(qxyk*gqyy(26)+qxzk*gqyy(27)+qyzk*gqyy(29)))
     &                 + qzzi*(qxxk*gqzz(25)+qyyk*gqzz(28)+qzzk*gqzz(30)
     &              +2.0d0*(qxyk*gqzz(26)+qxzk*gqzz(27)+qyzk*gqzz(29)))
     &        + 2.0d0*(qxyi*(qxxk*gqxy(25)+qyyk*gqxy(28)+qzzk*gqxy(30)
     &              +2.0d0*(qxyk*gqxy(26)+qxzk*gqxy(27)+qyzk*gqxy(29)))
     &                 + qxzi*(qxxk*gqxz(25)+qyyk*gqxz(28)+qzzk*gqxz(30)
     &              +2.0d0*(qxyk*gqxz(26)+qxzk*gqxz(27)+qyzk*gqxz(29)))
     &                 + qyzi*(qxxk*gqyz(25)+qyyk*gqyz(28)+qzzk*gqyz(30)
     &              +2.0d0*(qxyk*gqyz(26)+qxzk*gqyz(27)+qyzk*gqyz(29))))
                  dewkdr = ci*(uxk*gux(21)+uyk*guy(21)+uzk*guz(21))
     &                    -ck*(uxi*gc(22)+uyi*gc(23)+uzi*gc(24))
     &                 +ci*(qxxk*gqxx(21)+qyyk*gqyy(21)+qzzk*gqzz(21)
     &              +2.0d0*(qxyk*gqxy(21)+qxzk*gqxz(21)+qyzk*gqyz(21)))
     &                 +ck*(qxxi*gc(25)+qyyi*gc(28)+qzzi*gc(30)
     &              +2.0d0*(qxyi*gc(26)+qxzi*gc(27)+qyzi*gc(29)))
     &                 - uxi*(qxxk*gqxx(22)+qyyk*gqyy(22)+qzzk*gqzz(22)
     &              +2.0d0*(qxyk*gqxy(22)+qxzk*gqxz(22)+qyzk*gqyz(22)))
     &                 - uyi*(qxxk*gqxx(23)+qyyk*gqyy(23)+qzzk*gqzz(23)
     &              +2.0d0*(qxyk*gqxy(23)+qxzk*gqxz(23)+qyzk*gqyz(23)))
     &                 - uzi*(qxxk*gqxx(24)+qyyk*gqyy(24)+qzzk*gqzz(24)
     &              +2.0d0*(qxyk*gqxy(24)+qxzk*gqxz(24)+qyzk*gqyz(24)))
     &                 + uxk*(qxxi*gux(25)+qyyi*gux(28)+qzzi*gux(30)
     &              +2.0d0*(qxyi*gux(26)+qxzi*gux(27)+qyzi*gux(29)))
     &                 + uyk*(qxxi*guy(25)+qyyi*guy(28)+qzzi*guy(30)
     &              +2.0d0*(qxyi*guy(26)+qxzi*guy(27)+qyzi*guy(29)))
     &                 + uzk*(qxxi*guz(25)+qyyi*guz(28)+qzzi*guz(30)
     &              +2.0d0*(qxyi*guz(26)+qxzi*guz(27)+qyzi*guz(29)))
     &                 + qxxi*(qxxk*gqxx(25)+qyyk*gqyy(25)+qzzk*gqzz(25)
     &              +2.0d0*(qxyk*gqxy(25)+qxzk*gqxz(25)+qyzk*gqyz(25)))
     &                 + qyyi*(qxxk*gqxx(28)+qyyk*gqyy(28)+qzzk*gqzz(28)
     &              +2.0d0*(qxyk*gqxy(28)+qxzk*gqxz(28)+qyzk*gqyz(28)))
     &                 + qzzi*(qxxk*gqxx(30)+qyyk*gqyy(30)+qzzk*gqzz(30)
     &              +2.0d0*(qxyk*gqxy(30)+qxzk*gqxz(30)+qyzk*gqyz(30)))
     &        + 2.0d0*(qxyi*(qxxk*gqxx(26)+qyyk*gqyy(26)+qzzk*gqzz(26)
     &              +2.0d0*(qxyk*gqxy(26)+qxzk*gqxz(26)+qyzk*gqyz(26)))
     &                 + qxzi*(qxxk*gqxx(27)+qyyk*gqyy(27)+qzzk*gqzz(27)
     &              +2.0d0*(qxyk*gqxy(27)+qxzk*gqxz(27)+qyzk*gqyz(27)))
     &                 + qyzi*(qxxk*gqxx(29)+qyyk*gqyy(29)+qzzk*gqzz(29)
     &              +2.0d0*(qxyk*gqxy(29)+qxzk*gqxz(29)+qyzk*gqyz(29))))
                  dsumdr = desymdr + 0.5d0*(dewidr+dewkdr)
                  drbi = rbk*dsumdr
                  drbk = rbi*dsumdr
c
c     torque on permanent dipoles due to permanent reaction field
c
                  if (i .ne. k) then
                     fid(1) = uxk*gux(2) + uyk*gux(3) + uzk*gux(4)
     &          + 0.5d0*(ck*gux(1)+qxxk*gux(5)+qyyk*gux(8)+qzzk*gux(10)
     &                +2.0d0*(qxyk*gux(6)+qxzk*gux(7)+qyzk*gux(9))
     &                +ck*gc(2)+qxxk*gqxx(2)+qyyk*gqyy(2)+qzzk*gqzz(2)
     &                +2.0d0*(qxyk*gqxy(2)+qxzk*gqxz(2)+qyzk*gqyz(2)))
                     fid(2) = uxk*guy(2) + uyk*guy(3) + uzk*guy(4)
     &          + 0.5d0*(ck*guy(1)+qxxk*guy(5)+qyyk*guy(8)+qzzk*guy(10)
     &                +2.0d0*(qxyk*guy(6)+qxzk*guy(7)+qyzk*guy(9))
     &                +ck*gc(3)+qxxk*gqxx(3)+qyyk*gqyy(3)+qzzk*gqzz(3)
     &                +2.0d0*(qxyk*gqxy(3)+qxzk*gqxz(3)+qyzk*gqyz(3)))
                     fid(3) = uxk*guz(2) + uyk*guz(3) + uzk*guz(4)
     &          + 0.5d0*(ck*guz(1)+qxxk*guz(5)+qyyk*guz(8)+qzzk*guz(10)
     &                +2.0d0*(qxyk*guz(6)+qxzk*guz(7)+qyzk*guz(9))
     &                +ck*gc(4)+qxxk*gqxx(4)+qyyk*gqyy(4)+qzzk*gqzz(4)
     &                +2.0d0*(qxyk*gqxy(4)+qxzk*gqxz(4)+qyzk*gqyz(4)))
                     fkd(1) = uxi*gux(2) + uyi*gux(3) + uzi*gux(4)
     &          - 0.5d0*(ci*gux(1)+qxxi*gux(5)+qyyi*gux(8)+qzzi*gux(10)
     &                +2.0d0*(qxyi*gux(6)+qxzi*gux(7)+qyzi*gux(9))
     &                +ci*gc(2)+qxxi*gqxx(2)+qyyi*gqyy(2)+qzzi*gqzz(2)
     &                +2.0d0*(qxyi*gqxy(2)+qxzi*gqxz(2)+qyzi*gqyz(2)))
                     fkd(2) = uxi*guy(2) + uyi*guy(3) + uzi*guy(4)
     &          - 0.5d0*(ci*guy(1)+qxxi*guy(5)+qyyi*guy(8)+qzzi*guy(10)
     &                +2.0d0*(qxyi*guy(6)+qxzi*guy(7)+qyzi*guy(9))
     &                +ci*gc(3)+qxxi*gqxx(3)+qyyi*gqyy(3)+qzzi*gqzz(3)
     &                +2.0d0*(qxyi*gqxy(3)+qxzi*gqxz(3)+qyzi*gqyz(3)))
                     fkd(3) = uxi*guz(2) + uyi*guz(3) + uzi*guz(4)
     &          - 0.5d0*(ci*guz(1)+qxxi*guz(5)+qyyi*guz(8)+qzzi*guz(10)
     &                +2.0d0*(qxyi*guz(6)+qxzi*guz(7)+qyzi*guz(9))
     &                +ci*gc(4)+qxxi*gqxx(4)+qyyi*gqyy(4)+qzzi*gqzz(4)
     &                +2.0d0*(qxyi*gqxy(4)+qxzi*gqxz(4)+qyzi*gqyz(4)))
                     trq(1,i) = trq(1,i) + uyi*fid(3) - uzi*fid(2)
                     trq(2,i) = trq(2,i) + uzi*fid(1) - uxi*fid(3)
                     trq(3,i) = trq(3,i) + uxi*fid(2) - uyi*fid(1)
                     trq(1,k) = trq(1,k) + uyk*fkd(3) - uzk*fkd(2)
                     trq(2,k) = trq(2,k) + uzk*fkd(1) - uxk*fkd(3)
                     trq(3,k) = trq(3,k) + uxk*fkd(2) - uyk*fkd(1)
c
c     torque on quadrupoles due to permanent reaction field gradient
c
                     fidg(1,1) =
     &          - 0.5d0*(ck*gqxx(1)+uxk*gqxx(2)+uyk*gqxx(3)+uzk*gqxx(4)
     &                +qxxk*gqxx(5)+qyyk*gqxx(8)+qzzk*gqxx(10)
     &                +2.0d0*(qxyk*gqxx(6)+qxzk*gqxx(7)+qyzk*gqxx(9))
     &                +ck*gc(5)+uxk*gux(5)+uyk*guy(5)+uzk*guz(5)
     &                +qxxk*gqxx(5)+qyyk*gqyy(5)+qzzk*gqzz(5)
     &                +2.0d0*(qxyk*gqxy(5)+qxzk*gqxz(5)+qyzk*gqyz(5)))
                     fidg(1,2) =
     &          - 0.5d0*(ck*gqxy(1)+uxk*gqxy(2)+uyk*gqxy(3)+uzk*gqxy(4)
     &                +qxxk*gqxy(5)+qyyk*gqxy(8)+qzzk*gqxy(10)
     &                +2.0d0*(qxyk*gqxy(6)+qxzk*gqxy(7)+qyzk*gqxy(9))
     &                +ck*gc(6)+uxk*gux(6)+uyk*guy(6)+uzk*guz(6)
     &                +qxxk*gqxx(6)+qyyk*gqyy(6)+qzzk*gqzz(6)
     &                +2.0d0*(qxyk*gqxy(6)+qxzk*gqxz(6)+qyzk*gqyz(6)))
                     fidg(1,3) =
     &          - 0.5d0*(ck*gqxz(1)+uxk*gqxz(2)+uyk*gqxz(3)+uzk*gqxz(4)
     &                +qxxk*gqxz(5)+qyyk*gqxz(8)+qzzk*gqxz(10)
     &                +2.0d0*(qxyk*gqxz(6)+qxzk*gqxz(7)+qyzk*gqxz(9))
     &                +ck*gc(7)+uxk*gux(7)+uyk*guy(7)+uzk*guz(7)
     &                +qxxk*gqxx(7)+qyyk*gqyy(7)+qzzk*gqzz(7)
     &                +2.0d0*(qxyk*gqxy(7)+qxzk*gqxz(7)+qyzk*gqyz(7)))
                     fidg(2,2) =
     &          - 0.5d0*(ck*gqyy(1)+uxk*gqyy(2)+uyk*gqyy(3)+uzk*gqyy(4)
     &                +qxxk*gqyy(5)+qyyk*gqyy(8)+qzzk*gqyy(10)
     &                +2.0d0*(qxyk*gqyy(6)+qxzk*gqyy(7)+qyzk*gqyy(9))
     &                +ck*gc(8)+uxk*gux(8)+uyk*guy(8)+uzk*guz(8)
     &                +qxxk*gqxx(8)+qyyk*gqyy(8)+qzzk*gqzz(8)
     &                +2.0d0*(qxyk*gqxy(8)+qxzk*gqxz(8)+qyzk*gqyz(8)))
                     fidg(2,3) =
     &          - 0.5d0*(ck*gqyz(1)+uxk*gqyz(2)+uyk*gqyz(3)+uzk*gqyz(4)
     &                +qxxk*gqyz(5)+qyyk*gqyz(8)+qzzk*gqyz(10)
     &                +2.0d0*(qxyk*gqyz(6)+qxzk*gqyz(7)+qyzk*gqyz(9))
     &                +ck*gc(9)+uxk*gux(9)+uyk*guy(9)+uzk*guz(9)
     &                +qxxk*gqxx(9)+qyyk*gqyy(9)+qzzk*gqzz(9)
     &                +2.0d0*(qxyk*gqxy(9)+qxzk*gqxz(9)+qyzk*gqyz(9)))
                     fidg(3,3) =
     &          - 0.5d0*(ck*gqzz(1)+uxk*gqzz(2)+uyk*gqzz(3)+uzk*gqzz(4)
     &                +qxxk*gqzz(5)+qyyk*gqzz(8)+qzzk*gqzz(10)
     &                +2.0d0*(qxyk*gqzz(6)+qxzk*gqzz(7)+qyzk*gqzz(9))
     &                +ck*gc(10)+uxk*gux(10)+uyk*guy(10)+uzk*guz(10)
     &                +qxxk*gqxx(10)+qyyk*gqyy(10)+qzzk*gqzz(10)
     &             +2.0d0*(qxyk*gqxy(10)+qxzk*gqxz(10)+qyzk*gqyz(10)))
                     fidg(2,1) = fidg(1,2)
                     fidg(3,1) = fidg(1,3)
                     fidg(3,2) = fidg(2,3)
                     fkdg(1,1) =
     &          - 0.5d0*(ci*gqxx(1)-uxi*gqxx(2)-uyi*gqxx(3)-uzi *gqxx(4)
     &                +qxxi*gqxx(5)+qyyi*gqxx(8)+qzzi*gqxx(10)
     &                +2.0d0*(qxyi*gqxx(6)+qxzi*gqxx(7)+qyzi*gqxx(9))
     &                +ci*gc(5)-uxi*gux(5)-uyi*guy(5)-uzi*guz(5)
     &                +qxxi*gqxx(5)+qyyi*gqyy(5)+qzzi*gqzz(5)
     &                +2.0d0*(qxyi*gqxy(5)+qxzi*gqxz(5)+qyzi*gqyz(5)))
                     fkdg(1,2) =
     &          - 0.5d0*(ci*gqxy(1)-uxi*gqxy(2)-uyi*gqxy(3)-uzi*gqxy(4)
     &                +qxxi*gqxy(5)+qyyi*gqxy(8)+qzzi*gqxy(10)
     &                +2.0d0*(qxyi*gqxy(6)+qxzi*gqxy(7)+qyzi*gqxy(9))
     &                +ci*gc(6)-uxi*gux(6)-uyi*guy(6)-uzi*guz(6)
     &                +qxxi*gqxx(6)+qyyi*gqyy(6)+qzzi*gqzz(6)
     &                +2.0d0*(qxyi*gqxy(6)+qxzi*gqxz(6)+qyzi*gqyz(6)))
                     fkdg(1,3) =
     &          - 0.5d0*(ci*gqxz(1)-uxi*gqxz(2)-uyi*gqxz(3)-uzi*gqxz(4)
     &                +qxxi*gqxz(5)+qyyi*gqxz(8)+qzzi*gqxz(10)
     &                +2.0d0*(qxyi*gqxz(6)+qxzi*gqxz(7)+qyzi*gqxz(9))
     &                +ci*gc(7)-uxi*gux(7)-uyi*guy(7)-uzi*guz(7)
     &                +qxxi*gqxx(7)+qyyi*gqyy(7)+qzzi*gqzz(7)
     &                +2.0d0*(qxyi*gqxy(7)+qxzi*gqxz(7)+qyzi*gqyz(7)))
                     fkdg(2,2) =
     &          - 0.5d0*(ci*gqyy(1)-uxi*gqyy(2)-uyi*gqyy(3)-uzi*gqyy(4)
     &                +qxxi*gqyy(5)+qyyi*gqyy(8)+qzzi*gqyy(10)
     &                +2.0d0*(qxyi*gqyy(6)+qxzi*gqyy(7)+qyzi*gqyy(9))
     &                +ci*gc(8)-uxi*gux(8)-uyi*guy(8)-uzi*guz(8)
     &                +qxxi*gqxx(8)+qyyi*gqyy(8)+qzzi*gqzz(8)
     &                +2.0d0*(qxyi*gqxy(8)+qxzi*gqxz(8)+qyzi*gqyz(8)))
                     fkdg(2,3) =
     &          - 0.5d0*(ci*gqyz(1)-uxi*gqyz(2)-uyi*gqyz(3)-uzi*gqyz(4)
     &                +qxxi*gqyz(5)+qyyi*gqyz(8)+qzzi*gqyz(10)
     &                +2.0d0*(qxyi*gqyz(6)+qxzi*gqyz(7)+qyzi*gqyz(9))
     &                +ci*gc(9)-uxi*gux(9)-uyi*guy(9)-uzi*guz(9)
     &                +qxxi*gqxx(9)+qyyi*gqyy(9)+qzzi*gqzz(9)
     &                +2.0d0*(qxyi*gqxy(9)+qxzi*gqxz(9)+qyzi*gqyz(9)))
                     fkdg(3,3) =
     &          - 0.5d0*(ci*gqzz(1)-uxi*gqzz(2)-uyi*gqzz(3)-uzi*gqzz(4)
     &                +qxxi*gqzz(5)+qyyi*gqzz(8)+qzzi*gqzz(10)
     &                +2.0d0*(qxyi*gqzz(6)+qxzi*gqzz(7)+qyzi*gqzz(9))
     &                +ci*gc(10)-uxi*gux(10)-uyi*guy(10)-uzi*guz(10)
     &                +qxxi*gqxx(10)+qyyi*gqyy(10)+qzzi*gqzz(10)
     &              +2.0d0*(qxyi*gqxy(10)+qxzi*gqxz(10)+qyzi*gqyz(10)))
                     fkdg(2,1) = fkdg(1,2)
                     fkdg(3,1) = fkdg(1,3)
                     fkdg(3,2) = fkdg(2,3)
                     trq(1,i) = trq(1,i) + 2.0d0*
     &                    (qxyi*fidg(1,3)+qyyi*fidg(2,3)+qyzi*fidg(3,3)
     &                    -qxzi*fidg(1,2)-qyzi*fidg(2,2)-qzzi*fidg(3,2))
                     trq(2,i) = trq(2,i) + 2.0d0*
     &                    (qxzi*fidg(1,1)+qyzi*fidg(2,1)+qzzi*fidg(3,1)
     &                    -qxxi*fidg(1,3)-qxyi*fidg(2,3)-qxzi*fidg(3,3))
                     trq(3,i) = trq(3,i) + 2.0d0*
     &                    (qxxi*fidg(1,2)+qxyi*fidg(2,2)+qxzi*fidg(3,2)
     &                    -qxyi*fidg(1,1)-qyyi*fidg(2,1)-qyzi*fidg(3,1))
                     trq(1,k) = trq(1,k) + 2.0d0*
     &                    (qxyk*fkdg(1,3)+qyyk*fkdg(2,3)+qyzk*fkdg(3,3)
     &                    -qxzk*fkdg(1,2)-qyzk*fkdg(2,2)-qzzk*fkdg(3,2))
                     trq(2,k) = trq(2,k) + 2.0d0*
     &                    (qxzk*fkdg(1,1)+qyzk*fkdg(2,1)+qzzk*fkdg(3,1)
     &                    -qxxk*fkdg(1,3)-qxyk*fkdg(2,3)-qxzk*fkdg(3,3))
                     trq(3,k) = trq(3,k) + 2.0d0*
     &                    (qxxk*fkdg(1,2)+qxyk*fkdg(2,2)+qxzk*fkdg(3,2)
     &                    -qxyk*fkdg(1,1)-qyyk*fkdg(2,1)-qyzk*fkdg(3,1))
                  end if
c
c     electrostatic solvation energy of the permanent multipoles in
c     the GK reaction potential of the induced dipoles
c
                  esymi = -uxi*(dxk*gux(2)+dyk*guy(2)+dzk*guz(2))
     &                   - uyi*(dxk*gux(3)+dyk*guy(3)+dzk*guz(3))
     &                   - uzi*(dxk*gux(4)+dyk*guy(4)+dzk*guz(4))
     &                   - uxk*(dxi*gux(2)+dyi*guy(2)+dzi*guz(2))
     &                   - uyk*(dxi*gux(3)+dyi*guy(3)+dzi*guz(3))
     &                   - uzk*(dxi*gux(4)+dyi*guy(4)+dzi*guz(4))
                  ewii = ci*(dxk*gc(2)+dyk*gc(3)+dzk*gc(4))
     &                 - ck*(dxi*gux(1)+dyi*guy(1)+dzi*guz(1))
     &                 - dxi*(qxxk*gux(5)+qyyk*gux(8)+qzzk*gux(10)
     &                +2.0d0*(qxyk*gux(6)+qxzk*gux(7)+qyzk*gux(9)))
     &                 - dyi*(qxxk*guy(5)+qyyk*guy(8)+qzzk*guy(10)
     &                +2.0d0*(qxyk*guy(6)+qxzk*guy(7)+qyzk*guy(9)))
     &                 - dzi*(qxxk*guz(5)+qyyk*guz(8)+qzzk*guz(10)
     &                +2.0d0*(qxyk*guz(6)+qxzk*guz(7)+qyzk*guz(9)))
     &                 + dxk*(qxxi*gqxx(2)+qyyi*gqyy(2)+qzzi*gqzz(2)
     &                +2.0d0*(qxyi*gqxy(2)+qxzi*gqxz(2)+qyzi*gqyz(2)))
     &                 + dyk*(qxxi*gqxx(3)+qyyi*gqyy(3)+qzzi*gqzz(3)
     &                +2.0d0*(qxyi*gqxy(3)+qxzi*gqxz(3)+qyzi*gqyz(3)))
     &                 + dzk*(qxxi*gqxx(4)+qyyi*gqyy(4)+qzzi*gqzz(4)
     &                +2.0d0*(qxyi*gqxy(4)+qxzi*gqxz(4)+qyzi*gqyz(4)))
                  ewki = ci*(dxk*gux(1)+dyk*guy(1)+dzk*guz(1))
     &                 - ck*(dxi*gc(2)+dyi*gc(3)+dzi*gc(4))
     &                 - dxi*(qxxk*gqxx(2)+qyyk*gqyy(2)+qzzk*gqzz(2)
     &                +2.0d0*(qxyk*gqxy(2)+qxzk*gqxz(2)+qyzk*gqyz(2)))
     &                 - dyi*(qxxk*gqxx(3)+qyyk*gqyy(3)+qzzk*gqzz(3)
     &                +2.0d0*(qxyk*gqxy(3)+qxzk*gqxz(3)+qyzk*gqyz(3)))
     &                 - dzi*(qxxk*gqxx(4)+qyyk*gqyy(4)+qzzk*gqzz(4)
     &                +2.0d0*(qxyk*gqxy(4)+qxzk*gqxz(4)+qyzk*gqyz(4)))
     &                 + dxk*(qxxi*gux(5)+qyyi*gux(8)+qzzi*gux(10)
     &                +2.0d0*(qxyi*gux(6)+qxzi*gux(7)+qyzi*gux(9)))
     &                 + dyk*(qxxi*guy(5)+qyyi*guy(8)+qzzi*guy(10)
     &                +2.0d0*(qxyi*guy(6)+qxzi*guy(7)+qyzi*guy(9)))
     &                 + dzk*(qxxi*guz(5)+qyyi*guz(8)+qzzi*guz(10)
     &                +2.0d0*(qxyi*guz(6)+qxzi*guz(7)+qyzi*guz(9)))
c
c     electrostatic solvation free energy gradient of the permanent
c     multipoles in the reaction potential of the induced dipoles
c
                  dpsymdx = -uxi*(sxk*gux(5)+syk*guy(5)+szk*guz(5))
     &                     - uyi*(sxk*gux(6)+syk*guy(6)+szk*guz(6))
     &                     - uzi*(sxk*gux(7)+syk*guy(7)+szk*guz(7))
     &                     - uxk*(sxi*gux(5)+syi*guy(5)+szi*guz(5))
     &                     - uyk*(sxi*gux(6)+syi*guy(6)+szi*guz(6))
     &                     - uzk*(sxi*gux(7)+syi*guy(7)+szi*guz(7))
                  dpwidx = ci*(sxk*gc(5)+syk*gc(6)+szk*gc(7))
     &                   - ck*(sxi*gux(2)+syi*guy(2)+szi*guz(2))
     &                   - sxi*(qxxk*gux(11)+qyyk*gux(14)+qzzk*gux(16)
     &                +2.0d0*(qxyk*gux(12)+qxzk*gux(13)+qyzk*gux(15)))
     &                   - syi*(qxxk*guy(11)+qyyk*guy(14)+qzzk*guy(16)
     &                +2.0d0*(qxyk*guy(12)+qxzk*guy(13)+qyzk*guy(15)))
     &                   - szi*(qxxk*guz(11)+qyyk*guz(14)+qzzk*guz(16)
     &                +2.0d0*(qxyk*guz(12)+qxzk*guz(13)+qyzk*guz(15)))
     &                   + sxk*(qxxi*gqxx(5)+qyyi*gqyy(5)+qzzi*gqzz(5)
     &                +2.0d0*(qxyi*gqxy(5)+qxzi*gqxz(5)+qyzi*gqyz(5)))
     &                   + syk*(qxxi*gqxx(6)+qyyi*gqyy(6)+qzzi*gqzz(6)
     &                +2.0d0*(qxyi*gqxy(6)+qxzi*gqxz(6)+qyzi*gqyz(6)))
     &                   + szk*(qxxi*gqxx(7)+qyyi*gqyy(7)+qzzi*gqzz(7)
     &                +2.0d0*(qxyi*gqxy(7)+qxzi*gqxz(7)+qyzi*gqyz(7)))
                  dpwkdx = ci*(sxk*gux(2)+syk*guy(2)+szk*guz(2))
     &                   - ck*(sxi*gc(5)+syi*gc(6)+szi*gc(7))
     &                   - sxi*(qxxk*gqxx(5)+qyyk*gqyy(5)+qzzk*gqzz(5)
     &                +2.0d0*(qxyk*gqxy(5)+qxzk*gqxz(5)+qyzk*gqyz(5)))
     &                   - syi*(qxxk*gqxx(6)+qyyk*gqyy(6)+qzzk*gqzz(6)
     &                +2.0d0*(qxyk*gqxy(6)+qxzk*gqxz(6)+qyzk*gqyz(6)))
     &                   - szi*(qxxk*gqxx(7)+qyyk*gqyy(7)+qzzk*gqzz(7)
     &                +2.0d0*(qxyk*gqxy(7)+qxzk*gqxz(7)+qyzk*gqyz(7)))
     &                   + sxk*(qxxi*gux(11)+qyyi*gux(14)+qzzi*gux(16)
     &                +2.0d0*(qxyi*gux(12)+qxzi*gux(13)+qyzi*gux(15)))
     &                   + syk*(qxxi*guy(11)+qyyi*guy(14)+qzzi*guy(16)
     &                +2.0d0*(qxyi*guy(12)+qxzi*guy(13)+qyzi*guy(15)))
     &                   + szk*(qxxi*guz(11)+qyyi*guz(14)+qzzi*guz(16)
     &                +2.0d0*(qxyi*guz(12)+qxzi*guz(13)+qyzi*guz(15)))
                  dpdx = 0.5d0 * (dpsymdx + 0.5d0*(dpwidx + dpwkdx))
                  dpsymdy = -uxi*(sxk*gux(6)+syk*guy(6)+szk*guz(6))
     &                     - uyi*(sxk*gux(8)+syk*guy(8)+szk*guz(8))
     &                     - uzi*(sxk*gux(9)+syk*guy(9)+szk*guz(9))
     &                     - uxk*(sxi*gux(6)+syi*guy(6)+szi*guz(6))
     &                     - uyk*(sxi*gux(8)+syi*guy(8)+szi*guz(8))
     &                     - uzk*(sxi*gux(9)+syi*guy(9)+szi*guz(9))
                  dpwidy = ci*(sxk*gc(6)+syk*gc(8)+szk*gc(9))
     &                   - ck*(sxi*gux(3)+syi*guy(3)+szi*guz(3))
     &                   - sxi*(qxxk*gux(12)+qyyk*gux(17)+qzzk*gux(19)
     &                +2.0d0*(qxyk*gux(14)+qxzk*gux(15)+qyzk*gux(18)))
     &                   - syi*(qxxk*guy(12)+qyyk*guy(17)+qzzk*guy(19)
     &                +2.0d0*(qxyk*guy(14)+qxzk*guy(15)+qyzk*guy(18)))
     &                   - szi*(qxxk*guz(12)+qyyk*guz(17)+qzzk*guz(19)
     &                +2.0d0*(qxyk*guz(14)+qxzk*guz(15)+qyzk*guz(18)))
     &                   + sxk*(qxxi*gqxx(6)+qyyi*gqyy(6)+qzzi*gqzz(6)
     &                +2.0d0*(qxyi*gqxy(6)+qxzi*gqxz(6)+qyzi*gqyz(6)))
     &                   + syk*(qxxi*gqxx(8)+qyyi*gqyy(8)+qzzi*gqzz(8)
     &                +2.0d0*(qxyi*gqxy(8)+qxzi*gqxz(8)+qyzi*gqyz(8)))
     &                   + szk*(qxxi*gqxx(9)+qyyi*gqyy(9)+qzzi*gqzz(9)
     &                +2.0d0*(qxyi*gqxy(9)+qxzi*gqxz(9)+qyzi*gqyz(9)))
                  dpwkdy = ci*(sxk*gux(3)+syk*guy(3)+szk*guz(3))
     &                   - ck*(sxi*gc(6)+syi*gc(8)+szi*gc(9))
     &                   - sxi*(qxxk*gqxx(6)+qyyk*gqyy(6)+qzzk*gqzz(6)
     &                +2.0d0*(qxyk*gqxy(6)+qxzk*gqxz(6)+qyzk*gqyz(6)))
     &                   - syi*(qxxk*gqxx(8)+qyyk*gqyy(8)+qzzk*gqzz(8)
     &                +2.0d0*(qxyk*gqxy(8)+qxzk*gqxz(8)+qyzk*gqyz(8)))
     &                   - szi*(qxxk*gqxx(9)+qyyk*gqyy(9)+qzzk*gqzz(9)
     &                +2.0d0*(qxyk*gqxy(9)+qxzk*gqxz(9)+qyzk*gqyz(9)))
     &                   + sxk*(qxxi*gux(12)+qyyi*gux(17)+qzzi*gux(19)
     &                +2.0d0*(qxyi*gux(14)+qxzi*gux(15)+qyzi*gux(18)))
     &                   + syk*(qxxi*guy(12)+qyyi*guy(17)+qzzi*guy(19)
     &                +2.0d0*(qxyi*guy(14)+qxzi*guy(15)+qyzi*guy(18)))
     &                   + szk*(qxxi*guz(12)+qyyi*guz(17)+qzzi*guz(19)
     &                +2.0d0*(qxyi*guz(14)+qxzi*guz(15)+qyzi*guz(18)))
                  dpdy = 0.5d0 * (dpsymdy + 0.5d0*(dpwidy + dpwkdy))
                  dpsymdz = -uxi*(sxk*gux(7)+syk*guy(7)+szk*guz(7))
     &                     - uyi*(sxk*gux(9)+syk*guy(9)+szk*guz(9))
     &                     - uzi*(sxk*gux(10)+syk*guy(10)+szk*guz(10))
     &                     - uxk*(sxi*gux(7)+syi*guy(7)+szi*guz(7))
     &                     - uyk*(sxi*gux(9)+syi*guy(9)+szi*guz(9))
     &                     - uzk*(sxi*gux(10)+syi*guy(10)+szi*guz(10))
                  dpwidz = ci*(sxk*gc(7)+syk*gc(9)+szk*gc(10))
     &                   - ck*(sxi*gux(4)+syi*guy(4)+szi*guz(4))
     &                   - sxi*(qxxk*gux(13)+qyyk*gux(18)+qzzk*gux(20)
     &                +2.0d0*(qxyk*gux(15)+qxzk*gux(16)+qyzk*gux(19)))
     &                   - syi*(qxxk*guy(13)+qyyk*guy(18)+qzzk*guy(20)
     &                +2.0d0*(qxyk*guy(15)+qxzk*guy(16)+qyzk*guy(19)))
     &                   - szi*(qxxk*guz(13)+qyyk*guz(18)+qzzk*guz(20)
     &                +2.0d0*(qxyk*guz(15)+qxzk*guz(16)+qyzk*guz(19)))
     &                   + sxk*(qxxi*gqxx(7)+qyyi*gqyy(7)+qzzi*gqzz(7)
     &                +2.0d0*(qxyi*gqxy(7)+qxzi*gqxz(7)+qyzi*gqyz(7)))
     &                   + syk*(qxxi*gqxx(9)+qyyi*gqyy(9)+qzzi*gqzz(9)
     &                +2.0d0*(qxyi*gqxy(9)+qxzi*gqxz(9)+qyzi*gqyz(9)))
     &                  + szk*(qxxi*gqxx(10)+qyyi*gqyy(10)+qzzi*gqzz(10)
     &               +2.0d0*(qxyi*gqxy(10)+qxzi*gqxz(10)+qyzi*gqyz(10)))
                  dpwkdz = ci*(sxk*gux(4)+syk*guy(4)+szk*guz(4))
     &                   - ck*(sxi*gc(7)+syi*gc(9)+szi*gc(10))
     &                   - sxi*(qxxk*gqxx(7)+qyyk*gqyy(7)+qzzk*gqzz(7)
     &                +2.0d0*(qxyk*gqxy(7)+qxzk*gqxz(7)+qyzk*gqyz(7)))
     &                   - syi*(qxxk*gqxx(9)+qyyk*gqyy(9)+qzzk*gqzz(9)
     &                +2.0d0*(qxyk*gqxy(9)+qxzk*gqxz(9)+qyzk*gqyz(9)))
     &                  - szi*(qxxk*gqxx(10)+qyyk*gqyy(10)+qzzk*gqzz(10)
     &               +2.0d0*(qxyk*gqxy(10)+qxzk*gqxz(10)+qyzk*gqyz(10)))
     &                   + sxk*(qxxi*gux(13)+qyyi*gux(18)+qzzi*gux(20)
     &                +2.0d0*(qxyi*gux(15)+qxzi*gux(16)+qyzi*gux(19)))
     &                   + syk*(qxxi*guy(13)+qyyi*guy(18)+qzzi*guy(20)
     &                +2.0d0*(qxyi*guy(15)+qxzi*guy(16)+qyzi*guy(19)))
     &                   + szk*(qxxi*guz(13)+qyyi*guz(18)+qzzi*guz(20)
     &                +2.0d0*(qxyi*guz(15)+qxzi*guz(16)+qyzi*guz(19)))
                  dpdz = 0.5d0 * (dpsymdz + 0.5d0*(dpwidz+dpwkdz))
c
c     effective radii chain rule terms for the electrostatic solvation
c     free energy gradient of the permanent multipoles in the reaction
c     potential of the induced dipoles
c
                  dsymdr = -uxi*(sxk*gux(22)+syk*guy(22)+szk*guz(22))
     &                    - uyi*(sxk*gux(23)+syk*guy(23)+szk*guz(23))
     &                    - uzi*(sxk*gux(24)+syk*guy(24)+szk*guz(24))
     &                    - uxk*(sxi*gux(22)+syi*guy(22)+szi*guz(22))
     &                    - uyk*(sxi*gux(23)+syi*guy(23)+szi*guz(23))
     &                    - uzk*(sxi*gux(24)+syi*guy(24)+szi*guz(24))
                  dwipdr = ci*(sxk*gc(22)+syk*gc(23)+szk*gc(24))
     &                   - ck*(sxi*gux(21)+syi*guy(21)+szi*guz(21))
     &                - sxi*(qxxk*gux(25)+qyyk*gux(28)+qzzk*gux(30)
     &               +2.0d0*(qxyk*gux(26)+qxzk*gux(27)+qyzk*gux(29)))
     &                - syi*(qxxk*guy(25)+qyyk*guy(28)+qzzk*guy(30)
     &               +2.0d0*(qxyk*guy(26)+qxzk*guy(27)+qyzk*guy(29)))
     &                - szi*(qxxk*guz(25)+qyyk*guz(28)+qzzk*guz(30)
     &               +2.0d0*(qxyk*guz(26)+qxzk*guz(27)+qyzk*guz(29)))
     &                + sxk*(qxxi*gqxx(22)+qyyi*gqyy(22)+qzzi*gqzz(22)
     &               +2.0d0*(qxyi*gqxy(22)+qxzi*gqxz(22)+qyzi*gqyz(22)))
     &                + syk*(qxxi*gqxx(23)+qyyi*gqyy(23)+qzzi*gqzz(23)
     &               +2.0d0*(qxyi*gqxy(23)+qxzi*gqxz(23)+qyzi*gqyz(23)))
     &                + szk*(qxxi*gqxx(24)+qyyi*gqyy(24)+qzzi*gqzz(24)
     &               +2.0d0*(qxyi*gqxy(24)+qxzi*gqxz(24)+qyzi*gqyz(24)))
                  dwkpdr = ci*(sxk*gux(21)+syk*guy(21)+szk*guz(21))
     &                   - ck*(sxi*gc(22)+syi*gc(23)+szi*gc(24))
     &                - sxi*(qxxk*gqxx(22)+qyyk*gqyy(22)+qzzk*gqzz(22)
     &               +2.0d0*(qxyk*gqxy(22)+qxzk*gqxz(22)+qyzk*gqyz(22)))
     &                - syi*(qxxk*gqxx(23)+qyyk*gqyy(23)+qzzk*gqzz(23)
     &               +2.0d0*(qxyk*gqxy(23)+qxzk*gqxz(23)+qyzk*gqyz(23)))
     &                - szi*(qxxk*gqxx(24)+qyyk*gqyy(24)+qzzk*gqzz(24)
     &               +2.0d0*(qxyk*gqxy(24)+qxzk*gqxz(24)+qyzk*gqyz(24)))
     &                + sxk*(qxxi*gux(25)+qyyi*gux(28)+qzzi*gux(30)
     &               +2.0d0*(qxyi*gux(26)+qxzi*gux(27)+qyzi*gux(29)))
     &                + syk*(qxxi*guy(25)+qyyi*guy(28)+qzzi*guy(30)
     &               +2.0d0*(qxyi*guy(26)+qxzi*guy(27)+qyzi*guy(29)))
     &                + szk*(qxxi*guz(25)+qyyi*guz(28)+qzzi*guz(30)
     &               +2.0d0*(qxyi*guz(26)+qxzi*guz(27)+qyzi*guz(29)))
                  dsumdr = dsymdr + 0.5d0*(dwipdr+dwkpdr)
                  dpbi = 0.5d0*rbk*dsumdr
                  dpbk = 0.5d0*rbi*dsumdr
c
c     mutual polarization electrostatic solvation free energy gradient
c
                  if (poltyp .eq. 'MUTUAL') then
                     dpdx = dpdx - 0.5d0 *
     &                      (dxi*(pxk*gux(5)+pyk*gux(6)+pzk*gux(7))
     &                      + dyi*(pxk*guy(5)+pyk*guy(6)+pzk*guy(7))
     &                      + dzi*(pxk*guz(5)+pyk*guz(6)+pzk*guz(7))
     &                      + dxk*(pxi*gux(5)+pyi*gux(6)+pzi*gux(7))
     &                      + dyk*(pxi*guy(5)+pyi*guy(6)+pzi*guy(7))
     &                      + dzk*(pxi*guz(5)+pyi*guz(6)+pzi*guz(7)))
                     dpdy = dpdy - 0.5d0 *
     &                      (dxi*(pxk*gux(6)+pyk*gux(8)+pzk*gux(9))
     &                      + dyi*(pxk*guy(6)+pyk*guy(8)+pzk*guy(9))
     &                      + dzi*(pxk*guz(6)+pyk*guz(8)+pzk*guz(9))
     &                      + dxk*(pxi*gux(6)+pyi*gux(8)+pzi*gux(9))
     &                      + dyk*(pxi*guy(6)+pyi*guy(8)+pzi*guy(9))
     &                      + dzk*(pxi*guz(6)+pyi*guz(8)+pzi*guz(9)))
                     dpdz = dpdz - 0.5d0 *
     &                      (dxi*(pxk*gux(7)+pyk*gux(9)+pzk*gux(10))
     &                      + dyi*(pxk*guy(7)+pyk*guy(9)+pzk*guy(10))
     &                      + dzi*(pxk*guz(7)+pyk*guz(9)+pzk*guz(10))
     &                      + dxk*(pxi*gux(7)+pyi*gux(9)+pzi*gux(10))
     &                      + dyk*(pxi*guy(7)+pyi*guy(9)+pzi*guy(10))
     &                      + dzk*(pxi*guz(7)+pyi*guz(9)+pzi*guz(10)))
                     duvdr = dxi*(pxk*gux(22)+pyk*gux(23)+pzk*gux(24))
     &                      + dyi*(pxk*guy(22)+pyk*guy(23)+pzk*guy(24))
     &                      + dzi*(pxk*guz(22)+pyk*guz(23)+pzk*guz(24))
     &                      + dxk*(pxi*gux(22)+pyi*gux(23)+pzi*gux(24))
     &                      + dyk*(pxi*guy(22)+pyi*guy(23)+pzi*guy(24))
     &                      + dzk*(pxi*guz(22)+pyi*guz(23)+pzi*guz(24))
                     dpbi = dpbi - 0.5d0*rbk*duvdr
                     dpbk = dpbk - 0.5d0*rbi*duvdr
                  end if
c
c     torque due to induced reaction field on permanent dipoles
c
                  fid(1) = 0.5d0 * (sxk*gux(2)+syk*guy(2)+szk*guz(2))
                  fid(2) = 0.5d0 * (sxk*gux(3)+syk*guy(3)+szk*guz(3))
                  fid(3) = 0.5d0 * (sxk*gux(4)+syk*guy(4)+szk*guz(4))
                  fkd(1) = 0.5d0 * (sxi*gux(2)+syi*guy(2)+szi*guz(2))
                  fkd(2) = 0.5d0 * (sxi*gux(3)+syi*guy(3)+szi*guz(3))
                  fkd(3) = 0.5d0 * (sxi*gux(4)+syi*guy(4)+szi*guz(4))
                  if (i .eq. k) then
                     fid(1) = 0.5d0 * fid(1)
                     fid(2) = 0.5d0 * fid(2)
                     fid(3) = 0.5d0 * fid(3)
                     fkd(1) = 0.5d0 * fkd(1)
                     fkd(2) = 0.5d0 * fkd(2)
                     fkd(3) = 0.5d0 * fkd(3)
                  end if
                  trqi(1,i) = trqi(1,i) + uyi*fid(3) - uzi*fid(2)
                  trqi(2,i) = trqi(2,i) + uzi*fid(1) - uxi*fid(3)
                  trqi(3,i) = trqi(3,i) + uxi*fid(2) - uyi*fid(1)
                  trqi(1,k) = trqi(1,k) + uyk*fkd(3) - uzk*fkd(2)
                  trqi(2,k) = trqi(2,k) + uzk*fkd(1) - uxk*fkd(3)
                  trqi(3,k) = trqi(3,k) + uxk*fkd(2) - uyk*fkd(1)
c
c     torque due to induced reaction field gradient on quadrupoles
c
                  fidg(1,1) = -0.25d0 *
     &                           ((sxk*gqxx(2)+syk*gqxx(3)+szk*gqxx(4))
     &                          + (sxk*gux(5)+syk*guy(5)+szk*guz(5)))
                  fidg(1,2) = -0.25d0 *
     &                           ((sxk*gqxy(2)+syk*gqxy(3)+szk*gqxy(4))
     &                          + (sxk*gux(6)+syk*guy(6)+szk*guz(6)))
                  fidg(1,3) = -0.25d0 *
     &                           ((sxk*gqxz(2)+syk*gqxz(3)+szk*gqxz(4))
     &                          + (sxk*gux(7)+syk*guy(7)+szk*guz(7)))
                  fidg(2,2) = -0.25d0 *
     &                           ((sxk*gqyy(2)+syk*gqyy(3)+szk*gqyy(4))
     &                          + (sxk*gux(8)+syk*guy(8)+szk*guz(8)))
                  fidg(2,3) = -0.25d0 *
     &                           ((sxk*gqyz(2)+syk*gqyz(3)+szk*gqyz(4))
     &                          + (sxk*gux(9)+syk*guy(9)+szk*guz(9)))
                  fidg(3,3) = -0.25d0 *
     &                           ((sxk*gqzz(2)+syk*gqzz(3)+szk*gqzz(4))
     &                          + (sxk*gux(10)+syk*guy(10)+szk*guz(10)))
                  fidg(2,1) = fidg(1,2)
                  fidg(3,1) = fidg(1,3)
                  fidg(3,2) = fidg(2,3)
                  fkdg(1,1) = 0.25d0 *
     &                           ((sxi*gqxx(2)+syi*gqxx(3)+szi*gqxx(4))
     &                          + (sxi*gux(5)+syi*guy(5)+szi*guz(5)))
                  fkdg(1,2) = 0.25d0 *
     &                           ((sxi*gqxy(2)+syi*gqxy(3)+szi*gqxy(4))
     &                          + (sxi*gux(6)+syi*guy(6)+szi*guz(6)))
                  fkdg(1,3) = 0.25d0 *
     &                           ((sxi*gqxz(2)+syi*gqxz(3)+szi*gqxz(4))
     &                          + (sxi*gux(7)+syi*guy(7)+szi*guz(7)))
                  fkdg(2,2) = 0.25d0 *
     &                           ((sxi*gqyy(2)+syi*gqyy(3)+szi*gqyy(4))
     &                          + (sxi*gux(8)+syi*guy(8)+szi*guz(8)))
                  fkdg(2,3) = 0.25d0 *
     &                           ((sxi*gqyz(2)+syi*gqyz(3)+szi*gqyz(4))
     &                          + (sxi*gux(9)+syi*guy(9)+szi*guz(9)))
                  fkdg(3,3) = 0.25d0 *
     &                           ((sxi*gqzz(2)+syi*gqzz(3)+szi*gqzz(4))
     &                          + (sxi*gux(10)+syi*guy(10)+szi*guz(10)))
                  fkdg(2,1) = fkdg(1,2)
                  fkdg(3,1) = fkdg(1,3)
                  fkdg(3,2) = fkdg(2,3)
                  if (i .eq. k) then
                     fidg(1,1) = 0.5d0 * fidg(1,1)
                     fidg(1,2) = 0.5d0 * fidg(1,2)
                     fidg(1,3) = 0.5d0 * fidg(1,3)
                     fidg(2,1) = 0.5d0 * fidg(2,1)
                     fidg(2,2) = 0.5d0 * fidg(2,2)
                     fidg(2,3) = 0.5d0 * fidg(2,3)
                     fidg(3,1) = 0.5d0 * fidg(3,1)
                     fidg(3,2) = 0.5d0 * fidg(3,2)
                     fidg(3,3) = 0.5d0 * fidg(3,3)
                     fkdg(1,1) = 0.5d0 * fkdg(1,1)
                     fkdg(1,2) = 0.5d0 * fkdg(1,2)
                     fkdg(1,3) = 0.5d0 * fkdg(1,3)
                     fkdg(2,1) = 0.5d0 * fkdg(2,1)
                     fkdg(2,2) = 0.5d0 * fkdg(2,2)
                     fkdg(2,3) = 0.5d0 * fkdg(2,3)
                     fkdg(3,1) = 0.5d0 * fkdg(3,1)
                     fkdg(3,2) = 0.5d0 * fkdg(3,2)
                     fkdg(3,3) = 0.5d0 * fkdg(3,3)
                  end if
                  trqi(1,i) = trqi(1,i) + 2.0d0*
     &                  (qxyi*fidg(1,3)+qyyi*fidg(2,3)+qyzi*fidg(3,3)
     &                  -qxzi*fidg(1,2)-qyzi*fidg(2,2)-qzzi*fidg(3,2))
                  trqi(2,i) = trqi(2,i) + 2.0d0*
     &                  (qxzi*fidg(1,1)+qyzi*fidg(2,1)+qzzi*fidg(3,1)
     &                  -qxxi*fidg(1,3)-qxyi*fidg(2,3)-qxzi*fidg(3,3))
                  trqi(3,i) = trqi(3,i) + 2.0d0*
     &                  (qxxi*fidg(1,2)+qxyi*fidg(2,2)+qxzi*fidg(3,2)
     &                  -qxyi*fidg(1,1)-qyyi*fidg(2,1)-qyzi*fidg(3,1))
                  trqi(1,k) = trqi(1,k) + 2.0d0*
     &                  (qxyk*fkdg(1,3)+qyyk*fkdg(2,3)+qyzk*fkdg(3,3)
     &                  -qxzk*fkdg(1,2)-qyzk*fkdg(2,2)-qzzk*fkdg(3,2))
                  trqi(2,k) = trqi(2,k) + 2.0d0*
     &                  (qxzk*fkdg(1,1)+qyzk*fkdg(2,1)+qzzk*fkdg(3,1)
     &                  -qxxk*fkdg(1,3)-qxyk*fkdg(2,3)-qxzk*fkdg(3,3))
                  trqi(3,k) = trqi(3,k) + 2.0d0*
     &                  (qxxk*fkdg(1,2)+qxyk*fkdg(2,2)+qxzk*fkdg(3,2)
     &                  -qxyk*fkdg(1,1)-qyyk*fkdg(2,1)-qyzk*fkdg(3,1))
c
c     total permanent and induced energies for this interaction
c
                  e = esym + 0.5d0*(ewi+ewk)
                  ei = 0.5d0 * (esymi + 0.5d0*(ewii+ewki))
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     dedx = dedx * fgrp
                     dedy = dedy * fgrp
                     dedz = dedz * fgrp
                     drbi = drbi * fgrp
                     drbk = drbk * fgrp
                     ei = ei * fgrp
                     dpdx = dpdx * fgrp
                     dpdy = dpdy * fgrp
                     dpdz = dpdz * fgrp
                     dpbi = dpbi * fgrp
                     dpbk = dpbk * fgrp
                  end if
c
c     increment the overall energy and derivative expressions
c
                  if (i .eq. k) then
                     e = 0.5d0 * e
                     ei = 0.5d0 * ei
                     es = es + e + ei
                     drb(i) = drb(i) + drbi
                     drbp(i) = drbp(i) + dpbi
                  else
                     es = es + e + ei
                     des(1,i) = des(1,i) - dedx - dpdx
                     des(2,i) = des(2,i) - dedy - dpdy
                     des(3,i) = des(3,i) - dedz - dpdz
                     des(1,k) = des(1,k) + dedx + dpdx
                     des(2,k) = des(2,k) + dedy + dpdy
                     des(3,k) = des(3,k) + dedz + dpdz
                     drb(i) = drb(i) + drbi
                     drb(k) = drb(k) + drbk
                     drbp(i) = drbp(i) + dpbi
                     drbp(k) = drbp(k) + dpbk
c
c     increment the internal virial tensor components
c
                     vxx = xr * dedx
                     vyx = yr * dedx
                     vzx = zr * dedx
                     vyy = yr * dedy
                     vzy = zr * dedy
                     vzz = zr * dedz
                     vir(1,1) = vir(1,1) + vxx
                     vir(2,1) = vir(2,1) + vyx
                     vir(3,1) = vir(3,1) + vzx
                     vir(1,2) = vir(1,2) + vyx
                     vir(2,2) = vir(2,2) + vyy
                     vir(3,2) = vir(3,2) + vzy
                     vir(1,3) = vir(1,3) + vzx
                     vir(2,3) = vir(2,3) + vzy
                     vir(3,3) = vir(3,3) + vzz
                  end if
               end if
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     resolve site torques then increment forces and virial
c
      do ii = 1, npole
         i = ipole(ii)
         call torque (i,trq(1,i),fix,fiy,fiz,des)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
         call torque (i,trqi(1,i),fix,fiy,fiz,des)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         if (iz .eq. 0)  iz = i
         if (ix .eq. 0)  ix = i
         if (iy .eq. 0)  iy = i
         xiz = x(iz) - x(i)
         yiz = y(iz) - y(i)
         ziz = z(iz) - z(i)
         xix = x(ix) - x(i)
         yix = y(ix) - y(i)
         zix = z(ix) - z(i)
         xiy = x(iy) - x(i)
         yiy = y(iy) - y(i)
         ziy = z(iy) - z(i)
         vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
         vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                    + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
         vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                    + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 
         vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
         vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                    + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
         vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vxy
         vir(3,1) = vir(3,1) + vxz
         vir(1,2) = vir(1,2) + vxy
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vyz
         vir(1,3) = vir(1,3) + vxz
         vir(2,3) = vir(2,3) + vyz
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (trq)
      deallocate (trqi)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine epb1  --  Poisson-Boltzmann energy and derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "epb1" calculates the implicit solvation energy and derivatives
c     via the Poisson-Boltzmann plus nonpolar implicit solvation
c
c
      subroutine epb1
      implicit none
c
c
c     compute the energy and gradients via Poisson-Boltzmann
c
      call epb1a
c
c     correct energy and derivatives for vacuum to polarized state
c
      call ediff1a
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine epb1a  --  PB solvation energy and derivatives  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "epb1a" calculates the solvation energy and gradients for the
c     PB/NP solvation model
c
c
      subroutine epb1a
      use atoms
      use chgpot
      use deriv
      use energi
      use mpole
      use pbstuf
      use polar
      use polpot
      use potent
      implicit none
      integer i,j,ii
      real*8 etot
      real*8 fix(3),fiy(3),fiz(3)
      real*8, allocatable :: indpole(:,:)
      real*8, allocatable :: inppole(:,:)
      real*8, allocatable :: directf(:,:)
      real*8, allocatable :: directt(:,:)
      real*8, allocatable :: mutualf(:,:)
      real*8, allocatable :: polgrd(:,:)
      real*8, allocatable :: detor(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (indpole(3,n))
      allocate (inppole(3,n))
      allocate (directf(3,n))
      allocate (directt(3,n))
      allocate (mutualf(3,n))
      allocate (polgrd(3,n))
c
c     induced dipole implicit energy via their
c     interaction with the permanent multipoles
c
      if (use_polar) then
         etot = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            etot = etot + uinds(1,i)*pbep(1,i) + uinds(2,i)*pbep(2,i)
     &                + uinds(3,i)*pbep(3,i)
         end do
         etot = -0.5d0 * electric * etot
         pbe = pbe + etot
c
c     initialize induced dipole implicit energy gradients
c
         do i = 1, n
            do j = 1, 3
               indpole(j,i) = 0.0d0
               inppole(j,i) = 0.0d0
               directf(j,i) = 0.0d0
               directt(j,i) = 0.0d0
               mutualf(j,i) = 0.0d0
               polgrd(j,i) = 0.0d0
             end do
         end do
c
c     copy induced electrostatics into atom-based arrays
c
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               indpole(j,i) = uinds(j,i)
               inppole(j,i) = uinps(j,i)
            end do
         end do
c
c     perform dynamic allocation of some global arrays
c
         if (poltyp .eq. 'DIRECT') then
            if (.not. allocated(pbeuind))  allocate (pbeuind(3,n))
            if (.not. allocated(pbeuinp))  allocate (pbeuinp(3,n))
c
c     for direct polarization, the reaction field due to the
c     induced dipoles still needs to be computed because
c     the mutual portion of "apbsinduce" was not called
c
            do i = 1, n
               do j = 1, 3
                  pbeuind(j,i) = 0.0d0
                  pbeuinp(j,i) = 0.0d0
               end do
            end do
            call apbsinduce (indpole,pbeuind)
            call apbsnlinduce (inppole,pbeuinp)
         end if
c
c     compute direct induced dipole implicit solvation energy
c     gradients using potentials saved during the SCRF convergence
c
         call pbdirectpolforce (indpole,inppole,directf,directt)
c
c     convert torques due to induced dipole reaction field acting
c     on permanent multipoles into forces on adjacent atoms
c
         do ii = 1, npole
            i = ipole(ii)
            call torque (i,directt(1,i),fix,fiy,fiz,polgrd)
         end do
         do i = 1, n
            polgrd(1,i) = polgrd(1,i) - directf(1,i)
            polgrd(2,i) = polgrd(2,i) - directf(2,i)
            polgrd(3,i) = polgrd(3,i) - directf(3,i)
         end do
c
c     compute mutual induced dipole solvation energy gradients
c
         if (poltyp .eq. 'MUTUAL') then
            call pbmutualpolforce (indpole,inppole,mutualf)
            do i = 1, n
               polgrd(1,i) = polgrd(1,i) - mutualf(1,i)
               polgrd(2,i) = polgrd(2,i) - mutualf(2,i)
               polgrd(3,i) = polgrd(3,i) - mutualf(3,i)
            end do
         end if
c
c     add induced dipole implicit solvation energy gradients
c     to overall polarization energy gradients
c
         do i = 1, n
            des(1,i) = des(1,i) + polgrd(1,i)
            des(2,i) = des(2,i) + polgrd(2,i)
            des(3,i) = des(3,i) + polgrd(3,i)
         end do
c
c     if polarization is off, get the permanent reaction field
c
      else
         call pbempole
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (indpole)
      deallocate (inppole)
      deallocate (directf)
      deallocate (directt)
      deallocate (mutualf)
      deallocate (polgrd)
c
c     increment solvation energy by Poisson-Boltzmann results
c
      es = es + pbe
c
c     perform dynamic allocation of some local arrays
c
      allocate (detor(3,n))
c
c     convert torques on permanent moments due to their own reaction
c     field into forces on adjacent atoms
c
      do i = 1, n
         do j = 1, 3
            detor(j,i) = 0.0d0
          end do
      end do
      do ii = 1, npole
         i = ipole(ii)
         call torque (i,pbtp(1,i),fix,fiy,fiz,detor)
      end do
c
c     add permanent reaction field forces to the torque results
c
      do i = 1, n
         des(1,i) = des(1,i) - pbfp(1,i) + detor(1,i)
         des(2,i) = des(2,i) - pbfp(2,i) + detor(2,i)
         des(3,i) = des(3,i) - pbfp(3,i) + detor(3,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (detor)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine ediff1a  --  vacuum to SCRF via double loop  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "ediff1a" calculates the energy and derivatives of polarizing
c     the vacuum induced dipoles to their SCRF polarized values using
c     a double loop
c
c
      subroutine ediff1a
      use atoms
      use bound
      use boxes
      use chgpot
      use couple
      use deriv
      use energi
      use group
      use limits
      use mplpot
      use mpole
      use polar
      use polgrp
      use polpot
      use potent
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer ix,iy,iz
      integer kx,ky,kz
      real*8 ei,f,fgrp
      real*8 damp,gfd
      real*8 scale3,scale5
      real*8 scale7,scale9
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 psc3,psc5,psc7,psc9
      real*8 dsc3,dsc5,dsc7,dsc9
      real*8 scale3i,scale5i
      real*8 scale7i
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 pdi,pti,pgamma
      real*8 ci,di(3),qi(9)
      real*8 ck,dk(3),qk(9)
      real*8 fridmp(3),findmp(3)
      real*8 ftm2i(3)
      real*8 ttm2i(3),ttm3i(3)
      real*8 dixdk(3),fdir(3)
      real*8 dixuk(3),dkxui(3)
      real*8 dixukp(3),dkxuip(3)
      real*8 uixqkr(3),ukxqir(3)
      real*8 uixqkrp(3),ukxqirp(3)
      real*8 qiuk(3),qkui(3)
      real*8 qiukp(3),qkuip(3)
      real*8 rxqiuk(3),rxqkui(3)
      real*8 rxqiukp(3),rxqkuip(3)
      real*8 qidk(3),qkdi(3)
      real*8 qir(3),qkr(3)
      real*8 qiqkr(3),qkqir(3)
      real*8 qixqk(3),rxqir(3)
      real*8 dixr(3),dkxr(3)
      real*8 dixqkr(3),dkxqir(3)
      real*8 rxqkr(3),qkrxqir(3)
      real*8 rxqikr(3),rxqkir(3)
      real*8 rxqidk(3),rxqkdi(3)
      real*8 ddsc3(3),ddsc5(3)
      real*8 ddsc7(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 gli(7),glip(7)
      real*8 sc(10)
      real*8 sci(8),scip(8)
      real*8 gfi(6),gti(6)
      real*8, allocatable :: pscale(:)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: trqi(:,:)
      logical proceed,usei,usek
      character*6 mode
c
c
c     set conversion factor, cutoff and scaling coefficients
c
      if (npole .eq. 0)  return
      f = electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
      allocate (dscale(n))
      allocate (uscale(n))
      allocate (trqi(3,n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         pscale(i) = 1.0d0
         dscale(i) = 1.0d0
         uscale(i) = 1.0d0
      end do
c
c     initialize local variables for OpenMP calculation
c
      do i = 1, n
         do j = 1, 3
            trqi(j,i) = 0.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,x,y,z,xaxis,yaxis,
!$OMP& zaxis,pdamp,thole,rpole,uind,uinp,uinds,uinps,use,n12,n13,n14,
!$OMP& n15,i12,i13,i14,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14,
!$OMP& p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale,
!$OMP& p5iscale,d1scale,d2scale,d3scale,d4scale,u1scale,u2scale,
!$OMP& u3scale,u4scale,dpequal,use_group,use_intra,off2,f)
!$OMP& firstprivate(pscale,dscale,uscale)
!$OMP& shared(es,des,trqi)
!$OMP DO reduction(+:es,des,trqi)
c
c     calculate the multipole interaction energy and gradient
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         pdi = pdamp(i)
         pti = thole(i)
         ci = rpole(1,i)
         di(1) = rpole(2,i)
         di(2) = rpole(3,i)
         di(3) = rpole(4,i)
         qi(1) = rpole(5,i)
         qi(2) = rpole(6,i)
         qi(3) = rpole(7,i)
         qi(4) = rpole(8,i)
         qi(5) = rpole(9,i)
         qi(6) = rpole(10,i)
         qi(7) = rpole(11,i)
         qi(8) = rpole(12,i)
         qi(9) = rpole(13,i)
         usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
               uscale(ip14(j,i)) = u4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,ii,kk,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
            if (.not. proceed)  goto 10
            ck = rpole(1,k)
            dk(1) = rpole(2,k)
            dk(2) = rpole(3,k)
            dk(3) = rpole(4,k)
            qk(1) = rpole(5,k)
            qk(2) = rpole(6,k)
            qk(3) = rpole(7,k)
            qk(4) = rpole(8,k)
            qk(5) = rpole(9,k)
            qk(6) = rpole(10,k)
            qk(7) = rpole(11,k)
            qk(8) = rpole(12,k)
            qk(9) = rpole(13,k)
            xr = x(kk) - xi
            yr = y(kk) - yi
            zr = z(kk) - zi
            call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               rr1 = 1.0d0 / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
               scale3 = 1.0d0
               scale5 = 1.0d0
               scale7 = 1.0d0
               scale9 = 1.0d0
               do j = 1, 3
                  ddsc3(j) = 0.0d0
                  ddsc5(j) = 0.0d0
                  ddsc7(j) = 0.0d0
               end do
c
c     apply Thole polarization damping to scale factors
c
               damp = pdi * pdamp(k)
               pgamma = min(pti,thole(k))
               if (pgamma .eq. 0.0d0)  pgamma = max(pti,thole(k))
               if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                  damp = -pgamma * (r/damp)**3
                  if (damp .gt. -50.0d0) then
                     scale3 = 1.0d0 - exp(damp)
                     scale5 = 1.0d0 - (1.0d0-damp)*exp(damp)
                     scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2)
     &                                       *exp(damp)
                     scale9 = 1.0d0 - (1.0d0-damp+(18.0d0*damp**2
     &                                 -9.0d0*damp**3)/35.0d0)*exp(damp)
                     ddsc3(1) = -3.0d0*damp*exp(damp) * xr/r2
                     ddsc3(2) = -3.0d0*damp*exp(damp) * yr/r2
                     ddsc3(3) = -3.0d0*damp*exp(damp) * zr/r2
                     ddsc5(1) = -damp * ddsc3(1)
                     ddsc5(2) = -damp * ddsc3(2)
                     ddsc5(3) = -damp * ddsc3(3)
                     ddsc7(1) = (-0.2d0-0.6d0*damp) * ddsc5(1)
                     ddsc7(2) = (-0.2d0-0.6d0*damp) * ddsc5(2)
                     ddsc7(3) = (-0.2d0-0.6d0*damp) * ddsc5(3)
                  end if
               end if
               scale3i = scale3 * uscale(k)
               scale5i = scale5 * uscale(k)
               scale7i = scale7 * uscale(k)
               dsc3 = scale3 * dscale(k)
               dsc5 = scale5 * dscale(k)
               dsc7 = scale7 * dscale(k)
               dsc9 = scale9 * dscale(k)
               psc3 = scale3 * pscale(k)
               psc5 = scale5 * pscale(k)
               psc7 = scale7 * pscale(k)
               psc9 = scale9 * pscale(k)
c
c     construct auxiliary vectors for permanent terms
c
               dixdk(1) = di(2)*dk(3) - di(3)*dk(2)
               dixdk(2) = di(3)*dk(1) - di(1)*dk(3)
               dixdk(3) = di(1)*dk(2) - di(2)*dk(1)
               dixr(1) = di(2)*zr - di(3)*yr
               dixr(2) = di(3)*xr - di(1)*zr
               dixr(3) = di(1)*yr - di(2)*xr
               dkxr(1) = dk(2)*zr - dk(3)*yr
               dkxr(2) = dk(3)*xr - dk(1)*zr
               dkxr(3) = dk(1)*yr - dk(2)*xr
               qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr
               qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr
               qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr
               qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr
               qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr
               qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr
               qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3)
               qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3)
               qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3)
               qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3)
               qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3)
               qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3)
               qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9)
     &                       - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8)
               qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7)
     &                       - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9)
               qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8)
     &                       - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7)
               rxqir(1) = yr*qir(3) - zr*qir(2)
               rxqir(2) = zr*qir(1) - xr*qir(3)
               rxqir(3) = xr*qir(2) - yr*qir(1)
               rxqkr(1) = yr*qkr(3) - zr*qkr(2)
               rxqkr(2) = zr*qkr(1) - xr*qkr(3)
               rxqkr(3) = xr*qkr(2) - yr*qkr(1)
               rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2)
               rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3)
               rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1)
               rxqkir(1) = yr*qkqir(3) - zr*qkqir(2)
               rxqkir(2) = zr*qkqir(1) - xr*qkqir(3)
               rxqkir(3) = xr*qkqir(2) - yr*qkqir(1)
               qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2)
               qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3)
               qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1)
               qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3)
               qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3)
               qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3)
               qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3)
               qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3)
               qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3)
               dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2)
               dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3)
               dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1)
               dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2)
               dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3)
               dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1)
               rxqidk(1) = yr*qidk(3) - zr*qidk(2)
               rxqidk(2) = zr*qidk(1) - xr*qidk(3)
               rxqidk(3) = xr*qidk(2) - yr*qidk(1)
               rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2)
               rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3)
               rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1)
c
c     get intermediate variables for permanent energy terms
c
               sc(3) = di(1)*xr + di(2)*yr + di(3)*zr
               sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr
               sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr
               sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr
c
c     construct auxiliary vectors for induced terms
c
               dixuk(1) = di(2)*uinds(3,k) - di(3)*uinds(2,k)
               dixuk(2) = di(3)*uinds(1,k) - di(1)*uinds(3,k)
               dixuk(3) = di(1)*uinds(2,k) - di(2)*uinds(1,k)
               dkxui(1) = dk(2)*uinds(3,i) - dk(3)*uinds(2,i)
               dkxui(2) = dk(3)*uinds(1,i) - dk(1)*uinds(3,i)
               dkxui(3) = dk(1)*uinds(2,i) - dk(2)*uinds(1,i)
               dixukp(1) = di(2)*uinps(3,k) - di(3)*uinps(2,k)
               dixukp(2) = di(3)*uinps(1,k) - di(1)*uinps(3,k)
               dixukp(3) = di(1)*uinps(2,k) - di(2)*uinps(1,k)
               dkxuip(1) = dk(2)*uinps(3,i) - dk(3)*uinps(2,i)
               dkxuip(2) = dk(3)*uinps(1,i) - dk(1)*uinps(3,i)
               dkxuip(3) = dk(1)*uinps(2,i) - dk(2)*uinps(1,i)
               qiuk(1) = qi(1)*uinds(1,k) + qi(4)*uinds(2,k)
     &                      + qi(7)*uinds(3,k)
               qiuk(2) = qi(2)*uinds(1,k) + qi(5)*uinds(2,k)
     &                      + qi(8)*uinds(3,k)
               qiuk(3) = qi(3)*uinds(1,k) + qi(6)*uinds(2,k)
     &                      + qi(9)*uinds(3,k)
               qkui(1) = qk(1)*uinds(1,i) + qk(4)*uinds(2,i)
     &                      + qk(7)*uinds(3,i)
               qkui(2) = qk(2)*uinds(1,i) + qk(5)*uinds(2,i)
     &                      + qk(8)*uinds(3,i)
               qkui(3) = qk(3)*uinds(1,i) + qk(6)*uinds(2,i)
     &                      + qk(9)*uinds(3,i)
               qiukp(1) = qi(1)*uinps(1,k) + qi(4)*uinps(2,k)
     &                       + qi(7)*uinps(3,k)
               qiukp(2) = qi(2)*uinps(1,k) + qi(5)*uinps(2,k)
     &                       + qi(8)*uinps(3,k)
               qiukp(3) = qi(3)*uinps(1,k) + qi(6)*uinps(2,k)
     &                       + qi(9)*uinps(3,k)
               qkuip(1) = qk(1)*uinps(1,i) + qk(4)*uinps(2,i)
     &                       + qk(7)*uinps(3,i)
               qkuip(2) = qk(2)*uinps(1,i) + qk(5)*uinps(2,i)
     &                       + qk(8)*uinps(3,i)
               qkuip(3) = qk(3)*uinps(1,i) + qk(6)*uinps(2,i)
     &                       + qk(9)*uinps(3,i)
               uixqkr(1) = uinds(2,i)*qkr(3) - uinds(3,i)*qkr(2)
               uixqkr(2) = uinds(3,i)*qkr(1) - uinds(1,i)*qkr(3)
               uixqkr(3) = uinds(1,i)*qkr(2) - uinds(2,i)*qkr(1)
               ukxqir(1) = uinds(2,k)*qir(3) - uinds(3,k)*qir(2)
               ukxqir(2) = uinds(3,k)*qir(1) - uinds(1,k)*qir(3)
               ukxqir(3) = uinds(1,k)*qir(2) - uinds(2,k)*qir(1)
               uixqkrp(1) = uinps(2,i)*qkr(3) - uinps(3,i)*qkr(2)
               uixqkrp(2) = uinps(3,i)*qkr(1) - uinps(1,i)*qkr(3)
               uixqkrp(3) = uinps(1,i)*qkr(2) - uinps(2,i)*qkr(1)
               ukxqirp(1) = uinps(2,k)*qir(3) - uinps(3,k)*qir(2)
               ukxqirp(2) = uinps(3,k)*qir(1) - uinps(1,k)*qir(3)
               ukxqirp(3) = uinps(1,k)*qir(2) - uinps(2,k)*qir(1)
               rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2)
               rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3)
               rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1)
               rxqkui(1) = yr*qkui(3) - zr*qkui(2)
               rxqkui(2) = zr*qkui(1) - xr*qkui(3)
               rxqkui(3) = xr*qkui(2) - yr*qkui(1)
               rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2)
               rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3)
               rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1)
               rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2)
               rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3)
               rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1)
c
c     get intermediate variables for induction energy terms
c
               sci(1) = uinds(1,i)*dk(1) + uinds(2,i)*dk(2)
     &                     + uinds(3,i)*dk(3) + di(1)*uinds(1,k)
     &                     + di(2)*uinds(2,k) + di(3)*uinds(3,k)
               sci(2) = uinds(1,i)*uinds(1,k) + uinds(2,i)*uinds(2,k)
     &                     + uinds(3,i)*uinds(3,k)
               sci(3) = uinds(1,i)*xr + uinds(2,i)*yr + uinds(3,i)*zr
               sci(4) = uinds(1,k)*xr + uinds(2,k)*yr + uinds(3,k)*zr
               sci(7) = qir(1)*uinds(1,k) + qir(2)*uinds(2,k)
     &                     + qir(3)*uinds(3,k)
               sci(8) = qkr(1)*uinds(1,i) + qkr(2)*uinds(2,i)
     &                     + qkr(3)*uinds(3,i)
               scip(1) = uinps(1,i)*dk(1) + uinps(2,i)*dk(2)
     &                      + uinps(3,i)*dk(3) + di(1)*uinps(1,k)
     &                      + di(2)*uinps(2,k) + di(3)*uinps(3,k)
               scip(2) = uinds(1,i)*uinps(1,k) + uinds(2,i)*uinps(2,k)
     &                 + uinds(3,i)*uinps(3,k) + uinps(1,i)*uinds(1,k)
     &                 + uinps(2,i)*uinds(2,k) + uinps(3,i)*uinds(3,k)
               scip(3) = uinps(1,i)*xr + uinps(2,i)*yr + uinps(3,i)*zr
               scip(4) = uinps(1,k)*xr + uinps(2,k)*yr + uinps(3,k)*zr
               scip(7) = qir(1)*uinps(1,k) + qir(2)*uinps(2,k)
     &                      + qir(3)*uinps(3,k)
               scip(8) = qkr(1)*uinps(1,i) + qkr(2)*uinps(2,i)
     &                      + qkr(3)*uinps(3,i)
c
c     calculate the gl functions for potential energy
c
               gli(1) = ck*sci(3) - ci*sci(4)
               gli(2) = -sc(3)*sci(4) - sci(3)*sc(4)
               gli(3) = sci(3)*sc(6) - sci(4)*sc(5)
               gli(6) = sci(1)
               gli(7) = 2.0d0 * (sci(7)-sci(8))
               glip(1) = ck*scip(3) - ci*scip(4)
               glip(2) = -sc(3)*scip(4) - scip(3)*sc(4)
               glip(3) = scip(3)*sc(6) - scip(4)*sc(5)
               glip(6) = scip(1)
               glip(7) = 2.0d0 * (scip(7)-scip(8))
c
c     get the permanent multipole and induced energies
c
               ei = 0.5d0 * (rr3*(gli(1)+gli(6))*psc3
     &                          + rr5*(gli(2)+gli(7))*psc5
     &                          + rr7*gli(3)*psc7)
               ei = f * ei
               es = es + ei
c
c     intermediate variables for the induced-permanent terms
c
               gfi(1) = 0.5d0*rr5*((gli(1)+gli(6))*psc3
     &                     +(glip(1)+glip(6))*dsc3+scip(2)*scale3i)
     &                + 0.5d0*rr7*((gli(7)+gli(2))*psc5
     &                            +(glip(7)+glip(2))*dsc5
     &                     -(sci(3)*scip(4)+scip(3)*sci(4))*scale5i)
     &                + 0.5d0*rr9*(gli(3)*psc7+glip(3)*dsc7)
               gfi(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6)
               gfi(3) = rr3*ci + rr5*sc(3) + rr7*sc(5)
               gfi(4) = 2.0d0 * rr5
               gfi(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7)
               gfi(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7)
c
c     get the induced force
c
               ftm2i(1) = gfi(1)*xr + 0.5d0*
     &            (- rr3*ck*(uinds(1,i)*psc3+uinps(1,i)*dsc3)
     &             + rr5*sc(4)*(uinds(1,i)*psc5+uinps(1,i)*dsc5)
     &             - rr7*sc(6)*(uinds(1,i)*psc7+uinps(1,i)*dsc7))
     &             +(rr3*ci*(uinds(1,k)*psc3+uinps(1,k)*dsc3)
     &             + rr5*sc(3)*(uinds(1,k)*psc5+uinps(1,k)*dsc5)
     &             + rr7*sc(5)*(uinds(1,k)*psc7+uinps(1,k)*dsc7))*0.5d0
     &             + rr5*scale5i*(sci(4)*uinps(1,i)+scip(4)*uinds(1,i)
     &             + sci(3)*uinps(1,k)+scip(3)*uinds(1,k))*0.5d0
     &             + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1)
     &             + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1)
     &             + 0.5d0*gfi(4)*((qkui(1)-qiuk(1))*psc5
     &             + (qkuip(1)-qiukp(1))*dsc5)
     &             + gfi(5)*qir(1) + gfi(6)*qkr(1)
               ftm2i(2) = gfi(1)*yr + 0.5d0*
     &            (- rr3*ck*(uinds(2,i)*psc3+uinps(2,i)*dsc3)
     &             + rr5*sc(4)*(uinds(2,i)*psc5+uinps(2,i)*dsc5)
     &             - rr7*sc(6)*(uinds(2,i)*psc7+uinps(2,i)*dsc7))
     &             +(rr3*ci*(uinds(2,k)*psc3+uinps(2,k)*dsc3)
     &             + rr5*sc(3)*(uinds(2,k)*psc5+uinps(2,k)*dsc5)
     &             + rr7*sc(5)*(uinds(2,k)*psc7+uinps(2,k)*dsc7))*0.5d0
     &             + rr5*scale5i*(sci(4)*uinps(2,i)+scip(4)*uinds(2,i)
     &             + sci(3)*uinps(2,k)+scip(3)*uinds(2,k))*0.5d0
     &             + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2)
     &             + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2)
     &             + 0.5d0*gfi(4)*((qkui(2)-qiuk(2))*psc5
     &             + (qkuip(2)-qiukp(2))*dsc5)
     &             + gfi(5)*qir(2) + gfi(6)*qkr(2)
               ftm2i(3) = gfi(1)*zr  + 0.5d0*
     &            (- rr3*ck*(uinds(3,i)*psc3+uinps(3,i)*dsc3)
     &             + rr5*sc(4)*(uinds(3,i)*psc5+uinps(3,i)*dsc5)
     &             - rr7*sc(6)*(uinds(3,i)*psc7+uinps(3,i)*dsc7))
     &             +(rr3*ci*(uinds(3,k)*psc3+uinps(3,k)*dsc3)
     &             + rr5*sc(3)*(uinds(3,k)*psc5+uinps(3,k)*dsc5)
     &             + rr7*sc(5)*(uinds(3,k)*psc7+uinps(3,k)*dsc7))*0.5d0
     &             + rr5*scale5i*(sci(4)*uinps(3,i)+scip(4)*uinds(3,i)
     &             + sci(3)*uinps(3,k)+scip(3)*uinds(3,k))*0.5d0
     &             + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3)
     &             + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3)
     &             + 0.5d0*gfi(4)*((qkui(3)-qiuk(3))*psc5
     &             + (qkuip(3)-qiukp(3))*dsc5)
     &             + gfi(5)*qir(3) + gfi(6)*qkr(3)
c
c     intermediate values needed for partially excluded interactions
c
               fridmp(1) = 0.5d0 * (rr3*((gli(1)+gli(6))*pscale(kk)
     &                        +(glip(1)+glip(6))*dscale(kk))*ddsc3(1)
     &            + rr5*((gli(2)+gli(7))*pscale(kk)
     &                +(glip(2)+glip(7))*dscale(kk))*ddsc5(1)
     &            + rr7*(gli(3)*pscale(kk)+glip(3)*dscale(kk))*ddsc7(1))
               fridmp(2) = 0.5d0 * (rr3*((gli(1)+gli(6))*pscale(kk)
     &                        +(glip(1)+glip(6))*dscale(kk))*ddsc3(2)
     &            + rr5*((gli(2)+gli(7))*pscale(kk)
     &                +(glip(2)+glip(7))*dscale(kk))*ddsc5(2)
     &            + rr7*(gli(3)*pscale(kk)+glip(3)*dscale(kk))*ddsc7(2))
               fridmp(3) = 0.5d0 * (rr3*((gli(1)+gli(6))*pscale(kk)
     &                        +(glip(1)+glip(6))*dscale(kk))*ddsc3(3)
     &            + rr5*((gli(2)+gli(7))*pscale(kk)
     &                +(glip(2)+glip(7))*dscale(kk))*ddsc5(3)
     &            + rr7*(gli(3)*pscale(kk)+glip(3)*dscale(kk))*ddsc7(3))
c
c     get the induced-induced derivative terms
c
               findmp(1) = 0.5d0 * uscale(kk) * (scip(2)*rr3*ddsc3(1)
     &                   - rr5*ddsc5(1)*(sci(3)*scip(4)+scip(3)*sci(4)))
               findmp(2) = 0.5d0 * uscale(kk) * (scip(2)*rr3*ddsc3(2)
     &                   - rr5*ddsc5(2)*(sci(3)*scip(4)+scip(3)*sci(4)))
               findmp(3) = 0.5d0 * uscale(kk) * (scip(2)*rr3*ddsc3(3)
     &                   - rr5*ddsc5(3)*(sci(3)*scip(4)+scip(3)*sci(4)))
c
c     handle of scaling for partially excluded interactions
c
               ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1)
               ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2)
               ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3)
c
c     correction to convert mutual to direct polarization force
c
               if (poltyp .eq. 'DIRECT') then
                  gfd = 0.5d0 * (rr5*scip(2)*scale3i
     &                  - rr7*(scip(3)*sci(4)+sci(3)*scip(4))*scale5i)
                  fdir(1) = gfd*xr + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinps(1,i)+scip(4)*uinds(1,i)
     &                           +sci(3)*uinps(1,k)+scip(3)*uinds(1,k))
                  fdir(2) = gfd*yr + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinps(2,i)+scip(4)*uinds(2,i)
     &                           +sci(3)*uinps(2,k)+scip(3)*uinds(2,k))
                  fdir(3) = gfd*zr + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinps(3,i)+scip(4)*uinds(3,i)
     &                           +sci(3)*uinps(3,k)+scip(3)*uinds(3,k))
                  ftm2i(1) = ftm2i(1) - fdir(1) + findmp(1)
                  ftm2i(2) = ftm2i(2) - fdir(2) + findmp(2)
                  ftm2i(3) = ftm2i(3) - fdir(3) + findmp(3)
               end if
c
c     intermediate terms for torque between multipoles i and k
c
               gti(2) = 0.5d0 * (sci(4)*psc5+scip(4)*dsc5) * rr5
               gti(3) = 0.5d0 * (sci(3)*psc5+scip(3)*dsc5) * rr5
               gti(4) = gfi(4)
               gti(5) = gfi(5)
               gti(6) = gfi(6)
c
c     calculate the induced torque components
c
               ttm2i(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0
     &            + gti(2)*dixr(1) + gti(4)*((ukxqir(1)+rxqiuk(1))*psc5
     &            +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1)
               ttm2i(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0
     &            + gti(2)*dixr(2) + gti(4)*((ukxqir(2)+rxqiuk(2))*psc5
     &            +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2)
               ttm2i(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0
     &            + gti(2)*dixr(3) + gti(4)*((ukxqir(3)+rxqiuk(3))*psc5
     &            +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3)
               ttm3i(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0
     &            + gti(3)*dkxr(1) - gti(4)*((uixqkr(1)+rxqkui(1))*psc5
     &            +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gti(6)*rxqkr(1)
               ttm3i(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0
     &            + gti(3)*dkxr(2) - gti(4)*((uixqkr(2)+rxqkui(2))*psc5
     &            +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gti(6)*rxqkr(2)
               ttm3i(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0
     &            + gti(3)*dkxr(3) - gti(4)*((uixqkr(3)+rxqkui(3))*psc5
     &            +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gti(6)*rxqkr(3)
c
c     update the force components on sites i and k
c
               des(1,ii) = des(1,ii) + f*ftm2i(1)
               des(2,ii) = des(2,ii) + f*ftm2i(2)
               des(3,ii) = des(3,ii) + f*ftm2i(3)
               des(1,kk) = des(1,kk) - f*ftm2i(1)
               des(2,kk) = des(2,kk) - f*ftm2i(2)
               des(3,kk) = des(3,kk) - f*ftm2i(3)
c
c     update the torque components on sites i and k
c
               trqi(1,ii) = trqi(1,ii) + f*ttm2i(1)
               trqi(2,ii) = trqi(2,ii) + f*ttm2i(2)
               trqi(3,ii) = trqi(3,ii) + f*ttm2i(3)
               trqi(1,kk) = trqi(1,kk) + f*ttm3i(1)
               trqi(2,kk) = trqi(2,kk) + f*ttm3i(2)
               trqi(3,kk) = trqi(3,kk) + f*ttm3i(3)
c
c     construct auxiliary vectors for induced terms
c
               dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k)
               dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k)
               dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k)
               dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i)
               dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i)
               dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i)
               dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k)
               dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k)
               dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k)
               dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i)
               dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i)
               dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i)
               qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k)
     &                      + qi(7)*uind(3,k)
               qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k)
     &                      + qi(8)*uind(3,k)
               qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k)
     &                      + qi(9)*uind(3,k)
               qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i)
     &                      + qk(7)*uind(3,i)
               qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i)
     &                      + qk(8)*uind(3,i)
               qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i)
     &                      + qk(9)*uind(3,i)
               qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k)
     &                       + qi(7)*uinp(3,k)
               qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k)
     &                       + qi(8)*uinp(3,k)
               qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k)
     &                       + qi(9)*uinp(3,k)
               qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i)
     &                       + qk(7)*uinp(3,i)
               qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i)
     &                       + qk(8)*uinp(3,i)
               qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i)
     &                       + qk(9)*uinp(3,i)
               uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2)
               uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3)
               uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1)
               ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2)
               ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3)
               ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1)
               uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2)
               uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3)
               uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1)
               ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2)
               ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3)
               ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1)
               rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2)
               rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3)
               rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1)
               rxqkui(1) = yr*qkui(3) - zr*qkui(2)
               rxqkui(2) = zr*qkui(1) - xr*qkui(3)
               rxqkui(3) = xr*qkui(2) - yr*qkui(1)
               rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2)
               rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3)
               rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1)
               rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2)
               rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3)
               rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1)
c
c     get intermediate variables for induction energy terms
c
               sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2)
     &                     + uind(3,i)*dk(3) + di(1)*uind(1,k)
     &                     + di(2)*uind(2,k) + di(3)*uind(3,k)
               sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k)
     &                     + uind(3,i)*uind(3,k)
               sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr
               sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr
               sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k)
     &                     + qir(3)*uind(3,k)
               sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i)
     &                     + qkr(3)*uind(3,i)
               scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2)
     &                      + uinp(3,i)*dk(3) + di(1)*uinp(1,k)
     &                      + di(2)*uinp(2,k) + di(3)*uinp(3,k)
               scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k)
     &                      + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k)
     &                      + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k)
               scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr
               scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr
               scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k)
     &                      + qir(3)*uinp(3,k)
               scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i)
     &                      + qkr(3)*uinp(3,i)
c
c     calculate the gl functions for potential energy
c
               gli(1) = ck*sci(3) - ci*sci(4)
               gli(2) = -sc(3)*sci(4) - sci(3)*sc(4)
               gli(3) = sci(3)*sc(6) - sci(4)*sc(5)
               gli(6) = sci(1)
               gli(7) = 2.0d0 * (sci(7)-sci(8))
               glip(1) = ck*scip(3) - ci*scip(4)
               glip(2) = -sc(3)*scip(4) - scip(3)*sc(4)
               glip(3) = scip(3)*sc(6) - scip(4)*sc(5)
               glip(6) = scip(1)
               glip(7) = 2.0d0 * (scip(7)-scip(8))
c
c     get the permanent multipole and induced energies
c
               ei = -0.5d0 * (rr3*(gli(1)+gli(6))*psc3
     &                           + rr5*(gli(2)+gli(7))*psc5
     &                           + rr7*gli(3)*psc7)
               ei = f * ei
               es = es + ei
c
c     intermediate variables for the induced-permanent terms
c
               gfi(1) = 0.5d0*rr5*((gli(1)+gli(6))*psc3
     &                     +(glip(1)+glip(6))*dsc3+scip(2)*scale3i)
     &                + 0.5d0*rr7*((gli(7)+gli(2))*psc5
     &                            +(glip(7)+glip(2))*dsc5
     &                     -(sci(3)*scip(4)+scip(3)*sci(4))*scale5i)
     &                + 0.5d0*rr9*(gli(3)*psc7+glip(3)*dsc7)
               gfi(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6)
               gfi(3) = rr3*ci + rr5*sc(3) + rr7*sc(5)
               gfi(4) = 2.0d0 * rr5
               gfi(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7)
               gfi(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7)
c
c     get the induced force
c
               ftm2i(1) = gfi(1)*xr + 0.5d0*
     &            (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3)
     &             + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5)
     &             - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7))
     &             +(rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3)
     &             + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5)
     &             + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0
     &             + rr5*scale5i*(sci(4)*uinp(1,i)+scip(4)*uind(1,i)
     &             + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0
     &             + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1)
     &             + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1)
     &             + 0.5d0*gfi(4)*((qkui(1)-qiuk(1))*psc5
     &             + (qkuip(1)-qiukp(1))*dsc5)
     &             + gfi(5)*qir(1) + gfi(6)*qkr(1)
               ftm2i(2) = gfi(1)*yr + 0.5d0*
     &            (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3)
     &             + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5)
     &             - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7))
     &             +(rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3)
     &             + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5)
     &             + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0
     &             + rr5*scale5i*(sci(4)*uinp(2,i)+scip(4)*uind(2,i)
     &             + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0
     &             + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2)
     &             + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2)
     &             + 0.5d0*gfi(4)*((qkui(2)-qiuk(2))*psc5
     &             + (qkuip(2)-qiukp(2))*dsc5)
     &             + gfi(5)*qir(2) + gfi(6)*qkr(2)
               ftm2i(3) = gfi(1)*zr  + 0.5d0*
     &            (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3)
     &             + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5)
     &             - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7))
     &             +(rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3)
     &             + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5)
     &             + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0
     &             + rr5*scale5i*(sci(4)*uinp(3,i)+scip(4)*uind(3,i)
     &             + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0
     &             + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3)
     &             + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3)
     &             + 0.5d0*gfi(4)*((qkui(3)-qiuk(3))*psc5
     &             + (qkuip(3)-qiukp(3))*dsc5)
     &             + gfi(5)*qir(3) + gfi(6)*qkr(3)
c
c     intermediate values needed for partially excluded interactions
c
               fridmp(1) = 0.5d0 * (rr3*((gli(1)+gli(6))*pscale(kk)
     &                        +(glip(1)+glip(6))*dscale(kk))*ddsc3(1)
     &            + rr5*((gli(2)+gli(7))*pscale(kk)
     &                +(glip(2)+glip(7))*dscale(kk))*ddsc5(1)
     &            + rr7*(gli(3)*pscale(kk)+glip(3)*dscale(kk))*ddsc7(1))
               fridmp(2) = 0.5d0 * (rr3*((gli(1)+gli(6))*pscale(kk)
     &                        +(glip(1)+glip(6))*dscale(kk))*ddsc3(2)
     &            + rr5*((gli(2)+gli(7))*pscale(kk)
     &                +(glip(2)+glip(7))*dscale(kk))*ddsc5(2)
     &            + rr7*(gli(3)*pscale(kk)+glip(3)*dscale(kk))*ddsc7(2))
               fridmp(3) = 0.5d0 * (rr3*((gli(1)+gli(6))*pscale(kk)
     &                        +(glip(1)+glip(6))*dscale(kk))*ddsc3(3)
     &            + rr5*((gli(2)+gli(7))*pscale(kk)
     &                +(glip(2)+glip(7))*dscale(kk))*ddsc5(3)
     &            + rr7*(gli(3)*pscale(kk)+glip(3)*dscale(kk))*ddsc7(3))
c
c     get the induced-induced derivative terms
c
               findmp(1) = 0.5d0 * uscale(kk) * (scip(2)*rr3*ddsc3(1)
     &                   - rr5*ddsc5(1)*(sci(3)*scip(4)+scip(3)*sci(4)))
               findmp(2) = 0.5d0 * uscale(kk) * (scip(2)*rr3*ddsc3(2)
     &                   - rr5*ddsc5(2)*(sci(3)*scip(4)+scip(3)*sci(4)))
               findmp(3) = 0.5d0 * uscale(kk) * (scip(2)*rr3*ddsc3(3)
     &                   - rr5*ddsc5(3)*(sci(3)*scip(4)+scip(3)*sci(4)))
c
c     handle of scaling for partially excluded interactions
c
               ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1)
               ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2)
               ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3)
c
c     correction to convert mutual to direct polarization force
c
               if (poltyp .eq. 'DIRECT') then
                  gfd = 0.5d0 * (rr5*scip(2)*scale3i
     &                  - rr7*(scip(3)*sci(4)+sci(3)*scip(4))*scale5i)
                  fdir(1) = gfd*xr + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinp(1,i)+scip(4)*uind(1,i)
     &                           +sci(3)*uinp(1,k)+scip(3)*uind(1,k))
                  fdir(2) = gfd*yr + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinp(2,i)+scip(4)*uind(2,i)
     &                           +sci(3)*uinp(2,k)+scip(3)*uind(2,k))
                  fdir(3) = gfd*zr + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinp(3,i)+scip(4)*uind(3,i)
     &                           +sci(3)*uinp(3,k)+scip(3)*uind(3,k))
                  ftm2i(1) = ftm2i(1) - fdir(1) + findmp(1)
                  ftm2i(2) = ftm2i(2) - fdir(2) + findmp(2)
                  ftm2i(3) = ftm2i(3) - fdir(3) + findmp(3)
               end if
c
c     intermediate terms for torque between multipoles i and k
c
               gti(2) = 0.5d0 * (sci(4)*psc5+scip(4)*dsc5) * rr5
               gti(3) = 0.5d0 * (sci(3)*psc5+scip(3)*dsc5) * rr5
               gti(4) = gfi(4)
               gti(5) = gfi(5)
               gti(6) = gfi(6)
c
c     calculate the induced torque components
c
               ttm2i(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0
     &            + gti(2)*dixr(1) + gti(4)*((ukxqir(1)+rxqiuk(1))*psc5
     &            +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1)
               ttm2i(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0
     &            + gti(2)*dixr(2) + gti(4)*((ukxqir(2)+rxqiuk(2))*psc5
     &            +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2)
               ttm2i(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0
     &            + gti(2)*dixr(3) + gti(4)*((ukxqir(3)+rxqiuk(3))*psc5
     &            +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3)
               ttm3i(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0
     &            + gti(3)*dkxr(1) - gti(4)*((uixqkr(1)+rxqkui(1))*psc5
     &            +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gti(6)*rxqkr(1)
               ttm3i(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0
     &            + gti(3)*dkxr(2) - gti(4)*((uixqkr(2)+rxqkui(2))*psc5
     &            +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gti(6)*rxqkr(2)
               ttm3i(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0
     &            + gti(3)*dkxr(3) - gti(4)*((uixqkr(3)+rxqkui(3))*psc5
     &            +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gti(6)*rxqkr(3)
c
c     update the force components on sites i and k
c
               des(1,i) = des(1,i) - f*ftm2i(1)
               des(2,i) = des(2,i) - f*ftm2i(2)
               des(3,i) = des(3,i) - f*ftm2i(3)
               des(1,k) = des(1,k) + f*ftm2i(1)
               des(2,k) = des(2,k) + f*ftm2i(2)
               des(3,k) = des(3,k) + f*ftm2i(3)
c
c     update the torque components on sites i and k
c
               trqi(1,i) = trqi(1,i) - f*ttm2i(1)
               trqi(2,i) = trqi(2,i) - f*ttm2i(2)
               trqi(3,i) = trqi(3,i) - f*ttm2i(3)
               trqi(1,k) = trqi(1,k) - f*ttm3i(1)
               trqi(2,k) = trqi(2,k) - f*ttm3i(2)
               trqi(3,k) = trqi(3,k) - f*ttm3i(3)
            end if
   10       continue
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
               uscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     convert torque components into Cartesian forces
c
      do ii = 1, npole
         i = ipole(ii)
         call torque (i,trqi(1,i),fix,fiy,fiz,des)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      deallocate (dscale)
      deallocate (uscale)
      deallocate (trqi)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ediff1b  --  vacuum to SCRF via neighbor list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ediff1b" calculates the energy and derivatives of polarizing
c     the vacuum induced dipoles to their SCRF polarized values using
c     a neighbor list
c
c
      subroutine ediff1b
      use atoms
      use bound
      use boxes
      use chgpot
      use couple
      use deriv
      use energi
      use group
      use limits
      use mplpot
      use mpole
      use neigh
      use polar
      use polgrp
      use polpot
      use potent
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer ix,iy,iz
      integer kx,ky,kz
      real*8 ei,f,fgrp
      real*8 damp,gfd
      real*8 scale3,scale5
      real*8 scale7,scale9
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 psc3,psc5,psc7,psc9
      real*8 dsc3,dsc5,dsc7,dsc9
      real*8 scale3i,scale5i
      real*8 scale7i
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9
      real*8 pdi,pti,pgamma
      real*8 ci,di(3),qi(9)
      real*8 ck,dk(3),qk(9)
      real*8 fridmp(3),findmp(3)
      real*8 ftm2i(3)
      real*8 ttm2i(3),ttm3i(3)
      real*8 dixdk(3),fdir(3)
      real*8 dixuk(3),dkxui(3)
      real*8 dixukp(3),dkxuip(3)
      real*8 uixqkr(3),ukxqir(3)
      real*8 uixqkrp(3),ukxqirp(3)
      real*8 qiuk(3),qkui(3)
      real*8 qiukp(3),qkuip(3)
      real*8 rxqiuk(3),rxqkui(3)
      real*8 rxqiukp(3),rxqkuip(3)
      real*8 qidk(3),qkdi(3)
      real*8 qir(3),qkr(3)
      real*8 qiqkr(3),qkqir(3)
      real*8 qixqk(3),rxqir(3)
      real*8 dixr(3),dkxr(3)
      real*8 dixqkr(3),dkxqir(3)
      real*8 rxqkr(3),qkrxqir(3)
      real*8 rxqikr(3),rxqkir(3)
      real*8 rxqidk(3),rxqkdi(3)
      real*8 ddsc3(3),ddsc5(3)
      real*8 ddsc7(3)
      real*8 fix(3),fiy(3),fiz(3)
      real*8 gli(7),glip(7)
      real*8 sc(10)
      real*8 sci(8),scip(8)
      real*8 gfi(6),gti(6)
      real*8, allocatable :: pscale(:)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: trqi(:,:)
      logical proceed,usei,usek
      character*6 mode
c
c
c     set conversion factor, cutoff and scaling coefficients
c
      if (npole .eq. 0)  return
      f = electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
      allocate (dscale(n))
      allocate (uscale(n))
      allocate (trqi(3,n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         pscale(i) = 1.0d0
         dscale(i) = 1.0d0
         uscale(i) = 1.0d0
      end do
c
c     initialize local variables for OpenMP calculation
c
      do i = 1, n
         do j = 1, 3
            trqi(j,i) = 0.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,x,y,z,xaxis,yaxis,
!$OMP& zaxis,pdamp,thole,rpole,uind,uinp,uinds,uinps,nelst,elst,
!$OMP& use,n12,n13,n14,n15,i12,i13,i14,i15,np11,ip11,np12,ip12,np13,
!$OMP& ip13,np14,ip14,p2scale,p3scale,p4scale,p5scale,p2iscale,
!$OMP& p3iscale,p4iscale,p5iscale,d1scale,d2scale,d3scale,d4scale,
!$OMP& u1scale,u2scale,u3scale,u4scale,dpequal,use_group,use_intra,
!$OMP& off2,f)
!$OMP& firstprivate(pscale,dscale,uscale)
!$OMP& shared(es,des,trqi)
!$OMP DO reduction(+:es,des,trqi)
c
c     calculate the multipole interaction energy and gradient
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         pdi = pdamp(i)
         pti = thole(i)
         ci = rpole(1,i)
         di(1) = rpole(2,i)
         di(2) = rpole(3,i)
         di(3) = rpole(4,i)
         qi(1) = rpole(5,i)
         qi(2) = rpole(6,i)
         qi(3) = rpole(7,i)
         qi(4) = rpole(8,i)
         qi(5) = rpole(9,i)
         qi(6) = rpole(10,i)
         qi(7) = rpole(11,i)
         qi(8) = rpole(12,i)
         qi(9) = rpole(13,i)
         usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
               uscale(ip14(j,i)) = u4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
            if (.not. proceed)  goto 10
            ck = rpole(1,k)
            dk(1) = rpole(2,k)
            dk(2) = rpole(3,k)
            dk(3) = rpole(4,k)
            qk(1) = rpole(5,k)
            qk(2) = rpole(6,k)
            qk(3) = rpole(7,k)
            qk(4) = rpole(8,k)
            qk(5) = rpole(9,k)
            qk(6) = rpole(10,k)
            qk(7) = rpole(11,k)
            qk(8) = rpole(12,k)
            qk(9) = rpole(13,k)
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            call image (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               rr1 = 1.0d0 / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
               scale3 = 1.0d0
               scale5 = 1.0d0
               scale7 = 1.0d0
               scale9 = 1.0d0
               do j = 1, 3
                  ddsc3(j) = 0.0d0
                  ddsc5(j) = 0.0d0
                  ddsc7(j) = 0.0d0
               end do
c
c     apply Thole polarization damping to scale factors
c
               damp = pdi * pdamp(k)
               pgamma = min(pti,thole(k))
               if (pgamma .eq. 0.0d0)  pgamma = max(pti,thole(k))
               if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then
                  damp = -pgamma * (r/damp)**3
                  if (damp .gt. -50.0d0) then
                     scale3 = 1.0d0 - exp(damp)
                     scale5 = 1.0d0 - (1.0d0-damp)*exp(damp)
                     scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2)
     &                                       *exp(damp)
                     scale9 = 1.0d0 - (1.0d0-damp+(18.0d0*damp**2
     &                                 -9.0d0*damp**3)/35.0d0)*exp(damp)
                     ddsc3(1) = -3.0d0*damp*exp(damp) * xr/r2
                     ddsc3(2) = -3.0d0*damp*exp(damp) * yr/r2
                     ddsc3(3) = -3.0d0*damp*exp(damp) * zr/r2
                     ddsc5(1) = -damp * ddsc3(1)
                     ddsc5(2) = -damp * ddsc3(2)
                     ddsc5(3) = -damp * ddsc3(3)
                     ddsc7(1) = (-0.2d0-0.6d0*damp) * ddsc5(1)
                     ddsc7(2) = (-0.2d0-0.6d0*damp) * ddsc5(2)
                     ddsc7(3) = (-0.2d0-0.6d0*damp) * ddsc5(3)
                  end if
               end if
               scale3i = scale3 * uscale(k)
               scale5i = scale5 * uscale(k)
               scale7i = scale7 * uscale(k)
               dsc3 = scale3 * dscale(k)
               dsc5 = scale5 * dscale(k)
               dsc7 = scale7 * dscale(k)
               dsc9 = scale9 * dscale(k)
               psc3 = scale3 * pscale(k)
               psc5 = scale5 * pscale(k)
               psc7 = scale7 * pscale(k)
               psc9 = scale9 * pscale(k)
c
c     construct auxiliary vectors for permanent terms
c
               dixdk(1) = di(2)*dk(3) - di(3)*dk(2)
               dixdk(2) = di(3)*dk(1) - di(1)*dk(3)
               dixdk(3) = di(1)*dk(2) - di(2)*dk(1)
               dixr(1) = di(2)*zr - di(3)*yr
               dixr(2) = di(3)*xr - di(1)*zr
               dixr(3) = di(1)*yr - di(2)*xr
               dkxr(1) = dk(2)*zr - dk(3)*yr
               dkxr(2) = dk(3)*xr - dk(1)*zr
               dkxr(3) = dk(1)*yr - dk(2)*xr
               qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr
               qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr
               qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr
               qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr
               qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr
               qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr
               qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3)
               qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3)
               qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3)
               qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3)
               qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3)
               qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3)
               qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9)
     &                       - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8)
               qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7)
     &                       - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9)
               qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8)
     &                       - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7)
               rxqir(1) = yr*qir(3) - zr*qir(2)
               rxqir(2) = zr*qir(1) - xr*qir(3)
               rxqir(3) = xr*qir(2) - yr*qir(1)
               rxqkr(1) = yr*qkr(3) - zr*qkr(2)
               rxqkr(2) = zr*qkr(1) - xr*qkr(3)
               rxqkr(3) = xr*qkr(2) - yr*qkr(1)
               rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2)
               rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3)
               rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1)
               rxqkir(1) = yr*qkqir(3) - zr*qkqir(2)
               rxqkir(2) = zr*qkqir(1) - xr*qkqir(3)
               rxqkir(3) = xr*qkqir(2) - yr*qkqir(1)
               qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2)
               qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3)
               qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1)
               qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3)
               qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3)
               qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3)
               qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3)
               qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3)
               qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3)
               dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2)
               dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3)
               dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1)
               dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2)
               dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3)
               dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1)
               rxqidk(1) = yr*qidk(3) - zr*qidk(2)
               rxqidk(2) = zr*qidk(1) - xr*qidk(3)
               rxqidk(3) = xr*qidk(2) - yr*qidk(1)
               rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2)
               rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3)
               rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1)
c
c     get intermediate variables for permanent energy terms
c
               sc(3) = di(1)*xr + di(2)*yr + di(3)*zr
               sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr
               sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr
               sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr
c
c     construct auxiliary vectors for induced terms
c
               dixuk(1) = di(2)*uinds(3,k) - di(3)*uinds(2,k)
               dixuk(2) = di(3)*uinds(1,k) - di(1)*uinds(3,k)
               dixuk(3) = di(1)*uinds(2,k) - di(2)*uinds(1,k)
               dkxui(1) = dk(2)*uinds(3,i) - dk(3)*uinds(2,i)
               dkxui(2) = dk(3)*uinds(1,i) - dk(1)*uinds(3,i)
               dkxui(3) = dk(1)*uinds(2,i) - dk(2)*uinds(1,i)
               dixukp(1) = di(2)*uinps(3,k) - di(3)*uinps(2,k)
               dixukp(2) = di(3)*uinps(1,k) - di(1)*uinps(3,k)
               dixukp(3) = di(1)*uinps(2,k) - di(2)*uinps(1,k)
               dkxuip(1) = dk(2)*uinps(3,i) - dk(3)*uinps(2,i)
               dkxuip(2) = dk(3)*uinps(1,i) - dk(1)*uinps(3,i)
               dkxuip(3) = dk(1)*uinps(2,i) - dk(2)*uinps(1,i)
               qiuk(1) = qi(1)*uinds(1,k) + qi(4)*uinds(2,k)
     &                      + qi(7)*uinds(3,k)
               qiuk(2) = qi(2)*uinds(1,k) + qi(5)*uinds(2,k)
     &                      + qi(8)*uinds(3,k)
               qiuk(3) = qi(3)*uinds(1,k) + qi(6)*uinds(2,k)
     &                      + qi(9)*uinds(3,k)
               qkui(1) = qk(1)*uinds(1,i) + qk(4)*uinds(2,i)
     &                      + qk(7)*uinds(3,i)
               qkui(2) = qk(2)*uinds(1,i) + qk(5)*uinds(2,i)
     &                      + qk(8)*uinds(3,i)
               qkui(3) = qk(3)*uinds(1,i) + qk(6)*uinds(2,i)
     &                      + qk(9)*uinds(3,i)
               qiukp(1) = qi(1)*uinps(1,k) + qi(4)*uinps(2,k)
     &                       + qi(7)*uinps(3,k)
               qiukp(2) = qi(2)*uinps(1,k) + qi(5)*uinps(2,k)
     &                       + qi(8)*uinps(3,k)
               qiukp(3) = qi(3)*uinps(1,k) + qi(6)*uinps(2,k)
     &                       + qi(9)*uinps(3,k)
               qkuip(1) = qk(1)*uinps(1,i) + qk(4)*uinps(2,i)
     &                       + qk(7)*uinps(3,i)
               qkuip(2) = qk(2)*uinps(1,i) + qk(5)*uinps(2,i)
     &                       + qk(8)*uinps(3,i)
               qkuip(3) = qk(3)*uinps(1,i) + qk(6)*uinps(2,i)
     &                       + qk(9)*uinps(3,i)
               uixqkr(1) = uinds(2,i)*qkr(3) - uinds(3,i)*qkr(2)
               uixqkr(2) = uinds(3,i)*qkr(1) - uinds(1,i)*qkr(3)
               uixqkr(3) = uinds(1,i)*qkr(2) - uinds(2,i)*qkr(1)
               ukxqir(1) = uinds(2,k)*qir(3) - uinds(3,k)*qir(2)
               ukxqir(2) = uinds(3,k)*qir(1) - uinds(1,k)*qir(3)
               ukxqir(3) = uinds(1,k)*qir(2) - uinds(2,k)*qir(1)
               uixqkrp(1) = uinps(2,i)*qkr(3) - uinps(3,i)*qkr(2)
               uixqkrp(2) = uinps(3,i)*qkr(1) - uinps(1,i)*qkr(3)
               uixqkrp(3) = uinps(1,i)*qkr(2) - uinps(2,i)*qkr(1)
               ukxqirp(1) = uinps(2,k)*qir(3) - uinps(3,k)*qir(2)
               ukxqirp(2) = uinps(3,k)*qir(1) - uinps(1,k)*qir(3)
               ukxqirp(3) = uinps(1,k)*qir(2) - uinps(2,k)*qir(1)
               rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2)
               rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3)
               rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1)
               rxqkui(1) = yr*qkui(3) - zr*qkui(2)
               rxqkui(2) = zr*qkui(1) - xr*qkui(3)
               rxqkui(3) = xr*qkui(2) - yr*qkui(1)
               rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2)
               rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3)
               rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1)
               rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2)
               rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3)
               rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1)
c
c     get intermediate variables for induction energy terms
c
               sci(1) = uinds(1,i)*dk(1) + uinds(2,i)*dk(2)
     &                     + uinds(3,i)*dk(3) + di(1)*uinds(1,k)
     &                     + di(2)*uinds(2,k) + di(3)*uinds(3,k)
               sci(2) = uinds(1,i)*uinds(1,k) + uinds(2,i)*uinds(2,k)
     &                     + uinds(3,i)*uinds(3,k)
               sci(3) = uinds(1,i)*xr + uinds(2,i)*yr + uinds(3,i)*zr
               sci(4) = uinds(1,k)*xr + uinds(2,k)*yr + uinds(3,k)*zr
               sci(7) = qir(1)*uinds(1,k) + qir(2)*uinds(2,k)
     &                     + qir(3)*uinds(3,k)
               sci(8) = qkr(1)*uinds(1,i) + qkr(2)*uinds(2,i)
     &                     + qkr(3)*uinds(3,i)
               scip(1) = uinps(1,i)*dk(1) + uinps(2,i)*dk(2)
     &                      + uinps(3,i)*dk(3) + di(1)*uinps(1,k)
     &                      + di(2)*uinps(2,k) + di(3)*uinps(3,k)
               scip(2) = uinds(1,i)*uinps(1,k) + uinds(2,i)*uinps(2,k)
     &                 + uinds(3,i)*uinps(3,k) + uinps(1,i)*uinds(1,k)
     &                 + uinps(2,i)*uinds(2,k) + uinps(3,i)*uinds(3,k)
               scip(3) = uinps(1,i)*xr + uinps(2,i)*yr + uinps(3,i)*zr
               scip(4) = uinps(1,k)*xr + uinps(2,k)*yr + uinps(3,k)*zr
               scip(7) = qir(1)*uinps(1,k) + qir(2)*uinps(2,k)
     &                      + qir(3)*uinps(3,k)
               scip(8) = qkr(1)*uinps(1,i) + qkr(2)*uinps(2,i)
     &                      + qkr(3)*uinps(3,i)
c
c     calculate the gl functions for potential energy
c
               gli(1) = ck*sci(3) - ci*sci(4)
               gli(2) = -sc(3)*sci(4) - sci(3)*sc(4)
               gli(3) = sci(3)*sc(6) - sci(4)*sc(5)
               gli(6) = sci(1)
               gli(7) = 2.0d0 * (sci(7)-sci(8))
               glip(1) = ck*scip(3) - ci*scip(4)
               glip(2) = -sc(3)*scip(4) - scip(3)*sc(4)
               glip(3) = scip(3)*sc(6) - scip(4)*sc(5)
               glip(6) = scip(1)
               glip(7) = 2.0d0 * (scip(7)-scip(8))
c
c     get the permanent multipole and induced energies
c
               ei = 0.5d0 * (rr3*(gli(1)+gli(6))*psc3
     &                          + rr5*(gli(2)+gli(7))*psc5
     &                          + rr7*gli(3)*psc7)
               ei = f * ei
               es = es + ei
c
c     intermediate variables for the induced-permanent terms
c
               gfi(1) = 0.5d0*rr5*((gli(1)+gli(6))*psc3
     &                     +(glip(1)+glip(6))*dsc3+scip(2)*scale3i)
     &                + 0.5d0*rr7*((gli(7)+gli(2))*psc5
     &                            +(glip(7)+glip(2))*dsc5
     &                     -(sci(3)*scip(4)+scip(3)*sci(4))*scale5i)
     &                + 0.5d0*rr9*(gli(3)*psc7+glip(3)*dsc7)
               gfi(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6)
               gfi(3) = rr3*ci + rr5*sc(3) + rr7*sc(5)
               gfi(4) = 2.0d0 * rr5
               gfi(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7)
               gfi(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7)
c
c     get the induced force
c
               ftm2i(1) = gfi(1)*xr + 0.5d0*
     &            (- rr3*ck*(uinds(1,i)*psc3+uinps(1,i)*dsc3)
     &             + rr5*sc(4)*(uinds(1,i)*psc5+uinps(1,i)*dsc5)
     &             - rr7*sc(6)*(uinds(1,i)*psc7+uinps(1,i)*dsc7))
     &             +(rr3*ci*(uinds(1,k)*psc3+uinps(1,k)*dsc3)
     &             + rr5*sc(3)*(uinds(1,k)*psc5+uinps(1,k)*dsc5)
     &             + rr7*sc(5)*(uinds(1,k)*psc7+uinps(1,k)*dsc7))*0.5d0
     &             + rr5*scale5i*(sci(4)*uinps(1,i)+scip(4)*uinds(1,i)
     &             + sci(3)*uinps(1,k)+scip(3)*uinds(1,k))*0.5d0
     &             + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1)
     &             + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1)
     &             + 0.5d0*gfi(4)*((qkui(1)-qiuk(1))*psc5
     &             + (qkuip(1)-qiukp(1))*dsc5)
     &             + gfi(5)*qir(1) + gfi(6)*qkr(1)
               ftm2i(2) = gfi(1)*yr + 0.5d0*
     &            (- rr3*ck*(uinds(2,i)*psc3+uinps(2,i)*dsc3)
     &             + rr5*sc(4)*(uinds(2,i)*psc5+uinps(2,i)*dsc5)
     &             - rr7*sc(6)*(uinds(2,i)*psc7+uinps(2,i)*dsc7))
     &             +(rr3*ci*(uinds(2,k)*psc3+uinps(2,k)*dsc3)
     &             + rr5*sc(3)*(uinds(2,k)*psc5+uinps(2,k)*dsc5)
     &             + rr7*sc(5)*(uinds(2,k)*psc7+uinps(2,k)*dsc7))*0.5d0
     &             + rr5*scale5i*(sci(4)*uinps(2,i)+scip(4)*uinds(2,i)
     &             + sci(3)*uinps(2,k)+scip(3)*uinds(2,k))*0.5d0
     &             + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2)
     &             + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2)
     &             + 0.5d0*gfi(4)*((qkui(2)-qiuk(2))*psc5
     &             + (qkuip(2)-qiukp(2))*dsc5)
     &             + gfi(5)*qir(2) + gfi(6)*qkr(2)
               ftm2i(3) = gfi(1)*zr  + 0.5d0*
     &            (- rr3*ck*(uinds(3,i)*psc3+uinps(3,i)*dsc3)
     &             + rr5*sc(4)*(uinds(3,i)*psc5+uinps(3,i)*dsc5)
     &             - rr7*sc(6)*(uinds(3,i)*psc7+uinps(3,i)*dsc7))
     &             +(rr3*ci*(uinds(3,k)*psc3+uinps(3,k)*dsc3)
     &             + rr5*sc(3)*(uinds(3,k)*psc5+uinps(3,k)*dsc5)
     &             + rr7*sc(5)*(uinds(3,k)*psc7+uinps(3,k)*dsc7))*0.5d0
     &             + rr5*scale5i*(sci(4)*uinps(3,i)+scip(4)*uinds(3,i)
     &             + sci(3)*uinps(3,k)+scip(3)*uinds(3,k))*0.5d0
     &             + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3)
     &             + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3)
     &             + 0.5d0*gfi(4)*((qkui(3)-qiuk(3))*psc5
     &             + (qkuip(3)-qiukp(3))*dsc5)
     &             + gfi(5)*qir(3) + gfi(6)*qkr(3)
c
c     intermediate values needed for partially excluded interactions
c
               fridmp(1) = 0.5d0 * (rr3*((gli(1)+gli(6))*pscale(kk)
     &                        +(glip(1)+glip(6))*dscale(kk))*ddsc3(1)
     &            + rr5*((gli(2)+gli(7))*pscale(kk)
     &                +(glip(2)+glip(7))*dscale(kk))*ddsc5(1)
     &            + rr7*(gli(3)*pscale(kk)+glip(3)*dscale(kk))*ddsc7(1))
               fridmp(2) = 0.5d0 * (rr3*((gli(1)+gli(6))*pscale(kk)
     &                        +(glip(1)+glip(6))*dscale(kk))*ddsc3(2)
     &            + rr5*((gli(2)+gli(7))*pscale(kk)
     &                +(glip(2)+glip(7))*dscale(kk))*ddsc5(2)
     &            + rr7*(gli(3)*pscale(kk)+glip(3)*dscale(kk))*ddsc7(2))
               fridmp(3) = 0.5d0 * (rr3*((gli(1)+gli(6))*pscale(kk)
     &                        +(glip(1)+glip(6))*dscale(kk))*ddsc3(3)
     &            + rr5*((gli(2)+gli(7))*pscale(kk)
     &                +(glip(2)+glip(7))*dscale(kk))*ddsc5(3)
     &            + rr7*(gli(3)*pscale(kk)+glip(3)*dscale(kk))*ddsc7(3))
c
c     get the induced-induced derivative terms
c
               findmp(1) = 0.5d0 * uscale(kk) * (scip(2)*rr3*ddsc3(1)
     &                   - rr5*ddsc5(1)*(sci(3)*scip(4)+scip(3)*sci(4)))
               findmp(2) = 0.5d0 * uscale(kk) * (scip(2)*rr3*ddsc3(2)
     &                   - rr5*ddsc5(2)*(sci(3)*scip(4)+scip(3)*sci(4)))
               findmp(3) = 0.5d0 * uscale(kk) * (scip(2)*rr3*ddsc3(3)
     &                   - rr5*ddsc5(3)*(sci(3)*scip(4)+scip(3)*sci(4)))
c
c     handle of scaling for partially excluded interactions
c
               ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1)
               ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2)
               ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3)
c
c     correction to convert mutual to direct polarization force
c
               if (poltyp .eq. 'DIRECT') then
                  gfd = 0.5d0 * (rr5*scip(2)*scale3i
     &                  - rr7*(scip(3)*sci(4)+sci(3)*scip(4))*scale5i)
                  fdir(1) = gfd*xr + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinps(1,i)+scip(4)*uinds(1,i)
     &                           +sci(3)*uinps(1,k)+scip(3)*uinds(1,k))
                  fdir(2) = gfd*yr + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinps(2,i)+scip(4)*uinds(2,i)
     &                           +sci(3)*uinps(2,k)+scip(3)*uinds(2,k))
                  fdir(3) = gfd*zr + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinps(3,i)+scip(4)*uinds(3,i)
     &                           +sci(3)*uinps(3,k)+scip(3)*uinds(3,k))
                  ftm2i(1) = ftm2i(1) - fdir(1) + findmp(1)
                  ftm2i(2) = ftm2i(2) - fdir(2) + findmp(2)
                  ftm2i(3) = ftm2i(3) - fdir(3) + findmp(3)
               end if
c
c     intermediate terms for torque between multipoles i and k
c
               gti(2) = 0.5d0 * (sci(4)*psc5+scip(4)*dsc5) * rr5
               gti(3) = 0.5d0 * (sci(3)*psc5+scip(3)*dsc5) * rr5
               gti(4) = gfi(4)
               gti(5) = gfi(5)
               gti(6) = gfi(6)
c
c     calculate the induced torque components
c
               ttm2i(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0
     &            + gti(2)*dixr(1) + gti(4)*((ukxqir(1)+rxqiuk(1))*psc5
     &            +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1)
               ttm2i(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0
     &            + gti(2)*dixr(2) + gti(4)*((ukxqir(2)+rxqiuk(2))*psc5
     &            +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2)
               ttm2i(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0
     &            + gti(2)*dixr(3) + gti(4)*((ukxqir(3)+rxqiuk(3))*psc5
     &            +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3)
               ttm3i(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0
     &            + gti(3)*dkxr(1) - gti(4)*((uixqkr(1)+rxqkui(1))*psc5
     &            +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gti(6)*rxqkr(1)
               ttm3i(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0
     &            + gti(3)*dkxr(2) - gti(4)*((uixqkr(2)+rxqkui(2))*psc5
     &            +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gti(6)*rxqkr(2)
               ttm3i(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0
     &            + gti(3)*dkxr(3) - gti(4)*((uixqkr(3)+rxqkui(3))*psc5
     &            +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gti(6)*rxqkr(3)
c
c     update the force components on sites i and k
c
               des(1,i) = des(1,i) + f*ftm2i(1)
               des(2,i) = des(2,i) + f*ftm2i(2)
               des(3,i) = des(3,i) + f*ftm2i(3)
               des(1,k) = des(1,k) - f*ftm2i(1)
               des(2,k) = des(2,k) - f*ftm2i(2)
               des(3,k) = des(3,k) - f*ftm2i(3)
c
c     update the torque components on sites i and k
c
               trqi(1,i) = trqi(1,i) + f*ttm2i(1)
               trqi(2,i) = trqi(2,i) + f*ttm2i(2)
               trqi(3,i) = trqi(3,i) + f*ttm2i(3)
               trqi(1,k) = trqi(1,k) + f*ttm3i(1)
               trqi(2,k) = trqi(2,k) + f*ttm3i(2)
               trqi(3,k) = trqi(3,k) + f*ttm3i(3)
c
c     construct auxiliary vectors for induced terms
c
               dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k)
               dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k)
               dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k)
               dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i)
               dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i)
               dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i)
               dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k)
               dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k)
               dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k)
               dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i)
               dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i)
               dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i)
               qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k)
     &                      + qi(7)*uind(3,k)
               qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k)
     &                      + qi(8)*uind(3,k)
               qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k)
     &                      + qi(9)*uind(3,k)
               qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i)
     &                      + qk(7)*uind(3,i)
               qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i)
     &                      + qk(8)*uind(3,i)
               qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i)
     &                      + qk(9)*uind(3,i)
               qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k)
     &                       + qi(7)*uinp(3,k)
               qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k)
     &                       + qi(8)*uinp(3,k)
               qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k)
     &                       + qi(9)*uinp(3,k)
               qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i)
     &                       + qk(7)*uinp(3,i)
               qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i)
     &                       + qk(8)*uinp(3,i)
               qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i)
     &                       + qk(9)*uinp(3,i)
               uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2)
               uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3)
               uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1)
               ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2)
               ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3)
               ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1)
               uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2)
               uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3)
               uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1)
               ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2)
               ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3)
               ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1)
               rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2)
               rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3)
               rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1)
               rxqkui(1) = yr*qkui(3) - zr*qkui(2)
               rxqkui(2) = zr*qkui(1) - xr*qkui(3)
               rxqkui(3) = xr*qkui(2) - yr*qkui(1)
               rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2)
               rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3)
               rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1)
               rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2)
               rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3)
               rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1)
c
c     get intermediate variables for induction energy terms
c
               sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2)
     &                     + uind(3,i)*dk(3) + di(1)*uind(1,k)
     &                     + di(2)*uind(2,k) + di(3)*uind(3,k)
               sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k)
     &                     + uind(3,i)*uind(3,k)
               sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr
               sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr
               sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k)
     &                     + qir(3)*uind(3,k)
               sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i)
     &                     + qkr(3)*uind(3,i)
               scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2)
     &                      + uinp(3,i)*dk(3) + di(1)*uinp(1,k)
     &                      + di(2)*uinp(2,k) + di(3)*uinp(3,k)
               scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k)
     &                      + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k)
     &                      + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k)
               scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr
               scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr
               scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k)
     &                      + qir(3)*uinp(3,k)
               scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i)
     &                      + qkr(3)*uinp(3,i)
c
c     calculate the gl functions for potential energy
c
               gli(1) = ck*sci(3) - ci*sci(4)
               gli(2) = -sc(3)*sci(4) - sci(3)*sc(4)
               gli(3) = sci(3)*sc(6) - sci(4)*sc(5)
               gli(6) = sci(1)
               gli(7) = 2.0d0 * (sci(7)-sci(8))
               glip(1) = ck*scip(3) - ci*scip(4)
               glip(2) = -sc(3)*scip(4) - scip(3)*sc(4)
               glip(3) = scip(3)*sc(6) - scip(4)*sc(5)
               glip(6) = scip(1)
               glip(7) = 2.0d0 * (scip(7)-scip(8))
c
c     get the permanent multipole and induced energies
c
               ei = -0.5d0 * (rr3*(gli(1)+gli(6))*psc3
     &                           + rr5*(gli(2)+gli(7))*psc5
     &                           + rr7*gli(3)*psc7)
               ei = f * ei
               es = es + ei
c
c     intermediate variables for the induced-permanent terms
c
               gfi(1) = 0.5d0*rr5*((gli(1)+gli(6))*psc3
     &                     +(glip(1)+glip(6))*dsc3+scip(2)*scale3i)
     &                + 0.5d0*rr7*((gli(7)+gli(2))*psc5
     &                            +(glip(7)+glip(2))*dsc5
     &                     -(sci(3)*scip(4)+scip(3)*sci(4))*scale5i)
     &                + 0.5d0*rr9*(gli(3)*psc7+glip(3)*dsc7)
               gfi(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6)
               gfi(3) = rr3*ci + rr5*sc(3) + rr7*sc(5)
               gfi(4) = 2.0d0 * rr5
               gfi(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7)
               gfi(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7)
c
c     get the induced force
c
               ftm2i(1) = gfi(1)*xr + 0.5d0*
     &            (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3)
     &             + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5)
     &             - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7))
     &             +(rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3)
     &             + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5)
     &             + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0
     &             + rr5*scale5i*(sci(4)*uinp(1,i)+scip(4)*uind(1,i)
     &             + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0
     &             + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1)
     &             + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1)
     &             + 0.5d0*gfi(4)*((qkui(1)-qiuk(1))*psc5
     &             + (qkuip(1)-qiukp(1))*dsc5)
     &             + gfi(5)*qir(1) + gfi(6)*qkr(1)
               ftm2i(2) = gfi(1)*yr + 0.5d0*
     &            (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3)
     &             + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5)
     &             - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7))
     &             +(rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3)
     &             + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5)
     &             + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0
     &             + rr5*scale5i*(sci(4)*uinp(2,i)+scip(4)*uind(2,i)
     &             + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0
     &             + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2)
     &             + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2)
     &             + 0.5d0*gfi(4)*((qkui(2)-qiuk(2))*psc5
     &             + (qkuip(2)-qiukp(2))*dsc5)
     &             + gfi(5)*qir(2) + gfi(6)*qkr(2)
               ftm2i(3) = gfi(1)*zr  + 0.5d0*
     &            (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3)
     &             + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5)
     &             - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7))
     &             +(rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3)
     &             + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5)
     &             + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0
     &             + rr5*scale5i*(sci(4)*uinp(3,i)+scip(4)*uind(3,i)
     &             + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0
     &             + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3)
     &             + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3)
     &             + 0.5d0*gfi(4)*((qkui(3)-qiuk(3))*psc5
     &             + (qkuip(3)-qiukp(3))*dsc5)
     &             + gfi(5)*qir(3) + gfi(6)*qkr(3)
c
c     intermediate values needed for partially excluded interactions
c
               fridmp(1) = 0.5d0 * (rr3*((gli(1)+gli(6))*pscale(kk)
     &                        +(glip(1)+glip(6))*dscale(kk))*ddsc3(1)
     &            + rr5*((gli(2)+gli(7))*pscale(kk)
     &                +(glip(2)+glip(7))*dscale(kk))*ddsc5(1)
     &            + rr7*(gli(3)*pscale(kk)+glip(3)*dscale(kk))*ddsc7(1))
               fridmp(2) = 0.5d0 * (rr3*((gli(1)+gli(6))*pscale(kk)
     &                        +(glip(1)+glip(6))*dscale(kk))*ddsc3(2)
     &            + rr5*((gli(2)+gli(7))*pscale(kk)
     &                +(glip(2)+glip(7))*dscale(kk))*ddsc5(2)
     &            + rr7*(gli(3)*pscale(kk)+glip(3)*dscale(kk))*ddsc7(2))
               fridmp(3) = 0.5d0 * (rr3*((gli(1)+gli(6))*pscale(kk)
     &                        +(glip(1)+glip(6))*dscale(kk))*ddsc3(3)
     &            + rr5*((gli(2)+gli(7))*pscale(kk)
     &                +(glip(2)+glip(7))*dscale(kk))*ddsc5(3)
     &            + rr7*(gli(3)*pscale(kk)+glip(3)*dscale(kk))*ddsc7(3))
c
c     get the induced-induced derivative terms
c
               findmp(1) = 0.5d0 * uscale(kk) * (scip(2)*rr3*ddsc3(1)
     &                   - rr5*ddsc5(1)*(sci(3)*scip(4)+scip(3)*sci(4)))
               findmp(2) = 0.5d0 * uscale(kk) * (scip(2)*rr3*ddsc3(2)
     &                   - rr5*ddsc5(2)*(sci(3)*scip(4)+scip(3)*sci(4)))
               findmp(3) = 0.5d0 * uscale(kk) * (scip(2)*rr3*ddsc3(3)
     &                   - rr5*ddsc5(3)*(sci(3)*scip(4)+scip(3)*sci(4)))
c
c     handle of scaling for partially excluded interactions
c
               ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1)
               ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2)
               ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3)
c
c     correction to convert mutual to direct polarization force
c
               if (poltyp .eq. 'DIRECT') then
                  gfd = 0.5d0 * (rr5*scip(2)*scale3i
     &                  - rr7*(scip(3)*sci(4)+sci(3)*scip(4))*scale5i)
                  fdir(1) = gfd*xr + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinp(1,i)+scip(4)*uind(1,i)
     &                           +sci(3)*uinp(1,k)+scip(3)*uind(1,k))
                  fdir(2) = gfd*yr + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinp(2,i)+scip(4)*uind(2,i)
     &                           +sci(3)*uinp(2,k)+scip(3)*uind(2,k))
                  fdir(3) = gfd*zr + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinp(3,i)+scip(4)*uind(3,i)
     &                           +sci(3)*uinp(3,k)+scip(3)*uind(3,k))
                  ftm2i(1) = ftm2i(1) - fdir(1) + findmp(1)
                  ftm2i(2) = ftm2i(2) - fdir(2) + findmp(2)
                  ftm2i(3) = ftm2i(3) - fdir(3) + findmp(3)
               end if
c
c     intermediate terms for torque between multipoles i and k
c
               gti(2) = 0.5d0 * (sci(4)*psc5+scip(4)*dsc5) * rr5
               gti(3) = 0.5d0 * (sci(3)*psc5+scip(3)*dsc5) * rr5
               gti(4) = gfi(4)
               gti(5) = gfi(5)
               gti(6) = gfi(6)
c
c     calculate the induced torque components
c
               ttm2i(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0
     &            + gti(2)*dixr(1) + gti(4)*((ukxqir(1)+rxqiuk(1))*psc5
     &            +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1)
               ttm2i(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0
     &            + gti(2)*dixr(2) + gti(4)*((ukxqir(2)+rxqiuk(2))*psc5
     &            +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2)
               ttm2i(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0
     &            + gti(2)*dixr(3) + gti(4)*((ukxqir(3)+rxqiuk(3))*psc5
     &            +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3)
               ttm3i(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0
     &            + gti(3)*dkxr(1) - gti(4)*((uixqkr(1)+rxqkui(1))*psc5
     &            +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gti(6)*rxqkr(1)
               ttm3i(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0
     &            + gti(3)*dkxr(2) - gti(4)*((uixqkr(2)+rxqkui(2))*psc5
     &            +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gti(6)*rxqkr(2)
               ttm3i(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0
     &            + gti(3)*dkxr(3) - gti(4)*((uixqkr(3)+rxqkui(3))*psc5
     &            +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gti(6)*rxqkr(3)
c
c     update the force components on sites i and k
c
               des(1,i) = des(1,i) - f*ftm2i(1)
               des(2,i) = des(2,i) - f*ftm2i(2)
               des(3,i) = des(3,i) - f*ftm2i(3)
               des(1,k) = des(1,k) + f*ftm2i(1)
               des(2,k) = des(2,k) + f*ftm2i(2)
               des(3,k) = des(3,k) + f*ftm2i(3)
c
c     update the torque components on sites i and k
c
               trqi(1,i) = trqi(1,i) - f*ttm2i(1)
               trqi(2,i) = trqi(2,i) - f*ttm2i(2)
               trqi(3,i) = trqi(3,i) - f*ttm2i(3)
               trqi(1,k) = trqi(1,k) - f*ttm3i(1)
               trqi(2,k) = trqi(2,k) - f*ttm3i(2)
               trqi(3,k) = trqi(3,k) - f*ttm3i(3)
            end if
   10       continue
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
               uscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     convert torques into Cartesian forces
c
      do ii = 1, npole
         i = ipole(ii)
         call torque (i,trqi(1,i),fix,fiy,fiz,des)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      deallocate (dscale)
      deallocate (uscale)
      deallocate (trqi)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine enp1  --  cavity/dispersion energy and derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "enp1" calculates the nonpolar implicit solvation energy
c     and derivatives as a sum of cavity and dispersion terms
c
c
      subroutine enp1 (ecav,edisp)
      use atoms
      use atomid
      use deriv
      use kvdws
      use math
      use mpole
      use nonpol
      use shunt
      use solpot
      use solute
      implicit none
      integer i
      real*8 ecav,edisp
      real*8 evol,esurf,etemp
      real*8 probe,taper,dtaper
      real*8 reff,reff2,reff3
      real*8 reff4,reff5,dreff
      real*8, allocatable :: aesurf(:)
      real*8, allocatable :: aevol(:)
      real*8, allocatable :: aetemp(:)
      real*8, allocatable :: weight(:)
      real*8, allocatable :: dsurf(:,:)
      real*8, allocatable :: dvol(:,:)
      real*8, allocatable :: dtemp(:,:)
      character*6 mode
c
c
c     zero out the nonpolar solvation energy contributions
c
      esurf = 0.0d0
      evol = 0.0d0
      ecav = 0.0d0
      edisp = 0.0d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (aesurf(n))
      allocate (aevol(n))
      allocate (aetemp(n))
      allocate (dsurf(3,n))
      allocate (dvol(3,n))
      allocate (dtemp(3,n))
c
c     zero out the nonpolar solvation first derivatives
c
      do i = 1, n
         dsurf(1,i) = 0.0d0
         dsurf(2,i) = 0.0d0
         dsurf(3,i) = 0.0d0
         dvol(1,i) = 0.0d0
         dvol(2,i) = 0.0d0
         dvol(3,i) = 0.0d0
      end do
c
c     solvent probe radius is included in cavity radii
c
      probe = 0.0d0
c
c     compute surface area and effective radius for cavity
c
      call surface1 (radcav,asolv,probe,esurf,aesurf,dsurf)
      reff = 0.5d0 * sqrt(esurf/(pi*surften))
      dreff = 0.5d0 * reff / esurf
      reff2 = reff * reff
      reff3 = reff2 * reff
      reff4 = reff3 * reff
      reff5 = reff4 * reff
c
c     compute solvent excluded volume needed for small solutes
c
      if (reff .lt. spoff) then
         allocate (weight(n))
         do i = 1, n
            weight(i) = solvprs
         end do
         call volume1 (radcav,weight,probe,etemp,evol,
     &                    aetemp,aevol,dtemp,dvol)
         deallocate (weight)
      end if
c
c     include a full solvent excluded volume cavity term
c
      if (reff .le. spcut) then
         ecav = evol
         do i = 1, n
            des(1,i) = des(1,i) + dvol(1,i)
            des(2,i) = des(2,i) + dvol(2,i)
            des(3,i) = des(3,i) + dvol(3,i)
         end do
c
c     include a tapered solvent excluded volume cavity term
c
      else if (reff .le. spoff) then
         mode = 'GKV'
         call switch (mode)
         taper = c5*reff5 + c4*reff4 + c3*reff3
     &              + c2*reff2 + c1*reff + c0
         dtaper = (5.0d0*c5*reff4+4.0d0*c4*reff3+3.0d0*c3*reff2
     &                +2.0d0*c2*reff+c1) * dreff
         ecav = evol * taper
         do i = 1, n
            des(1,i) = des(1,i) + taper*dvol(1,i)
     &                    + evol*dtaper*dsurf(1,i)
            des(2,i) = des(2,i) + taper*dvol(2,i)
     &                    + evol*dtaper*dsurf(2,i)
            des(3,i) = des(3,i) + taper*dvol(3,i)
     &                    + evol*dtaper*dsurf(3,i)
         end do
      end if
c
c     include a full solvent accessible surface area term
c
      if (reff .gt. stcut) then
         ecav = ecav + esurf
         do i = 1, n
            des(1,i) = des(1,i) + dsurf(1,i)
            des(2,i) = des(2,i) + dsurf(2,i)
            des(3,i) = des(3,i) + dsurf(3,i)
         end do
c
c     include a tapered solvent accessible surface area term
c
      else if (reff .gt. stoff) then
         mode = 'GKSA'
         call switch (mode)
         taper = c5*reff5 + c4*reff4 + c3*reff3
     &              + c2*reff2 + c1*reff + c0
         taper = 1.0d0 - taper
         dtaper = (5.0d0*c5*reff4+4.0d0*c4*reff3+3.0d0*c3*reff2
     &                +2.0d0*c2*reff+c1) * dreff
         dtaper = -dtaper
         ecav = ecav + taper*esurf
         do i = 1, n
            des(1,i) = des(1,i) + (taper+esurf*dtaper)*dsurf(1,i)
            des(2,i) = des(2,i) + (taper+esurf*dtaper)*dsurf(2,i)
            des(3,i) = des(3,i) + (taper+esurf*dtaper)*dsurf(3,i)
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (aesurf)
      deallocate (aevol)
      deallocate (aetemp)
      deallocate (dsurf)
      deallocate (dvol)
      deallocate (dtemp)
c
c     find the implicit dispersion solvation energy
c
      call ewca1 (edisp)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine ewca1  --  WCA dispersion energy and derivs  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "ewca1" finds the Weeks-Chandler-Anderson dispersion energy
c     and derivatives of a solute
c
c
      subroutine ewca1 (edisp)
      use atoms
      use atomid
      use deriv
      use kvdws
      use math
      use nonpol
      use solute
      use vdw
      implicit none
      integer i,k
      real*8 edisp,e,idisp
      real*8 xi,yi,zi
      real*8 rk,sk,sk2
      real*8 xr,yr,zr
      real*8 r,r2,r3
      real*8 sum,term,iwca,irepl
      real*8 epsi,rmini,rio,rih,rmax
      real*8 ao,emixo,rmixo,rmixo7
      real*8 ah,emixh,rmixh,rmixh7
      real*8 lik,lik2,lik3,lik4
      real*8 lik5,lik6,lik10
      real*8 lik11,lik12,lik13
      real*8 uik,uik2,uik3,uik4
      real*8 uik5,uik6,uik10
      real*8 uik11,uik12,uik13
      real*8 de,dl,du
      real*8 dedx,dedy,dedz
c
c
c     zero out the Weeks-Chandler-Andersen dispersion energy
c
      edisp = 0.0d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(n,class,epsdsp,
!$OMP& raddsp,x,y,z,cdsp)
!$OMP& shared(edisp,des)
!$OMP DO reduction(+:edisp,des)
c
c     find the WCA dispersion energy and gradient components
c
      do i = 1, n
         epsi = epsdsp(i)
         rmini = raddsp(i)
         emixo = 4.0d0 * epso * epsi / ((sqrt(epso)+sqrt(epsi))**2)
         rmixo = 2.0d0 * (rmino**3+rmini**3) / (rmino**2+rmini**2)
         rmixo7 = rmixo**7
         ao = emixo * rmixo7
         emixh = 4.0d0 * epsh * epsi / ((sqrt(epsh)+sqrt(epsi))**2)
         rmixh = 2.0d0 * (rminh**3+rmini**3) / (rminh**2+rmini**2)
         rmixh7 = rmixh**7
         ah = emixh * rmixh7
         rio = 0.5d0*rmixo + dspoff
         rih = 0.5d0*rmixh + dspoff
c
c     remove contribution due to solvent displaced by solute atoms
c
         xi = x(i)
         yi = y(i)
         zi = z(i)
         sum = 0.0d0
         do k = 1, n
            if (i .ne. k) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               r = sqrt(r2)
               r3 = r * r2
               rk = raddsp(k)
               sk = rk * shctd
               sk2 = sk * sk
               de = 0.0d0
               if (rio .lt. r+sk) then
                  rmax = max(rio,r-sk)
                  lik = rmax
                  if (lik .lt. rmixo) then
                     lik2 = lik * lik
                     lik3 = lik2 * lik
                     lik4 = lik3 * lik
                     uik = min(r+sk,rmixo)
                     uik2 = uik * uik
                     uik3 = uik2 * uik
                     uik4 = uik3 * uik
                     term = 4.0d0 * pi / (48.0d0*r)
     &                      * (3.0d0*(lik4-uik4) - 8.0d0*r*(lik3-uik3)
     &                          + 6.0d0*(r2-sk2)*(lik2-uik2))
                     if (rio .gt. r-sk) then
                        dl = -lik2 + 2.0d0*r2 + 2.0d0*sk2
                        dl = dl * lik2
                     else
                        dl = -lik3 + 4.0d0*lik2*r - 6.0d0*lik*r2
     &                          + 2.0d0*lik*sk2 + 4.0d0*r3 - 4.0d0*r*sk2
                        dl = dl * lik
                     end if
                     if (r+sk .gt. rmixo) then
                        du = -uik2 + 2.0d0*r2 + 2.0d0*sk2
                        du = -du * uik2
                     else
                        du = -uik3 + 4.0d0*uik2*r - 6.0d0*uik*r2
     &                          + 2.0d0*uik*sk2 + 4.0d0*r3 - 4.0d0*r*sk2
                        du = -du * uik
                     end if
                     iwca = -emixo * term
                     de = de - emixo*pi*(dl+du)/(4.0d0*r2)
                     sum = sum + iwca
                  end if
                  uik = r + sk
                  if (uik .gt. rmixo) then
                     uik2 = uik * uik
                     uik3 = uik2 * uik
                     uik4 = uik3 * uik
                     uik5 = uik4 * uik
                     uik6 = uik5 * uik
                     uik10 = uik5 * uik5
                     uik11 = uik10 * uik
                     uik12 = uik11 * uik
                     uik13 = uik12 * uik
                     lik = max(rmax,rmixo)
                     lik2 = lik * lik
                     lik3 = lik2 * lik
                     lik4 = lik3 * lik
                     lik5 = lik4 * lik
                     lik6 = lik5 * lik
                     lik10 = lik5 * lik5
                     lik11 = lik10 * lik
                     lik12 = lik11 * lik
                     lik13 = lik12 * lik
                     term = 4.0d0 * pi / (120.0d0*r*lik5*uik5)
     &                      * (15.0d0*uik*lik*r*(uik4-lik4)
     &                         - 10.0d0*uik2*lik2*(uik3-lik3)
     &                         + 6.0d0*(sk2-r2)*(uik5-lik5))
                     if (rio.gt.r-sk .or. rmax.lt.rmixo) then
                        dl = -5.0d0*lik2 + 3.0d0*r2 + 3.0d0*sk2
                        dl = -dl / lik5
                     else
                        dl = 5.0d0*lik3 - 33.0d0*lik*r2 - 3.0d0*lik*sk2
     &                          + 15.0d0*(lik2*r+r3-r*sk2)
                        dl = dl / lik6
                     end if
                     du = 5.0d0*uik3 - 33.0d0*uik*r2 - 3.0d0*uik*sk2
     &                       + 15.0d0*(uik2*r+r3-r*sk2)
                     du = -du / uik6
                     idisp = -2.0d0 * ao * term
                     de = de -2.0d0*ao*pi*(dl + du)/(15.0d0*r2)
                     term = 4.0d0 * pi / (2640.0d0*r*lik12*uik12)
     &                      * (120.0d0*uik*lik*r*(uik11-lik11)
     &                         - 66.0d0*uik2*lik2*(uik10-lik10)
     &                         + 55.0d0*(sk2-r2)*(uik12-lik12))
                     if (rio.gt.r-sk .or. rmax.lt.rmixo) then
                        dl = -6.0d0*lik2 + 5.0d0*r2 + 5.0d0*sk2
                        dl = -dl / lik12
                     else
                        dl = 6.0d0*lik3 - 125.0d0*lik*r2 - 5.0d0*lik*sk2
     &                          + 60.0d0*(lik2*r+r3-r*sk2)
                        dl = dl / lik13
                     end if
                     du = 6.0d0*uik3 - 125.0d0*uik*r2 -5.0d0*uik*sk2
     &                       + 60.0d0*(uik2*r+r3-r*sk2)
                     du = -du / uik13
                     irepl = ao * rmixo7 * term
                     de = de + ao*rmixo7*pi*(dl + du)/(60.0d0*r2)
                     sum = sum + irepl + idisp
                  end if
               end if
               if (rih .lt. r+sk) then
                  rmax = max(rih,r-sk)
                  lik = rmax
                  if (lik .lt. rmixh) then
                     lik2 = lik * lik
                     lik3 = lik2 * lik
                     lik4 = lik3 * lik
                     uik = min(r+sk,rmixh)
                     uik2 = uik * uik
                     uik3 = uik2 * uik
                     uik4 = uik3 * uik
                     term = 4.0d0 * pi / (48.0d0*r)
     &                      * (3.0d0*(lik4-uik4) - 8.0d0*r*(lik3-uik3)
     &                          + 6.0d0*(r2-sk2)*(lik2-uik2))
                     if (rih .gt. r-sk) then
                        dl = -lik2 + 2.0d0*r2 + 2.0d0*sk2
                        dl = dl * lik2
                     else
                        dl = -lik3 + 4.0d0*lik2*r - 6.0d0*lik*r2
     &                          + 2.0d0*lik*sk2 + 4.0d0*r3 - 4.0d0*r*sk2
                        dl = dl * lik
                     end if
                     if (r+sk .gt. rmixh) then
                        du = -uik2 + 2.0d0*r2 + 2.0d0*sk2
                        du = -du * uik2
                     else
                        du = -uik3 + 4.0d0*uik2*r - 6.0d0*uik*r2
     &                          + 2.0d0*uik*sk2 + 4.0d0*r3 - 4.0d0*r*sk2
                        du = -du * uik
                     end if
                     iwca = -2.0d0 * emixh * term
                     de = de - 2.0d0*emixh*pi*(dl+du)/(4.0d0*r2)
                     sum = sum + iwca
                  end if
                  uik = r + sk
                  if (uik .gt. rmixh) then
                     uik2 = uik * uik
                     uik3 = uik2 * uik
                     uik4 = uik3 * uik
                     uik5 = uik4 * uik
                     uik6 = uik5 * uik
                     uik10 = uik5 * uik5
                     uik11 = uik10 * uik
                     uik12 = uik11 * uik
                     uik13 = uik12 * uik
                     lik = max(rmax,rmixh)
                     lik2 = lik * lik
                     lik3 = lik2 * lik
                     lik4 = lik3 * lik
                     lik5 = lik4 * lik
                     lik6 = lik5 * lik
                     lik10 = lik5 * lik5
                     lik11 = lik10 * lik
                     lik12 = lik11 * lik
                     lik13 = lik12 * lik
                     term = 4.0d0 * pi / (120.0d0*r*lik5*uik5)
     &                      * (15.0d0*uik*lik*r*(uik4-lik4)
     &                         - 10.0d0*uik2*lik2*(uik3-lik3)
     &                         + 6.0d0*(sk2-r2)*(uik5-lik5))
                     if (rih.gt.r-sk .or. rmax.lt.rmixh) then
                        dl = -5.0d0*lik2 + 3.0d0*r2 + 3.0d0*sk2
                        dl = -dl / lik5
                     else
                        dl = 5.0d0*lik3 - 33.0d0*lik*r2 - 3.0d0*lik*sk2
     &                          + 15.0d0*(lik2*r+r3-r*sk2)
                        dl = dl / lik6
                     end if
                     du = 5.0d0*uik3 - 33.0d0*uik*r2 - 3.0d0*uik*sk2
     &                       + 15.0d0*(uik2*r+r3-r*sk2)
                     du = -du / uik6
                     idisp = -4.0d0 * ah * term
                     de = de - 4.0d0*ah*pi*(dl + du)/(15.0d0*r2)
                     term = 4.0d0 * pi / (2640.0d0*r*lik12*uik12)
     &                      * (120.0d0*uik*lik*r*(uik11-lik11)
     &                         - 66.0d0*uik2*lik2*(uik10-lik10)
     &                         + 55.0d0*(sk2-r2)*(uik12-lik12))
                     if (rih.gt.r-sk .or. rmax.lt.rmixh) then
                        dl = -6.0d0*lik2 + 5.0d0*r2 + 5.0d0*sk2
                        dl = -dl / lik12
                     else
                        dl = 6.0d0*lik3 - 125.0d0*lik*r2 - 5.0d0*lik*sk2
     &                          + 60.0d0*(lik2*r+r3-r*sk2)
                        dl = dl / lik13
                     end if
                     du = 6.0d0*uik3 - 125.0d0*uik*r2 -5.0d0*uik*sk2
     &                       + 60.0d0*(uik2*r+r3-r*sk2)
                     du = -du / uik13
                     irepl = 2.0d0 * ah * rmixh7 * term
                     de = de + ah*rmixh7*pi*(dl+du)/(30.0d0*r2)
                     sum = sum + irepl + idisp
                  end if
               end if
c
c     increment the individual dispersion gradient components
c
               de = -de/r * slevy * awater
               dedx = de * xr
               dedy = de * yr
               dedz = de * zr
               des(1,i) = des(1,i) + dedx
               des(2,i) = des(2,i) + dedy
               des(3,i) = des(3,i) + dedz
               des(1,k) = des(1,k) - dedx
               des(2,k) = des(2,k) - dedy
               des(3,k) = des(3,k) - dedz
            end if
         end do
c
c     increment the overall dispersion energy component
c
         e = cdsp(i) - slevy*awater*sum
         edisp = edisp + e
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ehpmf1  --  HPMF nonpolar solvation and derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ehpmf1" calculates the hydrophobic potential of mean force
c     energy and first derivatives using a pairwise double loop
c
c     literature reference:
c
c     M. S. Lin, N. L. Fawzi and T. Head-Gordon, "Hydrophobic
c     Potential of Mean Force as a Solvation Function for Protein
c     Structure Prediction", Structure, 15, 727-740 (2007)
c
c
      subroutine ehpmf1 (ehp)
      use atomid
      use atoms
      use couple
      use deriv
      use hpmf
      use math
      implicit none
      integer i,j,k,m
      integer ii,jj,kk
      integer sschk
      integer, allocatable :: omit(:)
      real*8 xi,yi,zi
      real*8 xk,yk,zk
      real*8 xr,yr,zr
      real*8 e,ehp,r,r2
      real*8 rsurf,pisurf
      real*8 hpmfcut2
      real*8 saterm,sasa
      real*8 rbig,rsmall
      real*8 part,cutv
      real*8 t1a,t1b
      real*8 e1,e2,e3,sum
      real*8 arg1,arg2,arg3
      real*8 arg12,arg22,arg32
      real*8 de1,de2,de3,dsum
      real*8 sumi,sumj,term
      real*8 dedx,dedy,dedz
      real*8, allocatable :: cutmtx(:)
      real*8, allocatable :: dcutmtx(:)
      real*8, allocatable :: dacsa(:,:)
c
c
c     zero out the hydrophobic potential of mean force energy
c
      ehp = 0.0d0
c
c     set some values needed during the HPMF calculation
c
      rsurf = rcarbon + 2.0d0*rwater
      pisurf = pi * (rcarbon+rwater)
      hpmfcut2 = hpmfcut * hpmfcut
c
c     perform dynamic allocation of some local arrays
c
      allocate (omit(n))
      allocate (cutmtx(n))
      allocate (dcutmtx(n))
      allocate (dacsa(n,npmf))
c
c     get the surface area and derivative terms for each atom
c
      do ii = 1, npmf
         i = ipmf(ii)
         saterm = acsa(i)
         sasa = 1.0d0
         do k = 1, n
            if (i .ne. k) then
               xr = x(i) - x(k)
               yr = y(i) - y(k)
               zr = z(i) - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               rbig = rpmf(k) + rsurf
               if (r2 .le. rbig*rbig) then
                  r = sqrt(r2)
                  rsmall = rpmf(k) - rcarbon
                  part = pisurf * (rbig-r) * (1.0d0+rsmall/r)
                  sasa = sasa * (1.0d0-saterm*part)
               end if
            end if
         end do
         sasa = acsurf * sasa
         cutv = tanh(tgrad*(sasa-toffset))
         cutmtx(i) = 0.5d0 * (1.0d0+cutv)
         dcutmtx(i) = 0.5d0 * tgrad * (1.0d0-cutv*cutv)
         do k = 1, n
            dacsa(k,ii) = 0.0d0
            if (i .ne. k) then
               xr = x(i) - x(k)
               yr = y(i) - y(k)
               zr = z(i) - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               rbig = rpmf(k) + rsurf
               if (r2 .le. rbig*rbig) then
                  r = sqrt(r2)
                  rsmall = rpmf(k) - rcarbon
                  part = pisurf * (rbig-r) * (1.0d0+rsmall/r)
                  t1b = -pisurf * (1.0d0+rbig*rsmall/r2)
                  t1a = -sasa / (1.0d0/saterm-part)
                  dacsa(k,ii) = t1a * t1b / r
               end if
            end if
         end do
      end do
c
c     find the hydrophobic PMF energy and derivs via a double loop
c
      do i = 1, n
         omit(i) = 0
      end do
      do ii = 1, npmf-1
         i = ipmf(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         sschk = 0
         do j = 1, n12(i)
            k = i12(j,i)
            omit(k) = i
            if (atomic(k) .eq. 16)  sschk = k
         end do
         do j = 1, n13(i)
            k = i13(j,i)
            omit(k) = i
         end do
         do j = 1, n14(i)
            k = i14(j,i)
            omit(k) = i
            if (sschk .ne. 0) then
               do jj = 1, n12(k)
                  m = i12(jj,k)
                  if (atomic(m) .eq. 16) then
                     do kk = 1, n12(m)
                        if (i12(kk,m) .eq. sschk)  omit(k) = 0
                     end do
                  end if
               end do
            end if
         end do
         do kk = ii+1, npmf
            k = ipmf(kk)
            xk = x(k)
            yk = y(k)
            zk = z(k)
            if (omit(k) .ne. i) then
               xr = xi - xk
               yr = yi - yk
               zr = zi - zk
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. hpmfcut2) then
                  r = sqrt(r2)
                  arg1 = (r-hc1) * hw1
                  arg12 = arg1 * arg1
                  arg2 = (r-hc2) * hw2
                  arg22 = arg2 * arg2
                  arg3 = (r-hc3) * hw3
                  arg32 = arg3 * arg3
                  e1 = hd1 * exp(-arg12)
                  e2 = hd2 * exp(-arg22)
                  e3 = hd3 * exp(-arg32)
                  sum = e1 + e2 + e3
                  e = sum * cutmtx(i) * cutmtx(k)
                  ehp = ehp + e
c
c     first part of hydrophobic PMF derivative calculation
c
                  de1 = -2.0d0 * e1 * arg1 * hw1
                  de2 = -2.0d0 * e2 * arg2 * hw2
                  de3 = -2.0d0 * e3 * arg3 * hw3
                  dsum = (de1+de2+de3) * cutmtx(i) * cutmtx(k) / r
                  dedx = dsum * xr
                  dedy = dsum * yr
                  dedz = dsum * zr
                  des(1,i) = des(1,i) + dedx
                  des(2,i) = des(2,i) + dedy
                  des(3,i) = des(3,i) + dedz
                  des(1,k) = des(1,k) - dedx
                  des(2,k) = des(2,k) - dedy
                  des(3,k) = des(3,k) - dedz
c
c     second part of hydrophobic PMF derivative calculation
c
                  sumi = sum * cutmtx(k) * dcutmtx(i)
                  sumj = sum * cutmtx(i) * dcutmtx(k)
                  if (sumi .ne. 0.0d0) then
                     do j = 1, n
                        if (dacsa(j,ii) .ne. 0.0d0) then
                           term = sumi * dacsa(j,ii)
                           dedx = term * (xi-x(j))
                           dedy = term * (yi-y(j))
                           dedz = term * (zi-z(j))
                           des(1,i) = des(1,i) + dedx
                           des(2,i) = des(2,i) + dedy
                           des(3,i) = des(3,i) + dedz
                           des(1,j) = des(1,j) - dedx
                           des(2,j) = des(2,j) - dedy
                           des(3,j) = des(3,j) - dedz
                        end if
                     end do
                  end if
                  if (sumj .ne. 0.0d0) then
                     do j = 1, n
                        if (dacsa(j,kk) .ne. 0.0d0) then
                           term = sumj * dacsa(j,kk)
                           dedx = term * (xk-x(j))
                           dedy = term * (yk-y(j))
                           dedz = term * (zk-z(j))
                           des(1,k) = des(1,k) + dedx
                           des(2,k) = des(2,k) + dedy
                           des(3,k) = des(3,k) + dedz
                           des(1,j) = des(1,j) - dedx
                           des(2,j) = des(2,j) - dedy
                           des(3,j) = des(3,j) - dedz
                        end if
                     end do
                  end if
               end if
            end if
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (omit)
      deallocate (cutmtx)
      deallocate (dcutmtx)
      deallocate (dacsa)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine esolv2  --  atom-by-atom solvation Hessian  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "esolv2" calculates second derivatives of the implicit
c     solvation energy for surface area, generalized Born,
c     generalized Kirkwood and Poisson-Boltzmann solvation models
c
c
      subroutine esolv2 (i)
      use mpole
      use potent
      use solpot
      use warp
      implicit none
      integer i
      real*8 probe
c     real*8, allocatable :: aes(:)
c     real*8, allocatable :: des(:,:)
c
c
c     set a value for the solvent molecule probe radius
c
      probe = 1.4d0
c
c     perform dynamic allocation of some local arrays
c
c     allocate (aes(n))
c     allocate (des(3,n))
c
c     compute the surface area-based solvation energy term
c
c     call surface1 (rsolv,asolv,probe,es,aes,des)
c
c     perform deallocation of some local arrays
c
c     deallocate (aes)
c     deallocate (des)
c
c     setup for generalized Kirkwood solvation only calculation
c
      if (solvtyp(1:2) .eq. 'GK') then
         if (.not.use_mpole .and. .not.use_polar) then
            call chkpole
            call rotpole ('MPOLE')
            call induce
         end if
      end if
c
c     get the electrostatic Hessian for GB/SA solvation
c
      if (use_born .and. solvtyp(1:2).ne.'GK') then
         if (use_smooth) then
            call egb2b (i)
         else
            call egb2a (i)
         end if
c
c     get full finite difference Hessian for other models
c
      else
         call esolv2a (i)
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine esolv2a  --  implicit solvation Hessian matrix  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "esolv2a" calculates second derivatives of the implicit solvation
c     potential energy by finite differences
c
c
      subroutine esolv2a (i)
      use atoms
      use charge
      use deriv
      use hessn
      use mpole
      use potent
      use solpot
      implicit none
      integer i,j,k,kk
      integer nlist
      integer, allocatable :: list(:)
      real*8 eps,old
      real*8, allocatable :: d0(:,:)
      logical prior
      logical biglist
      logical reborn
      logical reinduce
      logical twosided
c
c
c     set the default stepsize and flag for induced dipoles
c
      eps = 1.0d-5
      biglist = .false.
      reborn = .false.
      reinduce = .false.
      twosided = .false.
      if (n .le. 300) then
         biglist = .true.
         if (use_born)  reborn = .true.
         if (use_mpole .or. use_polar)  reinduce = .true.
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
      allocate (d0(3,n))
c
c     perform dynamic allocation of some global arrays
c
      prior = .false.
      if (allocated(des)) then
         prior = .true.
         if (size(des) .lt. 3*n) then
            deallocate (des)
         end if
      end if
      if (.not. allocated(des))  allocate (des(3,n))
c
c     optionally restrict calculation to current atom and any
c     auxiliaries; results in a faster but approximate Hessian
c
      nlist = 0
      if (biglist) then
         nlist = n
         do k = 1, n
            list(k) = k
         end do
      else
         if (use_born .and. solvtyp(1:2).ne.'GK') then
            do kk = 1, nion
               k = iion(kk)
               if (k .eq. i) then
                  nlist = nlist + 1
                  list(nlist) = k
               end if
            end do
         else if (solvtyp(1:2) .eq. 'GK') then
            do kk = 1, npole
               k = ipole(kk)
               if (k.eq.i .or. zaxis(k).eq.i .or. xaxis(k).eq.i
     &                .or. abs(yaxis(k)).eq.i) then
                  nlist = nlist + 1
                  list(nlist) = k
               end if
            end do
         else
            nlist = 1
            list(1) = i
         end if
      end if
c
c     get solvation first derivatives for the base structure
c
      if (.not. twosided) then
         call esolv2b (nlist,list,reborn,reinduce)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = des(j,k)
            end do
         end do
      end if
c
c     find numerical x-components via perturbed structures
c
      old = x(i)
      if (twosided) then
         x(i) = x(i) - 0.5d0*eps
         call esolv2b (nlist,list,reborn,reinduce)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = des(j,k)
            end do
         end do
      end if
      x(i) = x(i) + eps
      call esolv2b (nlist,list,reborn,reinduce)
      x(i) = old
      do k = 1, n
         do j = 1, 3
            hessx(j,k) = hessx(j,k) + (des(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical y-components via perturbed structures
c
      old = y(i)
      if (twosided) then
         y(i) = y(i) - 0.5d0*eps
         call esolv2b (nlist,list,reborn,reinduce)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = des(j,k)
            end do
         end do
      end if
      y(i) = y(i) + eps
      call esolv2b (nlist,list,reborn,reinduce)
      y(i) = old
      do k = 1, n
         do j = 1, 3
            hessy(j,k) = hessy(j,k) + (des(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical z-components via perturbed structures
c
      old = z(i)
      if (twosided) then
         z(i) = z(i) - 0.5d0*eps
         call esolv2b (nlist,list,reborn,reinduce)
         do k = 1, n
            do j = 1, 3
               d0(j,k) = des(j,k)
            end do
         end do
      end if
      z(i) = z(i) + eps
      call esolv2b (nlist,list,reborn,reinduce)
      z(i) = old
      do k = 1, n
         do j = 1, 3
            hessz(j,k) = hessz(j,k) + (des(j,k)-d0(j,k))/eps
         end do
      end do
c
c     perform deallocation of some global arrays
c
      if (.not. prior) then
         deallocate (des)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (d0)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine esolv2b  --  finite diffs implicit solvation  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "esolv2b" finds implicit solvation gradients needed for
c     calculation of the Hessian matrix by finite differences
c
c
      subroutine esolv2b (nlist,list,reborn,reinduce)
      use mpole
      implicit none
      integer nlist
      integer list(*)
      logical reborn
      logical reinduce
c
c
c     get implicit solvation gradient for finite differences
c
      if (reborn)  call born
      if (reinduce) then
         call chkpole
         call rotpole ('MPOLE')
         call induce
      end if     
      call esolv1
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine egb2a  --  atom-by-atom GB solvation Hessian  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "egb2a" calculates second derivatives of the generalized
c     Born energy term for the GB/SA solvation models
c
c     note this version does not contain the chain rule terms
c     for derivatives of Born radii with respect to coordinates
c
c
      subroutine egb2a (i)
      use atoms
      use charge
      use chgpot
      use hessn
      use shunt
      use solute
      implicit none
      integer i,j,k,kk
      real*8 e,de,d2e
      real*8 fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7
      real*8 dwater,rb2,rm2
      real*8 expterm,shift
      real*8 d2edx,d2edy,d2edz
      real*8 taper,dtaper,d2taper
      real*8 trans,dtrans,d2trans
      real*8 fgb,fgb2,dfgb
      real*8 dfgb2,d2fgb
      real*8 term(3,3)
      character*6 mode
c
c
c     first see if the atom of interest carries a charge
c
      do kk = 1, nion
         k = iion(kk)
         if (k .eq. i) then
            fi = pchg(k)
            goto 10
         end if
      end do
      return
   10 continue
c
c     store the coordinates of the atom of interest
c
      xi = x(i)
      yi = y(i)
      zi = z(i)
c
c     set the solvent dielectric and energy conversion factor
c
      dwater = 78.3d0
      fi = -electric * (1.0d0 - 1.0d0/dwater) * fi
c
c     set cutoff distances and switching function coefficients
c
      mode = 'CHARGE'
      call switch (mode)
c
c     calculate GB polarization energy Hessian elements
c
      do kk = 1, nion
         k = iion(kk)
         if (i .ne. k) then
            xr = xi - x(k)
            yr = yi - y(k)
            zr = zi - z(k)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               fik = fi * pchg(k)
c
c     compute chain rule terms for Hessian matrix elements
c
               rb2 = rborn(i) * rborn(k)
               expterm = exp(-0.25d0*r2/rb2)
               fgb2 = r2 + rb2*expterm
               fgb = sqrt(fgb2)
               dfgb = (1.0d0-0.25d0*expterm) * r / fgb
               dfgb2 = dfgb * dfgb
               d2fgb = -dfgb2/fgb + dfgb/r
     &                    + 0.125d0*(r2/rb2)*expterm/fgb
               de = -fik * dfgb / fgb2
               d2e = -fik * (d2fgb-2.0d0*dfgb2/fgb) / fgb2
c
c     use energy switching if near the cutoff distance
c
               if (r2 .gt. cut2) then
                  e = fik / fgb
                  rm2 = (0.5d0 * (off+cut))**2
                  shift = fik / sqrt(rm2 + rb2*exp(-0.25d0*rm2/rb2))
                  e = e - shift
                  r3 = r2 * r
                  r4 = r2 * r2
                  r5 = r2 * r3
                  r6 = r3 * r3
                  r7 = r3 * r4
                  taper = c5*r5 + c4*r4 + c3*r3 + c2*r2 + c1*r + c0
                  dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                        + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                  d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2
     &                         + 6.0d0*c3*r + 2.0d0*c2
                  trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4
     &                            + f3*r3 + f2*r2 + f1*r + f0)
                  dtrans = fik * (7.0d0*f7*r6 + 6.0d0*f6*r5
     &                            + 5.0d0*f5*r4 + 4.0d0*f4*r3
     &                            + 3.0d0*f3*r2 + 2.0d0*f2*r + f1)
                  d2trans = fik * (42.0d0*f7*r5 + 30.0d0*f6*r4
     &                             + 20.0d0*f5*r3 + 12.0d0*f4*r2
     &                             + 6.0d0*f3*r + 2.0d0*f2)
                  d2e = e*d2taper + 2.0d0*de*dtaper
     &                     + d2e*taper + d2trans
                  de = e*dtaper + de*taper + dtrans
               end if
c
c     form the individual Hessian element components
c
               de = de / r
               d2e = (d2e-de) / r2
               d2edx = d2e * xr
               d2edy = d2e * yr
               d2edz = d2e * zr
               term(1,1) = d2edx*xr + de
               term(1,2) = d2edx*yr
               term(1,3) = d2edx*zr
               term(2,1) = term(1,2)
               term(2,2) = d2edy*yr + de
               term(2,3) = d2edy*zr
               term(3,1) = term(1,3)
               term(3,2) = term(2,3)
               term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
               do j = 1, 3
                  hessx(j,i) = hessx(j,i) + term(1,j)
                  hessy(j,i) = hessy(j,i) + term(2,j)
                  hessz(j,i) = hessz(j,i) + term(3,j)
                  hessx(j,k) = hessx(j,k) - term(1,j)
                  hessy(j,k) = hessy(j,k) - term(2,j)
                  hessz(j,k) = hessz(j,k) - term(3,j)
               end do
            end if
         end if
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine egb2b  --  GB solvation Hessian for smoothing  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "egb2b" calculates second derivatives of the generalized
c     Born energy term for the GB/SA solvation models for use with
c     potential smoothing methods
c
c     note this version does not contain the chain rule terms
c     for derivatives of Born radii with respect to coordinates
c
c
      subroutine egb2b (i)
      use atoms
      use charge
      use chgpot
      use hessn
      use math
      use solute
      use warp
      implicit none
      integer i,j,k,kk
      real*8 fi,fik,de,d2e
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 dwater,width
      real*8 r,r2,rb2
      real*8 fgb,fgb2
      real*8 dfgb,dfgb2,d2fgb
      real*8 d2edx,d2edy,d2edz
      real*8 sterm,expterm
      real*8 erf,erfterm
      real*8 term(3,3)
      external erf
c
c
c     first see if the atom of interest carries a charge
c
      do kk = 1, nion
         k = iion(kk)
         if (k .eq. i) then
            fi = pchg(k)
            goto 10
         end if
      end do
      return
   10 continue
c
c     store the coordinates of the atom of interest
c
      xi = x(i)
      yi = y(i)
      zi = z(i)
c
c     set the solvent dielectric and energy conversion factor
c
      dwater = 78.3d0
      fi = -electric * (1.0d0 - 1.0d0/dwater) * fi
c
c     set the extent of smoothing to be performed
c
      sterm = 0.5d0 / sqrt(diffc)
c
c     calculate GB polarization energy Hessian elements
c
      do kk = 1, nion
         k = iion(kk)
         if (i .ne. k) then
            xr = xi - x(k)
            yr = yi - y(k)
            zr = zi - z(k)
            r2 = xr*xr + yr*yr + zr*zr
            r = sqrt(r2)
            fik = fi * pchg(k)
c
c     compute chain rule terms for Hessian matrix elements
c
            rb2 = rborn(i) * rborn(k)
            expterm = exp(-0.25d0*r2/rb2)
            fgb2 = r2 + rb2*expterm
            fgb = sqrt(fgb2)
            dfgb = (1.0d0-0.25d0*expterm) * r / fgb
            dfgb2 = dfgb * dfgb
            d2fgb = -dfgb2/fgb + dfgb/r
     &                 + 0.125d0*(r2/rb2)*expterm/fgb
            de = -fik * dfgb / fgb2
            d2e = -fik * (d2fgb-2.0d0*dfgb2/fgb) / fgb2
c
c     use a smoothable GB analogous to the Coulomb solution
c
            if (deform .gt. 0.0d0) then
               width = deform + 0.15d0*rb2*exp(-0.006d0*rb2/deform)
               width = sterm / sqrt(width)
               erfterm = erf(width*fgb)
               expterm = width * exp(-(width*fgb)**2) / rootpi
               de = de * (erfterm-2.0d0*expterm*fgb)
               d2e = d2e*erfterm + 2.0d0*fik*expterm
     &                  * (d2fgb/fgb-2.0d0*dfgb2*(1.0d0/fgb2+width**2))
            end if
c
c     form the individual Hessian element components
c
            de = de / r
            d2e = (d2e-de) / r2
            d2edx = d2e * xr
            d2edy = d2e * yr
            d2edz = d2e * zr
            term(1,1) = d2edx*xr + de
            term(1,2) = d2edx*yr
            term(1,3) = d2edx*zr
            term(2,1) = term(1,2)
            term(2,2) = d2edy*yr + de
            term(2,3) = d2edy*zr
            term(3,1) = term(1,3)
            term(3,2) = term(2,3)
            term(3,3) = d2edz*zr + de
c
c     increment diagonal and off-diagonal Hessian elements
c
            do j = 1, 3
               hessx(j,i) = hessx(j,i) + term(1,j)
               hessy(j,i) = hessy(j,i) + term(2,j)
               hessz(j,i) = hessz(j,i) + term(3,j)
               hessx(j,k) = hessx(j,k) - term(1,j)
               hessy(j,k) = hessy(j,k) - term(2,j)
               hessz(j,k) = hessz(j,k) - term(3,j)
            end do
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine esolv3  --  solvation energy and analysis  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "esolv3" calculates the implicit solvation energy for
c     surface area, generalized Born, generalized Kirkwood
c     and Poisson-Boltzmann solvation models; also partitions
c     the energy among the atoms
c
c
      subroutine esolv3
      use action
      use analyz
      use atomid
      use atoms
      use energi
      use inform
      use iounit
      use limits
      use math
      use mpole
      use potent
      use solpot
      use solute
      use warp
      implicit none
      integer i,nehp
      real*8 e,ai,ri,rb
      real*8 term,probe
      real*8 esurf,ehp,eace
      real*8 ecav,edisp
      real*8, allocatable :: aecav(:)
      real*8, allocatable :: aedisp(:)
      real*8, allocatable :: aehp(:)
      real*8, allocatable :: aenp(:)
      logical header,huge
c
c
c     zero out the implicit solvation energy and partitioning
c
      nes = 0
      do i = 1, n
         aes(i) = 0.0d0
      end do
      es = 0.0d0
      esurf = 0.0d0
      ecav = 0.0d0
      edisp = 0.0d0
      ehp = 0.0d0
      eace = 0.0d0
c
c     set a value for the solvent molecule probe radius
c
      probe = 1.4d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (aecav(n))
      allocate (aedisp(n))
      allocate (aehp(n))
      allocate (aenp(n))
c
c     total solvation energy for surface area only models
c
      if (solvtyp.eq.'ASP' .or. solvtyp.eq.'SASA') then
         call surface (rsolv,asolv,probe,es,aes)
         nes = nes + n
c
c     nonpolar energy as hydrophobic potential of mean force
c
      else if (solvtyp(4:7) .eq. 'HPMF') then
         call ehpmf3 (ehp,nehp,aehp)
         es = ehp
         nes = nes + nehp
         do i = 1, n
            aes(i) = aes(i) + aehp(i)
         end do
c
c     nonpolar energy for Onion GB method via exact area
c
      else if (solvtyp.eq.'GB' .and. borntyp.eq.'ONION') then
         call surface (rsolv,asolv,probe,esurf,aes)
         es = esurf
         nes = nes + n
c
c     nonpolar energy as cavity formation plus dispersion
c
      else if (solvtyp.eq.'GK' .or. solvtyp.eq.'PB') then
         call enp3 (ecav,aecav,edisp,aedisp)
         es = ecav + edisp
         nes = nes + 2*n
         do i = 1, n
            aes(i) = aecav(i) + aedisp(i)
         end do
c
c     nonpolar energy via ACE surface area approximation
c
      else
         term = 4.0d0 * pi
         do i = 1, n
            ai = asolv(i)
            ri = rsolv(i)
            rb = rborn(i)
            if (rb .ne. 0.0d0) then
               e = ai * term * (ri+probe)**2 * (ri/rb)**6
               eace = eace + e
               nes = nes + 1
               aes(i) = aes(i) + e
            end if
         end do
         es = eace
      end if
c
c     store the nonpolar or surface area energy for each atom
c
      do i = 1, n
         aenp(i) = aes(i)
      end do
c
c     get polarization energy term for the solvation methods
c
      if (solvtyp(1:2) .eq. 'GK') then
         if (.not.use_mpole .and. .not.use_polar) then
            call chkpole
            call rotpole ('MPOLE')
            call induce
         end if
         call egk3
      else if (solvtyp(1:2) .eq. 'PB') then
         call epb3
      else if (use_born) then
         if (use_smooth) then
            call egb3c
         else if (use_clist) then
            call egb3b
         else
            call egb3a
         end if
      end if
c
c     print a message if the energy of any interaction is large
c
      header = .true.
      do i = 1, n
         huge = (abs(aes(i)) .gt. 25.0d0)
         if (debug .or. (verbose.and.huge)) then
            if (header) then
               header = .false.
               write (iout,10)
   10          format (/,' Individual Atomic Solvation Energy',
     &                    ' Terms :',
     &                 //,' Type',12x,'Atom Name',20x,'Nonpolar',
     &                    7x,'Polar',6x,'Energy',/)
            end if
            write (iout,20)  i,name(i),aenp(i),aes(i)-aenp(i),aes(i)
   20       format (' Solvate',6x,i7,'-',a3,17x,3f12.4)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (aecav)
      deallocate (aedisp)
      deallocate (aehp)
      deallocate (aenp)
c
c     print nonpolar and electrostatic components for selected models
c
      if (verbose) then
         if (solvtyp.eq.'ASP' .or. solvtyp.eq.'SASA') then
            write (iout,30)  esurf,es-esurf
   30       format (/,' Implicit Solvation Energy Components :'
     &              //,' SA Nonpolar',25x,f12.4,
     &              /,' Electrostatic',23x,f12.4)
         else if (solvtyp(4:7) .eq. 'HPMF') then
            write (iout,40)  ehp,es-ehp
   40       format (/,' Implicit Solvation Energy Components :'
     &              //,' Hydrophobic PMF',21x,f12.4,
     &              /,' Electrostatic',23x,f12.4)
         else if (solvtyp.eq.'GB' .and. borntyp.eq.'ONION') then
            write (iout,50)  esurf,es-esurf
   50       format (/,' Implicit Solvation Energy Components :'
     &              //,' SA Nonpolar',25x,f12.4,
     &              /,' Electrostatic',23x,f12.4)
         else if (solvtyp.eq.'GK' .or. solvtyp.eq.'PB') then
            write (iout,60)  ecav,edisp,es-ecav-edisp
   60       format (/,' Implicit Solvation Energy Components :'
     &              //,' Cavitation',26x,f12.4,
     &              /,' Dispersion',26x,f12.4,
     &              /,' Electrostatic',23x,f12.4)
         else
            write (iout,70)  eace,es-eace
   70       format (/,' Implicit Solvation Energy Components :'
     &              //,' ACE Nonpolar',24x,f12.4,
     &              /,' Electrostatic',23x,f12.4)
         end if
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine egb3a  --  GB polarization analysis via loop  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "egb3a" calculates the generalized Born electrostatic energy
c     for GB/SA solvation models using a pairwise double loop; also
c     partitions the energy among the atoms
c
c
      subroutine egb3a
      use action
      use analyz
      use atoms
      use charge
      use chgpot
      use energi
      use group
      use inter
      use molcul
      use shunt
      use solute
      use usage
      implicit none
      integer i,k,ii,kk
      real*8 e,f,fi,fik
      real*8 dwater,fgrp
      real*8 rbi,rb2,rm2
      real*8 fgb,fgm
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7
      real*8 shift,taper,trans
      logical proceed,usei
      character*6 mode
c
c
c     set the solvent dielectric and energy conversion factor
c
      if (nion .eq. 0)  return
      dwater = 78.3d0
      f = -electric * (1.0d0 - 1.0d0/dwater)
c
c     set cutoff distances and switching function coefficients
c
      mode = 'CHARGE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,use,x,y,z,
!$OMP& f,pchg,rborn,use_group,off,off2,cut,cut2,molcule,
!$OMP& c0,c1,c2,c3,c4,c5,f0,f1,f2,f3,f4,f5,f6,f7)
!$OMP& shared(es,nes,aes,einter)
!$OMP DO reduction(+:es,nes,aes,einter)
c
c     calculate GB electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         usei = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         rbi = rborn(i)
c
c     decide whether to compute the current interaction
c
         do kk = ii, nion
            k = iion(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  fik = fi * pchg(k)
                  rb2 = rbi * rborn(k)
                  fgb = sqrt(r2 + rb2*exp(-0.25d0*r2/rb2))
                  e = fik / fgb
c
c     use shifted energy switching if near the cutoff distance
c
                  rm2 = (0.5d0 * (off+cut))**2
                  fgm = sqrt(rm2 + rb2*exp(-0.25d0*rm2/rb2))
                  shift = fik / fgm
                  e = e - shift
                  if (r2 .gt. cut2) then
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     r6 = r3 * r3
                     r7 = r3 * r4
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4
     &                               + f3*r3 + f2*r2 + f1*r + f0)
                     e = e*taper + trans
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall GB polarization energy component
c
                  nes = nes + 1
                  if (i .eq. k) then
                     es = es + 0.5d0*e
                     aes(i) = aes(i) + 0.5d0*e
                  else
                     es = es + e
                     aes(i) = aes(i) + 0.5d0*e
                     aes(k) = aes(k) + 0.5d0*e
                  end if
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
               end if
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine egb3b  --  GB polarization analysis via list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "egb3b" calculates the generalized Born electrostatic energy
c     for GB/SA solvation models using a pairwise neighbor list; also
c     partitions the energy among the atoms
c
c
      subroutine egb3b
      use action
      use analyz
      use atoms
      use charge
      use chgpot
      use energi
      use group
      use inter
      use molcul
      use neigh
      use shunt
      use solute
      use usage
      implicit none
      integer i,k,ii,kk
      real*8 e,f,fi,fik
      real*8 dwater,fgrp
      real*8 rbi,rb2,rm2
      real*8 fgb,fgm
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7
      real*8 shift,taper,trans
      logical proceed,usei
      character*6 mode
c
c
c     set the solvent dielectric and energy conversion factor
c
      if (nion .eq. 0)  return
      dwater = 78.3d0
      f = -electric * (1.0d0 - 1.0d0/dwater)
c
c     set cutoff distances and switching function coefficients
c
      mode = 'CHARGE'
      call switch (mode)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,use,x,y,z,
!$OMP& f,pchg,rborn,nelst,elst,use_group,off,off2,cut,cut2,
!$OMP& molcule,c0,c1,c2,c3,c4,c5,f0,f1,f2,f3,f4,f5,f6,f7)
!$OMP& shared(es,nes,aes,einter)
!$OMP DO reduction(+:es,nes,aes,einter)
c
c     calculate GB electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         usei = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         rbi = rborn(i)
c
c     calculate the self-energy term for the current atom
c
         fik = fi * pchg(i)
         rb2 = rbi * rbi
         e = fik / rbi
         rm2 = (0.5d0 * (off+cut))**2
         fgm = sqrt(rm2 + rb2*exp(-0.25d0*rm2/rb2))
         shift = fik / fgm
         e = e - shift
         nes = nes + 1
         es = es + 0.5d0*e
         aes(i) = aes(i) + 0.5d0*e
c
c     decide whether to compute the current interaction
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  fik = fi * pchg(k)
                  rb2 = rbi * rborn(k)
                  fgb = sqrt(r2 + rb2*exp(-0.25d0*r2/rb2))
                  e = fik / fgb
c
c     use shifted energy switching if near the cutoff distance
c
                  rm2 = (0.5d0 * (off+cut))**2
                  fgm = sqrt(rm2 + rb2*exp(-0.25d0*rm2/rb2))
                  shift = fik / fgm
                  e = e - shift
                  if (r2 .gt. cut2) then
                     r = sqrt(r2)
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     r6 = r3 * r3
                     r7 = r3 * r4
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4
     &                               + f3*r3 + f2*r2 + f1*r + f0)
                     e = e*taper + trans
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall GB polarization energy component
c
                  nes = nes + 1
                  es = es + e
                  aes(i) = aes(i) + 0.5d0*e
                  aes(k) = aes(k) + 0.5d0*e
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
               end if
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine egb3c  --  GB energy and analysis for smoothing  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "egb3c" calculates the generalized Born electrostatic energy
c     for GB/SA solvation models for use with potential smoothing
c     methods via analogy to the smoothing of Coulomb's law; also
c     partitions the energy among the atoms
c
c
      subroutine egb3c
      use action
      use analyz
      use atoms
      use charge
      use chgpot
      use energi
      use group
      use inter
      use molcul
      use solute
      use usage
      use warp
      implicit none
      integer i,k,ii,kk
      real*8 e,fgrp
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 dwater,width
      real*8 erf,sterm
      real*8 r2,fgb
      real*8 rbi,rb2
      logical proceed,usei
      external erf
c
c
c     set the solvent dielectric and energy conversion factor
c
      if (nion .eq. 0)  return
      dwater = 78.3d0
      f = -electric * (1.0d0 - 1.0d0/dwater)
c
c     set the extent of smoothing to be performed
c
      sterm = 0.5d0 / sqrt(diffc)
c
c     calculate GB electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         usei = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(i)
         rbi = rborn(i)
c
c     decide whether to compute the current interaction
c
         do kk = ii, nion
            k = iion(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               fik = fi * pchg(k)
               rb2 = rbi * rborn(k)
               fgb = sqrt(r2 + rb2*exp(-0.25d0*r2/rb2))
               e = fik / fgb
c
c     use a smoothable GB analogous to the Coulomb solution
c
               if (deform .gt. 0.0d0) then
                  width = deform + 0.15d0*rb2*exp(-0.006d0*rb2/deform)
                  width = sterm / sqrt(width)
                  e = e * erf(width*fgb)
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the overall GB solvation energy component
c
               nes = nes + 1
               if (i .eq. k) then
                  es = es + 0.5d0*e
                  aes(i) = aes(i) + 0.5d0*e
               else
                  es = es + e
                  aes(i) = aes(i) + 0.5d0*e
                  aes(k) = aes(k) + 0.5d0*e
               end if
c
c     increment the total intermolecular energy
c
               if (molcule(i) .ne. molcule(k)) then
                  einter = einter + e
               end if
            end if
         end do
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine egk3  --  GK polarization energy & analysis  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "egk3" calculates the generalized Kirkwood electrostatic
c     energy for GK/NP solvation models; also partitions the
c     energy among the atoms
c
c
      subroutine egk3
      use energi
      use mpole
      use potent
      implicit none
c
c
c     setup the multipoles for solvation only calculations
c
      if (.not. use_mpole) then
         call chkpole
         call rotpole ('MPOLE')
      end if
c
c     compute the generalized Kirkwood energy and analysis
c
      call egk3a
c
c     correct solvation energy for vacuum to polarized state
c
      if (use_polar) then
         call ediff3
      else if (.not.use_mpole .and. .not.use_polar) then
         call ediff3
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine egk3a  --  find generalized Kirkwood energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "egk3a" calculates the electrostatic portion of the implicit
c     solvation energy via the generalized Kirkwood model; also
c     partitions the energy among the atoms
c
c
      subroutine egk3a
      use action
      use analyz
      use atoms
      use atomid
      use chgpot
      use energi
      use gkstuf
      use group
      use inform
      use inter
      use iounit
      use molcul
      use mpole
      use polar
      use shunt
      use solute
      use usage
      implicit none
      integer i,k,ii,kk
      real*8 e,ei
      real*8 fc,fd,fq
      real*8 dwater,fgrp
      real*8 r2,rb2
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xr2,yr2,zr2
      real*8 ci,ck
      real*8 uxi,uyi,uzi
      real*8 uxk,uyk,uzk
      real*8 dxi,dyi,dzi
      real*8 dxk,dyk,dzk
      real*8 qxxi,qxyi,qxzi
      real*8 qyyi,qyzi,qzzi
      real*8 qxxk,qxyk,qxzk
      real*8 qyyk,qyzk,qzzk
      real*8 rbi,rbk
      real*8 expterm
      real*8 gf,gf2,gf3
      real*8 gf5,gf7,gf9
      real*8 expc,dexpc
      real*8 expc1,expcdexpc
      real*8 a(0:4,0:2)
      real*8 gc(10),gux(10)
      real*8 guy(10),guz(10)
      real*8 gqxx(10),gqxy(10)
      real*8 gqxz(10),gqyy(10)
      real*8 gqyz(10),gqzz(10)
      real*8 esym,ewi,ewk
      real*8 esymi,ewii,ewki
      real*8, allocatable :: eself(:)
      real*8, allocatable :: ecross(:)
      logical proceed,usei
      character*6 mode
c
c
c     set the bulk dielectric constant to the water value
c
      if (npole .le. 0)  return
      dwater = 78.3d0
      fc = electric * 1.0d0 * (1.0d0-dwater)/(0.0d0+1.0d0*dwater)
      fd = electric * 2.0d0 * (1.0d0-dwater)/(1.0d0+2.0d0*dwater)
      fq = electric * 3.0d0 * (1.0d0-dwater)/(2.0d0+3.0d0*dwater)
c
c     set cutoff distances and switching function coefficients
c
      mode = 'MPOLE'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (eself(n))
      allocate (ecross(n))
c
c     initialize variables to accumulate self- and cross-energies
c
      do i = 1, n
         eself(i) = 0.0d0
         ecross(i) = 0.0d0
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,use,x,y,z,
!$OMP& rborn,rpole,uinds,use_group,off2,molcule,gkc,fc,fd,fq)
!$OMP& shared(es,nes,aes,eself,ecross,einter)
!$OMP DO reduction(+:es,nes,aes,eself,ecross,einter)
c
c     calculate GK electrostatic solvation free energy
c
      do ii = 1, npole
         i = ipole(ii)
         usei = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         rbi = rborn(i)
         ci = rpole(1,i)
         uxi = rpole(2,i)
         uyi = rpole(3,i)
         uzi = rpole(4,i)
         qxxi = rpole(5,i)
         qxyi = rpole(6,i)
         qxzi = rpole(7,i)
         qyyi = rpole(9,i)
         qyzi = rpole(10,i)
         qzzi = rpole(13,i)
         dxi = uinds(1,i)
         dyi = uinds(2,i)
         dzi = uinds(3,i)
c
c     decide whether to compute the current interaction
c
         do kk = ii, npole
            k = ipole(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               xr2 = xr * xr
               yr2 = yr * yr
               zr2 = zr * zr
               r2 = xr2 + yr2 + zr2
               if (r2 .le. off2) then
                  rbk = rborn(k)
                  ck = rpole(1,k)
                  uxk = rpole(2,k)
                  uyk = rpole(3,k)
                  uzk = rpole(4,k)
                  qxxk = rpole(5,k)
                  qxyk = rpole(6,k)
                  qxzk = rpole(7,k)
                  qyyk = rpole(9,k)
                  qyzk = rpole(10,k)
                  qzzk = rpole(13,k)
                  dxk = uinds(1,k)
                  dyk = uinds(2,k)
                  dzk = uinds(3,k)
                  rb2 = rbi * rbk
                  expterm = exp(-r2 / (gkc * rb2))
                  expc = expterm / gkc
                  dexpc = -2.0d0/(gkc*rbi*rbk)
                  gf2 = 1.0d0 / (r2 + rb2*expterm)
                  gf = sqrt(gf2)
                  gf3 = gf2 * gf
                  gf5 = gf3 * gf2
                  gf7 = gf5 * gf2
                  gf9 = gf7 * gf2
c
c     reaction potential auxiliary terms
c
                  a(0,0) = gf
                  a(1,0) = -gf3
                  a(2,0) = 3.0d0 * gf5
                  a(3,0) = -15.0d0 * gf7
                  a(4,0) = 105.0d0 * gf9
c
c     reaction potential gradient auxiliary terms
c
                  expc1 = 1.0d0 - expc
                  a(0,1) = expc1 * a(1,0)
                  a(1,1) = expc1 * a(2,0)
                  a(2,1) = expc1 * a(3,0)
                  a(3,1) = expc1 * a(4,0)
c
c     second reaction potential gradient auxiliary terms
c
                  expcdexpc = -expc * dexpc
                  a(0,2) = expc1*a(1,1) + expcdexpc*a(1,0)
                  a(1,2) = expc1*a(2,1) + expcdexpc*a(2,0)
                  a(2,2) = expc1*a(3,1) + expcdexpc*a(3,0)
c
c     multiply the auxillary terms by their dieletric functions
c
                  a(0,0) = fc * a(0,0)
                  a(0,1) = fc * a(0,1)
                  a(0,2) = fc * a(0,2)
                  a(1,0) = fd * a(1,0)
                  a(1,1) = fd * a(1,1)
                  a(1,2) = fd * a(1,2)
                  a(2,0) = fq * a(2,0)
                  a(2,1) = fq * a(2,1)
                  a(2,2) = fq * a(2,2)
c
c     unweighted reaction potential tensor
c
                  gc(1) = a(0,0)
                  gux(1) = xr * a(1,0)
                  guy(1) = yr * a(1,0)
                  guz(1) = zr * a(1,0)
                  gqxx(1) = xr2 * a(2,0)
                  gqyy(1) = yr2 * a(2,0)
                  gqzz(1) = zr2 * a(2,0)
                  gqxy(1) = xr * yr * a(2,0)
                  gqxz(1) = xr * zr * a(2,0)
                  gqyz(1) = yr * zr * a(2,0)
c
c     unweighted reaction potential gradient tensor
c
                  gc(2) = xr * a(0,1)
                  gc(3) = yr * a(0,1)
                  gc(4) = zr * a(0,1)
                  gux(2) = a(1,0) + xr2*a(1,1)
                  gux(3) = xr * yr * a(1,1)
                  gux(4) = xr * zr * a(1,1)
                  guy(2) = gux(3)
                  guy(3) = a(1,0) + yr2*a(1,1)
                  guy(4) = yr * zr * a(1,1)
                  guz(2) = gux(4)
                  guz(3) = guy(4)
                  guz(4) = a(1,0) + zr2*a(1,1)
                  gqxx(2) = xr * (2.0d0*a(2,0)+xr2*a(2,1))
                  gqxx(3) = yr * xr2 * a(2,1)
                  gqxx(4) = zr * xr2 * a(2,1)
                  gqyy(2) = xr * yr2 * a(2,1)
                  gqyy(3) = yr * (2.0d0*a(2,0)+yr2*a(2,1))
                  gqyy(4) = zr * yr2 * a(2,1)
                  gqzz(2) = xr * zr2 * a(2,1)
                  gqzz(3) = yr * zr2 * a(2,1)
                  gqzz(4) = zr * (2.0d0*a(2,0)+zr2*a(2,1))
                  gqxy(2) = yr * (a(2,0)+xr2*a(2,1))
                  gqxy(3) = xr * (a(2,0)+yr2*a(2,1))
                  gqxy(4) = zr * xr * yr * a(2,1)
                  gqxz(2) = zr * (a(2,0)+xr2*a(2,1))
                  gqxz(3) = gqxy(4)
                  gqxz(4) = xr * (a(2,0)+zr2*a(2,1))
                  gqyz(2) = gqxy(4)
                  gqyz(3) = zr * (a(2,0)+yr2*a(2,1))
                  gqyz(4) = yr * (a(2,0)+zr2*a(2,1))
c
c     unweighted second reaction potential gradient tensor
c
                  gc(5) = a(0,1) + xr2*a(0,2)
                  gc(6) = xr * yr * a(0,2)
                  gc(7) = xr * zr * a(0,2)
                  gc(8) = a(0,1) + yr2*a(0,2)
                  gc(9) = yr * zr * a(0,2)
                  gc(10) = a(0,1) + zr2*a(0,2)
                  gux(5) = xr * (a(1,1)+2.0d0*a(1,1)+xr2*a(1,2))
                  gux(6) = yr * (a(1,1)+xr2*a(1,2))
                  gux(7) = zr * (a(1,1)+xr2*a(1,2))
                  gux(8) = xr * (a(1,1)+yr2*a(1,2))
                  gux(9) = zr * xr * yr * a(1,2)
                  gux(10) = xr * (a(1,1)+zr2*a(1,2))
                  guy(5) = yr * (a(1,1)+xr2*a(1,2))
                  guy(6) = xr * (a(1,1)+yr2*a(1,2))
                  guy(7) = gux(9)
                  guy(8) = yr * (a(1,1)+2.0d0*a(1,1)+yr2*a(1,2))
                  guy(9) = zr * (a(1,1)+yr2*a(1,2))
                  guy(10) = yr * (a(1,1)+zr2*a(1,2))
                  guz(5) = zr * (a(1,1)+xr2*a(1,2))
                  guz(6) = gux(9)
                  guz(7) = xr * (a(1,1)+zr2*a(1,2))
                  guz(8) = zr * (a(1,1)+yr2*a(1,2))
                  guz(9) = yr * (a(1,1)+zr2*a(1,2))
                  guz(10) = zr * (a(1,1)+2.0d0*a(1,1)+zr2*a(1,2))
                  gqxx(5) = 2.0d0*a(2,0) + xr2*(5.0d0*a(2,1)+xr2*a(2,2))
                  gqxx(6) = yr * xr *(2.0d0*a(2,1)+xr2*a(2,2))
                  gqxx(7) = zr * xr *(2.0d0*a(2,1)+xr2*a(2,2))
                  gqxx(8) = xr2 * (a(2,1)+yr2*a(2,2))
                  gqxx(9) = zr * yr * xr2 * a(2,2)
                  gqxx(10) = xr2 * (a(2,1)+zr2*a(2,2))
                  gqyy(5) = yr2 * (a(2,1)+xr2*a(2,2))
                  gqyy(6) = xr * yr * (2.0d0*a(2,1)+yr2*a(2,2))
                  gqyy(7) = xr * zr * yr2 * a(2,2)
                  gqyy(8) = 2.0d0*a(2,0) + yr2*(5.0d0*a(2,1)+yr2*a(2,2))
                  gqyy(9) = yr * zr * (2.0d0*a(2,1)+yr2*a(2,2))
                  gqyy(10) = yr2 * (a(2,1)+zr2*a(2,2))
                  gqzz(5) = zr2 * (a(2,1)+xr2*a(2,2))
                  gqzz(6) = xr * yr * zr2 * a(2,2)
                  gqzz(7) = xr * zr * (2.0d0*a(2,1)+zr2*a(2,2))
                  gqzz(8) = zr2 * (a(2,1)+yr2*a(2,2))
                  gqzz(9) = yr * zr * (2.0d0*a(2,1)+zr2*a(2,2))
                  gqzz(10) = 2.0d0*a(2,0)
     &                          + zr2*(5.0d0*a(2,1)+zr2*a(2,2))
                  gqxy(5) = xr * yr * (3.0d0*a(2,1)+xr2*a(2,2))
                  gqxy(6) = a(2,0) + (xr2+yr2)*a(2,1) + xr2*yr2*a(2,2)
                  gqxy(7) = zr * yr * (a(2,1)+xr2*a(2,2))
                  gqxy(8) = xr * yr * (3.0d0*a(2,1)+yr2*a(2,2))
                  gqxy(9) = zr * xr * (a(2,1)+yr2*a(2,2))
                  gqxy(10) = xr * yr * (a(2,1)+zr2*a(2,2))
                  gqxz(5) = xr * zr * (3.0d0*a(2,1)+xr2*a(2,2))
                  gqxz(6) = yr * zr * (a(2,1)+xr2*a(2,2))
                  gqxz(7) = a(2,0) + (xr2+zr2)*a(2,1) + xr2*zr2*a(2,2)
                  gqxz(8) = xr * zr * (a(2,1)+yr2*a(2,2))
                  gqxz(9) = xr * yr * (a(2,1)+zr2*a(2,2))
                  gqxz(10) = xr * zr * (3.0d0*a(2,1)+zr2*a(2,2))
                  gqyz(5) = zr * yr * (a(2,1)+xr2*a(2,2))
                  gqyz(6) = xr * zr * (a(2,1)+yr2*a(2,2))
                  gqyz(7) = xr * yr * (a(2,1)+zr2*a(2,2))
                  gqyz(8) = yr * zr * (3.0d0*a(2,1)+yr2*a(2,2))
                  gqyz(9) = a(2,0) + (yr2+zr2)*a(2,1) + yr2*zr2*a(2,2)
                  gqyz(10) = yr * zr * (3.0d0*a(2,1)+zr2*a(2,2))
c
c     electrostatic solvation free energy of the permanent multipoles
c     in their own GK reaction potential
c
                  esym = ci*ck*gc(1)
     &                     - uxi*(uxk*gux(2)+uyk*guy(2)+uzk*guz(2))
     &                     - uyi*(uxk*gux(3)+uyk*guy(3)+uzk*guz(3))
     &                     - uzi*(uxk*gux(4)+uyk*guy(4)+uzk*guz(4))
                  ewi = ci*(uxk*gc(2)+uyk*gc(3)+uzk*gc(4))
     &                    - ck*(uxi*gux(1)+uyi*guy(1)+uzi*guz(1))
     &               + ci*(qxxk*gc(5)+qyyk*gc(8)+qzzk*gc(10)
     &                  +2.0d0*(qxyk*gc(6)+qxzk*gc(7)+qyzk*gc(9)))
     &               + ck*(qxxi*gqxx(1)+qyyi*gqyy(1)+qzzi*gqzz(1)
     &                  +2.0d0*(qxyi*gqxy(1)+qxzi*gqxz(1)+qyzi*gqyz(1)))
     &               - uxi*(qxxk*gux(5)+qyyk*gux(8)+qzzk*gux(10)
     &                  +2.0d0*(qxyk*gux(6)+qxzk*gux(7)+qyzk*gux(9)))
     &               - uyi*(qxxk*guy(5)+qyyk*guy(8)+qzzk*guy(10)
     &                  +2.0d0*(qxyk*guy(6)+qxzk*guy(7)+qyzk*guy(9)))
     &               - uzi*(qxxk*guz(5)+qyyk*guz(8)+qzzk*guz(10)
     &                  +2.0d0*(qxyk*guz(6)+qxzk*guz(7)+qyzk*guz(9)))
     &               + uxk*(qxxi*gqxx(2)+qyyi*gqyy(2)+qzzi*gqzz(2)
     &                  +2.0d0*(qxyi*gqxy(2)+qxzi*gqxz(2)+qyzi*gqyz(2)))
     &               + uyk*(qxxi*gqxx(3)+qyyi*gqyy(3)+qzzi*gqzz(3)
     &                  +2.0d0*(qxyi*gqxy(3)+qxzi*gqxz(3)+qyzi*gqyz(3)))
     &               + uzk*(qxxi*gqxx(4)+qyyi*gqyy(4)+qzzi*gqzz(4)
     &                  +2.0d0*(qxyi*gqxy(4)+qxzi*gqxz(4)+qyzi*gqyz(4)))
     &               + qxxi*(qxxk*gqxx(5)+qyyk*gqxx(8)+qzzk*gqxx(10)
     &                  +2.0d0*(qxyk*gqxx(6)+qxzk*gqxx(7)+qyzk*gqxx(9)))
     &               + qyyi*(qxxk*gqyy(5)+qyyk*gqyy(8)+qzzk*gqyy(10)
     &                  +2.0d0*(qxyk*gqyy(6)+qxzk*gqyy(7)+qyzk*gqyy(9)))
     &               + qzzi*(qxxk*gqzz(5)+qyyk*gqzz(8)+qzzk*gqzz(10)
     &                  +2.0d0*(qxyk*gqzz(6)+qxzk*gqzz(7)+qyzk*gqzz(9)))
     &          + 2.0d0 * (qxyi*(qxxk*gqxy(5)+qyyk*gqxy(8)+qzzk*gqxy(10)
     &               +2.0d0*(qxyk*gqxy(6)+qxzk*gqxy(7)+qyzk*gqxy(9)))
     &               + qxzi*(qxxk*gqxz(5)+qyyk*gqxz(8)+qzzk*gqxz(10)
     &               +2.0d0*(qxyk*gqxz(6)+qxzk*gqxz(7)+qyzk*gqxz(9)))
     &               + qyzi*(qxxk*gqyz(5)+qyyk*gqyz(8)+qzzk*gqyz(10)
     &               +2.0d0*(qxyk*gqyz(6)+qxzk*gqyz(7)+qyzk*gqyz(9))))
                  ewk = ci*(uxk*gux(1)+uyk*guy(1)+uzk*guz(1))
     &                    - ck*(uxi*gc(2)+uyi*gc(3)+uzi*gc(4))
     &               + ci*(qxxk*gqxx(1)+qyyk*gqyy(1)+qzzk*gqzz(1)
     &                  +2.0d0*(qxyk*gqxy(1)+qxzk*gqxz(1)+qyzk*gqyz(1)))
     &               + ck*(qxxi*gc(5)+qyyi*gc(8)+qzzi*gc(10)
     &                  +2.0d0*(qxyi*gc(6)+qxzi*gc(7)+qyzi*gc(9)))
     &               - uxi*(qxxk*gqxx(2)+qyyk*gqyy(2)+qzzk*gqzz(2)
     &                  +2.0d0*(qxyk*gqxy(2)+qxzk*gqxz(2)+qyzk*gqyz(2)))
     &               - uyi*(qxxk*gqxx(3)+qyyk*gqyy(3)+qzzk*gqzz(3)
     &                  +2.0d0*(qxyk*gqxy(3)+qxzk*gqxz(3)+qyzk*gqyz(3)))
     &               - uzi*(qxxk*gqxx(4)+qyyk*gqyy(4)+qzzk*gqzz(4)
     &                  +2.0d0*(qxyk*gqxy(4)+qxzk*gqxz(4)+qyzk*gqyz(4)))
     &               + uxk*(qxxi*gux(5)+qyyi*gux(8)+qzzi*gux(10)
     &                  +2.0d0*(qxyi*gux(6)+qxzi*gux(7)+qyzi*gux(9)))
     &               + uyk*(qxxi*guy(5)+qyyi*guy(8)+qzzi*guy(10)
     &                  +2.0d0*(qxyi*guy(6)+qxzi*guy(7)+qyzi*guy(9)))
     &               + uzk*(qxxi*guz(5)+qyyi*guz(8)+qzzi*guz(10)
     &                  +2.0d0*(qxyi*guz(6)+qxzi*guz(7)+qyzi*guz(9)))
     &               + qxxi*(qxxk*gqxx(5)+qyyk*gqyy(5)+qzzk*gqzz(5)
     &                  +2.0d0*(qxyk*gqxy(5)+qxzk*gqxz(5)+qyzk*gqyz(5)))
     &               + qyyi*(qxxk*gqxx(8)+qyyk*gqyy(8)+qzzk*gqzz(8)
     &                  +2.0d0*(qxyk*gqxy(8)+qxzk*gqxz(8)+qyzk*gqyz(8)))
     &               + qzzi*(qxxk*gqxx(10)+qyyk*gqyy(10)+qzzk*gqzz(10)
     &               +2.0d0*(qxyk*gqxy(10)+qxzk*gqxz(10)+qyzk*gqyz(10)))
     &          + 2.0d0*(qxyi*(qxxk*gqxx(6)+qyyk*gqyy(6)+qzzk*gqzz(6)
     &               +2.0d0*(qxyk*gqxy(6)+qxzk*gqxz(6)+qyzk*gqyz(6)))
     &               + qxzi*(qxxk*gqxx(7)+qyyk*gqyy(7)+qzzk*gqzz(7)
     &               +2.0d0*(qxyk*gqxy(7)+qxzk*gqxz(7)+qyzk*gqyz(7)))
     &               + qyzi*(qxxk*gqxx(9)+qyyk*gqyy(9)+qzzk*gqzz(9)
     &               +2.0d0*(qxyk*gqxy(9)+qxzk*gqxz(9)+qyzk*gqyz(9))))
c
c     electrostatic solvation free energy of the permenant multipoles
c     in the GK reaction potential of the induced dipoles
c
                  esymi = -uxi*(dxk*gux(2)+dyk*guy(2)+dzk*guz(2))
     &                      - uyi*(dxk*gux(3)+dyk*guy(3)+dzk*guz(3))
     &                      - uzi*(dxk*gux(4)+dyk*guy(4)+dzk*guz(4))
     &                      - uxk*(dxi*gux(2)+dyi*guy(2)+dzi*guz(2))
     &                      - uyk*(dxi*gux(3)+dyi*guy(3)+dzi*guz(3))
     &                      - uzk*(dxi*gux(4)+dyi*guy(4)+dzi*guz(4))
                  ewii = ci*(dxk*gc(2)+dyk*gc(3)+dzk*gc(4))
     &                     - ck*(dxi*gux(1)+dyi*guy(1)+dzi*guz(1))
     &              - dxi*(qxxk*gux(5)+qyyk*gux(8)+qzzk*gux(10)
     &                 +2.0d0*(qxyk*gux(6)+qxzk*gux(7)+qyzk*gux(9)))
     &              - dyi*(qxxk*guy(5)+qyyk*guy(8)+qzzk*guy(10)
     &                 +2.0d0*(qxyk*guy(6)+qxzk*guy(7)+qyzk*guy(9)))
     &              - dzi*(qxxk*guz(5)+qyyk*guz(8)+qzzk*guz(10)
     &                 +2.0d0*(qxyk*guz(6)+qxzk*guz(7)+qyzk*guz(9)))
     &              + dxk*(qxxi*gqxx(2)+qyyi*gqyy(2)+qzzi*gqzz(2)
     &                 +2.0d0*(qxyi*gqxy(2)+qxzi*gqxz(2)+qyzi*gqyz(2)))
     &              + dyk*(qxxi*gqxx(3)+qyyi*gqyy(3)+qzzi*gqzz(3)
     &                 +2.0d0*(qxyi*gqxy(3)+qxzi*gqxz(3)+qyzi*gqyz(3)))
     &              + dzk*(qxxi*gqxx(4)+qyyi*gqyy(4)+qzzi*gqzz(4)
     &                 +2.0d0*(qxyi*gqxy(4)+qxzi*gqxz(4)+qyzi*gqyz(4)))
                  ewki = ci*(dxk*gux(1)+dyk*guy(1)+dzk*guz(1))
     &                     - ck*(dxi*gc(2)+dyi*gc(3)+dzi*gc(4))
     &              - dxi*(qxxk*gqxx(2)+qyyk*gqyy(2)+qzzk*gqzz(2)
     &                 +2.0d0*(qxyk*gqxy(2)+qxzk*gqxz(2)+qyzk*gqyz(2)))
     &              - dyi*(qxxk*gqxx(3)+qyyk*gqyy(3)+qzzk*gqzz(3)
     &                 +2.0d0*(qxyk*gqxy(3)+qxzk*gqxz(3)+qyzk*gqyz(3)))
     &              - dzi*(qxxk*gqxx(4)+qyyk*gqyy(4)+qzzk*gqzz(4)
     &                 +2.0d0*(qxyk*gqxy(4)+qxzk*gqxz(4)+qyzk*gqyz(4)))
     &              + dxk*(qxxi*gux(5)+qyyi*gux(8)+qzzi*gux(10)
     &                 +2.0d0*(qxyi*gux(6)+qxzi*gux(7)+qyzi*gux(9)))
     &              + dyk*(qxxi*guy(5)+qyyi*guy(8)+qzzi*guy(10)
     &                 +2.0d0*(qxyi*guy(6)+qxzi*guy(7)+qyzi*guy(9)))
     &              + dzk*(qxxi*guz(5)+qyyi*guz(8)+qzzi*guz(10)
     &                 +2.0d0*(qxyi*guz(6)+qxzi*guz(7)+qyzi*guz(9)))
c
c     total permanent and induced energies for this interaction
c
                  e = esym + 0.5d0*(ewi+ewk)
                  ei = 0.5d0 * (esymi + 0.5d0*(ewii+ewki))
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     e = e * fgrp
                     ei = ei * fgrp
                  end if
c
c     increment the total GK electrostatic solvation energy
c
                  nes = nes + 1
                  if (i .eq. k) then
                     e = 0.5d0 * e
                     ei = 0.5d0 * ei
                     es = es + e + ei
                     aes(i) = aes(i) + e + ei
                     eself(i) = eself(i) + e + ei
                  else
                     es = es + e + ei
                     aes(i) = aes(i) + 0.5d0*(e+ei)
                     aes(k) = aes(k) + 0.5d0*(e+ei)
                     ecross(i) = ecross(i) + 0.5d0*(e+ei)
                     ecross(k) = ecross(k) + 0.5d0*(e+ei)
                  end if
c
c     increment the total intermolecule energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e + ei
                  end if
               end if
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     print the self-energy and cross-energy terms
c
      if (debug) then
         write (iout,10)
   10    format (/,' Generalized Kirkwood Self-Energies and',
     &              ' Cross-Energies :',
     &           //,' Type',12x,'Atom Name',24x,'Self',7x,'Cross',/)
         do i = 1, n
            write (iout,20)  i,name(i),eself(i),ecross(i)
   20       format (' Solv-GK',5x,i8,'-',a3,17x,2f12.4)
            if (i .gt. 1) then
               eself(1) = eself(1) + eself(i)
               ecross(1) = ecross(1) + ecross(i)
            end if
         end do
         write (iout,30) eself(1),ecross(1)
   30    format (/,' Solv-GK',11x,'Total',18x,2f12.4)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (eself)
      deallocate (ecross)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine epb3  --  PB polarization energy & analysis  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "epb3" calculates the implicit solvation energy via the
c     Poisson-Boltzmann model; also partitions the energy among
c     the atoms
c
c
      subroutine epb3
      use analyz
      use atomid
      use atoms
      use chgpot
      use energi
      use inform
      use iounit
      use mpole
      use pbstuf
      use polar
      use potent
      implicit none
      integer i,ii
      real*8 e,etot
c
c
c     compute the electrostatic energy via Poisson-Boltzmann
c
      if (use_polar) then
         e = 0.0d0
         etot = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            e = uinds(1,i)*pbep(1,i) + uinds(2,i)*pbep(2,i)
     &             + uinds(3,i)*pbep(3,i)
            e = -0.5d0 * electric * e
            apbe(i) = apbe(i) + e
            etot = etot + e
         end do
         pbe = pbe + etot
      else
         call pbempole
      end if
c
c     increment solvation energy and analysis by PB results
c
      es = es + pbe
      do ii = 1, npole
         i = ipole(i)
         aes(i) = aes(i) + apbe(i)
      end do
c
c     print the Poisson-Boltzmann solvation energy over atoms
c
      if (debug) then
         write (iout,10)
   10    format (/,' Poisson-Boltzmann Solvation Energies :',
     &           //,' Type',12x,'Atom Name',22x,'Energy',/)
         do ii = 1, npole
            i = ipole(ii)
            write (iout,20)  i,name(i),apbe(i)
   20       format (' Solv-PB',5x,i8,'-',a3,17x,f12.4)
         end do
         write (iout,30) pbe
   30    format (/,' Solv-PB',11x,'Total',18x,f12.4)
      end if
c
c     correct solvation energy for vacuum to polarized state
c
      call ediff3
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ediff3  --  correct GK for polarization change  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ediff3" calculates the energy of polarizing vacuum induced
c     dipoles to their generalized Kirkwood values with energy analysis
c
c
      subroutine ediff3
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use chgpot
      use couple
      use energi
      use group
      use inform
      use iounit
      use mpole
      use polar
      use polgrp
      use polpot
      use shunt
      use usage
      implicit none
      integer i,j,k
      integer ii,kk
      integer ix,iy,iz
      integer kx,ky,kz
      real*8 ei,f
      real*8 fikp,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr,r,r2
      real*8 rr1,rr3,rr5,rr7
      real*8 ci,dix,diy,diz
      real*8 uix,uiy,uiz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 ukx,uky,ukz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 qix,qiy,qiz
      real*8 qkx,qky,qkz
      real*8 sc(6)
      real*8 sci(8)
      real*8 gli(3)
      real*8 dmpik(7)
      real*8, allocatable :: pscale(:)
      real*8, allocatable :: epvac(:)
      logical proceed,usei,usek
      character*6 mode
c
c
c     set conversion factor, cutoff and scaling coefficients
c
      if (npole .eq. 0)  return
      f = electric / dielec
      mode = 'MPOLE'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
      allocate (epvac(n))
c
c     set arrays for interaction scaling and vacuum polarization
c
      do i = 1, n
         pscale(i) = 1.0d0
         epvac(i) = 0.0d0
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,x,y,z,xaxis,yaxis,
!$OMP& zaxis,rpole,uind,uinds,use,n12,n13,n14,n15,np11,i12,i13,i14,i15,
!$OMP& ip11,p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale,
!$OMP& p5iscale,use_group,use_intra,off2,f)
!$OMP& firstprivate(pscale) shared(es,nes,aes,epvac)
!$OMP DO reduction(+:es,nes,aes,epvac)
c
c     calculate the multipole interaction energy term
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         iz = zaxis(i)
         ix = xaxis(i)
         iy = abs(yaxis(i))
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         uix = uinds(1,i) - uind(1,i)
         uiy = uinds(2,i) - uind(2,i)
         uiz = uinds(3,i) - uind(3,i)
         usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy))
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = p2scale
            do k = 1, np11(i)
               if (i12(j,i) .eq. ip11(k,i))
     &            pscale(i12(j,i)) = p2iscale
            end do
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = p3scale
            do k = 1, np11(i)
               if (i13(j,i) .eq. ip11(k,i))
     &            pscale(i13(j,i)) = p3iscale
            end do
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = p4scale
            do k = 1, np11(i)
               if (i14(j,i) .eq. ip11(k,i))
     &            pscale(i14(j,i)) = p4iscale
            end do
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = p5scale
            do k = 1, np11(i)
               if (i15(j,i) .eq. ip11(k,i))
     &            pscale(i15(j,i)) = p5iscale
            end do
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, npole
            k = ipole(kk)
            kz = zaxis(k)
            kx = xaxis(k)
            ky = abs(yaxis(k))
            usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (usei .or. usek)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  ck = rpole(1,k)
                  dkx = rpole(2,k)
                  dky = rpole(3,k)
                  dkz = rpole(4,k)
                  qkxx = rpole(5,k)
                  qkxy = rpole(6,k)
                  qkxz = rpole(7,k)
                  qkyy = rpole(9,k)
                  qkyz = rpole(10,k)
                  qkzz = rpole(13,k)
                  ukx = uinds(1,k) - uind(1,k)
                  uky = uinds(2,k) - uind(2,k)
                  ukz = uinds(3,k) - uind(3,k)
c
c     construct some intermediate quadrupole values
c
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
c
c     calculate the scalar products for permanent multipoles
c
                  sc(3) = dix*xr + diy*yr + diz*zr
                  sc(4) = dkx*xr + dky*yr + dkz*zr
                  sc(5) = qix*xr + qiy*yr + qiz*zr
                  sc(6) = qkx*xr + qky*yr + qkz*zr
c
c     calculate the scalar products for polarization components
c
                  sci(2) = uix*dkx + dix*ukx + uiy*dky
     &                        + diy*uky + uiz*dkz + diz*ukz
                  sci(3) = uix*xr + uiy*yr + uiz*zr
                  sci(4) = ukx*xr + uky*yr + ukz*zr
                  sci(7) = qix*ukx + qiy*uky + qiz*ukz
                  sci(8) = qkx*uix + qky*uiy + qkz*uiz
c
c     calculate the gl functions for polarization components
c
                  gli(1) = ck*sci(3) - ci*sci(4) + sci(2)
                  gli(2) = 2.0d0*(sci(7)-sci(8)) - sci(3)*sc(4)
     &                        - sc(3)*sci(4)
                  gli(3) = sci(3)*sc(6) - sci(4)*sc(5)
c
c     compute the energy contributions for this interaction
c
                  rr1 = 1.0d0 / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  call dampthole (ii,kk,7,r,dmpik)
                  ei = gli(1)*rr3*dmpik(3) + gli(2)*rr5*dmpik(5)
     &                    + gli(3)*rr7*dmpik(7)
c
c     make the adjustment for scaled interactions
c
                  fikp = f * pscale(k)
                  ei = 0.5d0 * fikp * ei
c
c     scale the interaction based on its group membership;
c     polarization cannot be group scaled as it is not pairwise
c
c                 if (use_group) then
c                    ei = ei * fgrp
c                 end if
c
c     increment the total GK electrostatic solvation energy
c
                  nes = nes + 1
                  es = es + ei
                  aes(i) = aes(i) + 0.5d0*ei
                  aes(k) = aes(k) + 0.5d0*ei
                  epvac(i) = epvac(i) + 0.5d0*ei
                  epvac(k) = epvac(k) + 0.5d0*ei
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, n12(i)
            pscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            pscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            pscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            pscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     print the energy of polarization of vacuum dipoles
c
      if (debug) then
         write (iout,10)
   10    format (/,' Implicit Solvation Vacuum Polarization',
     &              ' Energies :',
     &           //,' Type',12x,'Atom Name',22x,'Vacuum',/)
         do i = 1, n
            write (iout,20)  i,name(i),epvac(i)
   20       format (' Solv-Vac',4x,i8,'-',a3,17x,f12.4)
            if (i .gt. 1) then
               epvac(1) = epvac(1) + epvac(i)
            end if
         end do
         write (iout,30) epvac(1)
   30    format (/,' Solv-Vac',10x,'Total',18x,f12.4)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      deallocate (epvac)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine enp3  --  nonpolar solvation energy & analysis  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "enp3" calculates the nonpolar implicit solvation energy as
c     a sum of cavity and dispersion terms; also partitions the
c     energy among the atoms
c
c
      subroutine enp3 (ecav,aecav,edisp,aedisp)
      use atomid
      use atoms
      use kvdws
      use math
      use mpole
      use nonpol
      use shunt
      use solpot
      use solute
      implicit none
      integer i
      real*8 ecav,edisp
      real*8 probe,taper
      real*8 evol,esurf,etemp
      real*8 reff,reff2,reff3
      real*8 reff4,reff5
      real*8 aecav(*)
      real*8 aedisp(*)
      real*8, allocatable :: aesurf(:)
      real*8, allocatable :: aevol(:)
      real*8, allocatable :: aetemp(:)
      real*8, allocatable :: weight(:)
      character*6 mode
c
c
c     zero out the nonpolar solvation energy contributions
c
      esurf = 0.0d0
      evol = 0.0d0
      ecav = 0.0d0
      edisp = 0.0d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (aesurf(n))
      allocate (aevol(n))
      allocate (aetemp(n))
c
c     zero out the nonpolar solvation energy partitioning
c
      do i = 1, n
         aesurf(i) = 0.0d0
         aevol(i) = 0.0d0
         aecav(i) = 0.0d0
         aedisp(i) = 0.0d0
      end do
c
c     solvent probe radius is included in cavity radii
c
      probe = 0.0d0
c
c     compute surface area and effective radius for cavity
c
      call surface (radcav,asolv,probe,esurf,aesurf)
      reff = 0.5d0 * sqrt(esurf/(pi*surften))
      reff2 = reff * reff
      reff3 = reff2 * reff
      reff4 = reff3 * reff
      reff5 = reff4 * reff
c
c     compute solvent excluded volume needed for small solutes
c
      if (reff .lt. spoff) then
         allocate (weight(n))
         do i = 1, n
            weight(i) = solvprs
         end do
         call volume (radcav,weight,probe,etemp,evol,aetemp,aevol)
         deallocate (weight)
      end if
c
c     include a full solvent excluded volume cavity term
c
      if (reff .le. spcut) then
         ecav = evol
         do i = 1, n
            aecav(i) = aevol(i)
         end do
c
c     include a tapered solvent excluded volume cavity term
c
      else if (reff .le. spoff) then
         mode = 'GKV'
         call switch (mode)
         taper = c5*reff5 + c4*reff4 + c3*reff3
     &              + c2*reff2 + c1*reff + c0
         ecav = taper * evol
         do i = 1, n
            aecav(i) = taper * aevol(i)
         end do
      end if
c
c     include a full solvent accessible surface area term
c
      if (reff .gt. stcut) then
         ecav = esurf
         do i = 1, n
            aecav(i) = aesurf(i)
         end do
c
c     include a tapered solvent accessible surface area term
c
      else if (reff .gt. stoff) then
         mode = 'GKSA'
         call switch (mode)
         taper = c5*reff5 + c4*reff4 + c3*reff3
     &              + c2*reff2 + c1*reff + c0
         taper = 1.0d0 - taper
         ecav = ecav + taper*esurf
         do i = 1, n
            aecav(i) = taper * (aesurf(i)+aevol(i))
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (aesurf)
      deallocate (aevol)
      deallocate (aetemp)
c
c     find the implicit dispersion solvation energy
c
      call ewca3 (edisp,aedisp)
c     call ewca3x (edisp,aedisp)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ewca3  --  WCA dispersion energy and analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ewca3" find the Weeks-Chandler-Andersen dispersion energy
c     of a solute; also partitions the energy among the atoms
c
c
      subroutine ewca3 (edisp,aedisp)
      use atoms
      use atomid
      use deriv
      use inform
      use iounit
      use kvdws
      use math
      use nonpol
      use solute
      use vdw
      implicit none
      integer i,k
      real*8 edisp
      real*8 e,idisp
      real*8 xi,yi,zi
      real*8 rk,sk,sk2
      real*8 xr,yr,zr,r,r2
      real*8 sum,term,iwca,irepl
      real*8 epsi,rmini,rio,rih,rmax
      real*8 ao,emixo,rmixo,rmixo7
      real*8 ah,emixh,rmixh,rmixh7
      real*8 lik,lik2,lik3,lik4
      real*8 lik5,lik10,lik11,lik12
      real*8 uik,uik2,uik3,uik4
      real*8 uik5,uik10,uik11,uik12
      real*8 aedisp(*)
      real*8, allocatable :: aedispo(:)
c
c
c     zero out the WCA dispersion energy and partitioning
c
      edisp = 0.0d0
      do i = 1, n
         aedisp(i) = 0.0d0
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (aedispo(n))
c
c     transfer global to local copies for OpenMP calculation
c
      do i = 1, n
         aedispo(i) = aedisp(i)
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(n,class,epsdsp,
!$OMP& raddsp,x,y,z,cdsp)
!$OMP& shared(edisp,aedispo)
!$OMP DO reduction(+:edisp,aedispo)
c
c     find the Weeks-Chandler-Andersen dispersion energy
c
      do i = 1, n
         epsi = epsdsp(i)
         rmini = raddsp(i)
         emixo = 4.0d0 * epso * epsi / ((sqrt(epso)+sqrt(epsi))**2)
         rmixo = 2.0d0 * (rmino**3+rmini**3) / (rmino**2+rmini**2)
         rmixo7 = rmixo**7
         ao = emixo * rmixo7
         emixh = 4.0d0 * epsh * epsi / ((sqrt(epsh)+sqrt(epsi))**2)
         rmixh = 2.0d0 * (rminh**3+rmini**3) / (rminh**2+rmini**2)
         rmixh7 = rmixh**7
         ah = emixh * rmixh7
         xi = x(i)
         yi = y(i)
         zi = z(i)
         rio = 0.5d0*rmixo + dspoff
         rih = 0.5d0*rmixh + dspoff
c
c     remove contribution due to solvent displaced by solute atoms
c
         sum = 0.0d0
         do k = 1, n
            if (i .ne. k) then
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               r2 = xr*xr + yr*yr + zr*zr
               r = sqrt(r2)
               rk = raddsp(k)
               sk = rk * shctd
               sk2 = sk * sk
               if (rio .lt. r+sk) then
                  rmax = max(rio,r-sk)
                  lik = rmax
                  if (lik .lt. rmixo) then
                     lik2 = lik * lik
                     lik3 = lik2 * lik
                     lik4 = lik3 * lik
                     uik = min(r+sk,rmixo)
                     uik2 = uik * uik
                     uik3 = uik2 * uik
                     uik4 = uik3 * uik
                     term = 4.0d0 * pi / (48.0d0*r)
     &                    * (3.0d0*(lik4-uik4) - 8.0d0*r*(lik3-uik3)
     &                          + 6.0d0*(r2-sk2)*(lik2-uik2))
                     iwca = -emixo * term
                     sum = sum + iwca
                  end if
                  uik = r + sk
                  if (uik .gt. rmixo) then
                     uik2 = uik * uik
                     uik3 = uik2 * uik
                     uik4 = uik3 * uik
                     uik5 = uik4 * uik
                     uik10 = uik5 * uik5
                     uik11 = uik10 * uik
                     uik12 = uik11 * uik
                     lik = max(rmax,rmixo)
                     lik2 = lik * lik
                     lik3 = lik2 * lik
                     lik4 = lik3 * lik
                     lik5 = lik4 * lik
                     lik10 = lik5 * lik5
                     lik11 = lik10 * lik
                     lik12 = lik11 * lik
                     term = 4.0d0 * pi / (120.0d0*r*lik5*uik5)
     &                      * (15.0d0*uik*lik*r*(uik4-lik4)
     &                         - 10.0d0*uik2*lik2*(uik3-lik3)
     &                         + 6.0d0*(sk2-r2)*(uik5-lik5))
                     idisp = -2.0d0 * ao * term
                     term = 4.0d0 * pi / (2640.0d0*r*lik12*uik12)
     &                      * (120.0d0*uik*lik*r*(uik11-lik11)
     &                         - 66.0d0*uik2*lik2*(uik10-lik10)
     &                         + 55.0d0*(sk2-r2)*(uik12-lik12))
                     irepl = ao * rmixo7 * term
                     sum = sum + irepl + idisp
                  end if
               end if
               if (rih .lt. r+sk) then
                  rmax = max(rih,r-sk)
                  lik = rmax
                  if (lik .lt. rmixh) then
                     lik2 = lik * lik
                     lik3 = lik2 * lik
                     lik4 = lik3 * lik
                     uik = min(r+sk,rmixh)
                     uik2 = uik * uik
                     uik3 = uik2 * uik
                     uik4 = uik3 * uik
                     term = 4.0d0 * pi / (48.0d0*r)
     &                    * (3.0d0*(lik4-uik4) - 8.0d0*r*(lik3-uik3)
     &                          + 6.0d0*(r2-sk2)*(lik2-uik2))
                     iwca = -2.0d0 * emixh * term
                     sum = sum + iwca
                  end if
                  uik = r + sk
                  if (uik .gt. rmixh) then
                     uik2 = uik * uik
                     uik3 = uik2 * uik
                     uik4 = uik3 * uik
                     uik5 = uik4 * uik
                     uik10 = uik5 * uik5
                     uik11 = uik10 * uik
                     uik12 = uik11 * uik
                     lik = max(rmax,rmixh)
                     lik2 = lik * lik
                     lik3 = lik2 * lik
                     lik4 = lik3 * lik
                     lik5 = lik4 * lik
                     lik10 = lik5 * lik5
                     lik11 = lik10 * lik
                     lik12 = lik11 * lik
                     term = 4.0d0 * pi / (120.0d0*r*lik5*uik5)
     &                      * (15.0d0*uik*lik*r*(uik4-lik4)
     &                         - 10.0d0*uik2*lik2*(uik3-lik3)
     &                         + 6.0d0*(sk2-r2)*(uik5-lik5))
                     idisp = -4.0d0 * ah * term
                     term = 4.0d0 * pi / (2640.0d0*r*lik12*uik12)
     &                      * (120.0d0*uik*lik*r*(uik11-lik11)
     &                         - 66.0d0*uik2*lik2*(uik10-lik10)
     &                         + 55.0d0*(sk2-r2)*(uik12-lik12))
                     irepl = 2.0d0 * ah * rmixh7 * term
                     sum = sum + irepl + idisp
                  end if
               end if
            end if
         end do
c
c     increment the overall dispersion energy component
c
         e = cdsp(i) - slevy*awater*sum
         edisp = edisp + e
         aedispo(i) = e
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     transfer local to global copies for OpenMP calculation
c
      do i = 1, n
         aedisp(i) = aedispo(i)
      end do
c
c     print the total dispersion energy and energy for each atom
c
      if (debug) then
         write (iout,10)
   10    format (/,' HCT Implicit Solvation Dispersion :',
     &           //,' Type',12x,'Atom Name',22x,'Energy',/)
         do i = 1, n
            write (iout,20)  i,name(i),aedisp(i)
   20       format (' Disp-HCT',5x,i7,'-',a3,17x,f12.4)
         end do
         write (iout,30)  edisp
   30    format (/,' Disp-HCT',10x,'Total',18x,f12.4)
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ewca3x  --  alternative WCA energy & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ewca3x" finds the Weeks-Chandler-Anderson dispersion energy
c     of a solute using a numerical "onion shell" method; also
c     partitions the energy among the atoms
c
c
      subroutine ewca3x (edisp,aedisp)
      use atoms
      use atomid
      use couple
      use inform
      use iounit
      use kvdws
      use math
      use nonpol
      use solute
      use vdw
      implicit none
      integer i,j,k
      real*8 edisp,e
      real*8 t,tinit
      real*8 delta,offset
      real*8 ratio,rinit
      real*8 rmult,rswitch
      real*8 rmax,shell
      real*8 inner,outer
      real*8 area,fraction
      real*8 epsi,rmini
      real*8 epsoi,rminoi
      real*8 epshi,rminhi
      real*8 oer7,oer14
      real*8 her7,her14
      real*8 aedisp(*)
      real*8, allocatable :: roff(:)
      logical done
c
c
c     zero out the WCA dispersion energy and partitioning
c
      edisp = 0.0d0
      do i = 1, n
         aedisp(i) = 0.0d0
      end do
c
c     set parameters for high accuracy numerical shells
c
c     tinit = 0.2d0
c     rinit = 1.0d0
c     rmult = 1.5d0
c     rswitch = 7.0d0
c     rmax = 12.0d0
c
c     set parameters for medium accuracy numerical shells
c
      tinit = 1.0d0
      rinit = 1.0d0
      rmult = 2.0d0
      rswitch = 5.0d0
      rmax = 9.0d0
c
c     set parameters for low accuracy numerical shells
c
c     tinit = 1.0d0
c     rinit = 1.0d0
c     rmult = 2.0d0
c     rswitch = 4.0d0
c     rmax = 7.0d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (roff(n))
c
c     set parameters for atomic radii and probe radii
c
      offset = 0.27d0
      delta = offset + 0.55d0
      do i = 1, n
         roff(i) = raddsp(i) + delta
      end do
c
c     print header for output of the detailed energy components
c
      if (debug) then
         write (iout,10)
   10    format (/,' Onion Shell Implicit Solvation Dispersion :',
     &           //,' Type',12x,'Atom Name',22x,'Energy',/)
      end if
c
c     compute the dispersion energy for each atom in the system
c
      do i = 1, n
         epsi = epsdsp(i)
         rmini = raddsp(i)
         epsoi = 4.0d0 * epso * epsi / ((sqrt(epso)+sqrt(epsi))**2)
         rminoi = 2.0d0 * (rmino**3+rmini**3) / (rmino**2+rmini**2)
         epshi = 4.0d0 * epsh * epsi / ((sqrt(epsh)+sqrt(epsi))**2)
         rminhi = 2.0d0 * (rminh**3+rmini**3) / (rminh**2+rmini**2)
         her7 = epshi * rminhi**7
         oer7 = epsoi * rminoi**7
         her14 = epshi * rminhi**14
         oer14 = epsoi * rminoi**14
c
c     alter radii values for atoms attached to current atom
c
         roff(i) = raddsp(i) + offset
         do j = 1, n12(i)
            k = i12(j,i)
            roff(k) = raddsp(k) + offset
         end do
         do j = 1, n13(i)
            k = i13(j,i)
            roff(k) = raddsp(k) + offset
         end do
         do j = 1, n14(i)
            k = i14(j,i)
            roff(k) = raddsp(k) + offset
         end do
         do j = 1, n15(i)
            k = i15(j,i)
            roff(k) = raddsp(k) + offset
         end do
c
c     get the dispersion energy via a series of "onion" shells
c
         t = tinit
         ratio = rinit
         e = 0.0d0
         done = .false.
         do while (.not. done)
            inner = roff(i)
            outer = inner + t
            roff(i) = 0.5d0 * (inner+outer)
            call surfatom (i,area,roff)
            fraction = area / (4.0d0*pi*roff(i)**2)
            if (roff(i) .gt. 0.5d0*rminoi + dspoff) then
               if (outer .lt. rminoi) then
                  shell = (outer**3-inner**3)/3.0d0
                  e = e - epsoi*fraction*shell
               else if (inner .gt. rminoi) then
                  shell = (1.0d0/(inner**4)-1.0d0/(outer**4))/4.0d0
                  e = e - 2.0d0*oer7*fraction*shell
                  shell = (1.0d0/(inner**11)-1.0d0/(outer**11))/11.0d0
                  e = e + oer14*fraction*shell
               else
                  shell = (rminoi**3-inner**3)/3.0d0
                  e = e - epsoi*fraction*shell
                  shell = (1.0d0/(rminoi**4)-1.0d0/(outer**4))/4.0d0
                  e = e - 2.0d0*oer7*fraction*shell
                  shell = (1.0d0/(rminoi**11)-1.0d0/(outer**11))/11.0d0
                  e = e + oer14*fraction*shell
               end if
            end if
            if (outer .lt. rminhi) then
               shell = (outer**3-inner**3)/3.0d0
               e = e - 2.0d0*epshi*fraction*shell
            else if (inner .gt. rminhi) then
               shell = (1.0d0/(inner**4)-1.0d0/(outer**4)) / 4.0d0
               e = e - 4.0d0*her7*fraction*shell
               shell = (1.0d0/(inner**11)-1.0d0/(outer**11)) / 11.0d0
               e = e + 2.0d0*her14*fraction*shell
            else
               shell = (rminhi**3-inner**3)/3.0d0
               e = e - 2.0d0*epshi*fraction*shell
               shell = (1.0d0/(rminhi**4)-1.0d0/(outer**4)) / 4.0d0
               e = e - 4.0d0*her7*fraction*shell
               shell = (1.0d0/(rminhi**11)-1.0d0/(outer**11)) / 11.0d0
               e = e + 2.0d0*her14*fraction*shell
            end if
            if (outer .gt. rmax)  done = .true.
            if (fraction.gt.0.99d0 .and. outer.gt.rminoi)  done = .true.
            if (done) then
               e = e - 2.0d0*oer7*fraction/(4.0d0*outer**4)
               e = e + oer14*fraction/(11.0d0*outer**11)
               e = e - 4.0d0*her7*fraction/(4.0d0*outer**4)
               e = e + 2.0d0*her14*fraction/(11.0d0*outer**11)
            end if
            roff(i) = roff(i) + 0.5d0*t
            if (outer .gt. rswitch)  ratio = rmult
            t = ratio * t
c
c     print the dispersion energy for the current shell
c
c           if (debug) then
c              write (iout,20)  i,inner,outer,fraction,
c    &                          4.0d0*pi*awater*e
c 20          format (' Onion Shell :',4x,i8,2f9.2,2f12.4)
c           end if
         end do
c
c     increment the overall dispersion energy component
c
         e = 4.0d0 * pi * slevy * awater * e
         aedisp(i) = aedisp(i) + e
         edisp = edisp + e
c
c     reset the radii values for atoms attached to current atom
c
         roff(i) = raddsp(i) + delta
         do j = 1, n12(i)
            k = i12(j,i)
            roff(k) = raddsp(k) + delta
         end do
         do j = 1, n13(i)
            k = i13(j,i)
            roff(k) = raddsp(k) + delta
         end do
         do j = 1, n14(i)
            k = i14(j,i)
            roff(k) = raddsp(k) + delta
         end do
         do j = 1, n15(i)
            k = i15(j,i)
            roff(k) = raddsp(k) + delta
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (roff)
c
c     print the total dispersion energy and energy for each atom
c
      if (debug) then
         write (iout,30)
   30    format ()
         do i = 1, n
            write (iout,40)  i,aedisp(i)
   40       format (' Disp-Onion',3x,i7,'-',a3,17x,f12.4)
         end do
         write (iout,50)  edisp
   50    format (/,' Disp-Onion',8x,'Total',18x,f12.4)
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ehpmf3  --  hydrophobic PMF energy & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ehpmf3" calculates the hydrophobic potential of mean force
c     nonpolar energy; also partitions the energy among the atoms
c
c     literature reference:
c
c     M. S. Lin, N. L. Fawzi and T. Head-Gordon, "Hydrophobic
c     Potential of Mean Force as a Solvation Function for Protein
c     Structure Prediction", Structure, 15, 727-740 (2007)
c
c
      subroutine ehpmf3 (ehp,nehp,aehp)
      use atomid
      use atoms
      use couple
      use hpmf
      use math
      implicit none
      integer i,j,k,m
      integer ii,jj,kk
      integer nehp,sschk
      integer, allocatable :: omit(:)
      real*8 xr,yr,zr,r,r2
      real*8 e,ehp
      real*8 rsurf,pisurf
      real*8 hpmfcut2
      real*8 saterm,sasa
      real*8 rbig,rsmall
      real*8 part,cutv
      real*8 e1,e2,e3,sum
      real*8 arg1,arg2,arg3
      real*8 arg12,arg22,arg32
      real*8 aehp(*)
      real*8, allocatable :: cutmtx(:)
c
c
c     zero out the hydrophobic PMF energy and partitioning
c
      ehp = 0.0d0
      nehp = 0
      do i = 1, n
         aehp(i) = 0.0d0
      end do
c
c     set some values needed during the HPMF calculation
c
      rsurf = rcarbon + 2.0d0*rwater
      pisurf = pi * (rcarbon+rwater)
      hpmfcut2 = hpmfcut * hpmfcut
c
c     perform dynamic allocation of some local arrays
c
      allocate (omit(n))
      allocate (cutmtx(n))
c
c     get the solvent accessible surface area for each atom
c
      do ii = 1, npmf
         i = ipmf(ii)
         saterm = acsa(i)
         sasa = 1.0d0
         do k = 1, n
            if (i .ne. k) then
               xr = x(i) - x(k)
               yr = y(i) - y(k)
               zr = z(i) - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               rbig = rpmf(k) + rsurf
               if (r2 .le. rbig*rbig) then
                  r = sqrt(r2)
                  rsmall = rpmf(k) - rcarbon
                  part = pisurf * (rbig-r) * (1.0d0+rsmall/r)
                  sasa = sasa * (1.0d0-saterm*part)
               end if
            end if
         end do
         sasa = acsurf * sasa
         cutv = tanh(tgrad*(sasa-toffset))
         cutmtx(i) = 0.5d0 * (1.0d0+cutv)
      end do
c
c     find the hydrophobic PMF energy via a double loop search
c
      do i = 1, n
         omit(i) = 0
      end do
      do ii = 1, npmf-1
         i = ipmf(ii)
         sschk = 0
         do j = 1, n12(i)
            k = i12(j,i)
            omit(k) = i
            if (atomic(k) .eq. 16)  sschk = k
         end do
         do j = 1, n13(i)
            k = i13(j,i)
            omit(k) = i
         end do
         do j = 1, n14(i)
            k = i14(j,i)
            omit(k) = i
            if (sschk .ne. 0) then
               do jj = 1, n12(k)
                  m = i12(jj,k)
                  if (atomic(m) .eq. 16) then
                     do kk = 1, n12(m)
                        if (i12(kk,m) .eq. sschk)  omit(k) = 0
                     end do
                  end if
               end do
            end if
         end do
         do kk = ii+1, npmf
            k = ipmf(kk)
            if (omit(k) .ne. i) then
               xr = x(i) - x(k)
               yr = y(i) - y(k)
               zr = z(i) - z(k)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. hpmfcut2) then
                  r = sqrt(r2)
                  arg1 = (r-hc1) * hw1
                  arg12 = arg1 * arg1
                  arg2 = (r-hc2) * hw2
                  arg22 = arg2 * arg2
                  arg3 = (r-hc3) * hw3
                  arg32 = arg3 * arg3
                  e1 = hd1 * exp(-arg12)
                  e2 = hd2 * exp(-arg22)
                  e3 = hd3 * exp(-arg32)
                  sum = e1 + e2 + e3
                  e = sum * cutmtx(i) * cutmtx(k)
                  ehp = ehp + e
                  nehp = nehp + 1
                  aehp(i) = aehp(i) + 0.5d0*e
                  aehp(k) = aehp(k) + 0.5d0*e
               end if
            end if
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (omit)
      deallocate (cutmtx)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine estrbnd  --  stretch-bend cross term energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "estrbnd" calculates the stretch-bend potential energy
c
c
      subroutine estrbnd
      use angbnd
      use angpot
      use atoms
      use bndstr
      use bound
      use energi
      use group
      use math
      use strbnd
      use usage
      implicit none
      integer i,j,k
      integer istrbnd
      integer ia,ib,ic
      real*8 e,eps,dt
      real*8 dr1,dr2
      real*8 fgrp,angle
      real*8 force1,force2
      real*8 dot,cosine
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab,rcb
      logical proceed
c
c
c     zero out the stretch-bend cross term energy
c
      eba = 0.0d0
      if (nstrbnd .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nstrbnd,isb,iang,sbk,
!$OMP& anat,bl,bk,use,x,y,z,stbnunit,eps,use_group,use_polymer)
!$OMP& shared(eba)
!$OMP DO reduction(+:eba)
c
c     calculate the stretch-bend interaction energy term
c
      do istrbnd = 1, nstrbnd
         i = isb(1,istrbnd)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         force1 = sbk(1,istrbnd)
         force2 = sbk(2,istrbnd)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic))
c
c     get the coordinates of the atoms in the 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)
c
c     compute the value of the bond angle
c
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            if (use_polymer) then
               call image (xab,yab,zab)
               call image (xcb,ycb,zcb)
            end if
            rab = sqrt(max(xab*xab+yab*yab+zab*zab,eps))
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            dot = xab*xcb + yab*ycb + zab*zcb
            cosine = dot / (rab*rcb)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            dt = angle - anat(i)
c
c     get the stretch-bend interaction energy
c
            j = isb(2,istrbnd)
            k = isb(3,istrbnd)
            dr1 = rab - bl(j)
            dr2 = rcb - bl(k)
            e = stbnunit * (force1*dr1+force2*dr2) * dt
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total stretch-bend energy
c
            eba = eba + e
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine estrbnd1   --  stretch-bend energy and derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "estrbnd1" calculates the stretch-bend potential energy and
c     first derivatives with respect to Cartesian coordinates
c
c
      subroutine estrbnd1
      use angbnd
      use angpot
      use atoms
      use bndstr
      use bound
      use deriv
      use energi
      use group
      use math
      use strbnd
      use usage
      use virial
      implicit none
      integer i,j,k
      integer istrbnd
      integer ia,ib,ic
      real*8 e,eps,dt
      real*8 dr1,dr2
      real*8 fgrp,angle
      real*8 force1,force2
      real*8 dot,cosine
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab,rab2
      real*8 rcb,rcb2
      real*8 xp,yp,zp,rp
      real*8 term1,term2
      real*8 termr,term1t,term2t
      real*8 ddtdxia,ddtdyia,ddtdzia
      real*8 ddtdxic,ddtdyic,ddtdzic
      real*8 ddrdxia,ddrdyia,ddrdzia
      real*8 ddrdxic,ddrdyic,ddrdzic
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out the energy and first derivative components
c
      eba = 0.0d0
      do i = 1, n
         deba(1,i) = 0.0d0
         deba(2,i) = 0.0d0
         deba(3,i) = 0.0d0
      end do
      if (nstrbnd .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nstrbnd,isb,iang,sbk,
!$OMP& anat,bl,bk,use,x,y,z,stbnunit,eps,use_group,use_polymer)
!$OMP& shared(eba,deba,vir)
!$OMP DO reduction(+:eba,deba,vir)
c
c     calculate the stretch-bend energy and first derivatives
c
      do istrbnd = 1, nstrbnd
         i = isb(1,istrbnd)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         force1 = sbk(1,istrbnd)
         force2 = sbk(2,istrbnd)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic))
c
c     get the coordinates of the atoms in the 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)
c
c     compute the value of the bond angle
c
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            if (use_polymer) then
               call image (xab,yab,zab)
               call image (xcb,ycb,zcb)
            end if
            rab2 = max(xab*xab+yab*yab+zab*zab,eps)
            rab = sqrt(rab2)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
            rcb = sqrt(rcb2)
            xp = ycb*zab - zcb*yab
            yp = zcb*xab - xcb*zab
            zp = xcb*yab - ycb*xab
            rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps))
            dot = xab*xcb + yab*ycb + zab*zcb
            cosine = dot / (rab*rcb)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
c
c     find chain rule terms for the bond angle deviation
c
            dt = angle - anat(i)
            term1 = -radian / (rab2*rp)
            term2 = radian / (rcb2*rp)
            ddtdxia = term1 * (yab*zp-zab*yp)
            ddtdyia = term1 * (zab*xp-xab*zp)
            ddtdzia = term1 * (xab*yp-yab*xp)
            ddtdxic = term2 * (ycb*zp-zcb*yp)
            ddtdyic = term2 * (zcb*xp-xcb*zp)
            ddtdzic = term2 * (xcb*yp-ycb*xp)
c
c     find chain rule terms for the bond length deviations
c
            j = isb(2,istrbnd)
            k = isb(3,istrbnd)
            dr1 = rab - bl(j)
            term1 = 1.0d0 / rab
            dr2 = rcb - bl(k)
            term2 = 1.0d0 / rcb
            ddrdxia = term1 * xab
            ddrdyia = term1 * yab
            ddrdzia = term1 * zab
            ddrdxic = term2 * xcb
            ddrdyic = term2 * ycb
            ddrdzic = term2 * zcb
c
c     abbreviations used in defining chain rule terms
c
            term1 = stbnunit * force1
            term2 = stbnunit * force2
            termr = term1*dr1 + term2*dr2
            term1t = term1 * dt
            term2t = term2 * dt
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               termr = termr * fgrp
               term1t = term1t * fgrp
               term2t = term2t * fgrp
            end if
c
c     get the energy and master chain rule terms for derivatives
c
            e = termr * dt
            dedxia = term1t*ddrdxia + termr*ddtdxia
            dedyia = term1t*ddrdyia + termr*ddtdyia
            dedzia = term1t*ddrdzia + termr*ddtdzia
            dedxic = term2t*ddrdxic + termr*ddtdxic
            dedyic = term2t*ddrdyic + termr*ddtdyic
            dedzic = term2t*ddrdzic + termr*ddtdzic
            dedxib = -dedxia - dedxic
            dedyib = -dedyia - dedyic
            dedzib = -dedzia - dedzic
c
c     increment the total stretch-bend energy and derivatives
c
            eba = eba + e
            deba(1,ia) = deba(1,ia) + dedxia
            deba(2,ia) = deba(2,ia) + dedyia
            deba(3,ia) = deba(3,ia) + dedzia
            deba(1,ib) = deba(1,ib) + dedxib
            deba(2,ib) = deba(2,ib) + dedyib
            deba(3,ib) = deba(3,ib) + dedzib
            deba(1,ic) = deba(1,ic) + dedxic
            deba(2,ic) = deba(2,ic) + dedyic
            deba(3,ic) = deba(3,ic) + dedzic
c
c     increment the internal virial tensor components
c
            vxx = xab*dedxia + xcb*dedxic
            vyx = yab*dedxia + ycb*dedxic
            vzx = zab*dedxia + zcb*dedxic
            vyy = yab*dedyia + ycb*dedyic
            vzy = zab*dedyia + zcb*dedyic
            vzz = zab*dedzia + zcb*dedzic
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine estrbnd2  --  stretch-bend Hessian; analytical  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "estrbnd2" calculates the stretch-bend potential energy
c     second derivatives with respect to Cartesian coordinates
c
c
      subroutine estrbnd2 (iatom)
      use angbnd
      use angpot
      use atoms
      use bndstr
      use bound
      use group
      use hessn
      use math
      use strbnd
      implicit none
      integer i,j,k,iatom
      integer istrbnd
      integer ia,ib,ic
      real*8 angle,eps,fgrp
      real*8 dot,cosine
      real*8 force1,force2
      real*8 dt,dr,dr1,dr2
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab,rcb,rab2,rcb2
      real*8 xp,yp,zp,rp,rp2
      real*8 term,term1,term2
      real*8 xrab,yrab,zrab
      real*8 xrcb,yrcb,zrcb
      real*8 xabp,yabp,zabp
      real*8 xcbp,ycbp,zcbp
      real*8 ddtdxia,ddtdyia,ddtdzia
      real*8 ddtdxib,ddtdyib,ddtdzib
      real*8 ddtdxic,ddtdyic,ddtdzic
      real*8 ddrdxia,ddrdyia,ddrdzia
      real*8 ddrdxib,ddrdyib,ddrdzib
      real*8 ddrdxic,ddrdyic,ddrdzic
      real*8 dtxiaxia,dtxiayia,dtxiazia
      real*8 dtxibxib,dtxibyib,dtxibzib
      real*8 dtxicxic,dtxicyic,dtxiczic
      real*8 dtyiayia,dtyiazia,dtziazia
      real*8 dtyibyib,dtyibzib,dtzibzib
      real*8 dtyicyic,dtyiczic,dtziczic
      real*8 dtxibxia,dtxibyia,dtxibzia
      real*8 dtyibxia,dtyibyia,dtyibzia
      real*8 dtzibxia,dtzibyia,dtzibzia
      real*8 dtxibxic,dtxibyic,dtxibzic
      real*8 dtyibxic,dtyibyic,dtyibzic
      real*8 dtzibxic,dtzibyic,dtzibzic
      real*8 dtxiaxic,dtxiayic,dtxiazic
      real*8 dtyiaxic,dtyiayic,dtyiazic
      real*8 dtziaxic,dtziayic,dtziazic
      real*8 drxiaxia,drxiayia,drxiazia
      real*8 drxibxib,drxibyib,drxibzib
      real*8 drxicxic,drxicyic,drxiczic
      real*8 dryiayia,dryiazia,drziazia
      real*8 dryibyib,dryibzib,drzibzib
      real*8 dryicyic,dryiczic,drziczic
      logical proceed
c
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     calculate the stretch-bend interaction Hessian elements
c
      do istrbnd = 1, nstrbnd
         i = isb(1,istrbnd)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         force1 = sbk(1,istrbnd)
         force2 = sbk(2,istrbnd)
c
c     decide whether to compute the current interaction
c
         proceed = (iatom.eq.ia .or. iatom.eq.ib .or. iatom.eq.ic)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,0,0,0)
c
c     get the coordinates of the atoms in the 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)
c
c     compute the value of the bond angle
c
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            if (use_polymer) then
               call image (xab,yab,zab)
               call image (xcb,ycb,zcb)
            end if
            rab2 = max(xab*xab+yab*yab+zab*zab,eps)
            rab = sqrt(rab2)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps)
            rcb = sqrt(rcb2)
            xp = ycb*zab - zcb*yab
            yp = zcb*xab - xcb*zab
            zp = xcb*yab - ycb*xab
            rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps))
            dot = xab*xcb + yab*ycb + zab*zcb
            cosine = dot / (rab*rcb)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
c
c     first derivatives of angle with respect to coordinates
c
            dt = angle - anat(i)
            term1 = -radian / (rab2*rp)
            term2 = radian / (rcb2*rp)
            ddtdxia = term1 * (yab*zp-zab*yp)
            ddtdyia = term1 * (zab*xp-xab*zp)
            ddtdzia = term1 * (xab*yp-yab*xp)
            ddtdxic = term2 * (ycb*zp-zcb*yp)
            ddtdyic = term2 * (zcb*xp-xcb*zp)
            ddtdzic = term2 * (xcb*yp-ycb*xp)
            ddtdxib = -ddtdxia - ddtdxic
            ddtdyib = -ddtdyia - ddtdyic
            ddtdzib = -ddtdzia - ddtdzic
c
c     abbreviations used in defining chain rule terms
c
            xrab = 2.0d0 * xab / rab2
            yrab = 2.0d0 * yab / rab2
            zrab = 2.0d0 * zab / rab2
            xrcb = 2.0d0 * xcb / rcb2
            yrcb = 2.0d0 * ycb / rcb2
            zrcb = 2.0d0 * zcb / rcb2
            rp2 = 1.0d0 / (rp*rp)
            xabp = (yab*zp-zab*yp) * rp2
            yabp = (zab*xp-xab*zp) * rp2
            zabp = (xab*yp-yab*xp) * rp2
            xcbp = (ycb*zp-zcb*yp) * rp2
            ycbp = (zcb*xp-xcb*zp) * rp2
            zcbp = (xcb*yp-ycb*xp) * rp2
c
c     second derivatives of angle with respect to coordinates
c
            dtxiaxia = term1*(xab*xcb-dot) + ddtdxia*(xcbp-xrab)
            dtxiayia = term1*(zp+yab*xcb) + ddtdxia*(ycbp-yrab)
            dtxiazia = term1*(zab*xcb-yp) + ddtdxia*(zcbp-zrab)
            dtyiayia = term1*(yab*ycb-dot) + ddtdyia*(ycbp-yrab)
            dtyiazia = term1*(xp+zab*ycb) + ddtdyia*(zcbp-zrab)
            dtziazia = term1*(zab*zcb-dot) + ddtdzia*(zcbp-zrab)
            dtxicxic = term2*(dot-xab*xcb) - ddtdxic*(xabp+xrcb)
            dtxicyic = term2*(zp-ycb*xab) - ddtdxic*(yabp+yrcb)
            dtxiczic = -term2*(yp+zcb*xab) - ddtdxic*(zabp+zrcb)
            dtyicyic = term2*(dot-yab*ycb) - ddtdyic*(yabp+yrcb)
            dtyiczic = term2*(xp-zcb*yab) - ddtdyic*(zabp+zrcb)
            dtziczic = term2*(dot-zab*zcb) - ddtdzic*(zabp+zrcb)
            dtxiaxic = term1*(yab*yab+zab*zab) - ddtdxia*xabp
            dtxiayic = -term1*xab*yab - ddtdxia*yabp
            dtxiazic = -term1*xab*zab - ddtdxia*zabp
            dtyiaxic = -term1*xab*yab - ddtdyia*xabp
            dtyiayic = term1*(xab*xab+zab*zab) - ddtdyia*yabp
            dtyiazic = -term1*yab*zab - ddtdyia*zabp
            dtziaxic = -term1*xab*zab - ddtdzia*xabp
            dtziayic = -term1*yab*zab - ddtdzia*yabp
            dtziazic = term1*(xab*xab+yab*yab) - ddtdzia*zabp
c
c     more angle deviation derivatives resulting from symmetry
c
            dtxibxia = -dtxiaxia - dtxiaxic
            dtxibyia = -dtxiayia - dtyiaxic
            dtxibzia = -dtxiazia - dtziaxic
            dtyibxia = -dtxiayia - dtxiayic
            dtyibyia = -dtyiayia - dtyiayic
            dtyibzia = -dtyiazia - dtziayic
            dtzibxia = -dtxiazia - dtxiazic
            dtzibyia = -dtyiazia - dtyiazic
            dtzibzia = -dtziazia - dtziazic
            dtxibxic = -dtxicxic - dtxiaxic
            dtxibyic = -dtxicyic - dtxiayic
            dtxibzic = -dtxiczic - dtxiazic
            dtyibxic = -dtxicyic - dtyiaxic
            dtyibyic = -dtyicyic - dtyiayic
            dtyibzic = -dtyiczic - dtyiazic
            dtzibxic = -dtxiczic - dtziaxic
            dtzibyic = -dtyiczic - dtziayic
            dtzibzic = -dtziczic - dtziazic
            dtxibxib = -dtxibxia - dtxibxic
            dtxibyib = -dtxibyia - dtxibyic
            dtxibzib = -dtxibzia - dtxibzic
            dtyibyib = -dtyibyia - dtyibyic
            dtyibzib = -dtyibzia - dtyibzic
            dtzibzib = -dtzibzia - dtzibzic
c
c     compute the values of the bond length deviations
c
            j = isb(2,istrbnd)
            k = isb(3,istrbnd)
            term = stbnunit * force1
            dr1 = term*(rab-bl(j))
            term1 = term / rab
            term = stbnunit * force2
            dr2 = term*(rcb-bl(k))
            term2 = term / rcb
            dr = dr1 + dr2
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               dr = dr * fgrp
               dr1 = dr1 * fgrp
               dr2 = dr2 * fgrp
               term1 = term1 * fgrp
               term2 = term2 * fgrp
            end if
c
c     first derivatives of bond length with respect to coordinates
c
            ddrdxia = term1 * xab
            ddrdyia = term1 * yab
            ddrdzia = term1 * zab
            ddrdxic = term2 * xcb
            ddrdyic = term2 * ycb
            ddrdzic = term2 * zcb
            ddrdxib = -ddrdxia - ddrdxic
            ddrdyib = -ddrdyia - ddrdyic
            ddrdzib = -ddrdzia - ddrdzic
c
c     abbreviations used in defining chain rule terms
c
            xab = xab / rab
            yab = yab / rab
            zab = zab / rab
            xcb = xcb / rcb
            ycb = ycb / rcb
            zcb = zcb / rcb
c
c     second derivatives of bond length with respect to coordinates
c
            drxiaxia = term1 * (1.0d0-xab*xab)
            drxiayia = -term1 * xab*yab
            drxiazia = -term1 * xab*zab
            dryiayia = term1 * (1.0d0-yab*yab)
            dryiazia = -term1 * yab*zab
            drziazia = term1 * (1.0d0-zab*zab)
            drxicxic = term2 * (1.0d0-xcb*xcb)
            drxicyic = -term2 * xcb*ycb
            drxiczic = -term2 * xcb*zcb
            dryicyic = term2 * (1.0d0-ycb*ycb)
            dryiczic = -term2 * ycb*zcb
            drziczic = term2 * (1.0d0-zcb*zcb)
            drxibxib = drxiaxia + drxicxic
            drxibyib = drxiayia + drxicyic
            drxibzib = drxiazia + drxiczic
            dryibyib = dryiayia + dryicyic
            dryibzib = dryiazia + dryiczic
            drzibzib = drziazia + drziczic
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (ia .eq. iatom) then
               hessx(1,ia) = hessx(1,ia) + dt*drxiaxia + dr*dtxiaxia
     &                          + 2.0d0*ddtdxia*ddrdxia
               hessx(2,ia) = hessx(2,ia) + dt*drxiayia + dr*dtxiayia
     &                          + ddtdxia*ddrdyia + ddtdyia*ddrdxia
               hessx(3,ia) = hessx(3,ia) + dt*drxiazia + dr*dtxiazia
     &                          + ddtdxia*ddrdzia + ddtdzia*ddrdxia
               hessy(1,ia) = hessy(1,ia) + dt*drxiayia + dr*dtxiayia
     &                          + ddtdyia*ddrdxia + ddtdxia*ddrdyia
               hessy(2,ia) = hessy(2,ia) + dt*dryiayia + dr*dtyiayia
     &                          + 2.0d0*ddtdyia*ddrdyia
               hessy(3,ia) = hessy(3,ia) + dt*dryiazia + dr*dtyiazia
     &                          + ddtdyia*ddrdzia + ddtdzia*ddrdyia
               hessz(1,ia) = hessz(1,ia) + dt*drxiazia + dr*dtxiazia
     &                          + ddtdzia*ddrdxia + ddtdxia*ddrdzia
               hessz(2,ia) = hessz(2,ia) + dt*dryiazia + dr*dtyiazia
     &                          + ddtdzia*ddrdyia + ddtdyia*ddrdzia
               hessz(3,ia) = hessz(3,ia) + dt*drziazia + dr*dtziazia
     &                          + 2.0d0*ddtdzia*ddrdzia
               hessx(1,ib) = hessx(1,ib) - dt*drxiaxia + dr*dtxibxia
     &                          + ddtdxia*ddrdxib + ddtdxib*ddrdxia
               hessx(2,ib) = hessx(2,ib) - dt*drxiayia + dr*dtxibyia
     &                          + ddtdxia*ddrdyib + ddtdyib*ddrdxia
               hessx(3,ib) = hessx(3,ib) - dt*drxiazia + dr*dtxibzia
     &                          + ddtdxia*ddrdzib + ddtdzib*ddrdxia
               hessy(1,ib) = hessy(1,ib) - dt*drxiayia + dr*dtyibxia
     &                          + ddtdyia*ddrdxib + ddtdxib*ddrdyia
               hessy(2,ib) = hessy(2,ib) - dt*dryiayia + dr*dtyibyia
     &                          + ddtdyia*ddrdyib + ddtdyib*ddrdyia
               hessy(3,ib) = hessy(3,ib) - dt*dryiazia + dr*dtyibzia
     &                          + ddtdyia*ddrdzib + ddtdzib*ddrdyia
               hessz(1,ib) = hessz(1,ib) - dt*drxiazia + dr*dtzibxia
     &                          + ddtdzia*ddrdxib + ddtdxib*ddrdzia
               hessz(2,ib) = hessz(2,ib) - dt*dryiazia + dr*dtzibyia
     &                          + ddtdzia*ddrdyib + ddtdyib*ddrdzia
               hessz(3,ib) = hessz(3,ib) - dt*drziazia + dr*dtzibzia
     &                          + ddtdzia*ddrdzib + ddtdzib*ddrdzia
               hessx(1,ic) = hessx(1,ic) + dr*dtxiaxic
     &                          + ddtdxia*ddrdxic + ddtdxic*ddrdxia
               hessx(2,ic) = hessx(2,ic) + dr*dtxiayic
     &                          + ddtdxia*ddrdyic + ddtdyic*ddrdxia
               hessx(3,ic) = hessx(3,ic) + dr*dtxiazic
     &                          + ddtdxia*ddrdzic + ddtdzic*ddrdxia
               hessy(1,ic) = hessy(1,ic) + dr*dtyiaxic
     &                          + ddtdyia*ddrdxic + ddtdxic*ddrdyia
               hessy(2,ic) = hessy(2,ic) + dr*dtyiayic
     &                          + ddtdyia*ddrdyic + ddtdyic*ddrdyia
               hessy(3,ic) = hessy(3,ic) + dr*dtyiazic
     &                          + ddtdyia*ddrdzic + ddtdzic*ddrdyia
               hessz(1,ic) = hessz(1,ic) + dr*dtziaxic
     &                          + ddtdzia*ddrdxic + ddtdxic*ddrdzia
               hessz(2,ic) = hessz(2,ic) + dr*dtziayic
     &                          + ddtdzia*ddrdyic + ddtdyic*ddrdzia
               hessz(3,ic) = hessz(3,ic) + dr*dtziazic
     &                          + ddtdzia*ddrdzic + ddtdzic*ddrdzia
            else if (ib .eq. iatom) then
               hessx(1,ib) = hessx(1,ib) + dt*drxibxib + dr*dtxibxib
     &                          + 2.0d0*ddtdxib*ddrdxib
               hessx(2,ib) = hessx(2,ib) + dt*drxibyib + dr*dtxibyib
     &                          + ddtdxib*ddrdyib + ddtdyib*ddrdxib
               hessx(3,ib) = hessx(3,ib) + dt*drxibzib + dr*dtxibzib
     &                          + ddtdxib*ddrdzib + ddtdzib*ddrdxib
               hessy(1,ib) = hessy(1,ib) + dt*drxibyib + dr*dtxibyib
     &                          + ddtdyib*ddrdxib + ddtdxib*ddrdyib
               hessy(2,ib) = hessy(2,ib) + dt*dryibyib + dr*dtyibyib
     &                          + 2.0d0*ddtdyib*ddrdyib
               hessy(3,ib) = hessy(3,ib) + dt*dryibzib + dr*dtyibzib
     &                          + ddtdyib*ddrdzib + ddtdzib*ddrdyib
               hessz(1,ib) = hessz(1,ib) + dt*drxibzib + dr*dtxibzib
     &                          + ddtdzib*ddrdxib + ddtdxib*ddrdzib
               hessz(2,ib) = hessz(2,ib) + dt*dryibzib + dr*dtyibzib
     &                          + ddtdzib*ddrdyib + ddtdyib*ddrdzib
               hessz(3,ib) = hessz(3,ib) + dt*drzibzib + dr*dtzibzib
     &                          + 2.0d0*ddtdzib*ddrdzib
               hessx(1,ia) = hessx(1,ia) - dt*drxiaxia + dr*dtxibxia
     &                          + ddtdxib*ddrdxia + ddtdxia*ddrdxib
               hessx(2,ia) = hessx(2,ia) - dt*drxiayia + dr*dtxibyia
     &                          + ddtdxib*ddrdyia + ddtdyia*ddrdxib
               hessx(3,ia) = hessx(3,ia) - dt*drxiazia + dr*dtxibzia
     &                          + ddtdxib*ddrdzia + ddtdzia*ddrdxib
               hessy(1,ia) = hessy(1,ia) - dt*drxiayia + dr*dtyibxia
     &                          + ddtdyib*ddrdxia + ddtdxia*ddrdyib
               hessy(2,ia) = hessy(2,ia) - dt*dryiayia + dr*dtyibyia
     &                          + ddtdyib*ddrdyia + ddtdyia*ddrdyib
               hessy(3,ia) = hessy(3,ia) - dt*dryiazia + dr*dtyibzia
     &                          + ddtdyib*ddrdzia + ddtdzia*ddrdyib
               hessz(1,ia) = hessz(1,ia) - dt*drxiazia + dr*dtzibxia
     &                          + ddtdzib*ddrdxia + ddtdxia*ddrdzib
               hessz(2,ia) = hessz(2,ia) - dt*dryiazia + dr*dtzibyia
     &                          + ddtdzib*ddrdyia + ddtdyia*ddrdzib
               hessz(3,ia) = hessz(3,ia) - dt*drziazia + dr*dtzibzia
     &                          + ddtdzib*ddrdzia + ddtdzia*ddrdzib
               hessx(1,ic) = hessx(1,ic) - dt*drxicxic + dr*dtxibxic
     &                          + ddtdxib*ddrdxic + ddtdxic*ddrdxib
               hessx(2,ic) = hessx(2,ic) - dt*drxicyic + dr*dtxibyic
     &                          + ddtdxib*ddrdyic + ddtdyic*ddrdxib
               hessx(3,ic) = hessx(3,ic) - dt*drxiczic + dr*dtxibzic
     &                          + ddtdxib*ddrdzic + ddtdzic*ddrdxib
               hessy(1,ic) = hessy(1,ic) - dt*drxicyic + dr*dtyibxic
     &                          + ddtdyib*ddrdxic + ddtdxic*ddrdyib
               hessy(2,ic) = hessy(2,ic) - dt*dryicyic + dr*dtyibyic
     &                          + ddtdyib*ddrdyic + ddtdyic*ddrdyib
               hessy(3,ic) = hessy(3,ic) - dt*dryiczic + dr*dtyibzic
     &                          + ddtdyib*ddrdzic + ddtdzic*ddrdyib
               hessz(1,ic) = hessz(1,ic) - dt*drxiczic + dr*dtzibxic
     &                          + ddtdzib*ddrdxic + ddtdxic*ddrdzib
               hessz(2,ic) = hessz(2,ic) - dt*dryiczic + dr*dtzibyic
     &                          + ddtdzib*ddrdyic + ddtdyic*ddrdzib
               hessz(3,ic) = hessz(3,ic) - dt*drziczic + dr*dtzibzic
     &                          + ddtdzib*ddrdzic + ddtdzic*ddrdzib
            else if (ic .eq. iatom) then
               hessx(1,ic) = hessx(1,ic) + dt*drxicxic + dr*dtxicxic
     &                          + 2.0d0*ddtdxic*ddrdxic
               hessx(2,ic) = hessx(2,ic) + dt*drxicyic + dr*dtxicyic
     &                          + ddtdxic*ddrdyic + ddtdyic*ddrdxic
               hessx(3,ic) = hessx(3,ic) + dt*drxiczic + dr*dtxiczic
     &                          + ddtdxic*ddrdzic + ddtdzic*ddrdxic
               hessy(1,ic) = hessy(1,ic) + dt*drxicyic + dr*dtxicyic
     &                          + ddtdyic*ddrdxic + ddtdxic*ddrdyic
               hessy(2,ic) = hessy(2,ic) + dt*dryicyic + dr*dtyicyic
     &                          + 2.0d0*ddtdyic*ddrdyic
               hessy(3,ic) = hessy(3,ic) + dt*dryiczic + dr*dtyiczic
     &                          + ddtdyic*ddrdzic + ddtdzic*ddrdyic
               hessz(1,ic) = hessz(1,ic) + dt*drxiczic + dr*dtxiczic
     &                          + ddtdzic*ddrdxic + ddtdxic*ddrdzic
               hessz(2,ic) = hessz(2,ic) + dt*dryiczic + dr*dtyiczic
     &                          + ddtdzic*ddrdyic + ddtdyic*ddrdzic
               hessz(3,ic) = hessz(3,ic) + dt*drziczic + dr*dtziczic
     &                          + 2.0d0*ddtdzic*ddrdzic
               hessx(1,ib) = hessx(1,ib) - dt*drxicxic + dr*dtxibxic
     &                          + ddtdxic*ddrdxib + ddtdxib*ddrdxic
               hessx(2,ib) = hessx(2,ib) - dt*drxicyic + dr*dtxibyic
     &                          + ddtdxic*ddrdyib + ddtdyib*ddrdxic
               hessx(3,ib) = hessx(3,ib) - dt*drxiczic + dr*dtxibzic
     &                          + ddtdxic*ddrdzib + ddtdzib*ddrdxic
               hessy(1,ib) = hessy(1,ib) - dt*drxicyic + dr*dtyibxic
     &                          + ddtdyic*ddrdxib + ddtdxib*ddrdyic
               hessy(2,ib) = hessy(2,ib) - dt*dryicyic + dr*dtyibyic
     &                          + ddtdyic*ddrdyib + ddtdyib*ddrdyic
               hessy(3,ib) = hessy(3,ib) - dt*dryiczic + dr*dtyibzic
     &                          + ddtdyic*ddrdzib + ddtdzib*ddrdyic
               hessz(1,ib) = hessz(1,ib) - dt*drxiczic + dr*dtzibxic
     &                          + ddtdzic*ddrdxib + ddtdxib*ddrdzic
               hessz(2,ib) = hessz(2,ib) - dt*dryiczic + dr*dtzibyic
     &                          + ddtdzic*ddrdyib + ddtdyib*ddrdzic
               hessz(3,ib) = hessz(3,ib) - dt*drziczic + dr*dtzibzic
     &                          + ddtdzic*ddrdzib + ddtdzib*ddrdzic
               hessx(1,ia) = hessx(1,ia) + dr*dtxiaxic
     &                          + ddtdxic*ddrdxia + ddtdxia*ddrdxic
               hessx(2,ia) = hessx(2,ia) + dr*dtyiaxic
     &                          + ddtdxic*ddrdyia + ddtdyia*ddrdxic
               hessx(3,ia) = hessx(3,ia) + dr*dtziaxic
     &                          + ddtdxic*ddrdzia + ddtdzia*ddrdxic
               hessy(1,ia) = hessy(1,ia) + dr*dtxiayic
     &                          + ddtdyic*ddrdxia + ddtdxia*ddrdyic
               hessy(2,ia) = hessy(2,ia) + dr*dtyiayic
     &                          + ddtdyic*ddrdyia + ddtdyia*ddrdyic
               hessy(3,ia) = hessy(3,ia) + dr*dtziayic
     &                          + ddtdyic*ddrdzia + ddtdzia*ddrdyic
               hessz(1,ia) = hessz(1,ia) + dr*dtxiazic
     &                          + ddtdzic*ddrdxia + ddtdxia*ddrdzic
               hessz(2,ia) = hessz(2,ia) + dr*dtyiazic
     &                          + ddtdzic*ddrdyia + ddtdyia*ddrdzic
               hessz(3,ia) = hessz(3,ia) + dr*dtziazic
     &                          + ddtdzic*ddrdzia + ddtdzia*ddrdzic
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine estrbnd3  --  stretch-bend energy & analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "estrbnd3" calculates the stretch-bend potential energy;
c     also partitions the energy among the atoms
c
c
      subroutine estrbnd3
      use action
      use analyz
      use angbnd
      use angpot
      use atomid
      use atoms
      use bndstr
      use bound
      use energi
      use group
      use inform
      use iounit
      use math
      use strbnd
      use usage
      implicit none
      integer i,j,k
      integer istrbnd
      integer ia,ib,ic
      real*8 e,eps,dt
      real*8 dr1,dr2
      real*8 fgrp,angle
      real*8 force1,force2
      real*8 dot,cosine
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab,rcb
      logical proceed
      logical header,huge
c
c
c     zero out the energy component and partitioning terms
c
      neba = 0
      eba = 0.0d0
      do i = 1, n
         aeba(i) = 0.0d0
      end do
      if (nstrbnd .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nstrbnd.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Stretch-Bend Interactions :',
     &           //,' Type',18x,'Atom Names',18x,'dSB 1',
     &              5x,'dSB 2',6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nstrbnd,isb,iang,sbk,
!$OMP& anat,bl,bk,use,x,y,z,stbnunit,eps,use_group,use_polymer,
!$OMP& name,verbose,debug,header,iout)
!$OMP& shared(eba,neba,aeba)
!$OMP DO reduction(+:eba,neba,aeba)
c
c     calculate the stretch-bend interaction energy term
c
      do istrbnd = 1, nstrbnd
         i = isb(1,istrbnd)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         force1 = sbk(1,istrbnd)
         force2 = sbk(2,istrbnd)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic))
c
c     get the coordinates of the atoms in the 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)
c
c     compute the value of the bond angle
c
            xab = xia - xib
            yab = yia - yib
            zab = zia - zib
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            if (use_polymer) then
               call image (xab,yab,zab)
               call image (xcb,ycb,zcb)
            end if
            rab = sqrt(max(xab*xab+yab*yab+zab*zab,eps))
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            dot = xab*xcb + yab*ycb + zab*zcb
            cosine = dot / (rab*rcb)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            dt = angle - anat(i)
c
c     get the stretch-bend interaction energy
c
            j = isb(2,istrbnd)
            k = isb(3,istrbnd)
            dr1 = rab - bl(j)
            dr2 = rcb - bl(k)
            e = stbnunit * (force1*dr1+force2*dr2) * dt
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total stretch-bend energy
c
            neba = neba + 1
            eba = eba + e
            aeba(ib) = aeba(ib) + e
c
c     print a message if the energy of this interaction is large
c
            huge = (abs(e) .gt. 5.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Individual Stretch-Bend',
     &                       ' Interactions :',
     &                    //,' Type',18x,'Atom Names',18x,'dSB 1',
     &                       5x,'dSB 2',6x,'Energy',/)
               end if
               write (iout,30)  ia,name(ia),ib,name(ib),
     &                          ic,name(ic),dr1*dt,dr2*dt,e
   30          format (' StrBend',3x,3(i7,'-',a3),2x,2f10.4,f12.4)
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder  ##
c     ##                  All Rights Reserved                 ##
c     ##########################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine estrtor  --  stretch-torsion cross term energy  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "estrtor" calculates the stretch-torsion potential energy
c
c
      subroutine estrtor
      use atoms
      use bndstr
      use bound
      use energi
      use group
      use strtor
      use torpot
      use tors
      use usage
      implicit none
      integer i,k,istrtor
      integer ia,ib,ic,id
      real*8 e,eps,dr,fgrp
      real*8 rt2,ru2,rtru
      real*8 rba,rcb,rdc
      real*8 e1,e2,e3
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 sine3,cosine3
      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
      real*8 xdc,ydc,zdc
      logical proceed
c
c
c     zero out the stretch-torsion energy
c
      ebt = 0.0d0
      if (nstrtor .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nstrtor,ist,itors,kst,bl,
!$OMP& tors1,tors2,tors3,use,x,y,z,storunit,eps,use_group,use_polymer)
!$OMP& shared(ebt)
!$OMP DO reduction(+:ebt)
c
c     calculate the stretch-torsion interaction energy term
c
      do istrtor = 1, nstrtor
         i = ist(1,istrtor)
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rba = sqrt(xba*xba + yba*yba + zba*zba)
            rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
            rcb = max(rcb,eps)
            rdc = sqrt(xdc*xdc + ydc*ydc + zdc*zdc)
            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
            rt2 = max(rt2,eps)
            ru2 = xu*xu + yu*yu + zu*zu
            ru2 = max(ru2,eps)
            rtru = sqrt(rt2*ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     compute multiple angle trigonometry and phase terms
c
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            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)
c
c     get the stretch-torsion values for the first bond
c
            v1 = kst(1,istrtor)
            v2 = kst(2,istrtor)
            v3 = kst(3,istrtor)
            k = ist(2,istrtor)
            dr = rba - bl(k)
            e1 = storunit * dr * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     get the stretch-torsion values for the second bond
c
            v1 = kst(4,istrtor)
            v2 = kst(5,istrtor)
            v3 = kst(6,istrtor)
            k = ist(3,istrtor)
            dr = rcb - bl(k)
            e2 = storunit * dr * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     get the stretch-torsion values for the third bond
c
            v1 = kst(7,istrtor)
            v2 = kst(8,istrtor)
            v3 = kst(9,istrtor)
            k = ist(4,istrtor)
            dr = rdc - bl(k)
            e3 = storunit * dr * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e1 = e1 * fgrp
               e2 = e2 * fgrp
               e3 = e3 * fgrp
            end if
c
c     increment the total stretch-torsion energy
c
            e = e1 + e2 + e3
            ebt = ebt + e
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder  ##
c     ##                  All Rights Reserved                 ##
c     ##########################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine estrtor1  --  stretch-torsion energy & derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "estrtor1" calculates the stretch-torsion energy and first
c     derivatives with respect to Cartesian coordinates
c
c
      subroutine estrtor1
      use atoms
      use bndstr
      use bound
      use deriv
      use energi
      use group
      use strtor
      use torpot
      use tors
      use usage
      use virial
      implicit none
      integer i,k,istrtor
      integer ia,ib,ic,id
      real*8 e,eps,dr,fgrp
      real*8 rt2,ru2,rtru
      real*8 rba,rcb,rdc
      real*8 e1,e2,e3
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 sine3,cosine3
      real*8 phi1,phi2,phi3
      real*8 dphi1,dphi2,dphi3
      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
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 ddr,dedphi
      real*8 ddrdx,ddrdy,ddrdz
      real*8 dedxt,dedyt,dedzt
      real*8 dedxu,dedyu,dedzu
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out the stretch-torsion energy and first derivatives
c
      ebt = 0.0d0
      do i = 1, n
         debt(1,i) = 0.0d0
         debt(2,i) = 0.0d0
         debt(3,i) = 0.0d0
      end do
      if (nstrtor .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nstrtor,ist,itors,kst,bl,
!$OMP& tors1,tors2,tors3,use,x,y,z,storunit,eps,use_group,use_polymer)
!$OMP& shared(ebt,debt,vir)
!$OMP DO reduction(+:ebt,debt,vir)
c
c     calculate the stretch-torsion energy and first derivatives
c
      do istrtor = 1, nstrtor
         i = ist(1,istrtor)
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rba = sqrt(xba*xba + yba*yba + zba*zba)
            rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
            rcb = max(rcb,eps)
            rdc = sqrt(xdc*xdc + ydc*ydc + zdc*zdc)
            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
            rt2 = max(rt2,eps)
            ru2 = xu*xu + yu*yu + zu*zu
            ru2 = max(ru2,eps)
            rtru = sqrt(rt2*ru2)
            xca = xic - xia
            yca = yic - yia
            zca = zic - zia
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            if (use_polymer) then
               call image (xca,yca,zca)
               call image (xdb,ydb,zdb)
            end if
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     compute multiple angle trigonometry and phase terms
c
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            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     get the stretch-torsion values for the first bond
c
            v1 = kst(1,istrtor)
            v2 = kst(2,istrtor)
            v3 = kst(3,istrtor)
            k = ist(2,istrtor)
            dr = rba - bl(k)
            e1 = storunit * dr * (v1*phi1 + v2*phi2 + v3*phi3)
            dedphi = storunit * dr * (v1*dphi1 + v2*dphi2 + v3*dphi3)
            rba = max(rba,eps)
            ddr = storunit * (v1*phi1 + v2*phi2 + v3*phi3) / rba
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e1 = e1 * fgrp
               dedphi = dedphi * fgrp
               ddr = ddr * fgrp
            end if
c
c     compute derivative components for this interaction
c
            ddrdx = xba * ddr
            ddrdy = yba * ddr
            ddrdz = zba * ddr
            dedxt = dedphi * (yt*zcb - ycb*zt) / (rt2*rcb)
            dedyt = dedphi * (zt*xcb - zcb*xt) / (rt2*rcb)
            dedzt = dedphi * (xt*ycb - xcb*yt) / (rt2*rcb)
            dedxu = -dedphi * (yu*zcb - ycb*zu) / (ru2*rcb)
            dedyu = -dedphi * (zu*xcb - zcb*xu) / (ru2*rcb)
            dedzu = -dedphi * (xu*ycb - xcb*yu) / (ru2*rcb)
c
c     determine chain rule components for the first bond
c
            dedxia = zcb*dedyt - ycb*dedzt - ddrdx
            dedyia = xcb*dedzt - zcb*dedxt - ddrdy
            dedzia = ycb*dedxt - xcb*dedyt - ddrdz
            dedxib = yca*dedzt - zca*dedyt + zdc*dedyu
     &                  - ydc*dedzu + ddrdx
            dedyib = zca*dedxt - xca*dedzt + xdc*dedzu
     &                  - zdc*dedxu + ddrdy
            dedzib = xca*dedyt - yca*dedxt + ydc*dedxu
     &                  - xdc*dedyu + ddrdz
            dedxic = zba*dedyt - yba*dedzt + ydb*dedzu
     &                  - zdb*dedyu
            dedyic = xba*dedzt - zba*dedxt + zdb*dedxu
     &                  - xdb*dedzu
            dedzic = yba*dedxt - xba*dedyt + xdb*dedyu
     &                  - ydb*dedxu
            dedxid = zcb*dedyu - ycb*dedzu
            dedyid = xcb*dedzu - zcb*dedxu
            dedzid = ycb*dedxu - xcb*dedyu
c
c     get the stretch-torsion values for the second bond
c
            v1 = kst(4,istrtor)
            v2 = kst(5,istrtor)
            v3 = kst(6,istrtor)
            k = ist(3,istrtor)
            dr = rcb - bl(k)
            e2 = storunit * dr * (v1*phi1 + v2*phi2 + v3*phi3)
            dedphi = storunit * dr * (v1*dphi1 + v2*dphi2 + v3*dphi3)
            ddr = storunit * (v1*phi1 + v2*phi2 + v3*phi3) / rcb
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e2 = e2 * fgrp
               dedphi = dedphi * fgrp
               ddr = ddr * fgrp
            end if
c
c     compute derivative components for this interaction
c
            ddrdx = xcb * ddr
            ddrdy = ycb * ddr
            ddrdz = zcb * ddr
            dedxt = dedphi * (yt*zcb - ycb*zt) / (rt2*rcb)
            dedyt = dedphi * (zt*xcb - zcb*xt) / (rt2*rcb)
            dedzt = dedphi * (xt*ycb - xcb*yt) / (rt2*rcb)
            dedxu = -dedphi * (yu*zcb - ycb*zu) / (ru2*rcb)
            dedyu = -dedphi * (zu*xcb - zcb*xu) / (ru2*rcb)
            dedzu = -dedphi * (xu*ycb - xcb*yu) / (ru2*rcb)
c
c     increment chain rule components for the second bond
c
            dedxia = dedxia + zcb*dedyt - ycb*dedzt
            dedyia = dedyia + xcb*dedzt - zcb*dedxt
            dedzia = dedzia + ycb*dedxt - xcb*dedyt
            dedxib = dedxib + yca*dedzt - zca*dedyt + zdc*dedyu
     &                  - ydc*dedzu - ddrdx
            dedyib = dedyib + zca*dedxt - xca*dedzt + xdc*dedzu
     &                  - zdc*dedxu - ddrdy
            dedzib = dedzib + xca*dedyt - yca*dedxt + ydc*dedxu
     &                  - xdc*dedyu - ddrdz
            dedxic = dedxic + zba*dedyt - yba*dedzt + ydb*dedzu
     &                  - zdb*dedyu + ddrdx
            dedyic = dedyic + xba*dedzt - zba*dedxt + zdb*dedxu
     &                  - xdb*dedzu + ddrdy
            dedzic = dedzic + yba*dedxt - xba*dedyt + xdb*dedyu
     &                  - ydb*dedxu + ddrdz
            dedxid = dedxid + zcb*dedyu - ycb*dedzu
            dedyid = dedyid + xcb*dedzu - zcb*dedxu
            dedzid = dedzid + ycb*dedxu - xcb*dedyu
c
c     get the stretch-torsion values for the third bond
c
            v1 = kst(7,istrtor)
            v2 = kst(8,istrtor)
            v3 = kst(9,istrtor)
            k = ist(4,istrtor)
            dr = rdc - bl(k)
            e3 = storunit * dr * (v1*phi1 + v2*phi2 + v3*phi3)
            dedphi = storunit * dr * (v1*dphi1 + v2*dphi2 + v3*dphi3)
            rdc = max(rdc,eps)
            ddr = storunit * (v1*phi1 + v2*phi2 + v3*phi3) / rdc
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e3 = e3 * fgrp
               dedphi = dedphi * fgrp
               ddr = ddr * fgrp
            end if
c
c     compute derivative components for this interaction
c
            ddrdx = xdc * ddr
            ddrdy = ydc * ddr
            ddrdz = zdc * ddr
            dedxt = dedphi * (yt*zcb - ycb*zt) / (rt2*rcb)
            dedyt = dedphi * (zt*xcb - zcb*xt) / (rt2*rcb)
            dedzt = dedphi * (xt*ycb - xcb*yt) / (rt2*rcb)
            dedxu = -dedphi * (yu*zcb - ycb*zu) / (ru2*rcb)
            dedyu = -dedphi * (zu*xcb - zcb*xu) / (ru2*rcb)
            dedzu = -dedphi * (xu*ycb - xcb*yu) / (ru2*rcb)
c
c     increment chain rule components for the third bond
c
            dedxia = dedxia + zcb*dedyt - ycb*dedzt
            dedyia = dedyia + xcb*dedzt - zcb*dedxt
            dedzia = dedzia + ycb*dedxt - xcb*dedyt
            dedxib = dedxib + yca*dedzt - zca*dedyt + zdc*dedyu
     &                  - ydc*dedzu
            dedyib = dedyib + zca*dedxt - xca*dedzt + xdc*dedzu
     &                  - zdc*dedxu
            dedzib = dedzib + xca*dedyt - yca*dedxt + ydc*dedxu
     &                  - xdc*dedyu
            dedxic = dedxic + zba*dedyt - yba*dedzt + ydb*dedzu
     &                  - zdb*dedyu - ddrdx
            dedyic = dedyic + xba*dedzt - zba*dedxt + zdb*dedxu
     &                  - xdb*dedzu - ddrdy
            dedzic = dedzic + yba*dedxt - xba*dedyt + xdb*dedyu
     &                  - ydb*dedxu - ddrdz
            dedxid = dedxid + zcb*dedyu - ycb*dedzu + ddrdx
            dedyid = dedyid + xcb*dedzu - zcb*dedxu + ddrdy
            dedzid = dedzid + ycb*dedxu - xcb*dedyu + ddrdz
c
c     increment the stretch-torsion energy and gradient
c
            e = e1 + e2 + e3
            ebt = ebt + e
            debt(1,ia) = debt(1,ia) + dedxia
            debt(2,ia) = debt(2,ia) + dedyia
            debt(3,ia) = debt(3,ia) + dedzia
            debt(1,ib) = debt(1,ib) + dedxib
            debt(2,ib) = debt(2,ib) + dedyib
            debt(3,ib) = debt(3,ib) + dedzib
            debt(1,ic) = debt(1,ic) + dedxic
            debt(2,ic) = debt(2,ic) + dedyic
            debt(3,ic) = debt(3,ic) + dedzic
            debt(1,id) = debt(1,id) + dedxid
            debt(2,id) = debt(2,id) + dedyid
            debt(3,id) = debt(3,id) + dedzid
c
c     increment the internal virial tensor components
c
            vxx = xcb*(dedxic+dedxid) - xba*dedxia + xdc*dedxid
            vyx = ycb*(dedxic+dedxid) - yba*dedxia + ydc*dedxid
            vzx = zcb*(dedxic+dedxid) - zba*dedxia + zdc*dedxid
            vyy = ycb*(dedyic+dedyid) - yba*dedyia + ydc*dedyid
            vzy = zcb*(dedyic+dedyid) - zba*dedyia + zdc*dedyid
            vzz = zcb*(dedzic+dedzid) - zba*dedzia + zdc*dedzid
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder  ##
c     ##                  All Rights Reserved                 ##
c     ##########################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine estrtor2  --  atomwise stretch-torsion Hessian  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "estrtor2" calculates the stretch-torsion potential energy
c     second derivatives with respect to Cartesian coordinates
c
c
      subroutine estrtor2 (i)
      use atoms
      use bndstr
      use bound
      use group
      use hessn
      use strtor
      use torpot
      use tors
      implicit none
      integer i,j,k,istrtor
      integer ia,ib,ic,id
      real*8 eps,fgrp
      real*8 dedphi
      real*8 d2edphi2
      real*8 rt2,ru2,rtru
      real*8 rba,rcb,rdc
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 sine3,cosine3
      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
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 phi1,phi2,phi3
      real*8 dphi1,dphi2,dphi3
      real*8 d2phi1,d2phi2,d2phi3
      real*8 dr,ddr,d2dr
      real*8 ddrdx,ddrdy,ddrdz
      real*8 d2drdxx,d2drdyy,d2drdzz
      real*8 d2drdxy,d2drdxz,d2drdyz
      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 xycb2,xzcb2,yzcb2
      real*8 rcbxt,rcbyt,rcbzt,rcbt2
      real*8 rcbxu,rcbyu,rcbzu,rcbu2
      real*8 dphidxibt,dphidyibt,dphidzibt
      real*8 dphidxibu,dphidyibu,dphidzibu
      real*8 dphidxict,dphidyict,dphidzict
      real*8 dphidxicu,dphidyicu,dphidzicu
      real*8 dxia,dyia,dzia
      real*8 dxib,dyib,dzib
      real*8 dxic,dyic,dzic
      real*8 dxid,dyid,dzid
      real*8 dxiaxia,dyiayia,dziazia
      real*8 dxibxib,dyibyib,dzibzib
      real*8 dxicxic,dyicyic,dziczic
      real*8 dxidxid,dyidyid,dzidzid
      real*8 dxiayia,dxiazia,dyiazia
      real*8 dxibyib,dxibzib,dyibzib
      real*8 dxicyic,dxiczic,dyiczic
      real*8 dxidyid,dxidzid,dyidzid
      real*8 dxiaxib,dxiayib,dxiazib
      real*8 dyiaxib,dyiayib,dyiazib
      real*8 dziaxib,dziayib,dziazib
      real*8 dxiaxic,dxiayic,dxiazic
      real*8 dyiaxic,dyiayic,dyiazic
      real*8 dziaxic,dziayic,dziazic
      real*8 dxiaxid,dxiayid,dxiazid
      real*8 dyiaxid,dyiayid,dyiazid
      real*8 dziaxid,dziayid,dziazid
      real*8 dxibxic,dxibyic,dxibzic
      real*8 dyibxic,dyibyic,dyibzic
      real*8 dzibxic,dzibyic,dzibzic
      real*8 dxibxid,dxibyid,dxibzid
      real*8 dyibxid,dyibyid,dyibzid
      real*8 dzibxid,dzibyid,dzibzid
      real*8 dxicxid,dxicyid,dxiczid
      real*8 dyicxid,dyicyid,dyiczid
      real*8 dzicxid,dzicyid,dziczid
      logical proceed
c
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     calculate the stretch-torsion interaction Hessian elements
c
      do istrtor = 1, nstrtor
         j = ist(1,istrtor)
         ia = itors(1,j)
         ib = itors(2,j)
         ic = itors(3,j)
         id = itors(4,j)
c
c     decide whether to compute the current interaction
c
         proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic .or. i.eq.id)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,id,0,0)
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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rba = sqrt(xba*xba + yba*yba + zba*zba)
            rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
            rcb = max(rcb,eps)
            rdc = sqrt(xdc*xdc + ydc*ydc + zdc*zdc)
            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
            rt2 = max(rt2,eps)
            ru2 = xu*xu + yu*yu + zu*zu
            ru2 = max(ru2,eps)
            rtru = sqrt(rt2*ru2)
            xca = xic - xia
            yca = yic - yia
            zca = zic - zia
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            if (use_polymer) then
               call image (xca,yca,zca)
               call image (xdb,ydb,zdb)
            end if
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     abbreviations for first derivative chain rule terms
c
            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     abbreviations for second derivative chain rule terms
c
            xycb2 = xcb*xcb + ycb*ycb
            xzcb2 = xcb*xcb + zcb*zcb
            yzcb2 = ycb*ycb + zcb*zcb
            rcbxt = -2.0d0 * rcb * dphidxt
            rcbyt = -2.0d0 * rcb * dphidyt
            rcbzt = -2.0d0 * rcb * dphidzt
            rcbt2 = rcb * rt2
            rcbxu = 2.0d0 * rcb * dphidxu
            rcbyu = 2.0d0 * rcb * dphidyu
            rcbzu = 2.0d0 * rcb * dphidzu
            rcbu2 = rcb * ru2
            dphidxibt = yca*dphidzt - zca*dphidyt
            dphidxibu = zdc*dphidyu - ydc*dphidzu
            dphidyibt = zca*dphidxt - xca*dphidzt
            dphidyibu = xdc*dphidzu - zdc*dphidxu
            dphidzibt = xca*dphidyt - yca*dphidxt
            dphidzibu = ydc*dphidxu - xdc*dphidyu
            dphidxict = zba*dphidyt - yba*dphidzt
            dphidxicu = ydb*dphidzu - zdb*dphidyu
            dphidyict = xba*dphidzt - zba*dphidxt
            dphidyicu = zdb*dphidxu - xdb*dphidzu
            dphidzict = yba*dphidxt - xba*dphidyt
            dphidzicu = xdb*dphidyu - ydb*dphidxu
c
c     intermediate terms for first derivative components
c
            dphidxia = zcb*dphidyt - ycb*dphidzt
            dphidyia = xcb*dphidzt - zcb*dphidxt
            dphidzia = ycb*dphidxt - xcb*dphidyt
            dphidxib = dphidxibt + dphidxibu
            dphidyib = dphidyibt + dphidyibu
            dphidzib = dphidzibt + dphidzibu
            dphidxic = dphidxict + dphidxicu
            dphidyic = dphidyict + dphidyicu
            dphidzic = dphidzict + dphidzicu
            dphidxid = zcb*dphidyu - ycb*dphidzu
            dphidyid = xcb*dphidzu - zcb*dphidxu
            dphidzid = ycb*dphidxu - xcb*dphidyu
c
c     chain rule terms for torsion second derivative components
c
            dxiaxia = rcbxt*dphidxia
            dxiayia = rcbxt*dphidyia - zcb*rcb/rt2
            dxiazia = rcbxt*dphidzia + ycb*rcb/rt2
            dxiaxic = rcbxt*dphidxict + xcb*xt/rcbt2
            dxiayic = rcbxt*dphidyict - dphidzt
     &                   - (xba*zcb*xcb+zba*yzcb2)/rcbt2
            dxiazic = rcbxt*dphidzict + dphidyt
     &                   + (xba*ycb*xcb+yba*yzcb2)/rcbt2
            dxiaxid = 0.0d0
            dxiayid = 0.0d0
            dxiazid = 0.0d0
            dyiayia = rcbyt*dphidyia
            dyiazia = rcbyt*dphidzia - xcb*rcb/rt2
            dyiaxib = rcbyt*dphidxibt - dphidzt
     &                   - (yca*zcb*ycb+zca*xzcb2)/rcbt2
            dyiaxic = rcbyt*dphidxict + dphidzt
     &                   + (yba*zcb*ycb+zba*xzcb2)/rcbt2
            dyiayic = rcbyt*dphidyict + ycb*yt/rcbt2
            dyiazic = rcbyt*dphidzict - dphidxt
     &                   - (yba*xcb*ycb+xba*xzcb2)/rcbt2
            dyiaxid = 0.0d0
            dyiayid = 0.0d0
            dyiazid = 0.0d0
            dziazia = rcbzt*dphidzia
            dziaxib = rcbzt*dphidxibt + dphidyt
     &                   + (zca*ycb*zcb+yca*xycb2)/rcbt2
            dziayib = rcbzt*dphidyibt - dphidxt
     &                   - (zca*xcb*zcb+xca*xycb2)/rcbt2
            dziaxic = rcbzt*dphidxict - dphidyt
     &                   - (zba*ycb*zcb+yba*xycb2)/rcbt2
            dziayic = rcbzt*dphidyict + dphidxt
     &                   + (zba*xcb*zcb+xba*xycb2)/rcbt2
            dziazic = rcbzt*dphidzict + zcb*zt/rcbt2
            dziaxid = 0.0d0
            dziayid = 0.0d0
            dziazid = 0.0d0
            dxibxic = -xcb*dphidxib/(rcb*rcb)
     &          - (yca*(zba*xcb+yt)-zca*(yba*xcb-zt))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidxibt/rt2
     &          - (zdc*(ydb*xcb+zu)-ydc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidxibu/ru2
            dxibyic = -ycb*dphidxib/(rcb*rcb) + dphidzt + dphidzu
     &          - (yca*(zba*ycb-xt)+zca*(xba*xcb+zcb*zba))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidxibt/rt2
     &          + (zdc*(xdb*xcb+zcb*zdb)+ydc*(zdb*ycb+xu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidxibu/ru2
            dxibxid = rcbxu*dphidxibu + xcb*xu/rcbu2
            dxibyid = rcbyu*dphidxibu - dphidzu
     &                   - (ydc*zcb*ycb+zdc*xzcb2)/rcbu2
            dxibzid = rcbzu*dphidxibu + dphidyu
     &                   + (zdc*ycb*zcb+ydc*xycb2)/rcbu2
            dyibzib = ycb*dphidzib/(rcb*rcb)
     &          - (xca*(xca*xcb+zcb*zca)+yca*(ycb*xca+zt))/rcbt2
     &          - 2.0d0*(xt*zca-xca*zt)*dphidzibt/rt2
     &          + (ydc*(xdc*ycb-zu)+xdc*(xdc*xcb+zcb*zdc))/rcbu2
     &          + 2.0d0*(xu*zdc-xdc*zu)*dphidzibu/ru2
            dyibxic = -xcb*dphidyib/(rcb*rcb) - dphidzt - dphidzu
     &          + (xca*(zba*xcb+yt)+zca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidyibt/rt2
     &          - (zdc*(zdb*zcb+ycb*ydb)+xdc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidyibu/ru2
            dyibyic = -ycb*dphidyib/(rcb*rcb)
     &          - (zca*(xba*ycb+zt)-xca*(zba*ycb-xt))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidyibt/rt2
     &          - (xdc*(zdb*ycb+xu)-zdc*(xdb*ycb-zu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidyibu/ru2
            dyibxid = rcbxu*dphidyibu + dphidzu
     &                   + (xdc*zcb*xcb+zdc*yzcb2)/rcbu2
            dyibyid = rcbyu*dphidyibu + ycb*yu/rcbu2
            dyibzid = rcbzu*dphidyibu - dphidxu
     &                   - (zdc*xcb*zcb+xdc*xycb2)/rcbu2
            dzibxic = -xcb*dphidzib/(rcb*rcb) + dphidyt + dphidyu
     &          - (xca*(yba*xcb-zt)+yca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidzibt/rt2
     &          + (ydc*(zdb*zcb+ycb*ydb)+xdc*(ydb*xcb+zu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidzibu/ru2
            dzibzic = -zcb*dphidzib/(rcb*rcb)
     &          - (xca*(yba*zcb+xt)-yca*(xba*zcb-yt))/rcbt2
     &          - 2.0d0*(xt*yba-xba*yt)*dphidzibt/rt2
     &          - (ydc*(xdb*zcb+yu)-xdc*(ydb*zcb-xu))/rcbu2
     &          + 2.0d0*(xu*ydb-xdb*yu)*dphidzibu/ru2
            dzibxid = rcbxu*dphidzibu - dphidyu
     &                   - (xdc*ycb*xcb+ydc*yzcb2)/rcbu2
            dzibyid = rcbyu*dphidzibu + dphidxu
     &                   + (ydc*xcb*ycb+xdc*xzcb2)/rcbu2
            dzibzid = rcbzu*dphidzibu + zcb*zu/rcbu2
            dxicxid = rcbxu*dphidxicu - xcb*(zdb*ycb-ydb*zcb)/rcbu2
            dxicyid = rcbyu*dphidxicu + dphidzu
     &                   + (ydb*zcb*ycb+zdb*xzcb2)/rcbu2
            dxiczid = rcbzu*dphidxicu - dphidyu
     &                   - (zdb*ycb*zcb+ydb*xycb2)/rcbu2
            dyicxid = rcbxu*dphidyicu - dphidzu
     &                   - (xdb*zcb*xcb+zdb*yzcb2)/rcbu2
            dyicyid = rcbyu*dphidyicu - ycb*(xdb*zcb-zdb*xcb)/rcbu2
            dyiczid = rcbzu*dphidyicu + dphidxu
     &                   + (zdb*xcb*zcb+xdb*xycb2)/rcbu2
            dzicxid = rcbxu*dphidzicu + dphidyu
     &                   + (xdb*ycb*xcb+ydb*yzcb2)/rcbu2
            dzicyid = rcbyu*dphidzicu - dphidxu
     &                   - (ydb*xcb*ycb+xdb*xzcb2)/rcbu2
            dziczid = rcbzu*dphidzicu - zcb*(ydb*xcb-xdb*ycb)/rcbu2
            dxidxid = rcbxu*dphidxid
            dxidyid = rcbxu*dphidyid + zcb*rcb/ru2
            dxidzid = rcbxu*dphidzid - ycb*rcb/ru2
            dyidyid = rcbyu*dphidyid
            dyidzid = rcbyu*dphidzid + xcb*rcb/ru2
            dzidzid = rcbzu*dphidzid
c
c     get some second derivative chain rule terms by difference
c
            dxiaxib = -dxiaxia - dxiaxic - dxiaxid
            dxiayib = -dxiayia - dxiayic - dxiayid
            dxiazib = -dxiazia - dxiazic - dxiazid
            dyiayib = -dyiayia - dyiayic - dyiayid
            dyiazib = -dyiazia - dyiazic - dyiazid
            dziazib = -dziazia - dziazic - dziazid
            dxibxib = -dxiaxib - dxibxic - dxibxid
            dxibyib = -dyiaxib - dxibyic - dxibyid
            dxibzib = -dxiazib - dzibxic - dzibxid
            dxibzic = -dziaxib - dxibzib - dxibzid
            dyibyib = -dyiayib - dyibyic - dyibyid
            dyibzic = -dziayib - dyibzib - dyibzid
            dzibzib = -dziazib - dzibzic - dzibzid
            dzibyic = -dyiazib - dyibzib - dzibyid
            dxicxic = -dxiaxic - dxibxic - dxicxid
            dxicyic = -dyiaxic - dyibxic - dxicyid
            dxiczic = -dziaxic - dzibxic - dxiczid
            dyicyic = -dyiayic - dyibyic - dyicyid
            dyiczic = -dziayic - dzibyic - dyiczid
            dziczic = -dziazic - dzibzic - dziczid
c
c     compute multiple angle trigonometry and phase terms
c
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            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)
            d2phi1 = -cosine*c1 - sine*s1
            d2phi2 = -4.0d0 * (cosine2*c2 + sine2*s2)
            d2phi3 = -9.0d0 * (cosine3*c3 + sine3*s3)
c
c     get the stretch-torsion values for the first bond
c
            v1 = kst(1,istrtor)
            v2 = kst(2,istrtor)
            v3 = kst(3,istrtor)
            k = ist(2,istrtor)
            dr = rba - bl(k)
            dedphi = storunit * (v1*dphi1 + v2*dphi2 + v3*dphi3)
            d2edphi2 = storunit * dr
     &                    * (v1*d2phi1 + v2*d2phi2 + v3*d2phi3)
            rba = max(rba,eps)
            ddr = 1.0d0 / rba
            d2dr = -storunit * (v1*phi1 + v2*phi2 + v3*phi3) / rba**3
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               dedphi = dedphi * fgrp
               d2edphi2 = d2edphi2 * fgrp
               d2dr = d2dr * fgrp
            end if
c
c     compute derivative components for this interaction
c
            ddrdx = xba * ddr
            ddrdy = yba * ddr
            ddrdz = zba * ddr
            d2drdxx = (xba*xba-rba*rba) * d2dr
            d2drdyy = (yba*yba-rba*rba) * d2dr
            d2drdzz = (zba*zba-rba*rba) * d2dr
            d2drdxy = xba * yba * d2dr
            d2drdxz = xba * zba * d2dr
            d2drdyz = yba * zba * d2dr
c
c     chain rule terms for first derivative components
c
            dxia = dedphi * dphidxia
            dyia = dedphi * dphidyia
            dzia = dedphi * dphidzia
            dxib = dedphi * dphidxib
            dyib = dedphi * dphidyib
            dzib = dedphi * dphidzib
            dxic = dedphi * dphidxic
            dyic = dedphi * dphidyic
            dzic = dedphi * dphidzic
            dxid = dedphi * dphidxid
            dyid = dedphi * dphidyid
            dzid = dedphi * dphidzid
            dedphi = dedphi * dr
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (i .eq. ia) then
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia
     &                          + d2edphi2*dphidxia*dphidxia
     &                          - 2.0d0*dxia*ddrdx + d2drdxx
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
     &                          - dxia*ddrdy - dyia*ddrdx + d2drdxy
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
     &                          - dxia*ddrdz - dzia*ddrdx + d2drdxz
               hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
     &                          - dyia*ddrdx - dxia*ddrdy + d2drdxy
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia
     &                          + d2edphi2*dphidyia*dphidyia
     &                          - 2.0d0*dyia*ddrdy + d2drdyy
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
     &                          - dyia*ddrdz - dzia*ddrdy + d2drdyz
               hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
     &                          - dxia*ddrdz - dzia*ddrdx + d2drdxz
               hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
     &                          - dyia*ddrdz - dzia*ddrdy + d2drdyz
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazia
     &                          + d2edphi2*dphidzia*dphidzia
     &                          - 2.0d0*dzia*ddrdz + d2drdzz
               hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxia*dphidxib
     &                          + dxia*ddrdx - dxib*ddrdx - d2drdxx
               hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib
     &                          + d2edphi2*dphidyia*dphidxib
     &                          + dyia*ddrdx - dxib*ddrdy - d2drdxy
               hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib
     &                          + d2edphi2*dphidzia*dphidxib
     &                          + dzia*ddrdx - dxib*ddrdz - d2drdxz
               hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib
     &                          + d2edphi2*dphidxia*dphidyib
     &                          + dxia*ddrdy - dyib*ddrdx - d2drdxy
               hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib
     &                          + d2edphi2*dphidyia*dphidyib
     &                          + dyia*ddrdy - dyib*ddrdy - d2drdyy
               hessz(2,ib) = hessz(2,ib) + dedphi*dziayib
     &                          + d2edphi2*dphidzia*dphidyib
     &                          + dzia*ddrdy - dyib*ddrdz - d2drdyz
               hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib
     &                          + d2edphi2*dphidxia*dphidzib
     &                          + dxia*ddrdz - dzib*ddrdx - d2drdxz
               hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib
     &                          + d2edphi2*dphidyia*dphidzib
     &                          + dyia*ddrdz - dzib*ddrdy - d2drdyz
               hessz(3,ib) = hessz(3,ib) + dedphi*dziazib
     &                          + d2edphi2*dphidzia*dphidzib
     &                          + dzia*ddrdz - dzib*ddrdz - d2drdzz
               hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxia*dphidxic
     &                          - dxic*ddrdx
               hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic
     &                          + d2edphi2*dphidyia*dphidxic
     &                          - dxic*ddrdy
               hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic
     &                          + d2edphi2*dphidzia*dphidxic
     &                          - dxic*ddrdz
               hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic
     &                          + d2edphi2*dphidxia*dphidyic
     &                          - dyic*ddrdx
               hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic
     &                          + d2edphi2*dphidyia*dphidyic
     &                          - dyic*ddrdy
               hessz(2,ic) = hessz(2,ic) + dedphi*dziayic
     &                          + d2edphi2*dphidzia*dphidyic
     &                          - dyic*ddrdz
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic
     &                          + d2edphi2*dphidxia*dphidzic
     &                          - dzic*ddrdx
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic
     &                          + d2edphi2*dphidyia*dphidzic
     &                          - dzic*ddrdy
               hessz(3,ic) = hessz(3,ic) + dedphi*dziazic
     &                          + d2edphi2*dphidzia*dphidzic
     &                          - dzic*ddrdz
               hessx(1,id) = hessx(1,id) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxia*dphidxid
     &                          - dxid*ddrdx
               hessy(1,id) = hessy(1,id) + dedphi*dyiaxid
     &                          + d2edphi2*dphidyia*dphidxid
     &                          - dxid*ddrdy
               hessz(1,id) = hessz(1,id) + dedphi*dziaxid
     &                          + d2edphi2*dphidzia*dphidxid
     &                          - dxid*ddrdz
               hessx(2,id) = hessx(2,id) + dedphi*dxiayid
     &                          + d2edphi2*dphidxia*dphidyid
     &                          - dyid*ddrdx
               hessy(2,id) = hessy(2,id) + dedphi*dyiayid
     &                          + d2edphi2*dphidyia*dphidyid
     &                          - dyid*ddrdy
               hessz(2,id) = hessz(2,id) + dedphi*dziayid
     &                          + d2edphi2*dphidzia*dphidyid
     &                          - dyid*ddrdz
               hessx(3,id) = hessx(3,id) + dedphi*dxiazid
     &                          + d2edphi2*dphidxia*dphidzid
     &                          - dzid*ddrdx
               hessy(3,id) = hessy(3,id) + dedphi*dyiazid
     &                          + d2edphi2*dphidyia*dphidzid
     &                          - dzid*ddrdy
               hessz(3,id) = hessz(3,id) + dedphi*dziazid
     &                          + d2edphi2*dphidzia*dphidzid
     &                          - dzid*ddrdz
            else if (i .eq. ib) then
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib
     &                          + d2edphi2*dphidxib*dphidxib
     &                          + 2.0d0*dxib*ddrdx + d2drdxx
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
     &                          + dyib*ddrdx + dxib*ddrdy + d2drdxy
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
     &                          + dzib*ddrdx + dxib*ddrdz + d2drdxz
               hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
     &                          + dxib*ddrdy + dyib*ddrdx + d2drdxy
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib
     &                          + d2edphi2*dphidyib*dphidyib
     &                          + 2.0d0*dyib*ddrdy + d2drdyy
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
     &                          + dzib*ddrdy + dyib*ddrdz + d2drdyz
               hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
     &                          + dxib*ddrdz + dzib*ddrdx + d2drdxz
               hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
     &                          + dyib*ddrdz + dzib*ddrdy + d2drdyz
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib
     &                          + d2edphi2*dphidzib*dphidzib
     &                          + 2.0d0*dzib*ddrdz + d2drdzz
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxib*dphidxia
     &                          + dxia*ddrdx - dxib*ddrdx - d2drdxx
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib
     &                          + d2edphi2*dphidyib*dphidxia
     &                          + dxia*ddrdy - dyib*ddrdx - d2drdxy
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib
     &                          + d2edphi2*dphidzib*dphidxia
     &                          + dxia*ddrdz - dzib*ddrdx - d2drdxz
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib
     &                          + d2edphi2*dphidxib*dphidyia
     &                          + dyia*ddrdx - dxib*ddrdy - d2drdxy
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib
     &                          + d2edphi2*dphidyib*dphidyia
     &                          + dyia*ddrdy - dyib*ddrdy - d2drdyy
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib
     &                          + d2edphi2*dphidzib*dphidyia
     &                          + dyia*ddrdz - dzib*ddrdy - d2drdyz
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib
     &                          + d2edphi2*dphidxib*dphidzia
     &                          + dzia*ddrdx - dxib*ddrdz - d2drdxz
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayib
     &                          + d2edphi2*dphidyib*dphidzia
     &                          + dzia*ddrdy - dyib*ddrdz - d2drdyz
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazib
     &                          + d2edphi2*dphidzib*dphidzia
     &                          + dzia*ddrdz - dzib*ddrdz - d2drdzz
               hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic
     &                          + d2edphi2*dphidxib*dphidxic
     &                          + dxic*ddrdx
               hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic
     &                          + d2edphi2*dphidyib*dphidxic
     &                          + dxic*ddrdy
               hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic
     &                          + d2edphi2*dphidzib*dphidxic
     &                          + dxic*ddrdz
               hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic
     &                          + d2edphi2*dphidxib*dphidyic
     &                          + dyic*ddrdx
               hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic
     &                          + d2edphi2*dphidyib*dphidyic
     &                          + dyic*ddrdy
               hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic
     &                          + d2edphi2*dphidzib*dphidyic
     &                          + dyic*ddrdz
               hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic
     &                          + d2edphi2*dphidxib*dphidzic
     &                          + dzic*ddrdx
               hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic
     &                          + d2edphi2*dphidyib*dphidzic
     &                          + dzic*ddrdy
               hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic
     &                          + d2edphi2*dphidzib*dphidzic
     &                          + dzic*ddrdz
               hessx(1,id) = hessx(1,id) + dedphi*dxibxid
     &                          + d2edphi2*dphidxib*dphidxid
     &                          + dxid*ddrdx
               hessy(1,id) = hessy(1,id) + dedphi*dyibxid
     &                          + d2edphi2*dphidyib*dphidxid
     &                          + dxid*ddrdy
               hessz(1,id) = hessz(1,id) + dedphi*dzibxid
     &                          + d2edphi2*dphidzib*dphidxid
     &                          + dxid*ddrdz
               hessx(2,id) = hessx(2,id) + dedphi*dxibyid
     &                          + d2edphi2*dphidxib*dphidyid
     &                          + dyid*ddrdx
               hessy(2,id) = hessy(2,id) + dedphi*dyibyid
     &                          + d2edphi2*dphidyib*dphidyid
     &                          + dyid*ddrdy
               hessz(2,id) = hessz(2,id) + dedphi*dzibyid
     &                          + d2edphi2*dphidzib*dphidyid
     &                          + dyid*ddrdz
               hessx(3,id) = hessx(3,id) + dedphi*dxibzid
     &                          + d2edphi2*dphidxib*dphidzid
     &                          + dzid*ddrdx
               hessy(3,id) = hessy(3,id) + dedphi*dyibzid
     &                          + d2edphi2*dphidyib*dphidzid
     &                          + dzid*ddrdy
               hessz(3,id) = hessz(3,id) + dedphi*dzibzid
     &                          + d2edphi2*dphidzib*dphidzid
     &                          + dzid*ddrdz
            else if (i .eq. ic) then
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic
     &                          + d2edphi2*dphidxic*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic
     &                          + d2edphi2*dphidyic*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczic
     &                          + d2edphi2*dphidzic*dphidzic
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxic*dphidxia
     &                          - dxic*ddrdx
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic
     &                          + d2edphi2*dphidyic*dphidxia
     &                          - dyic*ddrdx
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic
     &                          + d2edphi2*dphidzic*dphidxia
     &                          - dzic*ddrdx
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic
     &                          + d2edphi2*dphidxic*dphidyia
     &                          - dxic*ddrdy
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic
     &                          + d2edphi2*dphidyic*dphidyia
     &                          - dyic*ddrdy
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic
     &                          + d2edphi2*dphidzic*dphidyia
     &                          - dzic*ddrdy
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic
     &                          + d2edphi2*dphidxic*dphidzia
     &                          - dxic*ddrdz
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayic
     &                          + d2edphi2*dphidyic*dphidzia
     &                          - dyic*ddrdz
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazic
     &                          + d2edphi2*dphidzic*dphidzia
     &                          - dzic*ddrdz
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic
     &                          + d2edphi2*dphidxic*dphidxib
     &                          + dxic*ddrdx
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic
     &                          + d2edphi2*dphidyic*dphidxib
     &                          + dyic*ddrdx
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic
     &                          + d2edphi2*dphidzic*dphidxib
     &                          + dzic*ddrdx
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic
     &                          + d2edphi2*dphidxic*dphidyib
     &                          + dxic*ddrdy
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic
     &                          + d2edphi2*dphidyic*dphidyib
     &                          + dyic*ddrdy
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic
     &                          + d2edphi2*dphidzic*dphidyib
     &                          + dzic*ddrdy
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic
     &                          + d2edphi2*dphidxic*dphidzib
     &                          + dxic*ddrdz
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic
     &                          + d2edphi2*dphidyic*dphidzib
     &                          + dyic*ddrdz
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic
     &                          + d2edphi2*dphidzic*dphidzib
     &                          + dzic*ddrdz
               hessx(1,id) = hessx(1,id) + dedphi*dxicxid
     &                          + d2edphi2*dphidxic*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyicxid
     &                          + d2edphi2*dphidyic*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dzicxid
     &                          + d2edphi2*dphidzic*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxicyid
     &                          + d2edphi2*dphidxic*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyicyid
     &                          + d2edphi2*dphidyic*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dzicyid
     &                          + d2edphi2*dphidzic*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiczid
     &                          + d2edphi2*dphidxic*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiczid
     &                          + d2edphi2*dphidyic*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dziczid
     &                          + d2edphi2*dphidzic*dphidzid
            else if (i .eq. id) then
               hessx(1,id) = hessx(1,id) + dedphi*dxidxid
     &                          + d2edphi2*dphidxid*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessz(1,id) = hessz(1,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessx(2,id) = hessx(2,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyidyid
     &                          + d2edphi2*dphidyid*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessx(3,id) = hessx(3,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzidzid
     &                          + d2edphi2*dphidzid*dphidzid
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxid*dphidxia
     &                          - dxid*ddrdx
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid
     &                          + d2edphi2*dphidyid*dphidxia
     &                          - dyid*ddrdx
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid
     &                          + d2edphi2*dphidzid*dphidxia
     &                          - dzid*ddrdx
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid
     &                          + d2edphi2*dphidxid*dphidyia
     &                          - dxid*ddrdy
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid
     &                          + d2edphi2*dphidyid*dphidyia
     &                          - dyid*ddrdy
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid
     &                          + d2edphi2*dphidzid*dphidyia
     &                          - dzid*ddrdy
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid
     &                          + d2edphi2*dphidxid*dphidzia
     &                          - dxid*ddrdz
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayid
     &                          + d2edphi2*dphidyid*dphidzia
     &                          - dyid*ddrdz
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazid
     &                          + d2edphi2*dphidzid*dphidzia
     &                          - dzid*ddrdz
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid
     &                          + d2edphi2*dphidxid*dphidxib
     &                          + dxid*ddrdx
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid
     &                          + d2edphi2*dphidyid*dphidxib
     &                          + dyid*ddrdx
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid
     &                          + d2edphi2*dphidzid*dphidxib
     &                          + dzid*ddrdx
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid
     &                          + d2edphi2*dphidxid*dphidyib
     &                          + dxid*ddrdy
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid
     &                          + d2edphi2*dphidyid*dphidyib
     &                          + dyid*ddrdy
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid
     &                          + d2edphi2*dphidzid*dphidyib
     &                          + dzid*ddrdy
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid
     &                          + d2edphi2*dphidxid*dphidzib
     &                          + dxid*ddrdz
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid
     &                          + d2edphi2*dphidyid*dphidzib
     &                          + dyid*ddrdz
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid
     &                          + d2edphi2*dphidzid*dphidzib
     &                          + dzid*ddrdz
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid
     &                          + d2edphi2*dphidxid*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid
     &                          + d2edphi2*dphidyid*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid
     &                          + d2edphi2*dphidzid*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid
     &                          + d2edphi2*dphidxid*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid
     &                          + d2edphi2*dphidyid*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid
     &                          + d2edphi2*dphidzid*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid
     &                          + d2edphi2*dphidxid*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid
     &                          + d2edphi2*dphidyid*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczid
     &                          + d2edphi2*dphidzid*dphidzic
            end if
c
c     get the stretch-torsion values for the second bond
c
            v1 = kst(4,istrtor)
            v2 = kst(5,istrtor)
            v3 = kst(6,istrtor)
            k = ist(3,istrtor)
            dr = rcb - bl(k)
            dedphi = storunit * (v1*dphi1 + v2*dphi2 + v3*dphi3)
            d2edphi2 = storunit * dr
     &                    * (v1*d2phi1 + v2*d2phi2 + v3*d2phi3)
            ddr = 1.0d0 / rcb
            d2dr = -storunit * (v1*phi1 + v2*phi2 + v3*phi3) / rcb**3
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               dedphi = dedphi * fgrp
               d2edphi2 = d2edphi2 * fgrp
               d2dr = d2dr * fgrp
            end if
c
c     compute derivative components for this interaction
c
            ddrdx = xcb * ddr
            ddrdy = ycb * ddr
            ddrdz = zcb * ddr
            d2drdxx = (xcb*xcb-rcb*rcb) * d2dr
            d2drdyy = (ycb*ycb-rcb*rcb) * d2dr
            d2drdzz = (zcb*zcb-rcb*rcb) * d2dr
            d2drdxy = xcb * ycb * d2dr
            d2drdxz = xcb * zcb * d2dr
            d2drdyz = ycb * zcb * d2dr
c
c     chain rule terms for first derivative components
c
            dxia = dedphi * dphidxia
            dyia = dedphi * dphidyia
            dzia = dedphi * dphidzia
            dxib = dedphi * dphidxib
            dyib = dedphi * dphidyib
            dzib = dedphi * dphidzib
            dxic = dedphi * dphidxic
            dyic = dedphi * dphidyic
            dzic = dedphi * dphidzic
            dxid = dedphi * dphidxid
            dyid = dedphi * dphidyid
            dzid = dedphi * dphidzid
            dedphi = dedphi * dr
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (i .eq. ia) then
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia
     &                          + d2edphi2*dphidxia*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia
     &                          + d2edphi2*dphidyia*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazia
     &                          + d2edphi2*dphidzia*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxia*dphidxib
     &                          - dxia*ddrdx
               hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib
     &                          + d2edphi2*dphidyia*dphidxib
     &                          - dyia*ddrdx
               hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib
     &                          + d2edphi2*dphidzia*dphidxib
     &                          - dzia*ddrdx
               hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib
     &                          + d2edphi2*dphidxia*dphidyib
     &                          - dxia*ddrdy
               hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib
     &                          + d2edphi2*dphidyia*dphidyib
     &                          - dyia*ddrdy
               hessz(2,ib) = hessz(2,ib) + dedphi*dziayib
     &                          + d2edphi2*dphidzia*dphidyib
     &                          - dzia*ddrdy
               hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib
     &                          + d2edphi2*dphidxia*dphidzib
     &                          - dxia*ddrdz
               hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib
     &                          + d2edphi2*dphidyia*dphidzib
     &                          - dyia*ddrdz
               hessz(3,ib) = hessz(3,ib) + dedphi*dziazib
     &                          + d2edphi2*dphidzia*dphidzib
     &                          - dzia*ddrdz
               hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxia*dphidxic
     &                          + dxia*ddrdx
               hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic
     &                          + d2edphi2*dphidyia*dphidxic
     &                          + dyia*ddrdx
               hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic
     &                          + d2edphi2*dphidzia*dphidxic
     &                          + dzia*ddrdx
               hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic
     &                          + d2edphi2*dphidxia*dphidyic
     &                          + dxia*ddrdy
               hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic
     &                          + d2edphi2*dphidyia*dphidyic
     &                          + dyia*ddrdy
               hessz(2,ic) = hessz(2,ic) + dedphi*dziayic
     &                          + d2edphi2*dphidzia*dphidyic
     &                          + dzia*ddrdy
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic
     &                          + d2edphi2*dphidxia*dphidzic
     &                          + dxia*ddrdz
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic
     &                          + d2edphi2*dphidyia*dphidzic
     &                          + dyia*ddrdz
               hessz(3,ic) = hessz(3,ic) + dedphi*dziazic
     &                          + d2edphi2*dphidzia*dphidzic
     &                          + dzia*ddrdz
               hessx(1,id) = hessx(1,id) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxia*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyiaxid
     &                          + d2edphi2*dphidyia*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dziaxid
     &                          + d2edphi2*dphidzia*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxiayid
     &                          + d2edphi2*dphidxia*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyiayid
     &                          + d2edphi2*dphidyia*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dziayid
     &                          + d2edphi2*dphidzia*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiazid
     &                          + d2edphi2*dphidxia*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiazid
     &                          + d2edphi2*dphidyia*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dziazid
     &                          + d2edphi2*dphidzia*dphidzid
            else if (i .eq. ib) then
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib
     &                          + d2edphi2*dphidxib*dphidxib
     &                          - 2.0d0*dxib*ddrdx + d2drdxx
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
     &                          - dyib*ddrdx - dxib*ddrdy + d2drdxy
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
     &                          - dzib*ddrdx - dxib*ddrdz + d2drdxz
               hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
     &                          - dxib*ddrdy - dyib*ddrdx + d2drdxy
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib
     &                          + d2edphi2*dphidyib*dphidyib
     &                          - 2.0d0*dyib*ddrdy + d2drdyy
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
     &                          - dzib*ddrdy - dyib*ddrdz + d2drdyz
               hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
     &                          - dxib*ddrdz - dzib*ddrdx + d2drdxz
               hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
     &                          - dyib*ddrdz - dzib*ddrdy + d2drdyz
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib
     &                          + d2edphi2*dphidzib*dphidzib
     &                          - 2.0d0*dzib*ddrdz + d2drdzz
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxib*dphidxia
     &                          - dxia*ddrdx
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib
     &                          + d2edphi2*dphidyib*dphidxia
     &                          - dxia*ddrdy
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib
     &                          + d2edphi2*dphidzib*dphidxia
     &                          - dxia*ddrdz
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib
     &                          + d2edphi2*dphidxib*dphidyia
     &                          - dyia*ddrdx
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib
     &                          + d2edphi2*dphidyib*dphidyia
     &                          - dyia*ddrdy
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib
     &                          + d2edphi2*dphidzib*dphidyia
     &                          - dyia*ddrdz
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib
     &                          + d2edphi2*dphidxib*dphidzia
     &                          - dzia*ddrdx
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayib
     &                          + d2edphi2*dphidyib*dphidzia
     &                          - dzia*ddrdy
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazib
     &                          + d2edphi2*dphidzib*dphidzia
     &                          - dzia*ddrdz
               hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic
     &                          + d2edphi2*dphidxib*dphidxic
     &                          + (dxib-dxic)*ddrdx - d2drdxx
               hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic
     &                          + d2edphi2*dphidyib*dphidxic
     &                          + dyib*ddrdx - dxic*ddrdy - d2drdxy
               hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic
     &                          + d2edphi2*dphidzib*dphidxic
     &                          + dzib*ddrdx - dxic*ddrdz - d2drdxz
               hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic
     &                          + d2edphi2*dphidxib*dphidyic
     &                          + dxib*ddrdy - dyic*ddrdx - d2drdxy
               hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic
     &                          + d2edphi2*dphidyib*dphidyic
     &                          + (dyib-dyic)*ddrdy - d2drdyy
               hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic
     &                          + d2edphi2*dphidzib*dphidyic
     &                          + dzib*ddrdy - dyic*ddrdz - d2drdyz
               hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic
     &                          + d2edphi2*dphidxib*dphidzic
     &                          + dxib*ddrdz - dzic*ddrdx - d2drdxz
               hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic
     &                          + d2edphi2*dphidyib*dphidzic
     &                          + dyib*ddrdz - dzic*ddrdy - d2drdyz
               hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic
     &                          + d2edphi2*dphidzib*dphidzic
     &                          + (dzib-dzic)*ddrdz - d2drdzz
               hessx(1,id) = hessx(1,id) + dedphi*dxibxid
     &                          + d2edphi2*dphidxib*dphidxid
     &                          - dxid*ddrdx
               hessy(1,id) = hessy(1,id) + dedphi*dyibxid
     &                          + d2edphi2*dphidyib*dphidxid
     &                          - dxid*ddrdy
               hessz(1,id) = hessz(1,id) + dedphi*dzibxid
     &                          + d2edphi2*dphidzib*dphidxid
     &                          - dxid*ddrdz
               hessx(2,id) = hessx(2,id) + dedphi*dxibyid
     &                          + d2edphi2*dphidxib*dphidyid
     &                          - dyid*ddrdx
               hessy(2,id) = hessy(2,id) + dedphi*dyibyid
     &                          + d2edphi2*dphidyib*dphidyid
     &                          - dyid*ddrdy
               hessz(2,id) = hessz(2,id) + dedphi*dzibyid
     &                          + d2edphi2*dphidzib*dphidyid
     &                          - dyid*ddrdz
               hessx(3,id) = hessx(3,id) + dedphi*dxibzid
     &                          + d2edphi2*dphidxib*dphidzid
     &                          - dzid*ddrdx
               hessy(3,id) = hessy(3,id) + dedphi*dyibzid
     &                          + d2edphi2*dphidyib*dphidzid
     &                          - dzid*ddrdy
               hessz(3,id) = hessz(3,id) + dedphi*dzibzid
     &                          + d2edphi2*dphidzib*dphidzid
     &                          - dzid*ddrdz
            else if (i .eq. ic) then
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic
     &                          + d2edphi2*dphidxic*dphidxic
     &                          + 2.0d0*dxic*ddrdx + d2drdxx
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
     &                          + dyic*ddrdx + dxic*ddrdy + d2drdxy
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
     &                          + dzic*ddrdx + dxic*ddrdz + d2drdxz
               hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
     &                          + dxic*ddrdy + dyic*ddrdx + d2drdxy
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic
     &                          + d2edphi2*dphidyic*dphidyic
     &                          + 2.0d0*dyic*ddrdy + d2drdyy
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
     &                          + dzic*ddrdy + dyic*ddrdz + d2drdyz
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
     &                          + dxic*ddrdz + dzic*ddrdx + d2drdxz
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
     &                          + dyic*ddrdz + dzic*ddrdy + d2drdyz
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczic
     &                          + d2edphi2*dphidzic*dphidzic
     &                          + 2.0d0*dzic*ddrdz + d2drdzz
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxic*dphidxia
     &                          + dxia*ddrdx
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic
     &                          + d2edphi2*dphidyic*dphidxia
     &                          + dxia*ddrdy
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic
     &                          + d2edphi2*dphidzic*dphidxia
     &                          + dxia*ddrdz
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic
     &                          + d2edphi2*dphidxic*dphidyia
     &                          + dyia*ddrdx
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic
     &                          + d2edphi2*dphidyic*dphidyia
     &                          + dyia*ddrdy
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic
     &                          + d2edphi2*dphidzic*dphidyia
     &                          + dyia*ddrdz
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic
     &                          + d2edphi2*dphidxic*dphidzia
     &                          + dzia*ddrdx
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayic
     &                          + d2edphi2*dphidyic*dphidzia
     &                          + dzia*ddrdy
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazic
     &                          + d2edphi2*dphidzic*dphidzia
     &                          + dzia*ddrdz
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic
     &                          + d2edphi2*dphidxic*dphidxib
     &                          - (dxic-dxib)*ddrdx - d2drdxx
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic
     &                          + d2edphi2*dphidyic*dphidxib
     &                          - dyic*ddrdx + dxib*ddrdy - d2drdxy
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic
     &                          + d2edphi2*dphidzic*dphidxib
     &                          - dzic*ddrdx + dxib*ddrdz - d2drdxz
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic
     &                          + d2edphi2*dphidxic*dphidyib
     &                          - dxic*ddrdy + dyib*ddrdx - d2drdxy
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic
     &                          + d2edphi2*dphidyic*dphidyib
     &                          - (dyic-dyib)*ddrdy - d2drdyy
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic
     &                          + d2edphi2*dphidzic*dphidyib
     &                          - dzic*ddrdy + dyib*ddrdz - d2drdyz
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic
     &                          + d2edphi2*dphidxic*dphidzib
     &                          - dxic*ddrdz + dzib*ddrdx - d2drdxz
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic
     &                          + d2edphi2*dphidyic*dphidzib
     &                          - dyic*ddrdz + dzib*ddrdy - d2drdyz
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic
     &                          + d2edphi2*dphidzic*dphidzib
     &                          - (dzic-dzib)*ddrdz - d2drdzz
               hessx(1,id) = hessx(1,id) + dedphi*dxicxid
     &                          + d2edphi2*dphidxic*dphidxid
     &                          + dxid*ddrdx
               hessy(1,id) = hessy(1,id) + dedphi*dyicxid
     &                          + d2edphi2*dphidyic*dphidxid
     &                          + dxid*ddrdy
               hessz(1,id) = hessz(1,id) + dedphi*dzicxid
     &                          + d2edphi2*dphidzic*dphidxid
     &                          + dxid*ddrdz
               hessx(2,id) = hessx(2,id) + dedphi*dxicyid
     &                          + d2edphi2*dphidxic*dphidyid
     &                          + dyid*ddrdx
               hessy(2,id) = hessy(2,id) + dedphi*dyicyid
     &                          + d2edphi2*dphidyic*dphidyid
     &                          + dyid*ddrdy
               hessz(2,id) = hessz(2,id) + dedphi*dzicyid
     &                          + d2edphi2*dphidzic*dphidyid
     &                          + dyid*ddrdz
               hessx(3,id) = hessx(3,id) + dedphi*dxiczid
     &                          + d2edphi2*dphidxic*dphidzid
     &                          + dzid*ddrdx
               hessy(3,id) = hessy(3,id) + dedphi*dyiczid
     &                          + d2edphi2*dphidyic*dphidzid
     &                          + dzid*ddrdy
               hessz(3,id) = hessz(3,id) + dedphi*dziczid
     &                          + d2edphi2*dphidzic*dphidzid
     &                          + dzid*ddrdz
            else if (i .eq. id) then
               hessx(1,id) = hessx(1,id) + dedphi*dxidxid
     &                          + d2edphi2*dphidxid*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessz(1,id) = hessz(1,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessx(2,id) = hessx(2,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyidyid
     &                          + d2edphi2*dphidyid*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessx(3,id) = hessx(3,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzidzid
     &                          + d2edphi2*dphidzid*dphidzid
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxid*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid
     &                          + d2edphi2*dphidyid*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid
     &                          + d2edphi2*dphidzid*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid
     &                          + d2edphi2*dphidxid*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid
     &                          + d2edphi2*dphidyid*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid
     &                          + d2edphi2*dphidzid*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid
     &                          + d2edphi2*dphidxid*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayid
     &                          + d2edphi2*dphidyid*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazid
     &                          + d2edphi2*dphidzid*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid
     &                          + d2edphi2*dphidxid*dphidxib
     &                          - dxid*ddrdx
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid
     &                          + d2edphi2*dphidyid*dphidxib
     &                          - dyid*ddrdx
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid
     &                          + d2edphi2*dphidzid*dphidxib
     &                          - dzid*ddrdx
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid
     &                          + d2edphi2*dphidxid*dphidyib
     &                          - dxid*ddrdy
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid
     &                          + d2edphi2*dphidyid*dphidyib
     &                          - dyid*ddrdy
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid
     &                          + d2edphi2*dphidzid*dphidyib
     &                          - dzid*ddrdy
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid
     &                          + d2edphi2*dphidxid*dphidzib
     &                          - dxid*ddrdz
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid
     &                          + d2edphi2*dphidyid*dphidzib
     &                          - dyid*ddrdz
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid
     &                          + d2edphi2*dphidzid*dphidzib
     &                          - dzid*ddrdz
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid
     &                          + d2edphi2*dphidxid*dphidxic
     &                          + dxid*ddrdx
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid
     &                          + d2edphi2*dphidyid*dphidxic
     &                          + dyid*ddrdx
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid
     &                          + d2edphi2*dphidzid*dphidxic
     &                          + dzid*ddrdx
               hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid
     &                          + d2edphi2*dphidxid*dphidyic
     &                          + dxid*ddrdy
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid
     &                          + d2edphi2*dphidyid*dphidyic
     &                          + dyid*ddrdy
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid
     &                          + d2edphi2*dphidzid*dphidyic
     &                          + dzid*ddrdy
               hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid
     &                          + d2edphi2*dphidxid*dphidzic
     &                          + dxid*ddrdz
               hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid
     &                          + d2edphi2*dphidyid*dphidzic
     &                          + dyid*ddrdz
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczid
     &                          + d2edphi2*dphidzid*dphidzic
     &                          + dzid*ddrdz
            end if
c
c     get the stretch-torsion values for the third bond
c
            v1 = kst(7,istrtor)
            v2 = kst(8,istrtor)
            v3 = kst(9,istrtor)
            k = ist(4,istrtor)
            dr = rdc - bl(k)
            dedphi = storunit * (v1*dphi1 + v2*dphi2 + v3*dphi3)
            d2edphi2 = storunit * dr
     &                    * (v1*d2phi1 + v2*d2phi2 + v3*d2phi3)
            rdc = max(rdc,eps)
            ddr = 1.0d0 / rdc
            d2dr = -storunit * (v1*phi1 + v2*phi2 + v3*phi3) / rdc**3
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               dedphi = dedphi * fgrp
               d2edphi2 = d2edphi2 * fgrp
               d2dr = d2dr * fgrp
            end if
c
c     compute derivative components for this interaction
c
            ddrdx = xdc * ddr
            ddrdy = ydc * ddr
            ddrdz = zdc * ddr
            d2drdxx = (xdc*xdc-rdc*rdc) * d2dr
            d2drdyy = (ydc*ydc-rdc*rdc) * d2dr
            d2drdzz = (zdc*zdc-rdc*rdc) * d2dr
            d2drdxy = xdc * ydc * d2dr
            d2drdxz = xdc * zdc * d2dr
            d2drdyz = ydc * zdc * d2dr
c
c     chain rule terms for first derivative components
c
            dxia = dedphi * dphidxia
            dyia = dedphi * dphidyia
            dzia = dedphi * dphidzia
            dxib = dedphi * dphidxib
            dyib = dedphi * dphidyib
            dzib = dedphi * dphidzib
            dxic = dedphi * dphidxic
            dyic = dedphi * dphidyic
            dzic = dedphi * dphidzic
            dxid = dedphi * dphidxid
            dyid = dedphi * dphidyid
            dzid = dedphi * dphidzid
            dedphi = dedphi * dr
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (i .eq. ia) then
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia
     &                          + d2edphi2*dphidxia*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia
     &                          + d2edphi2*dphidyia*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazia
     &                          + d2edphi2*dphidzia*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxia*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib
     &                          + d2edphi2*dphidyia*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib
     &                          + d2edphi2*dphidzia*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib
     &                          + d2edphi2*dphidxia*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib
     &                          + d2edphi2*dphidyia*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dziayib
     &                          + d2edphi2*dphidzia*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib
     &                          + d2edphi2*dphidxia*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib
     &                          + d2edphi2*dphidyia*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dziazib
     &                          + d2edphi2*dphidzia*dphidzib
               hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxia*dphidxic
     &                          - dxia*ddrdx
               hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic
     &                          + d2edphi2*dphidyia*dphidxic
     &                          - dyia*ddrdx
               hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic
     &                          + d2edphi2*dphidzia*dphidxic
     &                          - dzia*ddrdx
               hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic
     &                          + d2edphi2*dphidxia*dphidyic
     &                          - dxia*ddrdy
               hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic
     &                          + d2edphi2*dphidyia*dphidyic
     &                          - dyia*ddrdy
               hessz(2,ic) = hessz(2,ic) + dedphi*dziayic
     &                          + d2edphi2*dphidzia*dphidyic
     &                          - dzia*ddrdy
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic
     &                          + d2edphi2*dphidxia*dphidzic
     &                          - dxia*ddrdz
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic
     &                          + d2edphi2*dphidyia*dphidzic
     &                          - dyia*ddrdz
               hessz(3,ic) = hessz(3,ic) + dedphi*dziazic
     &                          + d2edphi2*dphidzia*dphidzic
     &                          - dzia*ddrdz
               hessx(1,id) = hessx(1,id) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxia*dphidxid
     &                          + dxia*ddrdx
               hessy(1,id) = hessy(1,id) + dedphi*dyiaxid
     &                          + d2edphi2*dphidyia*dphidxid
     &                          + dyia*ddrdx
               hessz(1,id) = hessz(1,id) + dedphi*dziaxid
     &                          + d2edphi2*dphidzia*dphidxid
     &                          + dzia*ddrdx
               hessx(2,id) = hessx(2,id) + dedphi*dxiayid
     &                          + d2edphi2*dphidxia*dphidyid
     &                          + dxia*ddrdy
               hessy(2,id) = hessy(2,id) + dedphi*dyiayid
     &                          + d2edphi2*dphidyia*dphidyid
     &                          + dyia*ddrdy
               hessz(2,id) = hessz(2,id) + dedphi*dziayid
     &                          + d2edphi2*dphidzia*dphidyid
     &                          + dzia*ddrdy
               hessx(3,id) = hessx(3,id) + dedphi*dxiazid
     &                          + d2edphi2*dphidxia*dphidzid
     &                          + dxia*ddrdz
               hessy(3,id) = hessy(3,id) + dedphi*dyiazid
     &                          + d2edphi2*dphidyia*dphidzid
     &                          + dyia*ddrdz
               hessz(3,id) = hessz(3,id) + dedphi*dziazid
     &                          + d2edphi2*dphidzia*dphidzid
     &                          + dzia*ddrdz
            else if (i .eq. ib) then
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib
     &                          + d2edphi2*dphidxib*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib
     &                          + d2edphi2*dphidyib*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib
     &                          + d2edphi2*dphidzib*dphidzib
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxib*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib
     &                          + d2edphi2*dphidyib*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib
     &                          + d2edphi2*dphidzib*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib
     &                          + d2edphi2*dphidxib*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib
     &                          + d2edphi2*dphidyib*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib
     &                          + d2edphi2*dphidzib*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib
     &                          + d2edphi2*dphidxib*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayib
     &                          + d2edphi2*dphidyib*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazib
     &                          + d2edphi2*dphidzib*dphidzia
               hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic
     &                          + d2edphi2*dphidxib*dphidxic
     &                          - dxib*ddrdx
               hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic
     &                          + d2edphi2*dphidyib*dphidxic
     &                          - dyib*ddrdx
               hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic
     &                          + d2edphi2*dphidzib*dphidxic
     &                          - dzib*ddrdx
               hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic
     &                          + d2edphi2*dphidxib*dphidyic
     &                          - dxib*ddrdy
               hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic
     &                          + d2edphi2*dphidyib*dphidyic
     &                          - dyib*ddrdy
               hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic
     &                          + d2edphi2*dphidzib*dphidyic
     &                          - dzib*ddrdy
               hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic
     &                          + d2edphi2*dphidxib*dphidzic
     &                          - dxib*ddrdz
               hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic
     &                          + d2edphi2*dphidyib*dphidzic
     &                          - dyib*ddrdz
               hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic
     &                          + d2edphi2*dphidzib*dphidzic
     &                          - dzib*ddrdz
               hessx(1,id) = hessx(1,id) + dedphi*dxibxid
     &                          + d2edphi2*dphidxib*dphidxid
     &                          + dxib*ddrdx
               hessy(1,id) = hessy(1,id) + dedphi*dyibxid
     &                          + d2edphi2*dphidyib*dphidxid
     &                          + dyib*ddrdx
               hessz(1,id) = hessz(1,id) + dedphi*dzibxid
     &                          + d2edphi2*dphidzib*dphidxid
     &                          + dzib*ddrdx
               hessx(2,id) = hessx(2,id) + dedphi*dxibyid
     &                          + d2edphi2*dphidxib*dphidyid
     &                          + dxib*ddrdy
               hessy(2,id) = hessy(2,id) + dedphi*dyibyid
     &                          + d2edphi2*dphidyib*dphidyid
     &                          + dyib*ddrdy
               hessz(2,id) = hessz(2,id) + dedphi*dzibyid
     &                          + d2edphi2*dphidzib*dphidyid
     &                          + dzib*ddrdy
               hessx(3,id) = hessx(3,id) + dedphi*dxibzid
     &                          + d2edphi2*dphidxib*dphidzid
     &                          + dxib*ddrdz
               hessy(3,id) = hessy(3,id) + dedphi*dyibzid
     &                          + d2edphi2*dphidyib*dphidzid
     &                          + dyib*ddrdz
               hessz(3,id) = hessz(3,id) + dedphi*dzibzid
     &                          + d2edphi2*dphidzib*dphidzid
     &                          + dzib*ddrdz
            else if (i .eq. ic) then
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic
     &                          + d2edphi2*dphidxic*dphidxic
     &                          - 2.0d0*dxic*ddrdx + d2drdxx
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
     &                          - dyic*ddrdx - dxic*ddrdy + d2drdxy
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
     &                          - dzic*ddrdx - dxic*ddrdz + d2drdxz
               hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
     &                          - dxic*ddrdy - dyic*ddrdx + d2drdxy
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic
     &                          + d2edphi2*dphidyic*dphidyic
     &                          - 2.0d0*dyic*ddrdy + d2drdyy
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
     &                          - dzic*ddrdy - dyic*ddrdz + d2drdyz
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
     &                          - dxic*ddrdz - dzic*ddrdx + d2drdxz
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
     &                          - dyic*ddrdz - dzic*ddrdy + d2drdyz
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczic
     &                          + d2edphi2*dphidzic*dphidzic
     &                          - 2.0d0*dzic*ddrdz + d2drdzz
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxic*dphidxia
     &                          - dxia*ddrdx
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic
     &                          + d2edphi2*dphidyic*dphidxia
     &                          - dxia*ddrdy
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic
     &                          + d2edphi2*dphidzic*dphidxia
     &                          - dxia*ddrdz
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic
     &                          + d2edphi2*dphidxic*dphidyia
     &                          - dyia*ddrdx
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic
     &                          + d2edphi2*dphidyic*dphidyia
     &                          - dyia*ddrdy
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic
     &                          + d2edphi2*dphidzic*dphidyia
     &                          - dyia*ddrdz
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic
     &                          + d2edphi2*dphidxic*dphidzia
     &                          - dzia*ddrdx
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayic
     &                          + d2edphi2*dphidyic*dphidzia
     &                          - dzia*ddrdy
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazic
     &                          + d2edphi2*dphidzic*dphidzia
     &                          - dzia*ddrdz
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic
     &                          + d2edphi2*dphidxic*dphidxib
     &                          - dxib*ddrdx
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic
     &                          + d2edphi2*dphidyic*dphidxib
     &                          - dxib*ddrdy
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic
     &                          + d2edphi2*dphidzic*dphidxib
     &                          - dxib*ddrdz
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic
     &                          + d2edphi2*dphidxic*dphidyib
     &                          - dyib*ddrdx
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic
     &                          + d2edphi2*dphidyic*dphidyib
     &                          - dyib*ddrdy
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic
     &                          + d2edphi2*dphidzic*dphidyib
     &                          - dyib*ddrdz
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic
     &                          + d2edphi2*dphidxic*dphidzib
     &                          - dzib*ddrdx
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic
     &                          + d2edphi2*dphidyic*dphidzib
     &                          - dzib*ddrdy
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic
     &                          + d2edphi2*dphidzic*dphidzib
     &                          - dzib*ddrdz
               hessx(1,id) = hessx(1,id) + dedphi*dxicxid
     &                          + d2edphi2*dphidxic*dphidxid
     &                          - dxid*ddrdx + dxic*ddrdx - d2drdxx
               hessy(1,id) = hessy(1,id) + dedphi*dyicxid
     &                          + d2edphi2*dphidyic*dphidxid
     &                          - dxid*ddrdy + dyic*ddrdx - d2drdxy
               hessz(1,id) = hessz(1,id) + dedphi*dzicxid
     &                          + d2edphi2*dphidzic*dphidxid
     &                          - dxid*ddrdz + dzic*ddrdx - d2drdxz
               hessx(2,id) = hessx(2,id) + dedphi*dxicyid
     &                          + d2edphi2*dphidxic*dphidyid
     &                          - dyid*ddrdx + dxic*ddrdy - d2drdxy
               hessy(2,id) = hessy(2,id) + dedphi*dyicyid
     &                          + d2edphi2*dphidyic*dphidyid
     &                          - dyid*ddrdy + dyic*ddrdy - d2drdyy
               hessz(2,id) = hessz(2,id) + dedphi*dzicyid
     &                          + d2edphi2*dphidzic*dphidyid
     &                          - dyid*ddrdz + dzic*ddrdy - d2drdyz
               hessx(3,id) = hessx(3,id) + dedphi*dxiczid
     &                          + d2edphi2*dphidxic*dphidzid
     &                          - dzid*ddrdx + dxic*ddrdz - d2drdxz
               hessy(3,id) = hessy(3,id) + dedphi*dyiczid
     &                          + d2edphi2*dphidyic*dphidzid
     &                          - dzid*ddrdy + dyic*ddrdz - d2drdyz
               hessz(3,id) = hessz(3,id) + dedphi*dziczid
     &                          + d2edphi2*dphidzic*dphidzid
     &                          - dzid*ddrdz + dzic*ddrdz - d2drdzz
            else if (i .eq. id) then
               hessx(1,id) = hessx(1,id) + dedphi*dxidxid
     &                          + d2edphi2*dphidxid*dphidxid
     &                          + 2.0d0*dxid*ddrdx + d2drdxx
               hessy(1,id) = hessy(1,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
     &                          + dxid*ddrdy + dyid*ddrdx + d2drdxy
               hessz(1,id) = hessz(1,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
     &                          + dxid*ddrdz + dzid*ddrdx + d2drdxz
               hessx(2,id) = hessx(2,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
     &                          + dxid*ddrdy + dyid*ddrdx + d2drdxy
               hessy(2,id) = hessy(2,id) + dedphi*dyidyid
     &                          + d2edphi2*dphidyid*dphidyid
     &                          + 2.0d0*dyid*ddrdy + d2drdyy
               hessz(2,id) = hessz(2,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
     &                          + dyid*ddrdz + dzid*ddrdy + d2drdyz
               hessx(3,id) = hessx(3,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
     &                          + dxid*ddrdz + dzid*ddrdx + d2drdxz
               hessy(3,id) = hessy(3,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
     &                          + dyid*ddrdz + dzid*ddrdy + d2drdyz
               hessz(3,id) = hessz(3,id) + dedphi*dzidzid
     &                          + d2edphi2*dphidzid*dphidzid
     &                          + 2.0d0*dzid*ddrdz + d2drdzz
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxid*dphidxia
     &                          + dxia*ddrdx
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid
     &                          + d2edphi2*dphidyid*dphidxia
     &                          + dxia*ddrdy
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid
     &                          + d2edphi2*dphidzid*dphidxia
     &                          + dxia*ddrdz
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid
     &                          + d2edphi2*dphidxid*dphidyia
     &                          + dyia*ddrdx
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid
     &                          + d2edphi2*dphidyid*dphidyia
     &                          + dyia*ddrdy
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid
     &                          + d2edphi2*dphidzid*dphidyia
     &                          + dyia*ddrdz
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid
     &                          + d2edphi2*dphidxid*dphidzia
     &                          + dzia*ddrdx
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayid
     &                          + d2edphi2*dphidyid*dphidzia
     &                          + dzia*ddrdy
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazid
     &                          + d2edphi2*dphidzid*dphidzia
     &                          + dzia*ddrdz
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid
     &                          + d2edphi2*dphidxid*dphidxib
     &                          + dxib*ddrdx
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid
     &                          + d2edphi2*dphidyid*dphidxib
     &                          + dxib*ddrdy
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid
     &                          + d2edphi2*dphidzid*dphidxib
     &                          + dxib*ddrdz
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid
     &                          + d2edphi2*dphidxid*dphidyib
     &                          + dyib*ddrdx
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid
     &                          + d2edphi2*dphidyid*dphidyib
     &                          + dyib*ddrdy
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid
     &                          + d2edphi2*dphidzid*dphidyib
     &                          + dyib*ddrdz
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid
     &                          + d2edphi2*dphidxid*dphidzib
     &                          + dzib*ddrdx
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid
     &                          + d2edphi2*dphidyid*dphidzib
     &                          + dzib*ddrdy
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid
     &                          + d2edphi2*dphidzid*dphidzib
     &                          + dzib*ddrdz
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid
     &                          + d2edphi2*dphidxid*dphidxic
     &                          + dxic*ddrdx - dxid*ddrdx - d2drdxx
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid
     &                          + d2edphi2*dphidyid*dphidxic
     &                          + dxic*ddrdy - dyid*ddrdx - d2drdxy
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid
     &                          + d2edphi2*dphidzid*dphidxic
     &                          + dxic*ddrdz - dzid*ddrdx - d2drdxz
               hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid
     &                          + d2edphi2*dphidxid*dphidyic
     &                          + dyic*ddrdx - dxid*ddrdy - d2drdxy
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid
     &                          + d2edphi2*dphidyid*dphidyic
     &                          + dyic*ddrdy - dyid*ddrdy - d2drdyy
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid
     &                          + d2edphi2*dphidzid*dphidyic
     &                          + dyic*ddrdz - dzid*ddrdy - d2drdyz
               hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid
     &                          + d2edphi2*dphidxid*dphidzic
     &                          + dzic*ddrdx - dxid*ddrdz - d2drdxz
               hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid
     &                          + d2edphi2*dphidyid*dphidzic
     &                          + dzic*ddrdy - dyid*ddrdz - d2drdyz
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczid
     &                          + d2edphi2*dphidzid*dphidzic
     &                          + dzic*ddrdz - dzid*ddrdz - d2drdzz
            end if
         end if
      end do
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder  ##
c     ##                  All Rights Reserved                 ##
c     ##########################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine estrtor3  --  stretch-torsion energy & analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "estrtor3" calculates the stretch-torsion potential energy;
c     also partitions the energy terms among the atoms
c
c
      subroutine estrtor3
      use action
      use analyz
      use atomid
      use atoms
      use bndstr
      use bound
      use energi
      use group
      use inform
      use iounit
      use math
      use strtor
      use torpot
      use tors
      use usage
      implicit none
      integer i,k,istrtor
      integer ia,ib,ic,id
      real*8 e,eps,dr
      real*8 fgrp,angle
      real*8 rt2,ru2,rtru
      real*8 rba,rcb,rdc
      real*8 e1,e2,e3
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 sine,cosine
      real*8 sine2,cosine2
      real*8 sine3,cosine3
      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
      real*8 xdc,ydc,zdc
      logical proceed
      logical header,huge
c
c
c     zero out the stretch-torsion energy and partitioning terms
c
      nebt = 0
      ebt = 0.0d0
      do i = 1, n
         aebt(i) = 0.0d0
      end do
      if (nstrtor .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nstrtor.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Stretch-Torsion Interactions :',
     &           //,' Type',25x,'Atom Names',21x,'Angle',6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nstrtor,ist,itors,kst,bl,
!$OMP& tors1,tors2,tors3,use,x,y,z,storunit,eps,use_group,use_polymer,
!$OMP& name,verbose,debug,header,iout)
!$OMP& shared(ebt,nebt,aebt)
!$OMP DO reduction(+:ebt,nebt,aebt)
c
c     calculate the stretch-torsion interaction energy term
c
      do istrtor = 1, nstrtor
         i = ist(1,istrtor)
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rba = sqrt(xba*xba + yba*yba + zba*zba)
            rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
            rcb = max(rcb,eps)
            rdc = sqrt(xdc*xdc + ydc*ydc + zdc*zdc)
            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
            rt2 = max(rt2,eps)
            ru2 = xu*xu + yu*yu + zu*zu
            ru2 = max(ru2,eps)
            rtru = sqrt(rt2*ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
c
c     compute multiple angle trigonometry and phase terms
c
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            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)
c
c     get the stretch-torsion values for the first bond
c
            v1 = kst(1,istrtor)
            v2 = kst(2,istrtor)
            v3 = kst(3,istrtor)
            k = ist(2,istrtor)
            dr = rba - bl(k)
            e1 = storunit * dr * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     get the stretch-torsion values for the second bond
c
            v1 = kst(4,istrtor)
            v2 = kst(5,istrtor)
            v3 = kst(6,istrtor)
            k = ist(3,istrtor)
            dr = rcb - bl(k)
            e2 = storunit * dr * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     get the stretch-torsion values for the third bond
c
            v1 = kst(7,istrtor)
            v2 = kst(8,istrtor)
            v3 = kst(9,istrtor)
            k = ist(4,istrtor)
            dr = rdc - bl(k)
            e3 = storunit * dr * (v1*phi1 + v2*phi2 + v3*phi3)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e1 = e1 * fgrp
               e2 = e2 * fgrp
               e3 = e3 * fgrp
            end if
c
c     increment the total stretch-torsion energy
c
            nebt = nebt + 1
            e = e1 + e2 + e3
            ebt = ebt + e
            aebt(ia) = aebt(ia) + 0.5d0*e1
            aebt(ib) = aebt(ib) + 0.5d0*(e1+e2)
            aebt(ic) = aebt(ic) + 0.5d0*(e2+e3)
            aebt(id) = aebt(id) + 0.5d0*e3
c
c     print a message if the energy of this interaction is large
c
            huge = (abs(e) .gt. 3.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Individual Stretch-Torsion',
     &                       ' Interactions :',
     &                    //,' Type',25x,'Atom Names',21x,'Angle',
     &                       6x,'Energy',/)
               end if
               write (iout,30)  ia,name(ia),ib,name(ib),ic,
     &                          name(ic),id,name(id),angle,e
   30          format (' StrTors',3x,4(i7,'-',a3),f11.4,f12.4)
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine etors  --  torsional angle potential energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "etors" calculates the torsional potential energy
c
c
      subroutine etors
      use warp
      implicit none
c
c
c     choose standard or potential energy smoothing version
c
      if (use_smooth) then
         call etors0b
      else
         call etors0a
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine etors0a  --  standard torsional angle energy  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "etors0a" calculates the torsional potential energy
c     using a standard sum of Fourier terms
c
c
      subroutine etors0a
      use atoms
      use bound
      use energi
      use group
      use torpot
      use tors
      use usage
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps,rcb,fgrp
      real*8 xt,yt,zt,rt2
      real*8 xu,yu,zu,ru2
      real*8 xtu,ytu,ztu,rtru
      real*8 v1,v2,v3,v4,v5,v6
      real*8 c1,c2,c3,c4,c5,c6
      real*8 s1,s2,s3,s4,s5,s6
      real*8 cosine,cosine2
      real*8 cosine3,cosine4
      real*8 cosine5,cosine6
      real*8 sine,sine2,sine3
      real*8 sine4,sine5,sine6
      real*8 phi1,phi2,phi3
      real*8 phi4,phi5,phi6
      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 xdc,ydc,zdc
      real*8 xcb,ycb,zcb
      logical proceed
c
c
c     zero out the torsional potential energy
c
      et = 0.0d0
      if (ntors .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ntors,itors,tors1,tors2,tors3,
!$OMP& tors4,tors5,tors6,use,x,y,z,torsunit,eps,use_group,use_polymer)
!$OMP& shared(et)
!$OMP DO reduction(+:et)
c
c     calculate the torsional angle energy term
c
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the torsional parameters for this angle
c
            v1 = tors1(1,i)
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            v2 = tors2(1,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            v3 = tors3(1,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            v4 = tors4(1,i)
            c4 = tors4(3,i)
            s4 = tors4(4,i)
            v5 = tors5(1,i)
            c5 = tors5(3,i)
            s5 = tors5(4,i)
            v6 = tors6(1,i)
            c6 = tors6(3,i)
            s6 = tors6(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
            cosine4 = cosine*cosine3 - sine*sine3
            sine4 = cosine*sine3 + sine*cosine3
            cosine5 = cosine*cosine4 - sine*sine4
            sine5 = cosine*sine4 + sine*cosine4
            cosine6 = cosine*cosine5 - sine*sine5
            sine6 = cosine*sine5 + sine*cosine5
            phi1 = 1.0d0 + (cosine*c1 + sine*s1)
            phi2 = 1.0d0 + (cosine2*c2 + sine2*s2)
            phi3 = 1.0d0 + (cosine3*c3 + sine3*s3)
            phi4 = 1.0d0 + (cosine4*c4 + sine4*s4)
            phi5 = 1.0d0 + (cosine5*c5 + sine5*s5)
            phi6 = 1.0d0 + (cosine6*c6 + sine6*s6)
c
c     calculate the torsional energy for this angle
c
            e = torsunit * (v1*phi1 + v2*phi2 + v3*phi3
     &                         + v4*phi4 + v5*phi5 + v6*phi6)
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total torsional angle energy
c
            et = et + e
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine etors0b  --  torsional energy for smoothing  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "etors0b" calculates the torsional potential energy
c     for use with potential energy smoothing methods
c
c
      subroutine etors0b
      use atoms
      use energi
      use group
      use math
      use torpot
      use tors
      use usage
      use warp
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps,rcb,fgrp
      real*8 width,wterm
      real*8 xt,yt,zt,rt2
      real*8 xu,yu,zu,ru2
      real*8 xtu,ytu,ztu,rtru
      real*8 v1,v2,v3,v4,v5,v6
      real*8 c1,c2,c3,c4,c5,c6
      real*8 s1,s2,s3,s4,s5,s6
      real*8 cosine,cosine2
      real*8 cosine3,cosine4
      real*8 cosine5,cosine6
      real*8 sine,sine2,sine3
      real*8 sine4,sine5,sine6
      real*8 damp1,damp2,damp3
      real*8 damp4,damp5,damp6
      real*8 phi1,phi2,phi3
      real*8 phi4,phi5,phi6
      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 xdc,ydc,zdc
      real*8 xcb,ycb,zcb
      logical proceed
c
c
c     zero out the torsional potential energy
c
      et = 0.0d0
      if (ntors .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     set the extent of smoothing to be performed
c
      width = difft * deform
      if (width .le. 0.0d0) then
         damp1 = 1.0d0
         damp2 = 1.0d0
         damp3 = 1.0d0
         damp4 = 1.0d0
         damp5 = 1.0d0
         damp6 = 1.0d0
      else if (use_dem) then
         damp1 = exp(-width)
         damp2 = exp(-4.0d0*width)
         damp3 = exp(-9.0d0*width)
         damp4 = exp(-16.0d0*width)
         damp5 = exp(-25.0d0*width)
         damp6 = exp(-36.0d0*width)
      else if (use_gda) then
         wterm = difft / 12.0d0
      else if (use_tophat .or. use_stophat) then
         damp1 = 0.0d0
         damp2 = 0.0d0
         damp3 = 0.0d0
         damp4 = 0.0d0
         damp5 = 0.0d0
         damp6 = 0.0d0
         if (width .lt. pi)  damp1 = sin(width) / width
         wterm = 2.0d0 * width
         if (wterm .lt. pi)  damp2 = sin(wterm) / wterm
         wterm = 3.0d0 * width
         if (wterm .lt. pi)  damp3 = sin(wterm) / wterm
         wterm = 4.0d0 * width
         if (wterm .lt. pi)  damp4 = sin(wterm) / wterm
         wterm = 5.0d0 * width
         if (wterm .lt. pi)  damp5 = sin(wterm) / wterm
         wterm = 6.0d0 * width
         if (wterm .lt. pi)  damp6 = sin(wterm) / wterm
      end if
c
c     calculate the torsional angle energy term
c
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,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
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the torsional parameters for this angle
c
            v1 = tors1(1,i)
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            v2 = tors2(1,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            v3 = tors3(1,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            v4 = tors4(1,i)
            c4 = tors4(3,i)
            s4 = tors4(4,i)
            v5 = tors5(1,i)
            c5 = tors5(3,i)
            s5 = tors5(4,i)
            v6 = tors6(1,i)
            c6 = tors6(3,i)
            s6 = tors6(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
            cosine4 = cosine*cosine3 - sine*sine3
            sine4 = cosine*sine3 + sine*cosine3
            cosine5 = cosine*cosine4 - sine*sine4
            sine5 = cosine*sine4 + sine*cosine4
            cosine6 = cosine*cosine5 - sine*sine5
            sine6 = cosine*sine5 + sine*cosine5
            phi1 = 1.0d0 + (cosine*c1 + sine*s1)
            phi2 = 1.0d0 + (cosine2*c2 + sine2*s2)
            phi3 = 1.0d0 + (cosine3*c3 + sine3*s3)
            phi4 = 1.0d0 + (cosine4*c4 + sine4*s4)
            phi5 = 1.0d0 + (cosine5*c5 + sine5*s5)
            phi6 = 1.0d0 + (cosine6*c6 + sine6*s6)
c
c     transform the potential function via smoothing
c
            if (use_gda) then
               width = wterm * (m2(ia)+m2(ib)+m2(ic)+m2(id))
               damp1 = exp(-width)
               damp2 = exp(-4.0d0*width)
               damp3 = exp(-9.0d0*width)
               damp4 = exp(-16.0d0*width)
               damp5 = exp(-25.0d0*width)
               damp6 = exp(-36.0d0*width)
            end if
            phi1 = phi1 * damp1
            phi2 = phi2 * damp2
            phi3 = phi3 * damp3
            phi4 = phi4 * damp4
            phi5 = phi5 * damp5
            phi6 = phi6 * damp6
c
c     calculate the torsional energy for this angle
c
            e = torsunit * (v1*phi1 + v2*phi2 + v3*phi3
     &                         + v4*phi4 + v5*phi5 + v6*phi6)
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total torsional angle energy
c
            et = et + e
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine etors1  --  torsional energy & derivatives  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "etors1" calculates the torsional potential energy and first
c     derivatives with respect to Cartesian coordinates
c
c
      subroutine etors1
      use warp
      implicit none
c
c
c     choose standard or potential energy smoothing version
c
      if (use_smooth) then
         call etors1b
      else
         call etors1a
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine etors1a  --  standard torsional energy & derivs  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "etors1a" calculates the torsional potential energy and first
c     derivatives with respect to Cartesian coordinates using a
c     standard sum of Fourier terms
c
c
      subroutine etors1a
      use atoms
      use bound
      use deriv
      use energi
      use group
      use torpot
      use tors
      use usage
      use virial
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps,rcb
      real*8 dedphi,fgrp
      real*8 v1,v2,v3,v4,v5,v6
      real*8 c1,c2,c3,c4,c5,c6
      real*8 s1,s2,s3,s4,s5,s6
      real*8 cosine,cosine2
      real*8 cosine3,cosine4
      real*8 cosine5,cosine6
      real*8 sine,sine2,sine3
      real*8 sine4,sine5,sine6
      real*8 phi1,phi2,phi3
      real*8 phi4,phi5,phi6
      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 xdc,ydc,zdc
      real*8 xcb,ycb,zcb
      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 dphi4,dphi5,dphi6
      real*8 dedxt,dedyt,dedzt
      real*8 dedxu,dedyu,dedzu
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out the torsional energy and first derivatives
c
      et = 0.0d0
      do i = 1, n
         det(1,i) = 0.0d0
         det(2,i) = 0.0d0
         det(3,i) = 0.0d0
      end do
      if (ntors .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ntors,itors,tors1,tors2,tors3,
!$OMP& tors4,tors5,tors6,use,x,y,z,torsunit,eps,use_group,use_polymer)
!$OMP& shared(et,det,vir)
!$OMP DO reduction(+:et,det,vir)
c
c     calculate the torsional angle energy and first derivatives
c
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the torsional parameters for this angle
c
            v1 = tors1(1,i)
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            v2 = tors2(1,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            v3 = tors3(1,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            v4 = tors4(1,i)
            c4 = tors4(3,i)
            s4 = tors4(4,i)
            v5 = tors5(1,i)
            c5 = tors5(3,i)
            s5 = tors5(4,i)
            v6 = tors6(1,i)
            c6 = tors6(3,i)
            s6 = tors6(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
            cosine4 = cosine*cosine3 - sine*sine3
            sine4 = cosine*sine3 + sine*cosine3
            cosine5 = cosine*cosine4 - sine*sine4
            sine5 = cosine*sine4 + sine*cosine4
            cosine6 = cosine*cosine5 - sine*sine5
            sine6 = cosine*sine5 + sine*cosine5
            phi1 = 1.0d0 + (cosine*c1 + sine*s1)
            phi2 = 1.0d0 + (cosine2*c2 + sine2*s2)
            phi3 = 1.0d0 + (cosine3*c3 + sine3*s3)
            phi4 = 1.0d0 + (cosine4*c4 + sine4*s4)
            phi5 = 1.0d0 + (cosine5*c5 + sine5*s5)
            phi6 = 1.0d0 + (cosine6*c6 + sine6*s6)
            dphi1 = (cosine*s1 - sine*c1)
            dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2)
            dphi3 = 3.0d0 * (cosine3*s3 - sine3*c3)
            dphi4 = 4.0d0 * (cosine4*s4 - sine4*c4)
            dphi5 = 5.0d0 * (cosine5*s5 - sine5*c5)
            dphi6 = 6.0d0 * (cosine6*s6 - sine6*c6)
c
c     calculate torsional energy and master chain rule term
c
            e = torsunit * (v1*phi1 + v2*phi2 + v3*phi3
     &                         + v4*phi4 + v5*phi5 + v6*phi6)
            dedphi = torsunit * (v1*dphi1 + v2*dphi2 + v3*dphi3
     &                              + v4*dphi4 + v5*dphi5 + v6*dphi6)
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     chain rule terms for first derivative components
c
            xca = xic - xia
            yca = yic - yia
            zca = zic - zia
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            if (use_polymer) then
               call image (xca,yca,zca)
               call image (xdb,ydb,zdb)
            end if
            dedxt = dedphi * (yt*zcb - ycb*zt) / (rt2*rcb)
            dedyt = dedphi * (zt*xcb - zcb*xt) / (rt2*rcb)
            dedzt = dedphi * (xt*ycb - xcb*yt) / (rt2*rcb)
            dedxu = -dedphi * (yu*zcb - ycb*zu) / (ru2*rcb)
            dedyu = -dedphi * (zu*xcb - zcb*xu) / (ru2*rcb)
            dedzu = -dedphi * (xu*ycb - xcb*yu) / (ru2*rcb)
c
c     compute first derivative components for this angle
c
            dedxia = zcb*dedyt - ycb*dedzt
            dedyia = xcb*dedzt - zcb*dedxt
            dedzia = ycb*dedxt - xcb*dedyt
            dedxib = yca*dedzt - zca*dedyt + zdc*dedyu - ydc*dedzu
            dedyib = zca*dedxt - xca*dedzt + xdc*dedzu - zdc*dedxu
            dedzib = xca*dedyt - yca*dedxt + ydc*dedxu - xdc*dedyu
            dedxic = zba*dedyt - yba*dedzt + ydb*dedzu - zdb*dedyu
            dedyic = xba*dedzt - zba*dedxt + zdb*dedxu - xdb*dedzu
            dedzic = yba*dedxt - xba*dedyt + xdb*dedyu - ydb*dedxu
            dedxid = zcb*dedyu - ycb*dedzu
            dedyid = xcb*dedzu - zcb*dedxu
            dedzid = ycb*dedxu - xcb*dedyu
c
c     increment the total torsional angle energy and gradient
c
            et = et + e
            det(1,ia) = det(1,ia) + dedxia
            det(2,ia) = det(2,ia) + dedyia
            det(3,ia) = det(3,ia) + dedzia
            det(1,ib) = det(1,ib) + dedxib
            det(2,ib) = det(2,ib) + dedyib
            det(3,ib) = det(3,ib) + dedzib
            det(1,ic) = det(1,ic) + dedxic
            det(2,ic) = det(2,ic) + dedyic
            det(3,ic) = det(3,ic) + dedzic
            det(1,id) = det(1,id) + dedxid
            det(2,id) = det(2,id) + dedyid
            det(3,id) = det(3,id) + dedzid
c
c     increment the internal virial tensor components
c
            vxx = xcb*(dedxic+dedxid) - xba*dedxia + xdc*dedxid
            vyx = ycb*(dedxic+dedxid) - yba*dedxia + ydc*dedxid
            vzx = zcb*(dedxic+dedxid) - zba*dedxia + zdc*dedxid
            vyy = ycb*(dedyic+dedyid) - yba*dedyia + ydc*dedyid
            vzy = zcb*(dedyic+dedyid) - zba*dedyia + zdc*dedyid
            vzz = zcb*(dedzic+dedzid) - zba*dedzia + zdc*dedzid
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine etors1b  --  smoothed torsional energy & derivs  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "etors1b" calculates the torsional potential energy and first
c     derivatives with respect to Cartesian coordinates for use with
c     potential energy smoothing methods
c
c
      subroutine etors1b
      use atoms
      use deriv
      use energi
      use group
      use math
      use torpot
      use tors
      use usage
      use virial
      use warp
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps,rcb,dedphi
      real*8 width,wterm,fgrp
      real*8 v1,v2,v3,v4,v5,v6
      real*8 c1,c2,c3,c4,c5,c6
      real*8 s1,s2,s3,s4,s5,s6
      real*8 cosine,cosine2
      real*8 cosine3,cosine4
      real*8 cosine5,cosine6
      real*8 sine,sine2,sine3
      real*8 sine4,sine5,sine6
      real*8 damp1,damp2,damp3
      real*8 damp4,damp5,damp6
      real*8 phi1,phi2,phi3
      real*8 phi4,phi5,phi6
      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 xdc,ydc,zdc
      real*8 xcb,ycb,zcb
      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 dphi4,dphi5,dphi6
      real*8 dedxt,dedyt,dedzt
      real*8 dedxu,dedyu,dedzu
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out the torsional energy and first derivatives
c
      et = 0.0d0
      do i = 1, n
         det(1,i) = 0.0d0
         det(2,i) = 0.0d0
         det(3,i) = 0.0d0
      end do
      if (ntors .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     set the extent of smoothing to be performed
c
      width = difft * deform
      if (width .le. 0.0d0) then
         damp1 = 1.0d0
         damp2 = 1.0d0
         damp3 = 1.0d0
         damp4 = 1.0d0
         damp5 = 1.0d0
         damp6 = 1.0d0
      else if (use_dem) then
         damp1 = exp(-width)
         damp2 = exp(-4.0d0*width)
         damp3 = exp(-9.0d0*width)
         damp4 = exp(-16.0d0*width)
         damp5 = exp(-25.0d0*width)
         damp6 = exp(-36.0d0*width)
      else if (use_gda) then
         wterm = difft / 12.0d0
      else if (use_tophat .or. use_stophat) then
         damp1 = 0.0d0
         damp2 = 0.0d0
         damp3 = 0.0d0
         damp4 = 0.0d0
         damp5 = 0.0d0
         damp6 = 0.0d0
         if (width .lt. pi)  damp1 = sin(width) / width
         wterm = 2.0d0 * width
         if (wterm .lt. pi)  damp2 = sin(wterm) / wterm
         wterm = 3.0d0 * width
         if (wterm .lt. pi)  damp3 = sin(wterm) / wterm
         wterm = 4.0d0 * width
         if (wterm .lt. pi)  damp4 = sin(wterm) / wterm
         wterm = 5.0d0 * width
         if (wterm .lt. pi)  damp5 = sin(wterm) / wterm
         wterm = 6.0d0 * width
         if (wterm .lt. pi)  damp6 = sin(wterm) / wterm
      end if
c
c     calculate the torsional angle energy and first derivatives
c
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,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
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the torsional parameters for this angle
c
            v1 = tors1(1,i)
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            v2 = tors2(1,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            v3 = tors3(1,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            v4 = tors4(1,i)
            c4 = tors4(3,i)
            s4 = tors4(4,i)
            v5 = tors5(1,i)
            c5 = tors5(3,i)
            s5 = tors5(4,i)
            v6 = tors6(1,i)
            c6 = tors6(3,i)
            s6 = tors6(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
            cosine4 = cosine*cosine3 - sine*sine3
            sine4 = cosine*sine3 + sine*cosine3
            cosine5 = cosine*cosine4 - sine*sine4
            sine5 = cosine*sine4 + sine*cosine4
            cosine6 = cosine*cosine5 - sine*sine5
            sine6 = cosine*sine5 + sine*cosine5
            phi1 = 1.0d0 + (cosine*c1 + sine*s1)
            phi2 = 1.0d0 + (cosine2*c2 + sine2*s2)
            phi3 = 1.0d0 + (cosine3*c3 + sine3*s3)
            phi4 = 1.0d0 + (cosine4*c4 + sine4*s4)
            phi5 = 1.0d0 + (cosine5*c5 + sine5*s5)
            phi6 = 1.0d0 + (cosine6*c6 + sine6*s6)
            dphi1 = (cosine*s1 - sine*c1)
            dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2)
            dphi3 = 3.0d0 * (cosine3*s3 - sine3*c3)
            dphi4 = 4.0d0 * (cosine4*s4 - sine4*c4)
            dphi5 = 5.0d0 * (cosine5*s5 - sine5*c5)
            dphi6 = 6.0d0 * (cosine6*s6 - sine6*c6)
c
c     transform the potential function via smoothing
c
            if (use_gda) then
               width = wterm * (m2(ia)+m2(ib)+m2(ic)+m2(id))
               damp1 = exp(-width)
               damp2 = exp(-4.0d0*width)
               damp3 = exp(-9.0d0*width)
               damp4 = exp(-16.0d0*width)
               damp5 = exp(-25.0d0*width)
               damp6 = exp(-36.0d0*width)
            end if
            phi1 = phi1 * damp1
            phi2 = phi2 * damp2
            phi3 = phi3 * damp3
            phi4 = phi4 * damp4
            phi5 = phi5 * damp5
            phi6 = phi6 * damp6
            dphi1 = dphi1 * damp1
            dphi2 = dphi2 * damp2
            dphi3 = dphi3 * damp3
            dphi4 = dphi4 * damp4
            dphi5 = dphi5 * damp5
            dphi6 = dphi6 * damp6
c
c     calculate torsional energy and master chain rule term
c
            e = torsunit * (v1*phi1 + v2*phi2 + v3*phi3
     &                         + v4*phi4 + v5*phi5 + v6*phi6)
            dedphi = torsunit * (v1*dphi1 + v2*dphi2 + v3*dphi3
     &                              + v4*dphi4 + v5*dphi5 + v6*dphi6)
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     chain rule terms for first derivative components
c
            xca = xic - xia
            yca = yic - yia
            zca = zic - zia
            xdb = xid - xib
            ydb = yid - yib
            zdb = zid - zib
            dedxt = dedphi * (yt*zcb - ycb*zt) / (rt2*rcb)
            dedyt = dedphi * (zt*xcb - zcb*xt) / (rt2*rcb)
            dedzt = dedphi * (xt*ycb - xcb*yt) / (rt2*rcb)
            dedxu = -dedphi * (yu*zcb - ycb*zu) / (ru2*rcb)
            dedyu = -dedphi * (zu*xcb - zcb*xu) / (ru2*rcb)
            dedzu = -dedphi * (xu*ycb - xcb*yu) / (ru2*rcb)
c
c     compute first derivative components for this angle
c
            dedxia = zcb*dedyt - ycb*dedzt
            dedyia = xcb*dedzt - zcb*dedxt
            dedzia = ycb*dedxt - xcb*dedyt
            dedxib = yca*dedzt - zca*dedyt + zdc*dedyu - ydc*dedzu
            dedyib = zca*dedxt - xca*dedzt + xdc*dedzu - zdc*dedxu
            dedzib = xca*dedyt - yca*dedxt + ydc*dedxu - xdc*dedyu
            dedxic = zba*dedyt - yba*dedzt + ydb*dedzu - zdb*dedyu
            dedyic = xba*dedzt - zba*dedxt + zdb*dedxu - xdb*dedzu
            dedzic = yba*dedxt - xba*dedyt + xdb*dedyu - ydb*dedxu
            dedxid = zcb*dedyu - ycb*dedzu
            dedyid = xcb*dedzu - zcb*dedxu
            dedzid = ycb*dedxu - xcb*dedyu
c
c     increment the total torsional angle energy and gradient
c
            et = et + e
            det(1,ia) = det(1,ia) + dedxia
            det(2,ia) = det(2,ia) + dedyia
            det(3,ia) = det(3,ia) + dedzia
            det(1,ib) = det(1,ib) + dedxib
            det(2,ib) = det(2,ib) + dedyib
            det(3,ib) = det(3,ib) + dedzib
            det(1,ic) = det(1,ic) + dedxic
            det(2,ic) = det(2,ic) + dedyic
            det(3,ic) = det(3,ic) + dedzic
            det(1,id) = det(1,id) + dedxid
            det(2,id) = det(2,id) + dedyid
            det(3,id) = det(3,id) + dedzid
c
c     increment the internal virial tensor components
c
            vxx = xcb*(dedxic+dedxid) - xba*dedxia + xdc*dedxid
            vyx = ycb*(dedxic+dedxid) - yba*dedxia + ydc*dedxid
            vzx = zcb*(dedxic+dedxid) - zba*dedxia + zdc*dedxid
            vyy = ycb*(dedyic+dedyid) - yba*dedyia + ydc*dedyid
            vzy = zcb*(dedyic+dedyid) - zba*dedyia + zdc*dedyid
            vzz = zcb*(dedzic+dedzid) - zba*dedzia + zdc*dedzid
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine etors2  --  atom-by-atom torsional Hessian  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "etors2" calculates the second derivatives of the torsional
c     energy for a single atom
c
c
      subroutine etors2 (i)
      use warp
      implicit none
      integer i
c
c
c     choose standard or potential energy smoothing version
c
      if (use_smooth) then
         call etors2b (i)
      else
         call etors2a (i)
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine etors2a  --  standard torsional angle Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "etors2a" calculates the second derivatives of the torsional
c     energy for a single atom using a standard sum of Fourier terms
c
c
      subroutine etors2a (i)
      use atoms
      use bound
      use group
      use hessn
      use torpot
      use tors
      implicit none
      integer i,ktors
      integer ia,ib,ic,id
      real*8 eps,fgrp
      real*8 dedphi,d2edphi2
      real*8 v1,v2,v3,v4,v5,v6
      real*8 c1,c2,c3,c4,c5,c6
      real*8 s1,s2,s3,s4,s5,s6
      real*8 cosine,cosine2
      real*8 cosine3,cosine4
      real*8 cosine5,cosine6
      real*8 sine,sine2,sine3
      real*8 sine4,sine5,sine6
      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
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 xt,yt,zt,xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru,rcb
      real*8 dphi1,dphi2,dphi3
      real*8 dphi4,dphi5,dphi6
      real*8 d2phi1,d2phi2,d2phi3
      real*8 d2phi4,d2phi5,d2phi6
      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 xycb2,xzcb2,yzcb2
      real*8 rcbxt,rcbyt,rcbzt,rcbt2
      real*8 rcbxu,rcbyu,rcbzu,rcbu2
      real*8 dphidxibt,dphidyibt,dphidzibt
      real*8 dphidxibu,dphidyibu,dphidzibu
      real*8 dphidxict,dphidyict,dphidzict
      real*8 dphidxicu,dphidyicu,dphidzicu
      real*8 dxiaxia,dyiayia,dziazia
      real*8 dxibxib,dyibyib,dzibzib
      real*8 dxicxic,dyicyic,dziczic
      real*8 dxidxid,dyidyid,dzidzid
      real*8 dxiayia,dxiazia,dyiazia
      real*8 dxibyib,dxibzib,dyibzib
      real*8 dxicyic,dxiczic,dyiczic
      real*8 dxidyid,dxidzid,dyidzid
      real*8 dxiaxib,dxiayib,dxiazib
      real*8 dyiaxib,dyiayib,dyiazib
      real*8 dziaxib,dziayib,dziazib
      real*8 dxiaxic,dxiayic,dxiazic
      real*8 dyiaxic,dyiayic,dyiazic
      real*8 dziaxic,dziayic,dziazic
      real*8 dxiaxid,dxiayid,dxiazid
      real*8 dyiaxid,dyiayid,dyiazid
      real*8 dziaxid,dziayid,dziazid
      real*8 dxibxic,dxibyic,dxibzic
      real*8 dyibxic,dyibyic,dyibzic
      real*8 dzibxic,dzibyic,dzibzic
      real*8 dxibxid,dxibyid,dxibzid
      real*8 dyibxid,dyibyid,dyibzid
      real*8 dzibxid,dzibyid,dzibzid
      real*8 dxicxid,dxicyid,dxiczid
      real*8 dyicxid,dyicyid,dyiczid
      real*8 dzicxid,dzicyid,dziczid
      logical proceed
c
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     calculate the torsional angle interaction Hessian elements
c
      do ktors = 1, ntors
         ia = itors(1,ktors)
         ib = itors(2,ktors)
         ic = itors(3,ktors)
         id = itors(4,ktors)
c
c     decide whether to compute the current interaction
c
         proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic .or. i.eq.id)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,id,0,0)
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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the torsional parameters for this angle
c
            v1 = tors1(1,ktors)
            c1 = tors1(3,ktors)
            s1 = tors1(4,ktors)
            v2 = tors2(1,ktors)
            c2 = tors2(3,ktors)
            s2 = tors2(4,ktors)
            v3 = tors3(1,ktors)
            c3 = tors3(3,ktors)
            s3 = tors3(4,ktors)
            v4 = tors4(1,ktors)
            c4 = tors4(3,ktors)
            s4 = tors4(4,ktors)
            v5 = tors5(1,ktors)
            c5 = tors5(3,ktors)
            s5 = tors5(4,ktors)
            v6 = tors6(1,ktors)
            c6 = tors6(3,ktors)
            s6 = tors6(4,ktors)
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
            cosine4 = cosine*cosine3 - sine*sine3
            sine4 = cosine*sine3 + sine*cosine3
            cosine5 = cosine*cosine4 - sine*sine4
            sine5 = cosine*sine4 + sine*cosine4
            cosine6 = cosine*cosine5 - sine*sine5
            sine6 = cosine*sine5 + sine*cosine5
            dphi1 = (cosine*s1 - sine*c1)
            dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2)
            dphi3 = 3.0d0 * (cosine3*s3 - sine3*c3)
            dphi4 = 4.0d0 * (cosine4*s4 - sine4*c4)
            dphi5 = 5.0d0 * (cosine5*s5 - sine5*c5)
            dphi6 = 6.0d0 * (cosine6*s6 - sine6*c6)
            d2phi1 = -(cosine*c1 + sine*s1)
            d2phi2 = -4.0d0 * (cosine2*c2 + sine2*s2)
            d2phi3 = -9.0d0 * (cosine3*c3 + sine3*s3)
            d2phi4 = -16.0d0 * (cosine4*c4 + sine4*s4)
            d2phi5 = -25.0d0 * (cosine5*c5 + sine5*s5)
            d2phi6 = -36.0d0 * (cosine6*c6 + sine6*s6)
c
c     calculate the torsional master chain rule terms
c
            dedphi = torsunit * (v1*dphi1 + v2*dphi2 + v3*dphi3
     &                         + v4*dphi4 + v5*dphi5 + v6*dphi6)
            d2edphi2 = torsunit * (v1*d2phi1 + v2*d2phi2 + v3*d2phi3
     &                           + v4*d2phi4 + v5*d2phi5 + v6*d2phi6)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               dedphi = dedphi * fgrp
               d2edphi2 = d2edphi2 * 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
            if (use_polymer) then
               call image (xca,yca,zca)
               call image (xdb,ydb,zdb)
            end if
            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     abbreviations for second derivative chain rule terms
c
            xycb2 = xcb*xcb + ycb*ycb
            xzcb2 = xcb*xcb + zcb*zcb
            yzcb2 = ycb*ycb + zcb*zcb
            rcbxt = -2.0d0 * rcb * dphidxt
            rcbyt = -2.0d0 * rcb * dphidyt
            rcbzt = -2.0d0 * rcb * dphidzt
            rcbt2 = rcb * rt2
            rcbxu = 2.0d0 * rcb * dphidxu
            rcbyu = 2.0d0 * rcb * dphidyu
            rcbzu = 2.0d0 * rcb * dphidzu
            rcbu2 = rcb * ru2
            dphidxibt = yca*dphidzt - zca*dphidyt
            dphidxibu = zdc*dphidyu - ydc*dphidzu
            dphidyibt = zca*dphidxt - xca*dphidzt
            dphidyibu = xdc*dphidzu - zdc*dphidxu
            dphidzibt = xca*dphidyt - yca*dphidxt
            dphidzibu = ydc*dphidxu - xdc*dphidyu
            dphidxict = zba*dphidyt - yba*dphidzt
            dphidxicu = ydb*dphidzu - zdb*dphidyu
            dphidyict = xba*dphidzt - zba*dphidxt
            dphidyicu = zdb*dphidxu - xdb*dphidzu
            dphidzict = yba*dphidxt - xba*dphidyt
            dphidzicu = xdb*dphidyu - ydb*dphidxu
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 = dphidxibt + dphidxibu
            dphidyib = dphidyibt + dphidyibu
            dphidzib = dphidzibt + dphidzibu
            dphidxic = dphidxict + dphidxicu
            dphidyic = dphidyict + dphidyicu
            dphidzic = dphidzict + dphidzicu
            dphidxid = zcb*dphidyu - ycb*dphidzu
            dphidyid = xcb*dphidzu - zcb*dphidxu
            dphidzid = ycb*dphidxu - xcb*dphidyu
c
c     chain rule terms for second derivative components
c
            dxiaxia = rcbxt*dphidxia
            dxiayia = rcbxt*dphidyia - zcb*rcb/rt2
            dxiazia = rcbxt*dphidzia + ycb*rcb/rt2
            dxiaxic = rcbxt*dphidxict + xcb*xt/rcbt2
            dxiayic = rcbxt*dphidyict - dphidzt
     &                   - (xba*zcb*xcb+zba*yzcb2)/rcbt2
            dxiazic = rcbxt*dphidzict + dphidyt
     &                   + (xba*ycb*xcb+yba*yzcb2)/rcbt2
            dxiaxid = 0.0d0
            dxiayid = 0.0d0
            dxiazid = 0.0d0
            dyiayia = rcbyt*dphidyia
            dyiazia = rcbyt*dphidzia - xcb*rcb/rt2
            dyiaxib = rcbyt*dphidxibt - dphidzt
     &                   - (yca*zcb*ycb+zca*xzcb2)/rcbt2
            dyiaxic = rcbyt*dphidxict + dphidzt
     &                   + (yba*zcb*ycb+zba*xzcb2)/rcbt2
            dyiayic = rcbyt*dphidyict + ycb*yt/rcbt2
            dyiazic = rcbyt*dphidzict - dphidxt
     &                   - (yba*xcb*ycb+xba*xzcb2)/rcbt2
            dyiaxid = 0.0d0
            dyiayid = 0.0d0
            dyiazid = 0.0d0
            dziazia = rcbzt*dphidzia
            dziaxib = rcbzt*dphidxibt + dphidyt
     &                   + (zca*ycb*zcb+yca*xycb2)/rcbt2
            dziayib = rcbzt*dphidyibt - dphidxt
     &                   - (zca*xcb*zcb+xca*xycb2)/rcbt2
            dziaxic = rcbzt*dphidxict - dphidyt
     &                   - (zba*ycb*zcb+yba*xycb2)/rcbt2
            dziayic = rcbzt*dphidyict + dphidxt
     &                   + (zba*xcb*zcb+xba*xycb2)/rcbt2
            dziazic = rcbzt*dphidzict + zcb*zt/rcbt2
            dziaxid = 0.0d0
            dziayid = 0.0d0
            dziazid = 0.0d0
            dxibxic = -xcb*dphidxib/(rcb*rcb)
     &          - (yca*(zba*xcb+yt)-zca*(yba*xcb-zt))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidxibt/rt2
     &          - (zdc*(ydb*xcb+zu)-ydc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidxibu/ru2
            dxibyic = -ycb*dphidxib/(rcb*rcb) + dphidzt + dphidzu
     &          - (yca*(zba*ycb-xt)+zca*(xba*xcb+zcb*zba))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidxibt/rt2
     &          + (zdc*(xdb*xcb+zcb*zdb)+ydc*(zdb*ycb+xu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidxibu/ru2
            dxibxid = rcbxu*dphidxibu + xcb*xu/rcbu2
            dxibyid = rcbyu*dphidxibu - dphidzu
     &                   - (ydc*zcb*ycb+zdc*xzcb2)/rcbu2
            dxibzid = rcbzu*dphidxibu + dphidyu
     &                   + (zdc*ycb*zcb+ydc*xycb2)/rcbu2
            dyibzib = ycb*dphidzib/(rcb*rcb)
     &          - (xca*(xca*xcb+zcb*zca)+yca*(ycb*xca+zt))/rcbt2
     &          - 2.0d0*(xt*zca-xca*zt)*dphidzibt/rt2
     &          + (ydc*(xdc*ycb-zu)+xdc*(xdc*xcb+zcb*zdc))/rcbu2
     &          + 2.0d0*(xu*zdc-xdc*zu)*dphidzibu/ru2
            dyibxic = -xcb*dphidyib/(rcb*rcb) - dphidzt - dphidzu
     &          + (xca*(zba*xcb+yt)+zca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidyibt/rt2
     &          - (zdc*(zdb*zcb+ycb*ydb)+xdc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidyibu/ru2
            dyibyic = -ycb*dphidyib/(rcb*rcb)
     &          - (zca*(xba*ycb+zt)-xca*(zba*ycb-xt))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidyibt/rt2
     &          - (xdc*(zdb*ycb+xu)-zdc*(xdb*ycb-zu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidyibu/ru2
            dyibxid = rcbxu*dphidyibu + dphidzu
     &                   + (xdc*zcb*xcb+zdc*yzcb2)/rcbu2
            dyibyid = rcbyu*dphidyibu + ycb*yu/rcbu2
            dyibzid = rcbzu*dphidyibu - dphidxu
     &                   - (zdc*xcb*zcb+xdc*xycb2)/rcbu2
            dzibxic = -xcb*dphidzib/(rcb*rcb) + dphidyt + dphidyu
     &          - (xca*(yba*xcb-zt)+yca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidzibt/rt2
     &          + (ydc*(zdb*zcb+ycb*ydb)+xdc*(ydb*xcb+zu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidzibu/ru2
            dzibzic = -zcb*dphidzib/(rcb*rcb)
     &          - (xca*(yba*zcb+xt)-yca*(xba*zcb-yt))/rcbt2
     &          - 2.0d0*(xt*yba-xba*yt)*dphidzibt/rt2
     &          - (ydc*(xdb*zcb+yu)-xdc*(ydb*zcb-xu))/rcbu2
     &          + 2.0d0*(xu*ydb-xdb*yu)*dphidzibu/ru2
            dzibxid = rcbxu*dphidzibu - dphidyu
     &                   - (xdc*ycb*xcb+ydc*yzcb2)/rcbu2
            dzibyid = rcbyu*dphidzibu + dphidxu
     &                   + (ydc*xcb*ycb+xdc*xzcb2)/rcbu2
            dzibzid = rcbzu*dphidzibu + zcb*zu/rcbu2
            dxicxid = rcbxu*dphidxicu - xcb*(zdb*ycb-ydb*zcb)/rcbu2
            dxicyid = rcbyu*dphidxicu + dphidzu
     &                   + (ydb*zcb*ycb+zdb*xzcb2)/rcbu2
            dxiczid = rcbzu*dphidxicu - dphidyu
     &                   - (zdb*ycb*zcb+ydb*xycb2)/rcbu2
            dyicxid = rcbxu*dphidyicu - dphidzu
     &                   - (xdb*zcb*xcb+zdb*yzcb2)/rcbu2
            dyicyid = rcbyu*dphidyicu - ycb*(xdb*zcb-zdb*xcb)/rcbu2
            dyiczid = rcbzu*dphidyicu + dphidxu
     &                   + (zdb*xcb*zcb+xdb*xycb2)/rcbu2
            dzicxid = rcbxu*dphidzicu + dphidyu
     &                   + (xdb*ycb*xcb+ydb*yzcb2)/rcbu2
            dzicyid = rcbyu*dphidzicu - dphidxu
     &                   - (ydb*xcb*ycb+xdb*xzcb2)/rcbu2
            dziczid = rcbzu*dphidzicu - zcb*(ydb*xcb-xdb*ycb)/rcbu2
            dxidxid = rcbxu*dphidxid
            dxidyid = rcbxu*dphidyid + zcb*rcb/ru2
            dxidzid = rcbxu*dphidzid - ycb*rcb/ru2
            dyidyid = rcbyu*dphidyid
            dyidzid = rcbyu*dphidzid + xcb*rcb/ru2
            dzidzid = rcbzu*dphidzid
c
c     get some second derivative chain rule terms by difference
c
            dxiaxib = -dxiaxia - dxiaxic - dxiaxid
            dxiayib = -dxiayia - dxiayic - dxiayid
            dxiazib = -dxiazia - dxiazic - dxiazid
            dyiayib = -dyiayia - dyiayic - dyiayid
            dyiazib = -dyiazia - dyiazic - dyiazid
            dziazib = -dziazia - dziazic - dziazid
            dxibxib = -dxiaxib - dxibxic - dxibxid
            dxibyib = -dyiaxib - dxibyic - dxibyid
            dxibzib = -dxiazib - dzibxic - dzibxid
            dxibzic = -dziaxib - dxibzib - dxibzid
            dyibyib = -dyiayib - dyibyic - dyibyid
            dyibzic = -dziayib - dyibzib - dyibzid
            dzibzib = -dziazib - dzibzic - dzibzid
            dzibyic = -dyiazib - dyibzib - dzibyid
            dxicxic = -dxiaxic - dxibxic - dxicxid
            dxicyic = -dyiaxic - dyibxic - dxicyid
            dxiczic = -dziaxic - dzibxic - dxiczid
            dyicyic = -dyiayic - dyibyic - dyicyid
            dyiczic = -dziayic - dzibyic - dyiczid
            dziczic = -dziazic - dzibzic - dziczid
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (i .eq. ia) then
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia
     &                          + d2edphi2*dphidxia*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia
     &                          + d2edphi2*dphidyia*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazia
     &                          + d2edphi2*dphidzia*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxia*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib
     &                          + d2edphi2*dphidyia*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib
     &                          + d2edphi2*dphidzia*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib
     &                          + d2edphi2*dphidxia*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib
     &                          + d2edphi2*dphidyia*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dziayib
     &                          + d2edphi2*dphidzia*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib
     &                          + d2edphi2*dphidxia*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib
     &                          + d2edphi2*dphidyia*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dziazib
     &                          + d2edphi2*dphidzia*dphidzib
               hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxia*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic
     &                          + d2edphi2*dphidyia*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic
     &                          + d2edphi2*dphidzia*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic
     &                          + d2edphi2*dphidxia*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic
     &                          + d2edphi2*dphidyia*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dziayic
     &                          + d2edphi2*dphidzia*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic
     &                          + d2edphi2*dphidxia*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic
     &                          + d2edphi2*dphidyia*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziazic
     &                          + d2edphi2*dphidzia*dphidzic
               hessx(1,id) = hessx(1,id) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxia*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyiaxid
     &                          + d2edphi2*dphidyia*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dziaxid
     &                          + d2edphi2*dphidzia*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxiayid
     &                          + d2edphi2*dphidxia*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyiayid
     &                          + d2edphi2*dphidyia*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dziayid
     &                          + d2edphi2*dphidzia*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiazid
     &                          + d2edphi2*dphidxia*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiazid
     &                          + d2edphi2*dphidyia*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dziazid
     &                          + d2edphi2*dphidzia*dphidzid
            else if (i .eq. ib) then
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib
     &                          + d2edphi2*dphidxib*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib
     &                          + d2edphi2*dphidyib*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib
     &                          + d2edphi2*dphidzib*dphidzib
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxib*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib
     &                          + d2edphi2*dphidyib*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib
     &                          + d2edphi2*dphidzib*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib
     &                          + d2edphi2*dphidxib*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib
     &                          + d2edphi2*dphidyib*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib
     &                          + d2edphi2*dphidzib*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib
     &                          + d2edphi2*dphidxib*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayib
     &                          + d2edphi2*dphidyib*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazib
     &                          + d2edphi2*dphidzib*dphidzia
               hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic
     &                          + d2edphi2*dphidxib*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic
     &                          + d2edphi2*dphidyib*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic
     &                          + d2edphi2*dphidzib*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic
     &                          + d2edphi2*dphidxib*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic
     &                          + d2edphi2*dphidyib*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic
     &                          + d2edphi2*dphidzib*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic
     &                          + d2edphi2*dphidxib*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic
     &                          + d2edphi2*dphidyib*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic
     &                          + d2edphi2*dphidzib*dphidzic
               hessx(1,id) = hessx(1,id) + dedphi*dxibxid
     &                          + d2edphi2*dphidxib*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyibxid
     &                          + d2edphi2*dphidyib*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dzibxid
     &                          + d2edphi2*dphidzib*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxibyid
     &                          + d2edphi2*dphidxib*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyibyid
     &                          + d2edphi2*dphidyib*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dzibyid
     &                          + d2edphi2*dphidzib*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxibzid
     &                          + d2edphi2*dphidxib*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyibzid
     &                          + d2edphi2*dphidyib*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzibzid
     &                          + d2edphi2*dphidzib*dphidzid
            else if (i .eq. ic) then
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic
     &                          + d2edphi2*dphidxic*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic
     &                          + d2edphi2*dphidyic*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczic
     &                          + d2edphi2*dphidzic*dphidzic
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxic*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic
     &                          + d2edphi2*dphidyic*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic
     &                          + d2edphi2*dphidzic*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic
     &                          + d2edphi2*dphidxic*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic
     &                          + d2edphi2*dphidyic*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic
     &                          + d2edphi2*dphidzic*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic
     &                          + d2edphi2*dphidxic*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayic
     &                          + d2edphi2*dphidyic*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazic
     &                          + d2edphi2*dphidzic*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic
     &                          + d2edphi2*dphidxic*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic
     &                          + d2edphi2*dphidyic*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic
     &                          + d2edphi2*dphidzic*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic
     &                          + d2edphi2*dphidxic*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic
     &                          + d2edphi2*dphidyic*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic
     &                          + d2edphi2*dphidzic*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic
     &                          + d2edphi2*dphidxic*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic
     &                          + d2edphi2*dphidyic*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic
     &                          + d2edphi2*dphidzic*dphidzib
               hessx(1,id) = hessx(1,id) + dedphi*dxicxid
     &                          + d2edphi2*dphidxic*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyicxid
     &                          + d2edphi2*dphidyic*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dzicxid
     &                          + d2edphi2*dphidzic*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxicyid
     &                          + d2edphi2*dphidxic*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyicyid
     &                          + d2edphi2*dphidyic*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dzicyid
     &                          + d2edphi2*dphidzic*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiczid
     &                          + d2edphi2*dphidxic*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiczid
     &                          + d2edphi2*dphidyic*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dziczid
     &                          + d2edphi2*dphidzic*dphidzid
            else if (i .eq. id) then
               hessx(1,id) = hessx(1,id) + dedphi*dxidxid
     &                          + d2edphi2*dphidxid*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessz(1,id) = hessz(1,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessx(2,id) = hessx(2,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyidyid
     &                          + d2edphi2*dphidyid*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessx(3,id) = hessx(3,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzidzid
     &                          + d2edphi2*dphidzid*dphidzid
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxid*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid
     &                          + d2edphi2*dphidyid*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid
     &                          + d2edphi2*dphidzid*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid
     &                          + d2edphi2*dphidxid*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid
     &                          + d2edphi2*dphidyid*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid
     &                          + d2edphi2*dphidzid*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid
     &                          + d2edphi2*dphidxid*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayid
     &                          + d2edphi2*dphidyid*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazid
     &                          + d2edphi2*dphidzid*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid
     &                          + d2edphi2*dphidxid*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid
     &                          + d2edphi2*dphidyid*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid
     &                          + d2edphi2*dphidzid*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid
     &                          + d2edphi2*dphidxid*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid
     &                          + d2edphi2*dphidyid*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid
     &                          + d2edphi2*dphidzid*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid
     &                          + d2edphi2*dphidxid*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid
     &                          + d2edphi2*dphidyid*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid
     &                          + d2edphi2*dphidzid*dphidzib
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid
     &                          + d2edphi2*dphidxid*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid
     &                          + d2edphi2*dphidyid*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid
     &                          + d2edphi2*dphidzid*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid
     &                          + d2edphi2*dphidxid*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid
     &                          + d2edphi2*dphidyid*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid
     &                          + d2edphi2*dphidzid*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid
     &                          + d2edphi2*dphidxid*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid
     &                          + d2edphi2*dphidyid*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczid
     &                          + d2edphi2*dphidzid*dphidzic
            end if
         end if
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine etors2b  --  smoothed torsional angle Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "etors2b" calculates the second derivatives of the torsional
c     energy for a single atom for use with potential energy
c     smoothing methods
c
c
      subroutine etors2b (i)
      use atoms
      use group
      use hessn
      use math
      use torpot
      use tors
      use warp
      implicit none
      integer i,ktors
      integer ia,ib,ic,id
      real*8 eps,fgrp
      real*8 width,wterm
      real*8 dedphi,d2edphi2
      real*8 v1,v2,v3,v4,v5,v6
      real*8 c1,c2,c3,c4,c5,c6
      real*8 s1,s2,s3,s4,s5,s6
      real*8 cosine,cosine2
      real*8 cosine3,cosine4
      real*8 cosine5,cosine6
      real*8 sine,sine2,sine3
      real*8 sine4,sine5,sine6
      real*8 damp1,damp2,damp3
      real*8 damp4,damp5,damp6
      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
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 xt,yt,zt,xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru,rcb
      real*8 dphi1,dphi2,dphi3
      real*8 dphi4,dphi5,dphi6
      real*8 d2phi1,d2phi2,d2phi3
      real*8 d2phi4,d2phi5,d2phi6
      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 xycb2,xzcb2,yzcb2
      real*8 rcbxt,rcbyt,rcbzt,rcbt2
      real*8 rcbxu,rcbyu,rcbzu,rcbu2
      real*8 dphidxibt,dphidyibt,dphidzibt
      real*8 dphidxibu,dphidyibu,dphidzibu
      real*8 dphidxict,dphidyict,dphidzict
      real*8 dphidxicu,dphidyicu,dphidzicu
      real*8 dxiaxia,dyiayia,dziazia
      real*8 dxibxib,dyibyib,dzibzib
      real*8 dxicxic,dyicyic,dziczic
      real*8 dxidxid,dyidyid,dzidzid
      real*8 dxiayia,dxiazia,dyiazia
      real*8 dxibyib,dxibzib,dyibzib
      real*8 dxicyic,dxiczic,dyiczic
      real*8 dxidyid,dxidzid,dyidzid
      real*8 dxiaxib,dxiayib,dxiazib
      real*8 dyiaxib,dyiayib,dyiazib
      real*8 dziaxib,dziayib,dziazib
      real*8 dxiaxic,dxiayic,dxiazic
      real*8 dyiaxic,dyiayic,dyiazic
      real*8 dziaxic,dziayic,dziazic
      real*8 dxiaxid,dxiayid,dxiazid
      real*8 dyiaxid,dyiayid,dyiazid
      real*8 dziaxid,dziayid,dziazid
      real*8 dxibxic,dxibyic,dxibzic
      real*8 dyibxic,dyibyic,dyibzic
      real*8 dzibxic,dzibyic,dzibzic
      real*8 dxibxid,dxibyid,dxibzid
      real*8 dyibxid,dyibyid,dyibzid
      real*8 dzibxid,dzibyid,dzibzid
      real*8 dxicxid,dxicyid,dxiczid
      real*8 dyicxid,dyicyid,dyiczid
      real*8 dzicxid,dzicyid,dziczid
      logical proceed
c
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     set the extent of smoothing to be performed
c
      width = difft * deform
      if (width .le. 0.0d0) then
         damp1 = 1.0d0
         damp2 = 1.0d0
         damp3 = 1.0d0
         damp4 = 1.0d0
         damp5 = 1.0d0
         damp6 = 1.0d0
      else if (use_dem) then
         damp1 = exp(-width)
         damp2 = exp(-4.0d0*width)
         damp3 = exp(-9.0d0*width)
         damp4 = exp(-16.0d0*width)
         damp5 = exp(-25.0d0*width)
         damp6 = exp(-36.0d0*width)
      else if (use_gda) then
         wterm = difft / 12.0d0
      else if (use_tophat .or. use_stophat) then
         damp1 = 0.0d0
         damp2 = 0.0d0
         damp3 = 0.0d0
         damp4 = 0.0d0
         damp5 = 0.0d0
         damp6 = 0.0d0
         if (width .lt. pi)  damp1 = sin(width) / width
         wterm = 2.0d0 * width
         if (wterm .lt. pi)  damp2 = sin(wterm) / wterm
         wterm = 3.0d0 * width
         if (wterm .lt. pi)  damp3 = sin(wterm) / wterm
         wterm = 4.0d0 * width
         if (wterm .lt. pi)  damp4 = sin(wterm) / wterm
         wterm = 5.0d0 * width
         if (wterm .lt. pi)  damp5 = sin(wterm) / wterm
         wterm = 6.0d0 * width
         if (wterm .lt. pi)  damp6 = sin(wterm) / wterm
      end if
c
c     calculate the torsional angle energy term
c
      do ktors = 1, ntors
         ia = itors(1,ktors)
         ib = itors(2,ktors)
         ic = itors(3,ktors)
         id = itors(4,ktors)
c
c     decide whether to compute the current interaction
c
         proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic .or. i.eq.id)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,id,0,0)
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
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the torsional parameters for this angle
c
            v1 = tors1(1,ktors)
            c1 = tors1(3,ktors)
            s1 = tors1(4,ktors)
            v2 = tors2(1,ktors)
            c2 = tors2(3,ktors)
            s2 = tors2(4,ktors)
            v3 = tors3(1,ktors)
            c3 = tors3(3,ktors)
            s3 = tors3(4,ktors)
            v4 = tors4(1,ktors)
            c4 = tors4(3,ktors)
            s4 = tors4(4,ktors)
            v5 = tors5(1,ktors)
            c5 = tors5(3,ktors)
            s5 = tors5(4,ktors)
            v6 = tors6(1,ktors)
            c6 = tors6(3,ktors)
            s6 = tors6(4,ktors)
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
            cosine4 = cosine*cosine3 - sine*sine3
            sine4 = cosine*sine3 + sine*cosine3
            cosine5 = cosine*cosine4 - sine*sine4
            sine5 = cosine*sine4 + sine*cosine4
            cosine6 = cosine*cosine5 - sine*sine5
            sine6 = cosine*sine5 + sine*cosine5
            dphi1 = (cosine*s1 - sine*c1)
            dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2)
            dphi3 = 3.0d0 * (cosine3*s3 - sine3*c3)
            dphi4 = 4.0d0 * (cosine4*s4 - sine4*c4)
            dphi5 = 5.0d0 * (cosine5*s5 - sine5*c5)
            dphi6 = 6.0d0 * (cosine6*s6 - sine6*c6)
            d2phi1 = -(cosine*c1 + sine*s1)
            d2phi2 = -4.0d0 * (cosine2*c2 + sine2*s2)
            d2phi3 = -9.0d0 * (cosine3*c3 + sine3*s3)
            d2phi4 = -16.0d0 * (cosine4*c4 + sine4*s4)
            d2phi5 = -25.0d0 * (cosine5*c5 + sine5*s5)
            d2phi6 = -36.0d0 * (cosine6*c6 + sine6*s6)
c
c     transform the potential function via smoothing
c
            if (use_gda) then
               width = wterm * (m2(ia)+m2(ib)+m2(ic)+m2(id))
               damp1 = exp(-width)
               damp2 = exp(-4.0d0*width)
               damp3 = exp(-9.0d0*width)
               damp4 = exp(-16.0d0*width)
               damp5 = exp(-25.0d0*width)
               damp6 = exp(-36.0d0*width)
            end if
            dphi1 = dphi1 * damp1
            dphi2 = dphi2 * damp2
            dphi3 = dphi3 * damp3
            dphi4 = dphi4 * damp4
            dphi5 = dphi5 * damp5
            dphi6 = dphi6 * damp6
            d2phi1 = d2phi1 * damp1
            d2phi2 = d2phi2 * damp2
            d2phi3 = d2phi3 * damp3
            d2phi4 = d2phi4 * damp4
            d2phi5 = d2phi5 * damp5
            d2phi6 = d2phi6 * damp6
c
c     calculate the torsional master chain rule terms
c
            dedphi = torsunit * (v1*dphi1 + v2*dphi2 + v3*dphi3
     &                         + v4*dphi4 + v5*dphi5 + v6*dphi6)
            d2edphi2 = torsunit * (v1*d2phi1 + v2*d2phi2 + v3*d2phi3
     &                           + v4*d2phi4 + v5*d2phi5 + v6*d2phi6)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               dedphi = dedphi * fgrp
               d2edphi2 = d2edphi2 * 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     abbreviations for second derivative chain rule terms
c
            xycb2 = xcb*xcb + ycb*ycb
            xzcb2 = xcb*xcb + zcb*zcb
            yzcb2 = ycb*ycb + zcb*zcb
            rcbxt = -2.0d0 * rcb * dphidxt
            rcbyt = -2.0d0 * rcb * dphidyt
            rcbzt = -2.0d0 * rcb * dphidzt
            rcbt2 = rcb * rt2
            rcbxu = 2.0d0 * rcb * dphidxu
            rcbyu = 2.0d0 * rcb * dphidyu
            rcbzu = 2.0d0 * rcb * dphidzu
            rcbu2 = rcb * ru2
            dphidxibt = yca*dphidzt - zca*dphidyt
            dphidxibu = zdc*dphidyu - ydc*dphidzu
            dphidyibt = zca*dphidxt - xca*dphidzt
            dphidyibu = xdc*dphidzu - zdc*dphidxu
            dphidzibt = xca*dphidyt - yca*dphidxt
            dphidzibu = ydc*dphidxu - xdc*dphidyu
            dphidxict = zba*dphidyt - yba*dphidzt
            dphidxicu = ydb*dphidzu - zdb*dphidyu
            dphidyict = xba*dphidzt - zba*dphidxt
            dphidyicu = zdb*dphidxu - xdb*dphidzu
            dphidzict = yba*dphidxt - xba*dphidyt
            dphidzicu = xdb*dphidyu - ydb*dphidxu
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 = dphidxibt + dphidxibu
            dphidyib = dphidyibt + dphidyibu
            dphidzib = dphidzibt + dphidzibu
            dphidxic = dphidxict + dphidxicu
            dphidyic = dphidyict + dphidyicu
            dphidzic = dphidzict + dphidzicu
            dphidxid = zcb*dphidyu - ycb*dphidzu
            dphidyid = xcb*dphidzu - zcb*dphidxu
            dphidzid = ycb*dphidxu - xcb*dphidyu
c
c     chain rule terms for second derivative components
c
            dxiaxia = rcbxt*dphidxia
            dxiayia = rcbxt*dphidyia - zcb*rcb/rt2
            dxiazia = rcbxt*dphidzia + ycb*rcb/rt2
            dxiaxic = rcbxt*dphidxict + xcb*xt/rcbt2
            dxiayic = rcbxt*dphidyict - dphidzt
     &                   - (xba*zcb*xcb+zba*yzcb2)/rcbt2
            dxiazic = rcbxt*dphidzict + dphidyt
     &                   + (xba*ycb*xcb+yba*yzcb2)/rcbt2
            dxiaxid = 0.0d0
            dxiayid = 0.0d0
            dxiazid = 0.0d0
            dyiayia = rcbyt*dphidyia
            dyiazia = rcbyt*dphidzia - xcb*rcb/rt2
            dyiaxib = rcbyt*dphidxibt - dphidzt
     &                   - (yca*zcb*ycb+zca*xzcb2)/rcbt2
            dyiaxic = rcbyt*dphidxict + dphidzt
     &                   + (yba*zcb*ycb+zba*xzcb2)/rcbt2
            dyiayic = rcbyt*dphidyict + ycb*yt/rcbt2
            dyiazic = rcbyt*dphidzict - dphidxt
     &                   - (yba*xcb*ycb+xba*xzcb2)/rcbt2
            dyiaxid = 0.0d0
            dyiayid = 0.0d0
            dyiazid = 0.0d0
            dziazia = rcbzt*dphidzia
            dziaxib = rcbzt*dphidxibt + dphidyt
     &                   + (zca*ycb*zcb+yca*xycb2)/rcbt2
            dziayib = rcbzt*dphidyibt - dphidxt
     &                   - (zca*xcb*zcb+xca*xycb2)/rcbt2
            dziaxic = rcbzt*dphidxict - dphidyt
     &                   - (zba*ycb*zcb+yba*xycb2)/rcbt2
            dziayic = rcbzt*dphidyict + dphidxt
     &                   + (zba*xcb*zcb+xba*xycb2)/rcbt2
            dziazic = rcbzt*dphidzict + zcb*zt/rcbt2
            dziaxid = 0.0d0
            dziayid = 0.0d0
            dziazid = 0.0d0
            dxibxic = -xcb*dphidxib/(rcb*rcb)
     &          - (yca*(zba*xcb+yt)-zca*(yba*xcb-zt))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidxibt/rt2
     &          - (zdc*(ydb*xcb+zu)-ydc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidxibu/ru2
            dxibyic = -ycb*dphidxib/(rcb*rcb) + dphidzt + dphidzu
     &          - (yca*(zba*ycb-xt)+zca*(xba*xcb+zcb*zba))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidxibt/rt2
     &          + (zdc*(xdb*xcb+zcb*zdb)+ydc*(zdb*ycb+xu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidxibu/ru2
            dxibxid = rcbxu*dphidxibu + xcb*xu/rcbu2
            dxibyid = rcbyu*dphidxibu - dphidzu
     &                   - (ydc*zcb*ycb+zdc*xzcb2)/rcbu2
            dxibzid = rcbzu*dphidxibu + dphidyu
     &                   + (zdc*ycb*zcb+ydc*xycb2)/rcbu2
            dyibzib = ycb*dphidzib/(rcb*rcb)
     &          - (xca*(xca*xcb+zcb*zca)+yca*(ycb*xca+zt))/rcbt2
     &          - 2.0d0*(xt*zca-xca*zt)*dphidzibt/rt2
     &          + (ydc*(xdc*ycb-zu)+xdc*(xdc*xcb+zcb*zdc))/rcbu2
     &          + 2.0d0*(xu*zdc-xdc*zu)*dphidzibu/ru2
            dyibxic = -xcb*dphidyib/(rcb*rcb) - dphidzt - dphidzu
     &          + (xca*(zba*xcb+yt)+zca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidyibt/rt2
     &          - (zdc*(zdb*zcb+ycb*ydb)+xdc*(zdb*xcb-yu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidyibu/ru2
            dyibyic = -ycb*dphidyib/(rcb*rcb)
     &          - (zca*(xba*ycb+zt)-xca*(zba*ycb-xt))/rcbt2
     &          - 2.0d0*(zt*xba-zba*xt)*dphidyibt/rt2
     &          - (xdc*(zdb*ycb+xu)-zdc*(xdb*ycb-zu))/rcbu2
     &          + 2.0d0*(zu*xdb-zdb*xu)*dphidyibu/ru2
            dyibxid = rcbxu*dphidyibu + dphidzu
     &                   + (xdc*zcb*xcb+zdc*yzcb2)/rcbu2
            dyibyid = rcbyu*dphidyibu + ycb*yu/rcbu2
            dyibzid = rcbzu*dphidyibu - dphidxu
     &                   - (zdc*xcb*zcb+xdc*xycb2)/rcbu2
            dzibxic = -xcb*dphidzib/(rcb*rcb) + dphidyt + dphidyu
     &          - (xca*(yba*xcb-zt)+yca*(zba*zcb+ycb*yba))/rcbt2
     &          - 2.0d0*(yt*zba-yba*zt)*dphidzibt/rt2
     &          + (ydc*(zdb*zcb+ycb*ydb)+xdc*(ydb*xcb+zu))/rcbu2
     &          + 2.0d0*(yu*zdb-ydb*zu)*dphidzibu/ru2
            dzibzic = -zcb*dphidzib/(rcb*rcb)
     &          - (xca*(yba*zcb+xt)-yca*(xba*zcb-yt))/rcbt2
     &          - 2.0d0*(xt*yba-xba*yt)*dphidzibt/rt2
     &          - (ydc*(xdb*zcb+yu)-xdc*(ydb*zcb-xu))/rcbu2
     &          + 2.0d0*(xu*ydb-xdb*yu)*dphidzibu/ru2
            dzibxid = rcbxu*dphidzibu - dphidyu
     &                   - (xdc*ycb*xcb+ydc*yzcb2)/rcbu2
            dzibyid = rcbyu*dphidzibu + dphidxu
     &                   + (ydc*xcb*ycb+xdc*xzcb2)/rcbu2
            dzibzid = rcbzu*dphidzibu + zcb*zu/rcbu2
            dxicxid = rcbxu*dphidxicu - xcb*(zdb*ycb-ydb*zcb)/rcbu2
            dxicyid = rcbyu*dphidxicu + dphidzu
     &                   + (ydb*zcb*ycb+zdb*xzcb2)/rcbu2
            dxiczid = rcbzu*dphidxicu - dphidyu
     &                   - (zdb*ycb*zcb+ydb*xycb2)/rcbu2
            dyicxid = rcbxu*dphidyicu - dphidzu
     &                   - (xdb*zcb*xcb+zdb*yzcb2)/rcbu2
            dyicyid = rcbyu*dphidyicu - ycb*(xdb*zcb-zdb*xcb)/rcbu2
            dyiczid = rcbzu*dphidyicu + dphidxu
     &                   + (zdb*xcb*zcb+xdb*xycb2)/rcbu2
            dzicxid = rcbxu*dphidzicu + dphidyu
     &                   + (xdb*ycb*xcb+ydb*yzcb2)/rcbu2
            dzicyid = rcbyu*dphidzicu - dphidxu
     &                   - (ydb*xcb*ycb+xdb*xzcb2)/rcbu2
            dziczid = rcbzu*dphidzicu - zcb*(ydb*xcb-xdb*ycb)/rcbu2
            dxidxid = rcbxu*dphidxid
            dxidyid = rcbxu*dphidyid + zcb*rcb/ru2
            dxidzid = rcbxu*dphidzid - ycb*rcb/ru2
            dyidyid = rcbyu*dphidyid
            dyidzid = rcbyu*dphidzid + xcb*rcb/ru2
            dzidzid = rcbzu*dphidzid
c
c     get some second derivative chain rule terms by difference
c
            dxiaxib = -dxiaxia - dxiaxic - dxiaxid
            dxiayib = -dxiayia - dxiayic - dxiayid
            dxiazib = -dxiazia - dxiazic - dxiazid
            dyiayib = -dyiayia - dyiayic - dyiayid
            dyiazib = -dyiazia - dyiazic - dyiazid
            dziazib = -dziazia - dziazic - dziazid
            dxibxib = -dxiaxib - dxibxic - dxibxid
            dxibyib = -dyiaxib - dxibyic - dxibyid
            dxibzib = -dxiazib - dzibxic - dzibxid
            dxibzic = -dziaxib - dxibzib - dxibzid
            dyibyib = -dyiayib - dyibyic - dyibyid
            dyibzic = -dziayib - dyibzib - dyibzid
            dzibzib = -dziazib - dzibzic - dzibzid
            dzibyic = -dyiazib - dyibzib - dzibyid
            dxicxic = -dxiaxic - dxibxic - dxicxid
            dxicyic = -dyiaxic - dyibxic - dxicyid
            dxiczic = -dziaxic - dzibxic - dxiczid
            dyicyic = -dyiayic - dyibyic - dyicyid
            dyiczic = -dziayic - dzibyic - dyiczid
            dziczic = -dziazic - dzibzic - dziczid
c
c     increment diagonal and off-diagonal Hessian elements
c
            if (i .eq. ia) then
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia
     &                          + d2edphi2*dphidxia*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia
     &                          + d2edphi2*dphidxia*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia
     &                          + d2edphi2*dphidyia*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia
     &                          + d2edphi2*dphidxia*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia
     &                          + d2edphi2*dphidyia*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazia
     &                          + d2edphi2*dphidzia*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxia*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib
     &                          + d2edphi2*dphidyia*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib
     &                          + d2edphi2*dphidzia*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib
     &                          + d2edphi2*dphidxia*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib
     &                          + d2edphi2*dphidyia*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dziayib
     &                          + d2edphi2*dphidzia*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib
     &                          + d2edphi2*dphidxia*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib
     &                          + d2edphi2*dphidyia*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dziazib
     &                          + d2edphi2*dphidzia*dphidzib
               hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxia*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic
     &                          + d2edphi2*dphidyia*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic
     &                          + d2edphi2*dphidzia*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic
     &                          + d2edphi2*dphidxia*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic
     &                          + d2edphi2*dphidyia*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dziayic
     &                          + d2edphi2*dphidzia*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic
     &                          + d2edphi2*dphidxia*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic
     &                          + d2edphi2*dphidyia*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziazic
     &                          + d2edphi2*dphidzia*dphidzic
               hessx(1,id) = hessx(1,id) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxia*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyiaxid
     &                          + d2edphi2*dphidyia*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dziaxid
     &                          + d2edphi2*dphidzia*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxiayid
     &                          + d2edphi2*dphidxia*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyiayid
     &                          + d2edphi2*dphidyia*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dziayid
     &                          + d2edphi2*dphidzia*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiazid
     &                          + d2edphi2*dphidxia*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiazid
     &                          + d2edphi2*dphidyia*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dziazid
     &                          + d2edphi2*dphidzia*dphidzid
            else if (i .eq. ib) then
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib
     &                          + d2edphi2*dphidxib*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
               hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib
     &                          + d2edphi2*dphidxib*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib
     &                          + d2edphi2*dphidyib*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
               hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib
     &                          + d2edphi2*dphidxib*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib
     &                          + d2edphi2*dphidyib*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib
     &                          + d2edphi2*dphidzib*dphidzib
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib
     &                          + d2edphi2*dphidxib*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib
     &                          + d2edphi2*dphidyib*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib
     &                          + d2edphi2*dphidzib*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib
     &                          + d2edphi2*dphidxib*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib
     &                          + d2edphi2*dphidyib*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib
     &                          + d2edphi2*dphidzib*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib
     &                          + d2edphi2*dphidxib*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayib
     &                          + d2edphi2*dphidyib*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazib
     &                          + d2edphi2*dphidzib*dphidzia
               hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic
     &                          + d2edphi2*dphidxib*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic
     &                          + d2edphi2*dphidyib*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic
     &                          + d2edphi2*dphidzib*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic
     &                          + d2edphi2*dphidxib*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic
     &                          + d2edphi2*dphidyib*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic
     &                          + d2edphi2*dphidzib*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic
     &                          + d2edphi2*dphidxib*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic
     &                          + d2edphi2*dphidyib*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic
     &                          + d2edphi2*dphidzib*dphidzic
               hessx(1,id) = hessx(1,id) + dedphi*dxibxid
     &                          + d2edphi2*dphidxib*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyibxid
     &                          + d2edphi2*dphidyib*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dzibxid
     &                          + d2edphi2*dphidzib*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxibyid
     &                          + d2edphi2*dphidxib*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyibyid
     &                          + d2edphi2*dphidyib*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dzibyid
     &                          + d2edphi2*dphidzib*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxibzid
     &                          + d2edphi2*dphidxib*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyibzid
     &                          + d2edphi2*dphidyib*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzibzid
     &                          + d2edphi2*dphidzib*dphidzid
            else if (i .eq. ic) then
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic
     &                          + d2edphi2*dphidxic*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
               hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic
     &                          + d2edphi2*dphidxic*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic
     &                          + d2edphi2*dphidyic*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
               hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic
     &                          + d2edphi2*dphidxic*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic
     &                          + d2edphi2*dphidyic*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczic
     &                          + d2edphi2*dphidzic*dphidzic
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic
     &                          + d2edphi2*dphidxic*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic
     &                          + d2edphi2*dphidyic*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic
     &                          + d2edphi2*dphidzic*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic
     &                          + d2edphi2*dphidxic*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic
     &                          + d2edphi2*dphidyic*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic
     &                          + d2edphi2*dphidzic*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic
     &                          + d2edphi2*dphidxic*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayic
     &                          + d2edphi2*dphidyic*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazic
     &                          + d2edphi2*dphidzic*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic
     &                          + d2edphi2*dphidxic*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic
     &                          + d2edphi2*dphidyic*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic
     &                          + d2edphi2*dphidzic*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic
     &                          + d2edphi2*dphidxic*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic
     &                          + d2edphi2*dphidyic*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic
     &                          + d2edphi2*dphidzic*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic
     &                          + d2edphi2*dphidxic*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic
     &                          + d2edphi2*dphidyic*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic
     &                          + d2edphi2*dphidzic*dphidzib
               hessx(1,id) = hessx(1,id) + dedphi*dxicxid
     &                          + d2edphi2*dphidxic*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dyicxid
     &                          + d2edphi2*dphidyic*dphidxid
               hessz(1,id) = hessz(1,id) + dedphi*dzicxid
     &                          + d2edphi2*dphidzic*dphidxid
               hessx(2,id) = hessx(2,id) + dedphi*dxicyid
     &                          + d2edphi2*dphidxic*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyicyid
     &                          + d2edphi2*dphidyic*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dzicyid
     &                          + d2edphi2*dphidzic*dphidyid
               hessx(3,id) = hessx(3,id) + dedphi*dxiczid
     &                          + d2edphi2*dphidxic*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyiczid
     &                          + d2edphi2*dphidyic*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dziczid
     &                          + d2edphi2*dphidzic*dphidzid
            else if (i .eq. id) then
               hessx(1,id) = hessx(1,id) + dedphi*dxidxid
     &                          + d2edphi2*dphidxid*dphidxid
               hessy(1,id) = hessy(1,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessz(1,id) = hessz(1,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessx(2,id) = hessx(2,id) + dedphi*dxidyid
     &                          + d2edphi2*dphidxid*dphidyid
               hessy(2,id) = hessy(2,id) + dedphi*dyidyid
     &                          + d2edphi2*dphidyid*dphidyid
               hessz(2,id) = hessz(2,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessx(3,id) = hessx(3,id) + dedphi*dxidzid
     &                          + d2edphi2*dphidxid*dphidzid
               hessy(3,id) = hessy(3,id) + dedphi*dyidzid
     &                          + d2edphi2*dphidyid*dphidzid
               hessz(3,id) = hessz(3,id) + dedphi*dzidzid
     &                          + d2edphi2*dphidzid*dphidzid
               hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid
     &                          + d2edphi2*dphidxid*dphidxia
               hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid
     &                          + d2edphi2*dphidyid*dphidxia
               hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid
     &                          + d2edphi2*dphidzid*dphidxia
               hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid
     &                          + d2edphi2*dphidxid*dphidyia
               hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid
     &                          + d2edphi2*dphidyid*dphidyia
               hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid
     &                          + d2edphi2*dphidzid*dphidyia
               hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid
     &                          + d2edphi2*dphidxid*dphidzia
               hessy(3,ia) = hessy(3,ia) + dedphi*dziayid
     &                          + d2edphi2*dphidyid*dphidzia
               hessz(3,ia) = hessz(3,ia) + dedphi*dziazid
     &                          + d2edphi2*dphidzid*dphidzia
               hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid
     &                          + d2edphi2*dphidxid*dphidxib
               hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid
     &                          + d2edphi2*dphidyid*dphidxib
               hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid
     &                          + d2edphi2*dphidzid*dphidxib
               hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid
     &                          + d2edphi2*dphidxid*dphidyib
               hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid
     &                          + d2edphi2*dphidyid*dphidyib
               hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid
     &                          + d2edphi2*dphidzid*dphidyib
               hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid
     &                          + d2edphi2*dphidxid*dphidzib
               hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid
     &                          + d2edphi2*dphidyid*dphidzib
               hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid
     &                          + d2edphi2*dphidzid*dphidzib
               hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid
     &                          + d2edphi2*dphidxid*dphidxic
               hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid
     &                          + d2edphi2*dphidyid*dphidxic
               hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid
     &                          + d2edphi2*dphidzid*dphidxic
               hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid
     &                          + d2edphi2*dphidxid*dphidyic
               hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid
     &                          + d2edphi2*dphidyid*dphidyic
               hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid
     &                          + d2edphi2*dphidzid*dphidyic
               hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid
     &                          + d2edphi2*dphidxid*dphidzic
               hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid
     &                          + d2edphi2*dphidyid*dphidzic
               hessz(3,ic) = hessz(3,ic) + dedphi*dziczid
     &                          + d2edphi2*dphidzid*dphidzic
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine etors3  --  torsional angle energy & analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "etors3" calculates the torsional potential energy; also
c     partitions the energy among the atoms
c
c
      subroutine etors3
      use warp
      implicit none
c
c
c     choose standard or potential energy smoothing version
c
      if (use_smooth) then
         call etors3b
      else
         call etors3a
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine etors3a  --  standard torsion energy & analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "etors3a" calculates the torsional potential energy using
c     a standard sum of Fourier terms and partitions the energy
c     among the atoms
c
c
      subroutine etors3a
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use energi
      use group
      use inform
      use iounit
      use math
      use torpot
      use tors
      use usage
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps,rcb
      real*8 angle,fgrp
      real*8 xt,yt,zt,rt2
      real*8 xu,yu,zu,ru2
      real*8 xtu,ytu,ztu,rtru
      real*8 v1,v2,v3,v4,v5,v6
      real*8 c1,c2,c3,c4,c5,c6
      real*8 s1,s2,s3,s4,s5,s6
      real*8 cosine,cosine2
      real*8 cosine3,cosine4
      real*8 cosine5,cosine6
      real*8 sine,sine2,sine3
      real*8 sine4,sine5,sine6
      real*8 phi1,phi2,phi3
      real*8 phi4,phi5,phi6
      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 xdc,ydc,zdc
      real*8 xcb,ycb,zcb
      logical proceed
      logical header,huge
c
c
c     zero out the torsional energy and partitioning terms
c
      net = 0
      et = 0.0d0
      do i = 1, n
         aet(i) = 0.0d0
      end do
      if (ntors .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. ntors.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Torsional Angle Interactions :',
     &           //,' Type',25x,'Atom Names',21x,'Angle',
     &              6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ntors,itors,tors1,tors2,tors3,
!$OMP& tors4,tors5,tors6,use,x,y,z,torsunit,eps,use_group,use_polymer,
!$OMP& name,verbose,debug,header,iout)
!$OMP& shared(et,net,aet)
!$OMP DO reduction(+:et,net,aet)
c
c     calculate the torsional angle energy term
c
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,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
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
            end if
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
c
c     set the torsional parameters for this angle
c
            v1 = tors1(1,i)
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            v2 = tors2(1,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            v3 = tors3(1,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            v4 = tors4(1,i)
            c4 = tors4(3,i)
            s4 = tors4(4,i)
            v5 = tors5(1,i)
            c5 = tors5(3,i)
            s5 = tors5(4,i)
            v6 = tors6(1,i)
            c6 = tors6(3,i)
            s6 = tors6(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
            cosine4 = cosine*cosine3 - sine*sine3
            sine4 = cosine*sine3 + sine*cosine3
            cosine5 = cosine*cosine4 - sine*sine4
            sine5 = cosine*sine4 + sine*cosine4
            cosine6 = cosine*cosine5 - sine*sine5
            sine6 = cosine*sine5 + sine*cosine5
            phi1 = 1.0d0 + (cosine*c1 + sine*s1)
            phi2 = 1.0d0 + (cosine2*c2 + sine2*s2)
            phi3 = 1.0d0 + (cosine3*c3 + sine3*s3)
            phi4 = 1.0d0 + (cosine4*c4 + sine4*s4)
            phi5 = 1.0d0 + (cosine5*c5 + sine5*s5)
            phi6 = 1.0d0 + (cosine6*c6 + sine6*s6)
c
c     calculate the torsional energy for this angle
c
            e = torsunit * (v1*phi1 + v2*phi2 + v3*phi3
     &                         + v4*phi4 + v5*phi5 + v6*phi6)
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total torsional angle energy
c
            net = net + 1
            et = et + e
            aet(ib) = aet(ib) + 0.5d0*e
            aet(ic) = aet(ic) + 0.5d0*e
c
c     print a message if the energy of this interaction is large
c
            huge = (e .gt. 5.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Individual Torsional Angle',
     &                       ' Interactions :',
     &                    //,' Type',25x,'Atom Names',21x,'Angle',
     &                       6x,'Energy',/)
               end if
               write (iout,30)  ia,name(ia),ib,name(ib),ic,
     &                          name(ic),id,name(id),angle,e
   30          format (' Torsion',3x,4(i7,'-',a3),f11.4,f12.4)
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine etors3b  --  smoothed torsion energy & analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "etors3b" calculates the torsional potential energy for use
c     with potential energy smoothing methods and partitions the
c     energy among the atoms
c
c
      subroutine etors3b
      use action
      use analyz
      use atomid
      use atoms
      use energi
      use group
      use inform
      use iounit
      use math
      use torpot
      use tors
      use usage
      use warp
      implicit none
      integer i,ia,ib,ic,id
      real*8 e,eps,rcb
      real*8 angle,fgrp
      real*8 width,wterm
      real*8 xt,yt,zt,rt2
      real*8 xu,yu,zu,ru2
      real*8 xtu,ytu,ztu,rtru
      real*8 v1,v2,v3,v4,v5,v6
      real*8 c1,c2,c3,c4,c5,c6
      real*8 s1,s2,s3,s4,s5,s6
      real*8 cosine,cosine2
      real*8 cosine3,cosine4
      real*8 cosine5,cosine6
      real*8 sine,sine2,sine3
      real*8 sine4,sine5,sine6
      real*8 damp1,damp2,damp3
      real*8 damp4,damp5,damp6
      real*8 phi1,phi2,phi3
      real*8 phi4,phi5,phi6
      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 xdc,ydc,zdc
      real*8 xcb,ycb,zcb
      logical proceed
      logical header,huge
c
c
c     zero out the torsional energy and partitioning terms
c
      net = 0
      et = 0.0d0
      do i = 1, n
         aet(i) = 0.0d0
      end do
      if (ntors .eq. 0)  return
c
c     set tolerance for minimum distance and angle values
c
      eps = 0.0001d0
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. ntors.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Torsional Angle Interactions :',
     &           //,' Type',25x,'Atom Names',21x,'Angle',
     &              6x,'Energy',/)
      end if
c
c     set the extent of smoothing to be performed
c
      width = difft * deform
      if (width .le. 0.0d0) then
         damp1 = 1.0d0
         damp2 = 1.0d0
         damp3 = 1.0d0
         damp4 = 1.0d0
         damp5 = 1.0d0
         damp6 = 1.0d0
      else if (use_dem) then
         damp1 = exp(-width)
         damp2 = exp(-4.0d0*width)
         damp3 = exp(-9.0d0*width)
         damp4 = exp(-16.0d0*width)
         damp5 = exp(-25.0d0*width)
         damp6 = exp(-36.0d0*width)
      else if (use_gda) then
         wterm = difft / 12.0d0
      else if (use_tophat .or. use_stophat) then
         damp1 = 0.0d0
         damp2 = 0.0d0
         damp3 = 0.0d0
         damp4 = 0.0d0
         damp5 = 0.0d0
         damp6 = 0.0d0
         if (width .lt. pi)  damp1 = sin(width) / width
         wterm = 2.0d0 * width
         if (wterm .lt. pi)  damp2 = sin(wterm) / wterm
         wterm = 3.0d0 * width
         if (wterm .lt. pi)  damp3 = sin(wterm) / wterm
         wterm = 4.0d0 * width
         if (wterm .lt. pi)  damp4 = sin(wterm) / wterm
         wterm = 5.0d0 * width
         if (wterm .lt. pi)  damp5 = sin(wterm) / wterm
         wterm = 6.0d0 * width
         if (wterm .lt. pi)  damp6 = sin(wterm) / wterm
      end if
c
c     calculate the torsional angle energy term
c
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,0,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
            rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps))
            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 = max(xt*xt+yt*yt+zt*zt,eps)
            ru2 = max(xu*xu+yu*yu+zu*zu,eps)
            rtru = sqrt(rt2 * ru2)
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            if (sine .lt. 0.0d0)  angle = -angle
c
c     set the torsional parameters for this angle
c
            v1 = tors1(1,i)
            c1 = tors1(3,i)
            s1 = tors1(4,i)
            v2 = tors2(1,i)
            c2 = tors2(3,i)
            s2 = tors2(4,i)
            v3 = tors3(1,i)
            c3 = tors3(3,i)
            s3 = tors3(4,i)
            v4 = tors4(1,i)
            c4 = tors4(3,i)
            s4 = tors4(4,i)
            v5 = tors5(1,i)
            c5 = tors5(3,i)
            s5 = tors5(4,i)
            v6 = tors6(1,i)
            c6 = tors6(3,i)
            s6 = tors6(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
            cosine4 = cosine*cosine3 - sine*sine3
            sine4 = cosine*sine3 + sine*cosine3
            cosine5 = cosine*cosine4 - sine*sine4
            sine5 = cosine*sine4 + sine*cosine4
            cosine6 = cosine*cosine5 - sine*sine5
            sine6 = cosine*sine5 + sine*cosine5
            phi1 = 1.0d0 + (cosine*c1 + sine*s1)
            phi2 = 1.0d0 + (cosine2*c2 + sine2*s2)
            phi3 = 1.0d0 + (cosine3*c3 + sine3*s3)
            phi4 = 1.0d0 + (cosine4*c4 + sine4*s4)
            phi5 = 1.0d0 + (cosine5*c5 + sine5*s5)
            phi6 = 1.0d0 + (cosine6*c6 + sine6*s6)
c
c     transform the potential function via smoothing
c
            if (use_gda) then
               width = wterm * (m2(ia)+m2(ib)+m2(ic)+m2(id))
               damp1 = exp(-width)
               damp2 = exp(-4.0d0*width)
               damp3 = exp(-9.0d0*width)
               damp4 = exp(-16.0d0*width)
               damp5 = exp(-25.0d0*width)
               damp6 = exp(-36.0d0*width)
            end if
            phi1 = phi1 * damp1
            phi2 = phi2 * damp2
            phi3 = phi3 * damp3
            phi4 = phi4 * damp4
            phi5 = phi5 * damp5
            phi6 = phi6 * damp6
c
c     calculate the torsional energy for this angle
c
            e = torsunit * (v1*phi1 + v2*phi2 + v3*phi3
     &                         + v4*phi4 + v5*phi5 + v6*phi6)
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total torsional angle energy
c
            net = net + 1
            et = et + e
            aet(ib) = aet(ib) + 0.5d0*e
            aet(ic) = aet(ic) + 0.5d0*e
c
c     print a message if the energy of this interaction is large
c
            huge = (e .gt. 5.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Individual Torsional Angle',
     &                       ' Interactions :',
     &                    //,' Type',25x,'Atom Names',21x,'Angle',
     &                       6x,'Energy',/)
               end if
               write (iout,30)  ia,name(ia),ib,name(ib),ic,
     &                          name(ic),id,name(id),angle,e
   30          format (' Torsion',3x,4(i7,'-',a3),f11.4,f12.4)
            end if
         end if
      end do
      return
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 2003 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine etortor  --  torsion-torsion cross term energy  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "etortor" calculates the torsion-torsion potential energy
c
c
      subroutine etortor
      use atoms
      use bitor
      use bound
      use energi
      use group
      use ktrtor
      use math
      use torpot
      use tortor
      use usage
      implicit none
      integer i,k,itortor
      integer pos1,pos2
      integer ia,ib,ic,id,ie
      integer nlo,nhi,nt
      integer xlo,ylo
      real*8 e,fgrp,sign
      real*8 angle1,angle2
      real*8 value1,value2
      real*8 cosine1,cosine2
      real*8 xt,yt,zt,rt2
      real*8 xu,yu,zu,ru2
      real*8 xv,yv,zv,rv2
      real*8 rtru,rurv
      real*8 x1l,x1u
      real*8 y1l,y1u
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xie,yie,zie
      real*8 xba,yba,zba
      real*8 xdc,ydc,zdc
      real*8 xcb,ycb,zcb
      real*8 xed,yed,zed
      real*8 ftt(4),ft12(4)
      real*8 ft1(4),ft2(4)
      logical proceed
c
c
c     zero out the torsion-torsion energy
c
      ett = 0.0d0
      if (ntortor .eq. 0)  return
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ntortor,itt,ibitor,
!$OMP& use,x,y,z,tnx,ttx,tny,tty,tbf,tbx,tby,tbxy,ttorunit,
!$OMP& use_group,use_polymer)
!$OMP& shared(ett)
!$OMP DO reduction(+:ett)
c
c     calculate the torsion-torsion interaction energy term
c
      do itortor = 1, ntortor
         i = itt(1,itortor)
         k = itt(2,itortor)
         if (itt(3,itortor) .eq. 1) then
            ia = ibitor(1,i)
            ib = ibitor(2,i)
            ic = ibitor(3,i)
            id = ibitor(4,i)
            ie = ibitor(5,i)
         else
            ia = ibitor(5,i)
            ib = ibitor(4,i)
            ic = ibitor(3,i)
            id = ibitor(2,i)
            ie = ibitor(1,i)
         end if
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,ie,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic)
     &                               .or. use(id) .or. use(ie))
c
c     compute the values of the torsional angles
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)
            xie = x(ie)
            yie = y(ie)
            zie = z(ie)
            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
            xed = xie - xid
            yed = yie - yid
            zed = zie - zid
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
               call image (xed,yed,zed)
            end if
            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
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            xv = ydc*zed - yed*zdc
            yv = zdc*xed - zed*xdc
            zv = xdc*yed - xed*ydc
            rv2 = xv*xv + yv*yv + zv*zv
            rurv = sqrt(ru2 * rv2)
            if (rtru.ne.0.0d0 .and. rurv.ne.0.0d0) then
               cosine1 = (xt*xu + yt*yu + zt*zu) / rtru
               cosine1 = min(1.0d0,max(-1.0d0,cosine1))
               angle1 = radian * acos(cosine1)
               sign = xba*xu + yba*yu + zba*zu
               if (sign .lt. 0.0d0)  angle1 = -angle1
               value1 = angle1
               cosine2 = (xu*xv + yu*yv + zu*zv) / rurv
               cosine2 = min(1.0d0,max(-1.0d0,cosine2))
               angle2 = radian * acos(cosine2)
               sign = xcb*xv + ycb*yv + zcb*zv
               if (sign .lt. 0.0d0)  angle2 = -angle2
               value2 = angle2
c
c     check for inverted chirality at the central atom
c
               call chkttor (ib,ic,id,sign,value1,value2)
c
c     use bicubic interpolation to compute spline values
c
               nlo = 1
               nhi = tnx(k)
               do while (nhi-nlo .gt. 1)
                  nt = (nhi+nlo) / 2
                  if (ttx(nt,k) .gt. value1) then
                     nhi = nt
                  else
                     nlo = nt
                  end if
               end do
               xlo = nlo
               nlo = 1
               nhi = tny(k)
               do while (nhi-nlo .gt. 1)
                  nt = (nhi + nlo)/2
                  if (tty(nt,k) .gt. value2) then
                     nhi = nt
                  else
                     nlo = nt
                  end if
               end do
               ylo = nlo
               x1l = ttx(xlo,k)
               x1u = ttx(xlo+1,k)
               y1l = tty(ylo,k)
               y1u = tty(ylo+1,k)
               pos2 = ylo*tnx(k) + xlo
               pos1 = pos2 - tnx(k)
               ftt(1) = tbf(pos1,k)
               ftt(2) = tbf(pos1+1,k)
               ftt(3) = tbf(pos2+1,k)
               ftt(4) = tbf(pos2,k)
               ft1(1) = tbx(pos1,k)
               ft1(2) = tbx(pos1+1,k)
               ft1(3) = tbx(pos2+1,k)
               ft1(4) = tbx(pos2,k)
               ft2(1) = tby(pos1,k)
               ft2(2) = tby(pos1+1,k)
               ft2(3) = tby(pos2+1,k)
               ft2(4) = tby(pos2,k)
               ft12(1) = tbxy(pos1,k)
               ft12(2) = tbxy(pos1+1,k)
               ft12(3) = tbxy(pos2+1,k)
               ft12(4) = tbxy(pos2,k)
               call bcuint (ftt,ft1,ft2,ft12,x1l,x1u,
     &                      y1l,y1u,value1,value2,e)
               e = ttorunit * e
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the total torsion-torsion energy
c
               ett = ett + e
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine chkttor  --  check torsion-torsion chirality  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "chkttor" tests the attached atoms at a torsion-torsion central
c     site and changes the sign of the torsion values if the site has
c     opposite chirality to that for the original parameter
c
c     note that the sign convention used in this version is correct
c     for phi-psi torsion-torsion interactions defined for L-amino
c     acids in a protein force field; the code may need to be altered
c     for other chiral torsion-torsion situations, such as the sugar
c     rings in nucleic acids
c
c
      subroutine chkttor (ib,ic,id,sign,value1,value2)
      use atomid
      use atoms
      use couple
      implicit none
      integer i,j,k,m
      integer ia,ib,ic,id
      real*8 sign
      real*8 value1
      real*8 value2
      real*8 xac,yac,zac
      real*8 xbc,ybc,zbc
      real*8 xdc,ydc,zdc
      real*8 c1,c2,c3,vol
c
c
c     test for chirality at the central torsion-torsion site
c
      sign = 1.0d0
      if (n12(ic) .eq. 4) then
         j = 0
         do i = 1, 4
            m = i12(i,ic)
            if (m.ne.ib .and. m.ne.id) then
               if (j .eq. 0) then
                  j = m
               else
                  k = m
               end if
            end if
         end do
         ia = 0
         if (type(j) .gt. type(k))  ia = j
         if (type(k) .gt. type(j))  ia = k
         if (atomic(j) .gt. atomic(k))  ia = j
         if (atomic(k) .gt. atomic(j))  ia = k
c
c     compute the signed parallelpiped volume at central site
c
         if (ia .ne. 0) then
            xac = x(ia) - x(ic)
            yac = y(ia) - y(ic)
            zac = z(ia) - z(ic)
            xbc = x(ib) - x(ic)
            ybc = y(ib) - y(ic)
            zbc = z(ib) - z(ic)
            xdc = x(id) - x(ic)
            ydc = y(id) - y(ic)
            zdc = z(id) - z(ic)
            c1 = ybc*zdc - zbc*ydc
            c2 = ydc*zac - zdc*yac
            c3 = yac*zbc - zac*ybc
            vol = xac*c1 + xbc*c2 + xdc*c3
c
c     invert the angle values if chirality has an inverted sign
c
            if (vol .lt. 0.0d0) then
               sign = -1.0d0
               value1 = -value1
               value2 = -value2
            end if
         end if
      end if
      return
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 2003 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine etortor1  --  torsion-torsion energy & derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "etortor1" calculates the torsion-torsion energy and first
c     derivatives with respect to Cartesian coordinates
c
c
      subroutine etortor1
      use atoms
      use bitor
      use bound
      use deriv
      use energi
      use group
      use ktrtor
      use math
      use torpot
      use tortor
      use usage
      use virial
      implicit none
      integer i,k,itortor
      integer pos1,pos2
      integer ia,ib,ic,id,ie
      integer nlo,nhi,nt
      integer xlo,ylo
      real*8 e,fgrp,sign
      real*8 angle1,angle2
      real*8 value1,value2
      real*8 cosine1,cosine2
      real*8 xt,yt,zt,rt2
      real*8 xu,yu,zu,ru2
      real*8 xv,yv,zv,rv2
      real*8 rtru,rurv
      real*8 x1l,x1u
      real*8 y1l,y1u
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xie,yie,zie
      real*8 xba,yba,zba
      real*8 xdc,ydc,zdc
      real*8 xcb,ycb,zcb
      real*8 xed,yed,zed
      real*8 rcb,rdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 xec,yec,zec
      real*8 dedang1,dedang2
      real*8 dedxt,dedyt,dedzt
      real*8 dedxu,dedyu,dedzu
      real*8 dedxu2,dedyu2,dedzu2
      real*8 dedxv2,dedyv2,dedzv2
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      real*8 dedxib2,dedyib2,dedzib2
      real*8 dedxic2,dedyic2,dedzic2
      real*8 dedxid2,dedyid2,dedzid2
      real*8 dedxie2,dedyie2,dedzie2
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8 vxx2,vyy2,vzz2
      real*8 vyx2,vzx2,vzy2
      real*8 ftt(4),ft12(4)
      real*8 ft1(4),ft2(4)
      logical proceed
c
c
c     zero out the torsion-torsion energy and first derivatives
c
      ett = 0.0d0
      do i = 1, n
         dett(1,i) = 0.0d0
         dett(2,i) = 0.0d0
         dett(3,i) = 0.0d0
      end do
      if (ntortor .eq. 0)  return
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ntortor,itt,ibitor,
!$OMP& use,x,y,z,tnx,ttx,tny,tty,tbf,tbx,tby,tbxy,ttorunit,
!$OMP& use_group,use_polymer)
!$OMP& shared(ett,dett,vir)
!$OMP DO reduction(+:ett,dett,vir)
c
c     calculate the torsion-torsion interaction energy term
c
      do itortor = 1, ntortor
         i = itt(1,itortor)
         k = itt(2,itortor)
         if (itt(3,itortor) .eq. 1) then
            ia = ibitor(1,i)
            ib = ibitor(2,i)
            ic = ibitor(3,i)
            id = ibitor(4,i)
            ie = ibitor(5,i)
         else
            ia = ibitor(5,i)
            ib = ibitor(4,i)
            ic = ibitor(3,i)
            id = ibitor(2,i)
            ie = ibitor(1,i)
         end if
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,ie,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic)
     &                               .or. use(id) .or. use(ie))
c
c     compute the values of the torsional angles
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)
            xie = x(ie)
            yie = y(ie)
            zie = z(ie)
            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
            xed = xie - xid
            yed = yie - yid
            zed = zie - zid
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
               call image (xed,yed,zed)
            end if
            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
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            xv = ydc*zed - yed*zdc
            yv = zdc*xed - zed*xdc
            zv = xdc*yed - xed*ydc
            rv2 = xv*xv + yv*yv + zv*zv
            rurv = sqrt(ru2 * rv2)
            if (rtru.ne.0.0d0 .and. rurv.ne.0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine1 = (xt*xu + yt*yu + zt*zu) / rtru
               cosine1 = min(1.0d0,max(-1.0d0,cosine1))
               angle1 = radian * acos(cosine1)
               sign = xba*xu + yba*yu + zba*zu
               if (sign .lt. 0.0d0)  angle1 = -angle1
               value1 = angle1
               rdc = sqrt(xdc*xdc + ydc*ydc + zdc*zdc)
               cosine2 = (xu*xv + yu*yv + zu*zv) / rurv
               cosine2 = min(1.0d0,max(-1.0d0,cosine2))
               angle2 = radian * acos(cosine2)
               sign = xcb*xv + ycb*yv + zcb*zv
               if (sign .lt. 0.0d0)  angle2 = -angle2
               value2 = angle2
c
c     check for inverted chirality at the central atom
c
               call chkttor (ib,ic,id,sign,value1,value2)
c
c     use bicubic interpolation to compute spline values
c
               nlo = 1
               nhi = tnx(k)
               do while (nhi-nlo .gt. 1)
                  nt = (nhi+nlo) / 2
                  if (ttx(nt,k) .gt. value1) then
                     nhi = nt
                  else
                     nlo = nt
                  end if
               end do
               xlo = nlo
               nlo = 1
               nhi = tny(k)
               do while (nhi-nlo .gt. 1)
                  nt = (nhi + nlo)/2
                  if (tty(nt,k) .gt. value2) then
                     nhi = nt
                  else
                     nlo = nt
                  end if
               end do
               ylo = nlo
               x1l = ttx(xlo,k)
               x1u = ttx(xlo+1,k)
               y1l = tty(ylo,k)
               y1u = tty(ylo+1,k)
               pos2 = ylo*tnx(k) + xlo
               pos1 = pos2 - tnx(k)
               ftt(1) = tbf(pos1,k)
               ftt(2) = tbf(pos1+1,k)
               ftt(3) = tbf(pos2+1,k)
               ftt(4) = tbf(pos2,k)
               ft1(1) = tbx(pos1,k)
               ft1(2) = tbx(pos1+1,k)
               ft1(3) = tbx(pos2+1,k)
               ft1(4) = tbx(pos2,k)
               ft2(1) = tby(pos1,k)
               ft2(2) = tby(pos1+1,k)
               ft2(3) = tby(pos2+1,k)
               ft2(4) = tby(pos2,k)
               ft12(1) = tbxy(pos1,k)
               ft12(2) = tbxy(pos1+1,k)
               ft12(3) = tbxy(pos2+1,k)
               ft12(4) = tbxy(pos2,k)
               call bcuint1 (ftt,ft1,ft2,ft12,x1l,x1u,y1l,y1u,
     &                       value1,value2,e,dedang1,dedang2)
               e = ttorunit * e
               dedang1 = sign * ttorunit * radian * dedang1
               dedang2 = sign * ttorunit * radian * dedang2
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  e = e * fgrp
                  dedang1 = dedang1 * fgrp
                  dedang2 = dedang2 * fgrp
               end if
c
c     chain rule terms for first angle derivative components
c
               xca = xic - xia
               yca = yic - yia
               zca = zic - zia
               xdb = xid - xib
               ydb = yid - yib
               zdb = zid - zib
               if (use_polymer) then
                  call image (xca,yca,zca)
                  call image (xdb,ydb,zdb)
               end if
               dedxt = dedang1 * (yt*zcb - ycb*zt) / (rt2*rcb)
               dedyt = dedang1 * (zt*xcb - zcb*xt) / (rt2*rcb)
               dedzt = dedang1 * (xt*ycb - xcb*yt) / (rt2*rcb)
               dedxu = -dedang1 * (yu*zcb - ycb*zu) / (ru2*rcb)
               dedyu = -dedang1 * (zu*xcb - zcb*xu) / (ru2*rcb)
               dedzu = -dedang1 * (xu*ycb - xcb*yu) / (ru2*rcb)
c
c     compute first derivative components for first angle
c
               dedxia = zcb*dedyt - ycb*dedzt
               dedyia = xcb*dedzt - zcb*dedxt
               dedzia = ycb*dedxt - xcb*dedyt
               dedxib = yca*dedzt - zca*dedyt + zdc*dedyu - ydc*dedzu
               dedyib = zca*dedxt - xca*dedzt + xdc*dedzu - zdc*dedxu
               dedzib = xca*dedyt - yca*dedxt + ydc*dedxu - xdc*dedyu
               dedxic = zba*dedyt - yba*dedzt + ydb*dedzu - zdb*dedyu
               dedyic = xba*dedzt - zba*dedxt + zdb*dedxu - xdb*dedzu
               dedzic = yba*dedxt - xba*dedyt + xdb*dedyu - ydb*dedxu
               dedxid = zcb*dedyu - ycb*dedzu
               dedyid = xcb*dedzu - zcb*dedxu
               dedzid = ycb*dedxu - xcb*dedyu
c
c     chain rule terms for second angle derivative components
c
               xec = xie - xic
               yec = yie - yic
               zec = zie - zic
               if (use_polymer) then
                  call image (xdb,ydb,zdb)
                  call image (xec,yec,zec)
               end if
               dedxu2 = dedang2 * (yu*zdc - ydc*zu) / (ru2*rdc)
               dedyu2 = dedang2 * (zu*xdc - zdc*xu) / (ru2*rdc)
               dedzu2 = dedang2 * (xu*ydc - xdc*yu) / (ru2*rdc)
               dedxv2 = -dedang2 * (yv*zdc - ydc*zv) / (rv2*rdc)
               dedyv2 = -dedang2 * (zv*xdc - zdc*xv) / (rv2*rdc)
               dedzv2 = -dedang2 * (xv*ydc - xdc*yv) / (rv2*rdc)
c
c     compute first derivative components for second angle
c
               dedxib2 = zdc*dedyu2 - ydc*dedzu2
               dedyib2 = xdc*dedzu2 - zdc*dedxu2
               dedzib2 = ydc*dedxu2 - xdc*dedyu2
               dedxic2 = ydb*dedzu2 - zdb*dedyu2
     &                      + zed*dedyv2 - yed*dedzv2
               dedyic2 = zdb*dedxu2 - xdb*dedzu2
     &                      + xed*dedzv2 - zed*dedxv2
               dedzic2 = xdb*dedyu2 - ydb*dedxu2
     &                      + yed*dedxv2 - xed*dedyv2
               dedxid2 = zcb*dedyu2 - ycb*dedzu2
     &                      + yec*dedzv2 - zec*dedyv2
               dedyid2 = xcb*dedzu2 - zcb*dedxu2
     &                      + zec*dedxv2 - xec*dedzv2
               dedzid2 = ycb*dedxu2 - xcb*dedyu2
     &                      + xec*dedyv2 - yec*dedxv2
               dedxie2 = zdc*dedyv2 - ydc*dedzv2
               dedyie2 = xdc*dedzv2 - zdc*dedxv2
               dedzie2 = ydc*dedxv2 - xdc*dedyv2
c
c     increment the torsion-torsion energy and gradient
c
               ett = ett + e
               dett(1,ia) = dett(1,ia) + dedxia
               dett(2,ia) = dett(2,ia) + dedyia
               dett(3,ia) = dett(3,ia) + dedzia
               dett(1,ib) = dett(1,ib) + dedxib + dedxib2
               dett(2,ib) = dett(2,ib) + dedyib + dedyib2
               dett(3,ib) = dett(3,ib) + dedzib + dedzib2
               dett(1,ic) = dett(1,ic) + dedxic + dedxic2
               dett(2,ic) = dett(2,ic) + dedyic + dedyic2
               dett(3,ic) = dett(3,ic) + dedzic + dedzic2
               dett(1,id) = dett(1,id) + dedxid + dedxid2
               dett(2,id) = dett(2,id) + dedyid + dedyid2
               dett(3,id) = dett(3,id) + dedzid + dedzid2
               dett(1,ie) = dett(1,ie) + dedxie2
               dett(2,ie) = dett(2,ie) + dedyie2
               dett(3,ie) = dett(3,ie) + dedzie2
c
c     increment the internal virial tensor components
c
               vxx = xcb*(dedxic+dedxid) - xba*dedxia + xdc*dedxid
               vyx = ycb*(dedxic+dedxid) - yba*dedxia + ydc*dedxid
               vzx = zcb*(dedxic+dedxid) - zba*dedxia + zdc*dedxid
               vyy = ycb*(dedyic+dedyid) - yba*dedyia + ydc*dedyid
               vzy = zcb*(dedyic+dedyid) - zba*dedyia + zdc*dedyid
               vzz = zcb*(dedzic+dedzid) - zba*dedzia + zdc*dedzid
               vxx2 = xdc*(dedxid2+dedxie2) - xcb*dedxib2 + xed*dedxie2
               vyx2 = ydc*(dedxid2+dedxie2) - ycb*dedxib2 + yed*dedxie2
               vzx2 = zdc*(dedxid2+dedxie2) - zcb*dedxib2 + zed*dedxie2
               vyy2 = ydc*(dedyid2+dedyie2) - ycb*dedyib2 + yed*dedyie2
               vzy2 = zdc*(dedyid2+dedyie2) - zcb*dedyib2 + zed*dedyie2
               vzz2 = zdc*(dedzid2+dedzie2) - zcb*dedzib2 + zed*dedzie2
               vir(1,1) = vir(1,1) + vxx + vxx2
               vir(2,1) = vir(2,1) + vyx + vyx2
               vir(3,1) = vir(3,1) + vzx + vzx2
               vir(1,2) = vir(1,2) + vyx + vyx2
               vir(2,2) = vir(2,2) + vyy + vyy2
               vir(3,2) = vir(3,2) + vzy + vzy2
               vir(1,3) = vir(1,3) + vzx + vzx2
               vir(2,3) = vir(2,3) + vzy + vzy2
               vir(3,3) = vir(3,3) + vzz + vzz2
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 2003 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine etortor2  --  atomwise torsion-torsion Hessian  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "etortor2" calculates the torsion-torsion potential energy
c     second derivatives with respect to Cartesian coordinates
c
c
      subroutine etortor2 (i)
      use atoms
      use bitor
      use bound
      use group
      use hessn
      use ktrtor
      use math
      use torpot
      use tortor
      use units
      implicit none
      integer i,j,k,itortor
      integer pos1,pos2
      integer ia,ib,ic,id,ie
      integer nlo,nhi,nt,xlo,ylo
      real*8 e,fgrp,sign
      real*8 angle1,angle2
      real*8 value1,value2
      real*8 cosine1,cosine2
      real*8 dedang1,dedang2
      real*8 d2eda1a1,d2eda2a2
      real*8 d2eda1a2
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xie,yie,zie
      real*8 xba,yba,zba
      real*8 xcb,ycb,zcb
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 xed,yed,zed
      real*8 xec,yec,zec
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 xv,yv,zv
      real*8 x1l,x1u,y1l,y1u
      real*8 rt2,ru2,rv2
      real*8 rtru,rcb,rurv,rdc
      real*8 da1dxt,da1dyt,da1dzt
      real*8 da1dxu,da1dyu,da1dzu
      real*8 da1dxia,da1dyia,da1dzia
      real*8 da1dxib,da1dyib,da1dzib
      real*8 da1dxic,da1dyic,da1dzic
      real*8 da1dxid,da1dyid,da1dzid
      real*8 da2dxv,da2dyv,da2dzv
      real*8 da2dxu,da2dyu,da2dzu
      real*8 da2dxie,da2dyie,da2dzie
      real*8 da2dxib,da2dyib,da2dzib
      real*8 da2dxic,da2dyic,da2dzic
      real*8 da2dxid,da2dyid,da2dzid
      real*8 xycb2,xzcb2,yzcb2
      real*8 xydc2,xzdc2,yzdc2
      real*8 rcbxt,rcbyt,rcbzt,rcbt2
      real*8 rcbxu,rcbyu,rcbzu,rcbu2
      real*8 rdcxv,rdcyv,rdczv,rdcv2
      real*8 rdcxu,rdcyu,rdczu,rdcu2
      real*8 da1dxibt,da1dyibt,da1dzibt
      real*8 da1dxibu,da1dyibu,da1dzibu
      real*8 da1dxict,da1dyict,da1dzict
      real*8 da1dxicu,da1dyicu,da1dzicu
      real*8 da2dxidu,da2dyidu,da2dzidu
      real*8 da2dxidv,da2dyidv,da2dzidv
      real*8 da2dxicu,da2dyicu,da2dzicu
      real*8 da2dxicv,da2dyicv,da2dzicv
      real*8 dxiaxia,dyiayia,dziazia
      real*8 dxibxib,dyibyib,dzibzib
      real*8 dxicxic,dyicyic,dziczic
      real*8 dxidxid,dyidyid,dzidzid
      real*8 dxiayia,dxiazia,dyiazia
      real*8 dxibyib,dxibzib,dyibzib
      real*8 dxicyic,dxiczic,dyiczic
      real*8 dxidyid,dxidzid,dyidzid
      real*8 dxiaxib,dxiayib,dxiazib
      real*8 dyiaxib,dyiayib,dyiazib
      real*8 dziaxib,dziayib,dziazib
      real*8 dxiaxic,dxiayic,dxiazic
      real*8 dyiaxic,dyiayic,dyiazic
      real*8 dziaxic,dziayic,dziazic
      real*8 dxiaxid,dxiayid,dxiazid
      real*8 dyiaxid,dyiayid,dyiazid
      real*8 dziaxid,dziayid,dziazid
      real*8 dxibxic,dxibyic,dxibzic
      real*8 dyibxic,dyibyic,dyibzic
      real*8 dzibxic,dzibyic,dzibzic
      real*8 dxibxid,dxibyid,dxibzid
      real*8 dyibxid,dyibyid,dyibzid
      real*8 dzibxid,dzibyid,dzibzid
      real*8 dxicxid,dxicyid,dxiczid
      real*8 dyicxid,dyicyid,dyiczid
      real*8 dzicxid,dzicyid,dziczid
      real*8 dxibxib2,dyibyib2,dzibzib2
      real*8 dxicxic2,dyicyic2,dziczic2
      real*8 dxidxid2,dyidyid2,dzidzid2
      real*8 dxiexie2,dyieyie2,dziezie2
      real*8 dxibyib2,dxibzib2,dyibzib2
      real*8 dxicyic2,dxiczic2,dyiczic2
      real*8 dxidyid2,dxidzid2,dyidzid2
      real*8 dxieyie2,dxiezie2,dyiezie2
      real*8 dxibxic2,dxibyic2,dxibzic2
      real*8 dyibxic2,dyibyic2,dyibzic2
      real*8 dzibxic2,dzibyic2,dzibzic2
      real*8 dxibxid2,dxibyid2,dxibzid2
      real*8 dyibxid2,dyibyid2,dyibzid2
      real*8 dzibxid2,dzibyid2,dzibzid2
      real*8 dxibxie2,dxibyie2,dxibzie2
      real*8 dyibxie2,dyibyie2,dyibzie2
      real*8 dzibxie2,dzibyie2,dzibzie2
      real*8 dxicxid2,dxicyid2,dxiczid2
      real*8 dyicxid2,dyicyid2,dyiczid2
      real*8 dzicxid2,dzicyid2,dziczid2
      real*8 dxicxie2,dxicyie2,dxiczie2
      real*8 dyicxie2,dyicyie2,dyiczie2
      real*8 dzicxie2,dzicyie2,dziczie2
      real*8 dxidxie2,dxidyie2,dxidzie2
      real*8 dyidxie2,dyidyie2,dyidzie2
      real*8 dzidxie2,dzidyie2,dzidzie2
      real*8 ftt(4),ft12(4)
      real*8 ft1(4),ft2(4)
      logical proceed
c
c
c     compute the Hessian elements of the torsion-torsions
c
      do itortor = 1, ntortor
         j = itt(1,itortor)
         k = itt(2,itortor)
         if (itt(3,itortor) .eq. 1) then
            ia = ibitor(1,j)
            ib = ibitor(2,j)
            ic = ibitor(3,j)
            id = ibitor(4,j)
            ie = ibitor(5,j)
         else
            ia = ibitor(5,j)
            ib = ibitor(4,j)
            ic = ibitor(3,j)
            id = ibitor(2,j)
            ie = ibitor(1,j)
         end if
c
c     decide whether to compute the current interaction
c
         proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic
     &                 .or. i.eq.id .or. i.eq.ie)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ib,ic,id,ie,0)
c
c     compute the values of the torsional angles
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)
            xie = x(ie)
            yie = y(ie)
            zie = z(ie)
            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
            xed = xie - xid
            yed = yie - yid
            zed = zie - zid
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
               call image (xed,yed,zed)
            end if
            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
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            xv = ydc*zed - yed*zdc
            yv = zdc*xed - zed*xdc
            zv = xdc*yed - xed*ydc
            rv2 = xv*xv + yv*yv + zv*zv
            rurv = sqrt(ru2 * rv2)
            if (rtru .ne. 0.0d0 .and. rurv.ne.0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine1 = (xt*xu + yt*yu + zt*zu) / rtru
               cosine1 = min(1.0d0,max(-1.0d0,cosine1))
               angle1 = radian * acos(cosine1)
               sign = xba*xu + yba*yu + zba*zu
               if (sign .lt. 0.0d0)  angle1 = -angle1
               value1 = angle1
               rdc = sqrt(xdc*xdc + ydc*ydc + zdc*zdc)
               cosine2 = (xu*xv + yu*yv + zu*zv) / rurv
               cosine2 = min(1.0d0,max(-1.0d0,cosine2))
               angle2 = radian * acos(cosine2)
               sign = xcb*xv + ycb*yv + zcb*zv
               if (sign .lt. 0.0d0)  angle2 = -angle2
               value2 = angle2
c
c     check for inverted chirality at the central atom
c
               call chkttor (ib,ic,id,sign,value1,value2)
c
c     use bicubic interpolation to compute spline values
c
               nlo = 1
               nhi = tnx(k)
               do while (nhi-nlo .gt. 1)
                  nt = (nhi+nlo) / 2
                  if (ttx(nt,k) .gt. value1) then
                     nhi = nt
                  else
                     nlo = nt
                  end if
               end do
               xlo = nlo
               nlo = 1
               nhi = tny(k)
               do while (nhi-nlo .gt. 1)
                  nt = (nhi + nlo)/2
                  if (tty(nt,k) .gt. value2) then
                     nhi = nt
                  else
                     nlo = nt
                  end if
               end do
               ylo = nlo
               x1l = ttx(xlo,k)
               x1u = ttx(xlo+1,k)
               y1l = tty(ylo,k)
               y1u = tty(ylo+1,k)
               pos2 = ylo*tnx(k) + xlo
               pos1 = pos2 - tnx(k)
               ftt(1) = tbf(pos1,k)
               ftt(2) = tbf(pos1+1,k)
               ftt(3) = tbf(pos2+1,k)
               ftt(4) = tbf(pos2,k)
               ft1(1) = tbx(pos1,k)
               ft1(2) = tbx(pos1+1,k)
               ft1(3) = tbx(pos2+1,k)
               ft1(4) = tbx(pos2,k)
               ft2(1) = tby(pos1,k)
               ft2(2) = tby(pos1+1,k)
               ft2(3) = tby(pos2+1,k)
               ft2(4) = tby(pos2,k)
               ft12(1) = tbxy(pos1,k)
               ft12(2) = tbxy(pos1+1,k)
               ft12(3) = tbxy(pos2+1,k)
               ft12(4) = tbxy(pos2,k)
               call bcuint2 (ftt,ft1,ft2,ft12,x1l,x1u,y1l,y1u,
     &                       value1,value2,e,dedang1,dedang2,
     &                       d2eda1a2,d2eda1a1,d2eda2a2)
               dedang1 = sign * ttorunit * radian * dedang1
               dedang2 = sign * ttorunit * radian * dedang2
               d2eda1a1 = ttorunit * radian**2 * d2eda1a1
               d2eda2a2 = ttorunit * radian**2 * d2eda2a2
               d2eda1a2 = ttorunit * radian**2 * d2eda1a2
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  dedang1 = dedang1 * fgrp
                  dedang2 = dedang2 * fgrp
                  d2eda1a1 = d2eda1a1 * fgrp
                  d2eda2a2 = d2eda2a2 * fgrp
                  d2eda1a2 = d2eda1a2 * 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
               if (use_polymer) then
                  call image (xca,yca,zca)
                  call image (xdb,ydb,zdb)
               end if
               da1dxt = (yt*zcb - ycb*zt) / (rt2*rcb)
               da1dyt = (zt*xcb - zcb*xt) / (rt2*rcb)
               da1dzt = (xt*ycb - xcb*yt) / (rt2*rcb)
               da1dxu = -(yu*zcb - ycb*zu) / (ru2*rcb)
               da1dyu = -(zu*xcb - zcb*xu) / (ru2*rcb)
               da1dzu = -(xu*ycb - xcb*yu) / (ru2*rcb)
c
c     abbreviations for second derivative chain rule terms
c
               xycb2 = xcb*xcb + ycb*ycb
               xzcb2 = xcb*xcb + zcb*zcb
               yzcb2 = ycb*ycb + zcb*zcb
               rcbxt = -2.0d0 * rcb * da1dxt
               rcbyt = -2.0d0 * rcb * da1dyt
               rcbzt = -2.0d0 * rcb * da1dzt
               rcbt2 = rcb * rt2
               rcbxu = 2.0d0 * rcb * da1dxu
               rcbyu = 2.0d0 * rcb * da1dyu
               rcbzu = 2.0d0 * rcb * da1dzu
               rcbu2 = rcb * ru2
               da1dxibt = yca*da1dzt - zca*da1dyt
               da1dxibu = zdc*da1dyu - ydc*da1dzu
               da1dyibt = zca*da1dxt - xca*da1dzt
               da1dyibu = xdc*da1dzu - zdc*da1dxu
               da1dzibt = xca*da1dyt - yca*da1dxt
               da1dzibu = ydc*da1dxu - xdc*da1dyu
               da1dxict = zba*da1dyt - yba*da1dzt
               da1dxicu = ydb*da1dzu - zdb*da1dyu
               da1dyict = xba*da1dzt - zba*da1dxt
               da1dyicu = zdb*da1dxu - xdb*da1dzu
               da1dzict = yba*da1dxt - xba*da1dyt
               da1dzicu = xdb*da1dyu - ydb*da1dxu
c
c     chain rule terms for first derivative components
c
               da1dxia = zcb*da1dyt - ycb*da1dzt
               da1dyia = xcb*da1dzt - zcb*da1dxt
               da1dzia = ycb*da1dxt - xcb*da1dyt
               da1dxib = da1dxibt + da1dxibu
               da1dyib = da1dyibt + da1dyibu
               da1dzib = da1dzibt + da1dzibu
               da1dxic = da1dxict + da1dxicu
               da1dyic = da1dyict + da1dyicu
               da1dzic = da1dzict + da1dzicu
               da1dxid = zcb*da1dyu - ycb*da1dzu
               da1dyid = xcb*da1dzu - zcb*da1dxu
               da1dzid = ycb*da1dxu - xcb*da1dyu
c
c     chain rule terms for second derivative components
c
               dxiaxia = rcbxt*da1dxia
               dxiayia = rcbxt*da1dyia - zcb*rcb/rt2
               dxiazia = rcbxt*da1dzia + ycb*rcb/rt2
               dxiaxic = rcbxt*da1dxict + xcb*xt/rcbt2
               dxiayic = rcbxt*da1dyict - da1dzt
     &                      - (xba*zcb*xcb+zba*yzcb2)/rcbt2
               dxiazic = rcbxt*da1dzict + da1dyt
     &                      + (xba*ycb*xcb+yba*yzcb2)/rcbt2
               dxiaxid = 0.0d0
               dxiayid = 0.0d0
               dxiazid = 0.0d0
               dyiayia = rcbyt*da1dyia
               dyiazia = rcbyt*da1dzia - xcb*rcb/rt2
               dyiaxib = rcbyt*da1dxibt - da1dzt
     &                      - (yca*zcb*ycb+zca*xzcb2)/rcbt2
               dyiaxic = rcbyt*da1dxict + da1dzt
     &                      + (yba*zcb*ycb+zba*xzcb2)/rcbt2
               dyiayic = rcbyt*da1dyict + ycb*yt/rcbt2
               dyiazic = rcbyt*da1dzict - da1dxt
     &                      - (yba*xcb*ycb+xba*xzcb2)/rcbt2
               dyiaxid = 0.0d0
               dyiayid = 0.0d0
               dyiazid = 0.0d0
               dziazia = rcbzt*da1dzia
               dziaxib = rcbzt*da1dxibt + da1dyt
     &                      + (zca*ycb*zcb+yca*xycb2)/rcbt2
               dziayib = rcbzt*da1dyibt - da1dxt
     &                      - (zca*xcb*zcb+xca*xycb2)/rcbt2
               dziaxic = rcbzt*da1dxict - da1dyt
     &                      - (zba*ycb*zcb+yba*xycb2)/rcbt2
               dziayic = rcbzt*da1dyict + da1dxt
     &                      + (zba*xcb*zcb+xba*xycb2)/rcbt2
               dziazic = rcbzt*da1dzict + zcb*zt/rcbt2
               dziaxid = 0.0d0
               dziayid = 0.0d0
               dziazid = 0.0d0
               dxibxic = -xcb*da1dxib/(rcb*rcb)
     &             - (yca*(zba*xcb+yt)-zca*(yba*xcb-zt))/rcbt2
     &             - 2.0d0*(yt*zba-yba*zt)*da1dxibt/rt2
     &             - (zdc*(ydb*xcb+zu)-ydc*(zdb*xcb-yu))/rcbu2
     &             + 2.0d0*(yu*zdb-ydb*zu)*da1dxibu/ru2
               dxibyic = -ycb*da1dxib/(rcb*rcb) + da1dzt + da1dzu
     &             - (yca*(zba*ycb-xt)+zca*(xba*xcb+zcb*zba))/rcbt2
     &             - 2.0d0*(zt*xba-zba*xt)*da1dxibt/rt2
     &             + (zdc*(xdb*xcb+zcb*zdb)+ydc*(zdb*ycb+xu))/rcbu2
     &             + 2.0d0*(zu*xdb-zdb*xu)*da1dxibu/ru2
               dxibxid = rcbxu*da1dxibu + xcb*xu/rcbu2
               dxibyid = rcbyu*da1dxibu - da1dzu
     &                      - (ydc*zcb*ycb+zdc*xzcb2)/rcbu2
               dxibzid = rcbzu*da1dxibu + da1dyu
     &                      + (zdc*ycb*zcb+ydc*xycb2)/rcbu2
               dyibzib = ycb*da1dzib/(rcb*rcb)
     &             - (xca*(xca*xcb+zcb*zca)+yca*(ycb*xca+zt))/rcbt2
     &             - 2.0d0*(xt*zca-xca*zt)*da1dzibt/rt2
     &             + (ydc*(xdc*ycb-zu)+xdc*(xdc*xcb+zcb*zdc))/rcbu2
     &             + 2.0d0*(xu*zdc-xdc*zu)*da1dzibu/ru2
               dyibxic = -xcb*da1dyib/(rcb*rcb) - da1dzt - da1dzu
     &             + (xca*(zba*xcb+yt)+zca*(zba*zcb+ycb*yba))/rcbt2
     &             - 2.0d0*(yt*zba-yba*zt)*da1dyibt/rt2
     &             - (zdc*(zdb*zcb+ycb*ydb)+xdc*(zdb*xcb-yu))/rcbu2
     &             + 2.0d0*(yu*zdb-ydb*zu)*da1dyibu/ru2
               dyibyic = -ycb*da1dyib/(rcb*rcb)
     &             - (zca*(xba*ycb+zt)-xca*(zba*ycb-xt))/rcbt2
     &             - 2.0d0*(zt*xba-zba*xt)*da1dyibt/rt2
     &             - (xdc*(zdb*ycb+xu)-zdc*(xdb*ycb-zu))/rcbu2
     &             + 2.0d0*(zu*xdb-zdb*xu)*da1dyibu/ru2
               dyibxid = rcbxu*da1dyibu + da1dzu
     &                      + (xdc*zcb*xcb+zdc*yzcb2)/rcbu2
               dyibyid = rcbyu*da1dyibu + ycb*yu/rcbu2
               dyibzid = rcbzu*da1dyibu - da1dxu
     &                      - (zdc*xcb*zcb+xdc*xycb2)/rcbu2
               dzibxic = -xcb*da1dzib/(rcb*rcb) + da1dyt + da1dyu
     &             - (xca*(yba*xcb-zt)+yca*(zba*zcb+ycb*yba))/rcbt2
     &             - 2.0d0*(yt*zba-yba*zt)*da1dzibt/rt2
     &             + (ydc*(zdb*zcb+ycb*ydb)+xdc*(ydb*xcb+zu))/rcbu2
     &             + 2.0d0*(yu*zdb-ydb*zu)*da1dzibu/ru2
               dzibzic = -zcb*da1dzib/(rcb*rcb)
     &             - (xca*(yba*zcb+xt)-yca*(xba*zcb-yt))/rcbt2
     &             - 2.0d0*(xt*yba-xba*yt)*da1dzibt/rt2
     &             - (ydc*(xdb*zcb+yu)-xdc*(ydb*zcb-xu))/rcbu2
     &             + 2.0d0*(xu*ydb-xdb*yu)*da1dzibu/ru2
               dzibxid = rcbxu*da1dzibu - da1dyu
     &                      - (xdc*ycb*xcb+ydc*yzcb2)/rcbu2
               dzibyid = rcbyu*da1dzibu + da1dxu
     &                      + (ydc*xcb*ycb+xdc*xzcb2)/rcbu2
               dzibzid = rcbzu*da1dzibu + zcb*zu/rcbu2
               dxicxid = rcbxu*da1dxicu - xcb*(zdb*ycb-ydb*zcb)/rcbu2
               dxicyid = rcbyu*da1dxicu + da1dzu
     &                      + (ydb*zcb*ycb+zdb*xzcb2)/rcbu2
               dxiczid = rcbzu*da1dxicu - da1dyu
     &                      - (zdb*ycb*zcb+ydb*xycb2)/rcbu2
               dyicxid = rcbxu*da1dyicu - da1dzu
     &                      - (xdb*zcb*xcb+zdb*yzcb2)/rcbu2
               dyicyid = rcbyu*da1dyicu - ycb*(xdb*zcb-zdb*xcb)/rcbu2
               dyiczid = rcbzu*da1dyicu + da1dxu
     &                      + (zdb*xcb*zcb+xdb*xycb2)/rcbu2
               dzicxid = rcbxu*da1dzicu + da1dyu
     &                      + (xdb*ycb*xcb+ydb*yzcb2)/rcbu2
               dzicyid = rcbyu*da1dzicu - da1dxu
     &                      - (ydb*xcb*ycb+xdb*xzcb2)/rcbu2
               dziczid = rcbzu*da1dzicu - zcb*(ydb*xcb-xdb*ycb)/rcbu2
               dxidxid = rcbxu*da1dxid
               dxidyid = rcbxu*da1dyid + zcb*rcb/ru2
               dxidzid = rcbxu*da1dzid - ycb*rcb/ru2
               dyidyid = rcbyu*da1dyid
               dyidzid = rcbyu*da1dzid + xcb*rcb/ru2
               dzidzid = rcbzu*da1dzid
c
c     get some second derivative chain rule terms by difference
c
               dxiaxib = -dxiaxia - dxiaxic - dxiaxid
               dxiayib = -dxiayia - dxiayic - dxiayid
               dxiazib = -dxiazia - dxiazic - dxiazid
               dyiayib = -dyiayia - dyiayic - dyiayid
               dyiazib = -dyiazia - dyiazic - dyiazid
               dziazib = -dziazia - dziazic - dziazid
               dxibxib = -dxiaxib - dxibxic - dxibxid
               dxibyib = -dyiaxib - dxibyic - dxibyid
               dxibzib = -dxiazib - dzibxic - dzibxid
               dxibzic = -dziaxib - dxibzib - dxibzid
               dyibyib = -dyiayib - dyibyic - dyibyid
               dyibzic = -dziayib - dyibzib - dyibzid
               dzibzib = -dziazib - dzibzic - dzibzid
               dzibyic = -dyiazib - dyibzib - dzibyid
               dxicxic = -dxiaxic - dxibxic - dxicxid
               dxicyic = -dyiaxic - dyibxic - dxicyid
               dxiczic = -dziaxic - dzibxic - dxiczid
               dyicyic = -dyiayic - dyibyic - dyicyid
               dyiczic = -dziayic - dzibyic - dyiczid
               dziczic = -dziazic - dzibzic - dziczid
c
c     increment diagonal and off-diagonal Hessian elements
c
               if (i .eq. ia) then
                  hessx(1,ia) = hessx(1,ia) + dedang1*dxiaxia
     &                             + d2eda1a1*da1dxia*da1dxia
                  hessy(1,ia) = hessy(1,ia) + dedang1*dxiayia
     &                             + d2eda1a1*da1dxia*da1dyia
                  hessz(1,ia) = hessz(1,ia) + dedang1*dxiazia
     &                             + d2eda1a1*da1dxia*da1dzia
                  hessx(2,ia) = hessx(2,ia) + dedang1*dxiayia
     &                             + d2eda1a1*da1dxia*da1dyia
                  hessy(2,ia) = hessy(2,ia) + dedang1*dyiayia
     &                             + d2eda1a1*da1dyia*da1dyia
                  hessz(2,ia) = hessz(2,ia) + dedang1*dyiazia
     &                             + d2eda1a1*da1dyia*da1dzia
                  hessx(3,ia) = hessx(3,ia) + dedang1*dxiazia
     &                             + d2eda1a1*da1dxia*da1dzia
                  hessy(3,ia) = hessy(3,ia) + dedang1*dyiazia
     &                             + d2eda1a1*da1dyia*da1dzia
                  hessz(3,ia) = hessz(3,ia) + dedang1*dziazia
     &                             + d2eda1a1*da1dzia*da1dzia
                  hessx(1,ib) = hessx(1,ib) + dedang1*dxiaxib
     &                             + d2eda1a1*da1dxia*da1dxib
                  hessy(1,ib) = hessy(1,ib) + dedang1*dyiaxib
     &                             + d2eda1a1*da1dyia*da1dxib
                  hessz(1,ib) = hessz(1,ib) + dedang1*dziaxib
     &                             + d2eda1a1*da1dzia*da1dxib
                  hessx(2,ib) = hessx(2,ib) + dedang1*dxiayib
     &                             + d2eda1a1*da1dxia*da1dyib
                  hessy(2,ib) = hessy(2,ib) + dedang1*dyiayib
     &                             + d2eda1a1*da1dyia*da1dyib
                  hessz(2,ib) = hessz(2,ib) + dedang1*dziayib
     &                             + d2eda1a1*da1dzia*da1dyib
                  hessx(3,ib) = hessx(3,ib) + dedang1*dxiazib
     &                             + d2eda1a1*da1dxia*da1dzib
                  hessy(3,ib) = hessy(3,ib) + dedang1*dyiazib
     &                             + d2eda1a1*da1dyia*da1dzib
                  hessz(3,ib) = hessz(3,ib) + dedang1*dziazib
     &                             + d2eda1a1*da1dzia*da1dzib
                  hessx(1,ic) = hessx(1,ic) + dedang1*dxiaxic
     &                             + d2eda1a1*da1dxia*da1dxic
                  hessy(1,ic) = hessy(1,ic) + dedang1*dyiaxic
     &                             + d2eda1a1*da1dyia*da1dxic
                  hessz(1,ic) = hessz(1,ic) + dedang1*dziaxic
     &                             + d2eda1a1*da1dzia*da1dxic
                  hessx(2,ic) = hessx(2,ic) + dedang1*dxiayic
     &                             + d2eda1a1*da1dxia*da1dyic
                  hessy(2,ic) = hessy(2,ic) + dedang1*dyiayic
     &                             + d2eda1a1*da1dyia*da1dyic
                  hessz(2,ic) = hessz(2,ic) + dedang1*dziayic
     &                             + d2eda1a1*da1dzia*da1dyic
                  hessx(3,ic) = hessx(3,ic) + dedang1*dxiazic
     &                             + d2eda1a1*da1dxia*da1dzic
                  hessy(3,ic) = hessy(3,ic) + dedang1*dyiazic
     &                             + d2eda1a1*da1dyia*da1dzic
                  hessz(3,ic) = hessz(3,ic) + dedang1*dziazic
     &                             + d2eda1a1*da1dzia*da1dzic
                  hessx(1,id) = hessx(1,id) + dedang1*dxiaxid
     &                             + d2eda1a1*da1dxia*da1dxid
                  hessy(1,id) = hessy(1,id) + dedang1*dyiaxid
     &                             + d2eda1a1*da1dyia*da1dxid
                  hessz(1,id) = hessz(1,id) + dedang1*dziaxid
     &                             + d2eda1a1*da1dzia*da1dxid
                  hessx(2,id) = hessx(2,id) + dedang1*dxiayid
     &                             + d2eda1a1*da1dxia*da1dyid
                  hessy(2,id) = hessy(2,id) + dedang1*dyiayid
     &                             + d2eda1a1*da1dyia*da1dyid
                  hessz(2,id) = hessz(2,id) + dedang1*dziayid
     &                             + d2eda1a1*da1dzia*da1dyid
                  hessx(3,id) = hessx(3,id) + dedang1*dxiazid
     &                             + d2eda1a1*da1dxia*da1dzid
                  hessy(3,id) = hessy(3,id) + dedang1*dyiazid
     &                             + d2eda1a1*da1dyia*da1dzid
                  hessz(3,id) = hessz(3,id) + dedang1*dziazid
     &                             + d2eda1a1*da1dzia*da1dzid
               else if (i .eq. ib) then
                  hessx(1,ib) = hessx(1,ib) + dedang1*dxibxib
     &                             + d2eda1a1*da1dxib*da1dxib
                  hessy(1,ib) = hessy(1,ib) + dedang1*dxibyib
     &                             + d2eda1a1*da1dxib*da1dyib
                  hessz(1,ib) = hessz(1,ib) + dedang1*dxibzib
     &                             + d2eda1a1*da1dxib*da1dzib
                  hessx(2,ib) = hessx(2,ib) + dedang1*dxibyib
     &                             + d2eda1a1*da1dxib*da1dyib
                  hessy(2,ib) = hessy(2,ib) + dedang1*dyibyib
     &                             + d2eda1a1*da1dyib*da1dyib
                  hessz(2,ib) = hessz(2,ib) + dedang1*dyibzib
     &                             + d2eda1a1*da1dyib*da1dzib
                  hessx(3,ib) = hessx(3,ib) + dedang1*dxibzib
     &                             + d2eda1a1*da1dxib*da1dzib
                  hessy(3,ib) = hessy(3,ib) + dedang1*dyibzib
     &                             + d2eda1a1*da1dyib*da1dzib
                  hessz(3,ib) = hessz(3,ib) + dedang1*dzibzib
     &                             + d2eda1a1*da1dzib*da1dzib
                  hessx(1,ia) = hessx(1,ia) + dedang1*dxiaxib
     &                             + d2eda1a1*da1dxib*da1dxia
                  hessy(1,ia) = hessy(1,ia) + dedang1*dxiayib
     &                             + d2eda1a1*da1dyib*da1dxia
                  hessz(1,ia) = hessz(1,ia) + dedang1*dxiazib
     &                             + d2eda1a1*da1dzib*da1dxia
                  hessx(2,ia) = hessx(2,ia) + dedang1*dyiaxib
     &                             + d2eda1a1*da1dxib*da1dyia
                  hessy(2,ia) = hessy(2,ia) + dedang1*dyiayib
     &                             + d2eda1a1*da1dyib*da1dyia
                  hessz(2,ia) = hessz(2,ia) + dedang1*dyiazib
     &                             + d2eda1a1*da1dzib*da1dyia
                  hessx(3,ia) = hessx(3,ia) + dedang1*dziaxib
     &                             + d2eda1a1*da1dxib*da1dzia
                  hessy(3,ia) = hessy(3,ia) + dedang1*dziayib
     &                             + d2eda1a1*da1dyib*da1dzia
                  hessz(3,ia) = hessz(3,ia) + dedang1*dziazib
     &                             + d2eda1a1*da1dzib*da1dzia
                  hessx(1,ic) = hessx(1,ic) + dedang1*dxibxic
     &                             + d2eda1a1*da1dxib*da1dxic
                  hessy(1,ic) = hessy(1,ic) + dedang1*dyibxic
     &                             + d2eda1a1*da1dyib*da1dxic
                  hessz(1,ic) = hessz(1,ic) + dedang1*dzibxic
     &                             + d2eda1a1*da1dzib*da1dxic
                  hessx(2,ic) = hessx(2,ic) + dedang1*dxibyic
     &                             + d2eda1a1*da1dxib*da1dyic
                  hessy(2,ic) = hessy(2,ic) + dedang1*dyibyic
     &                             + d2eda1a1*da1dyib*da1dyic
                  hessz(2,ic) = hessz(2,ic) + dedang1*dzibyic
     &                             + d2eda1a1*da1dzib*da1dyic
                  hessx(3,ic) = hessx(3,ic) + dedang1*dxibzic
     &                             + d2eda1a1*da1dxib*da1dzic
                  hessy(3,ic) = hessy(3,ic) + dedang1*dyibzic
     &                             + d2eda1a1*da1dyib*da1dzic
                  hessz(3,ic) = hessz(3,ic) + dedang1*dzibzic
     &                             + d2eda1a1*da1dzib*da1dzic
                  hessx(1,id) = hessx(1,id) + dedang1*dxibxid
     &                             + d2eda1a1*da1dxib*da1dxid
                  hessy(1,id) = hessy(1,id) + dedang1*dyibxid
     &                             + d2eda1a1*da1dyib*da1dxid
                  hessz(1,id) = hessz(1,id) + dedang1*dzibxid
     &                             + d2eda1a1*da1dzib*da1dxid
                  hessx(2,id) = hessx(2,id) + dedang1*dxibyid
     &                             + d2eda1a1*da1dxib*da1dyid
                  hessy(2,id) = hessy(2,id) + dedang1*dyibyid
     &                             + d2eda1a1*da1dyib*da1dyid
                  hessz(2,id) = hessz(2,id) + dedang1*dzibyid
     &                             + d2eda1a1*da1dzib*da1dyid
                  hessx(3,id) = hessx(3,id) + dedang1*dxibzid
     &                             + d2eda1a1*da1dxib*da1dzid
                  hessy(3,id) = hessy(3,id) + dedang1*dyibzid
     &                             + d2eda1a1*da1dyib*da1dzid
                  hessz(3,id) = hessz(3,id) + dedang1*dzibzid
     &                             + d2eda1a1*da1dzib*da1dzid
               else if (i .eq. ic) then
                  hessx(1,ic) = hessx(1,ic) + dedang1*dxicxic
     &                             + d2eda1a1*da1dxic*da1dxic
                  hessy(1,ic) = hessy(1,ic) + dedang1*dxicyic
     &                             + d2eda1a1*da1dxic*da1dyic
                  hessz(1,ic) = hessz(1,ic) + dedang1*dxiczic
     &                             + d2eda1a1*da1dxic*da1dzic
                  hessx(2,ic) = hessx(2,ic) + dedang1*dxicyic
     &                             + d2eda1a1*da1dxic*da1dyic
                  hessy(2,ic) = hessy(2,ic) + dedang1*dyicyic
     &                             + d2eda1a1*da1dyic*da1dyic
                  hessz(2,ic) = hessz(2,ic) + dedang1*dyiczic
     &                             + d2eda1a1*da1dyic*da1dzic
                  hessx(3,ic) = hessx(3,ic) + dedang1*dxiczic
     &                             + d2eda1a1*da1dxic*da1dzic
                  hessy(3,ic) = hessy(3,ic) + dedang1*dyiczic
     &                             + d2eda1a1*da1dyic*da1dzic
                  hessz(3,ic) = hessz(3,ic) + dedang1*dziczic
     &                             + d2eda1a1*da1dzic*da1dzic
                  hessx(1,ia) = hessx(1,ia) + dedang1*dxiaxic
     &                             + d2eda1a1*da1dxic*da1dxia
                  hessy(1,ia) = hessy(1,ia) + dedang1*dxiayic
     &                             + d2eda1a1*da1dyic*da1dxia
                  hessz(1,ia) = hessz(1,ia) + dedang1*dxiazic
     &                             + d2eda1a1*da1dzic*da1dxia
                  hessx(2,ia) = hessx(2,ia) + dedang1*dyiaxic
     &                             + d2eda1a1*da1dxic*da1dyia
                  hessy(2,ia) = hessy(2,ia) + dedang1*dyiayic
     &                             + d2eda1a1*da1dyic*da1dyia
                  hessz(2,ia) = hessz(2,ia) + dedang1*dyiazic
     &                             + d2eda1a1*da1dzic*da1dyia
                  hessx(3,ia) = hessx(3,ia) + dedang1*dziaxic
     &                             + d2eda1a1*da1dxic*da1dzia
                  hessy(3,ia) = hessy(3,ia) + dedang1*dziayic
     &                             + d2eda1a1*da1dyic*da1dzia
                  hessz(3,ia) = hessz(3,ia) + dedang1*dziazic
     &                             + d2eda1a1*da1dzic*da1dzia
                  hessx(1,ib) = hessx(1,ib) + dedang1*dxibxic
     &                             + d2eda1a1*da1dxic*da1dxib
                  hessy(1,ib) = hessy(1,ib) + dedang1*dxibyic
     &                             + d2eda1a1*da1dyic*da1dxib
                  hessz(1,ib) = hessz(1,ib) + dedang1*dxibzic
     &                             + d2eda1a1*da1dzic*da1dxib
                  hessx(2,ib) = hessx(2,ib) + dedang1*dyibxic
     &                             + d2eda1a1*da1dxic*da1dyib
                  hessy(2,ib) = hessy(2,ib) + dedang1*dyibyic
     &                             + d2eda1a1*da1dyic*da1dyib
                  hessz(2,ib) = hessz(2,ib) + dedang1*dyibzic
     &                             + d2eda1a1*da1dzic*da1dyib
                  hessx(3,ib) = hessx(3,ib) + dedang1*dzibxic
     &                             + d2eda1a1*da1dxic*da1dzib
                  hessy(3,ib) = hessy(3,ib) + dedang1*dzibyic
     &                             + d2eda1a1*da1dyic*da1dzib
                  hessz(3,ib) = hessz(3,ib) + dedang1*dzibzic
     &                             + d2eda1a1*da1dzic*da1dzib
                  hessx(1,id) = hessx(1,id) + dedang1*dxicxid
     &                             + d2eda1a1*da1dxic*da1dxid
                  hessy(1,id) = hessy(1,id) + dedang1*dyicxid
     &                             + d2eda1a1*da1dyic*da1dxid
                  hessz(1,id) = hessz(1,id) + dedang1*dzicxid
     &                             + d2eda1a1*da1dzic*da1dxid
                  hessx(2,id) = hessx(2,id) + dedang1*dxicyid
     &                             + d2eda1a1*da1dxic*da1dyid
                  hessy(2,id) = hessy(2,id) + dedang1*dyicyid
     &                             + d2eda1a1*da1dyic*da1dyid
                  hessz(2,id) = hessz(2,id) + dedang1*dzicyid
     &                             + d2eda1a1*da1dzic*da1dyid
                  hessx(3,id) = hessx(3,id) + dedang1*dxiczid
     &                             + d2eda1a1*da1dxic*da1dzid
                  hessy(3,id) = hessy(3,id) + dedang1*dyiczid
     &                             + d2eda1a1*da1dyic*da1dzid
                  hessz(3,id) = hessz(3,id) + dedang1*dziczid
     &                             + d2eda1a1*da1dzic*da1dzid
               else if (i .eq. id) then
                  hessx(1,id) = hessx(1,id) + dedang1*dxidxid
     &                             + d2eda1a1*da1dxid*da1dxid
                  hessy(1,id) = hessy(1,id) + dedang1*dxidyid
     &                             + d2eda1a1*da1dxid*da1dyid
                  hessz(1,id) = hessz(1,id) + dedang1*dxidzid
     &                             + d2eda1a1*da1dxid*da1dzid
                  hessx(2,id) = hessx(2,id) + dedang1*dxidyid
     &                             + d2eda1a1*da1dxid*da1dyid
                  hessy(2,id) = hessy(2,id) + dedang1*dyidyid
     &                             + d2eda1a1*da1dyid*da1dyid
                  hessz(2,id) = hessz(2,id) + dedang1*dyidzid
     &                             + d2eda1a1*da1dyid*da1dzid
                  hessx(3,id) = hessx(3,id) + dedang1*dxidzid
     &                             + d2eda1a1*da1dxid*da1dzid
                  hessy(3,id) = hessy(3,id) + dedang1*dyidzid
     &                             + d2eda1a1*da1dyid*da1dzid
                  hessz(3,id) = hessz(3,id) + dedang1*dzidzid
     &                             + d2eda1a1*da1dzid*da1dzid
                  hessx(1,ia) = hessx(1,ia) + dedang1*dxiaxid
     &                             + d2eda1a1*da1dxid*da1dxia
                  hessy(1,ia) = hessy(1,ia) + dedang1*dxiayid
     &                             + d2eda1a1*da1dyid*da1dxia
                  hessz(1,ia) = hessz(1,ia) + dedang1*dxiazid
     &                             + d2eda1a1*da1dzid*da1dxia
                  hessx(2,ia) = hessx(2,ia) + dedang1*dyiaxid
     &                             + d2eda1a1*da1dxid*da1dyia
                  hessy(2,ia) = hessy(2,ia) + dedang1*dyiayid
     &                             + d2eda1a1*da1dyid*da1dyia
                  hessz(2,ia) = hessz(2,ia) + dedang1*dyiazid
     &                             + d2eda1a1*da1dzid*da1dyia
                  hessx(3,ia) = hessx(3,ia) + dedang1*dziaxid
     &                             + d2eda1a1*da1dxid*da1dzia
                  hessy(3,ia) = hessy(3,ia) + dedang1*dziayid
     &                             + d2eda1a1*da1dyid*da1dzia
                  hessz(3,ia) = hessz(3,ia) + dedang1*dziazid
     &                             + d2eda1a1*da1dzid*da1dzia
                  hessx(1,ib) = hessx(1,ib) + dedang1*dxibxid
     &                             + d2eda1a1*da1dxid*da1dxib
                  hessy(1,ib) = hessy(1,ib) + dedang1*dxibyid
     &                             + d2eda1a1*da1dyid*da1dxib
                  hessz(1,ib) = hessz(1,ib) + dedang1*dxibzid
     &                             + d2eda1a1*da1dzid*da1dxib
                  hessx(2,ib) = hessx(2,ib) + dedang1*dyibxid
     &                             + d2eda1a1*da1dxid*da1dyib
                  hessy(2,ib) = hessy(2,ib) + dedang1*dyibyid
     &                             + d2eda1a1*da1dyid*da1dyib
                  hessz(2,ib) = hessz(2,ib) + dedang1*dyibzid
     &                             + d2eda1a1*da1dzid*da1dyib
                  hessx(3,ib) = hessx(3,ib) + dedang1*dzibxid
     &                             + d2eda1a1*da1dxid*da1dzib
                  hessy(3,ib) = hessy(3,ib) + dedang1*dzibyid
     &                             + d2eda1a1*da1dyid*da1dzib
                  hessz(3,ib) = hessz(3,ib) + dedang1*dzibzid
     &                             + d2eda1a1*da1dzid*da1dzib
                  hessx(1,ic) = hessx(1,ic) + dedang1*dxicxid
     &                             + d2eda1a1*da1dxid*da1dxic
                  hessy(1,ic) = hessy(1,ic) + dedang1*dxicyid
     &                             + d2eda1a1*da1dyid*da1dxic
                  hessz(1,ic) = hessz(1,ic) + dedang1*dxiczid
     &                             + d2eda1a1*da1dzid*da1dxic
                  hessx(2,ic) = hessx(2,ic) + dedang1*dyicxid
     &                             + d2eda1a1*da1dxid*da1dyic
                  hessy(2,ic) = hessy(2,ic) + dedang1*dyicyid
     &                             + d2eda1a1*da1dyid*da1dyic
                  hessz(2,ic) = hessz(2,ic) + dedang1*dyiczid
     &                             + d2eda1a1*da1dzid*da1dyic
                  hessx(3,ic) = hessx(3,ic) + dedang1*dzicxid
     &                             + d2eda1a1*da1dxid*da1dzic
                  hessy(3,ic) = hessy(3,ic) + dedang1*dzicyid
     &                             + d2eda1a1*da1dyid*da1dzic
                  hessz(3,ic) = hessz(3,ic) + dedang1*dziczid
     &                             + d2eda1a1*da1dzid*da1dzic
               end if
c
c     abbreviations for first derivative chain rule terms
c
               xec = xie - xic
               yec = yie - yic
               zec = zie - zic
               if (use_polymer) then
                  call image (xec,yec,zec)
               end if
               da2dxu = (yu*zdc - ydc*zu) / (ru2*rdc)
               da2dyu = (zu*xdc - zdc*xu) / (ru2*rdc)
               da2dzu = (xu*ydc - xdc*yu) / (ru2*rdc)
               da2dxv = -(yv*zdc - ydc*zv) / (rv2*rdc)
               da2dyv = -(zv*xdc - zdc*xv) / (rv2*rdc)
               da2dzv = -(xv*ydc - xdc*yv) / (rv2*rdc)
c
c     abbreviations for second derivative chain rule terms
c
               xydc2 = xdc*xdc + ydc*ydc
               xzdc2 = xdc*xdc + zdc*zdc
               yzdc2 = ydc*ydc + zdc*zdc
               rdcxu = -2.0d0 * rdc * da2dxu
               rdcyu = -2.0d0 * rdc * da2dyu
               rdczu = -2.0d0 * rdc * da2dzu
               rdcu2 = rdc * ru2
               rdcxv = 2.0d0 * rdc * da2dxv
               rdcyv = 2.0d0 * rdc * da2dyv
               rdczv = 2.0d0 * rdc * da2dzv
               rdcv2 = rdc * rv2
               da2dxicu = ydb*da2dzu - zdb*da2dyu
               da2dxicv = zed*da2dyv - yed*da2dzv
               da2dyicu = zdb*da2dxu - xdb*da2dzu
               da2dyicv = xed*da2dzv - zed*da2dxv
               da2dzicu = xdb*da2dyu - ydb*da2dxu
               da2dzicv = yed*da2dxv - xed*da2dyv
               da2dxidu = zcb*da2dyu - ycb*da2dzu
               da2dxidv = yec*da2dzv - zec*da2dyv
               da2dyidu = xcb*da2dzu - zcb*da2dxu
               da2dyidv = zec*da2dxv - xec*da2dzv
               da2dzidu = ycb*da2dxu - xcb*da2dyu
               da2dzidv = xec*da2dyv - yec*da2dxv
c
c     chain rule terms for first derivative components
c
               da2dxib = zdc*da2dyu - ydc*da2dzu
               da2dyib = xdc*da2dzu - zdc*da2dxu
               da2dzib = ydc*da2dxu - xdc*da2dyu
               da2dxic = da2dxicu + da2dxicv
               da2dyic = da2dyicu + da2dyicv
               da2dzic = da2dzicu + da2dzicv
               da2dxid = da2dxidu + da2dxidv
               da2dyid = da2dyidu + da2dyidv
               da2dzid = da2dzidu + da2dzidv
               da2dxie = zdc*da2dyv - ydc*da2dzv
               da2dyie = xdc*da2dzv - zdc*da2dxv
               da2dzie = ydc*da2dxv - xdc*da2dyv
c
c     chain rule terms for second derivative components
c
               dxibxib2 = rdcxu*da2dxib
               dxibyib2 = rdcxu*da2dyib - zdc*rdc/ru2
               dxibzib2 = rdcxu*da2dzib + ydc*rdc/ru2
               dxibxid2 = rdcxu*da2dxidu + xdc*xu/rdcu2
               dxibyid2 = rdcxu*da2dyidu - da2dzu
     &                       - (xcb*zdc*xdc+zcb*yzdc2)/rdcu2
               dxibzid2 = rdcxu*da2dzidu + da2dyu
     &                       + (xcb*ydc*xdc+ycb*yzdc2)/rdcu2
               dxibxie2 = 0.0d0
               dxibyie2 = 0.0d0
               dxibzie2 = 0.0d0
               dyibyib2 = rdcyu*da2dyib
               dyibzib2 = rdcyu*da2dzib - xdc*rdc/ru2
               dyibxic2 = rdcyu*da2dxicu - da2dzu
     &                       - (ydb*zdc*ydc+zdb*xzdc2)/rdcu2
               dyibxid2 = rdcyu*da2dxidu + da2dzu
     &                       + (ycb*zdc*ydc+zcb*xzdc2)/rdcu2
               dyibyid2 = rdcyu*da2dyidu + ydc*yu/rdcu2
               dyibzid2 = rdcyu*da2dzidu - da2dxu
     &                       - (ycb*xdc*ydc+xcb*xzdc2)/rdcu2
               dyibxie2 = 0.0d0
               dyibyie2 = 0.0d0
               dyibzie2 = 0.0d0
               dzibzib2 = rdczu*da2dzib
               dzibxic2 = rdczu*da2dxicu + da2dyu
     &                       + (zdb*ydc*zdc+ydb*xydc2)/rdcu2
               dzibyic2 = rdczu*da2dyicu - da2dxu
     &                       - (zdb*xdc*zdc+xdb*xydc2)/rdcu2
               dzibxid2 = rdczu*da2dxidu - da2dyu
     &                       - (zcb*ydc*zdc+ycb*xydc2)/rdcu2
               dzibyid2 = rdczu*da2dyidu + da2dxu
     &                       + (zcb*xdc*zdc+xcb*xydc2)/rdcu2
               dzibzid2 = rdczu*da2dzidu + zdc*zu/rdcu2
               dzibxie2 = 0.0d0
               dzibyie2 = 0.0d0
               dzibzie2 = 0.0d0
               dxicxid2 = -xdc*da2dxic/(rdc*rdc)
     &             - (ydb*(zcb*xdc+yu)-zdb*(ycb*xdc-zu))/rdcu2
     &             - 2.0d0*(yu*zcb-ycb*zu)*da2dxicu/ru2
     &             - (zed*(yec*xdc+zv)-yed*(zec*xdc-yv))/rdcv2
     &             + 2.0d0*(yv*zec-yec*zv)*da2dxicv/rv2
               dxicyid2 = -ydc*da2dxic/(rdc*rdc) + da2dzu + da2dzv
     &             - (ydb*(zcb*ydc-xu)+zdb*(xcb*xdc+zdc*zcb))/rdcu2
     &             - 2.0d0*(zu*xcb-zcb*xu)*da2dxicu/ru2
     &             + (zed*(xec*xdc+zdc*zec)+yed*(zec*ydc+xv))/rdcv2
     &             + 2.0d0*(zv*xec-zec*xv)*da2dxicv/rv2
               dxicxie2 = rdcxv*da2dxicv + xdc*xv/rdcv2
               dxicyie2 = rdcyv*da2dxicv - da2dzv
     &                       - (yed*zdc*ydc+zed*xzdc2)/rdcv2
               dxiczie2 = rdczv*da2dxicv + da2dyv
     &                       + (zed*ydc*zdc+yed*xydc2)/rdcv2
               dyiczic2 = ydc*da2dzic/(rdc*rdc)
     &             - (xdb*(xdb*xdc+zdc*zdb)+ydb*(ydc*xdb+zu))/rdcu2
     &             - 2.0d0*(xu*zdb-xdb*zu)*da2dzicu/ru2
     &             + (yed*(xed*ydc-zv)+xed*(xed*xdc+zdc*zed))/rdcv2
     &             + 2.0d0*(xv*zed-xed*zv)*da2dzicv/rv2
               dyicxid2 = -xdc*da2dyic/(rdc*rdc) - da2dzu - da2dzv
     &             + (xdb*(zcb*xdc+yu)+zdb*(zcb*zdc+ydc*ycb))/rdcu2
     &             - 2.0d0*(yu*zcb-ycb*zu)*da2dyicu/ru2
     &             - (zed*(zec*zdc+ydc*yec)+xed*(zec*xdc-yv))/rdcv2
     &             + 2.0d0*(yv*zec-yec*zv)*da2dyicv/rv2
               dyicyid2 = -ydc*da2dyic/(rdc*rdc)
     &             - (zdb*(xcb*ydc+zu)-xdb*(zcb*ydc-xu))/rdcu2
     &             - 2.0d0*(zu*xcb-zcb*xu)*da2dyicu/ru2
     &             - (xed*(zec*ydc+xv)-zed*(xec*ydc-zv))/rdcv2
     &             + 2.0d0*(zv*xec-zec*xv)*da2dyicv/rv2
               dyicxie2 = rdcxv*da2dyicv + da2dzv
     &                       + (xed*zdc*xdc+zed*yzdc2)/rdcv2
               dyicyie2 = rdcyv*da2dyicv + ydc*yv/rdcv2
               dyiczie2 = rdczv*da2dyicv - da2dxv
     &                       - (zed*xdc*zdc+xed*xydc2)/rdcv2
               dzicxid2 = -xdc*da2dzic/(rdc*rdc) + da2dyu + da2dyv
     &             - (xdb*(ycb*xdc-zu)+ydb*(zcb*zdc+ydc*ycb))/rdcu2
     &             - 2.0d0*(yu*zcb-ycb*zu)*da2dzicu/ru2
     &             + (yed*(zec*zdc+ydc*yec)+xed*(yec*xdc+zv))/rdcv2
     &             + 2.0d0*(yv*zec-yec*zv)*da2dzicv/rv2
               dziczid2 = -zdc*da2dzic/(rdc*rdc)
     &             - (xdb*(ycb*zdc+xu)-ydb*(xcb*zdc-yu))/rdcu2
     &             - 2.0d0*(xu*ycb-xcb*yu)*da2dzicu/ru2
     &             - (yed*(xec*zdc+yv)-xed*(yec*zdc-xv))/rdcv2
     &             + 2.0d0*(xv*yec-xec*yv)*da2dzicv/rv2
               dzicxie2 = rdcxv*da2dzicv - da2dyv
     &                       - (xed*ydc*xdc+yed*yzdc2)/rdcv2
               dzicyie2 = rdcyv*da2dzicv + da2dxv
     &                       + (yed*xdc*ydc+xed*xzdc2)/rdcv2
               dziczie2 = rdczv*da2dzicv + zdc*zv/rdcv2
               dxidxie2 = rdcxv*da2dxidv - xdc*(zec*ydc-yec*zdc)/rdcv2
               dxidyie2 = rdcyv*da2dxidv + da2dzv
     &                       + (yec*zdc*ydc+zec*xzdc2)/rdcv2
               dxidzie2 = rdczv*da2dxidv - da2dyv
     &                       - (zec*ydc*zdc+yec*xydc2)/rdcv2
               dyidxie2 = rdcxv*da2dyidv - da2dzv
     &                       - (xec*zdc*xdc+zec*yzdc2)/rdcv2
               dyidyie2 = rdcyv*da2dyidv - ydc*(xec*zdc-zec*xdc)/rdcv2
               dyidzie2 = rdczv*da2dyidv + da2dxv
     &                       + (zec*xdc*zdc+xec*xydc2)/rdcv2
               dzidxie2 = rdcxv*da2dzidv + da2dyv
     &                       + (xec*ydc*xdc+yec*yzdc2)/rdcv2
               dzidyie2 = rdcyv*da2dzidv - da2dxv
     &                       - (yec*xdc*ydc+xec*xzdc2)/rdcv2
               dzidzie2 = rdczv*da2dzidv - zdc*(yec*xdc-xec*ydc)/rdcv2
               dxiexie2 = rdcxv*da2dxie
               dxieyie2 = rdcxv*da2dyie + zdc*rdc/rv2
               dxiezie2 = rdcxv*da2dzie - ydc*rdc/rv2
               dyieyie2 = rdcyv*da2dyie
               dyiezie2 = rdcyv*da2dzie + xdc*rdc/rv2
               dziezie2 = rdczv*da2dzie
c
c     get some second derivative chain rule terms by difference
c
               dxibxic2 = -dxibxib2 - dxibxid2 - dxibxie2
               dxibyic2 = -dxibyib2 - dxibyid2 - dxibyie2
               dxibzic2 = -dxibzib2 - dxibzid2 - dxibzie2
               dyibyic2 = -dyibyib2 - dyibyid2 - dyibyie2
               dyibzic2 = -dyibzib2 - dyibzid2 - dyibzie2
               dzibzic2 = -dzibzib2 - dzibzid2 - dzibzie2
               dxicxic2 = -dxibxic2 - dxicxid2 - dxicxie2
               dxicyic2 = -dyibxic2 - dxicyid2 - dxicyie2
               dxiczic2 = -dxibzic2 - dzicxid2 - dzicxie2
               dxiczid2 = -dzibxic2 - dxiczic2 - dxiczie2
               dyicyic2 = -dyibyic2 - dyicyid2 - dyicyie2
               dyiczid2 = -dzibyic2 - dyiczic2 - dyiczie2
               dziczic2 = -dzibzic2 - dziczid2 - dziczie2
               dzicyid2 = -dyibzic2 - dyiczic2 - dzicyie2
               dxidxid2 = -dxibxid2 - dxicxid2 - dxidxie2
               dxidyid2 = -dyibxid2 - dyicxid2 - dxidyie2
               dxidzid2 = -dzibxid2 - dzicxid2 - dxidzie2
               dyidyid2 = -dyibyid2 - dyicyid2 - dyidyie2
               dyidzid2 = -dzibyid2 - dzicyid2 - dyidzie2
               dzidzid2 = -dzibzid2 - dziczid2 - dzidzie2
c
c     increment diagonal and off-diagonal Hessian elements
c
               if (i .eq. ia) then
                  hessx(1,ib) = hessx(1,ib) + d2eda1a2*da1dxia*da2dxib
                  hessy(1,ib) = hessy(1,ib) + d2eda1a2*da1dyia*da2dxib
                  hessz(1,ib) = hessz(1,ib) + d2eda1a2*da1dzia*da2dxib
                  hessx(2,ib) = hessx(2,ib) + d2eda1a2*da1dxia*da2dyib
                  hessy(2,ib) = hessy(2,ib) + d2eda1a2*da1dyia*da2dyib
                  hessz(2,ib) = hessz(2,ib) + d2eda1a2*da1dzia*da2dyib
                  hessx(3,ib) = hessx(3,ib) + d2eda1a2*da1dxia*da2dzib
                  hessy(3,ib) = hessy(3,ib) + d2eda1a2*da1dyia*da2dzib
                  hessz(3,ib) = hessz(3,ib) + d2eda1a2*da1dzia*da2dzib
                  hessx(1,ic) = hessx(1,ic) + d2eda1a2*da1dxia*da2dxic
                  hessy(1,ic) = hessy(1,ic) + d2eda1a2*da1dyia*da2dxic
                  hessz(1,ic) = hessz(1,ic) + d2eda1a2*da1dzia*da2dxic
                  hessx(2,ic) = hessx(2,ic) + d2eda1a2*da1dxia*da2dyic
                  hessy(2,ic) = hessy(2,ic) + d2eda1a2*da1dyia*da2dyic
                  hessz(2,ic) = hessz(2,ic) + d2eda1a2*da1dzia*da2dyic
                  hessx(3,ic) = hessx(3,ic) + d2eda1a2*da1dxia*da2dzic
                  hessy(3,ic) = hessy(3,ic) + d2eda1a2*da1dyia*da2dzic
                  hessz(3,ic) = hessz(3,ic) + d2eda1a2*da1dzia*da2dzic
                  hessx(1,id) = hessx(1,id) + d2eda1a2*da1dxia*da2dxid
                  hessy(1,id) = hessy(1,id) + d2eda1a2*da1dyia*da2dxid
                  hessz(1,id) = hessz(1,id) + d2eda1a2*da1dzia*da2dxid
                  hessx(2,id) = hessx(2,id) + d2eda1a2*da1dxia*da2dyid
                  hessy(2,id) = hessy(2,id) + d2eda1a2*da1dyia*da2dyid
                  hessz(2,id) = hessz(2,id) + d2eda1a2*da1dzia*da2dyid
                  hessx(3,id) = hessx(3,id) + d2eda1a2*da1dxia*da2dzid
                  hessy(3,id) = hessy(3,id) + d2eda1a2*da1dyia*da2dzid
                  hessz(3,id) = hessz(3,id) + d2eda1a2*da1dzia*da2dzid
                  hessx(1,ie) = hessx(1,ie) + d2eda1a2*da1dxia*da2dxie
                  hessy(1,ie) = hessy(1,ie) + d2eda1a2*da1dyia*da2dxie
                  hessz(1,ie) = hessz(1,ie) + d2eda1a2*da1dzia*da2dxie
                  hessx(2,ie) = hessx(2,ie) + d2eda1a2*da1dxia*da2dyie
                  hessy(2,ie) = hessy(2,ie) + d2eda1a2*da1dyia*da2dyie
                  hessz(2,ie) = hessz(2,ie) + d2eda1a2*da1dzia*da2dyie
                  hessx(3,ie) = hessx(3,ie) + d2eda1a2*da1dxia*da2dzie
                  hessy(3,ie) = hessy(3,ie) + d2eda1a2*da1dyia*da2dzie
                  hessz(3,ie) = hessz(3,ie) + d2eda1a2*da1dzia*da2dzie
               else if (i .eq. ib) then
                  hessx(1,ib) = hessx(1,ib) + dedang2*dxibxib2
     &                             + d2eda2a2*da2dxib*da2dxib
     &                             + 2.0d0*d2eda1a2*da1dxib*da2dxib
                  hessy(1,ib) = hessy(1,ib) + dedang2*dxibyib2
     &                             + d2eda2a2*da2dxib*da2dyib
     &                             + d2eda1a2*da1dxib*da2dyib
     &                             + d2eda1a2*da2dxib*da1dyib
                  hessz(1,ib) = hessz(1,ib) + dedang2*dxibzib2
     &                             + d2eda2a2*da2dxib*da2dzib
     &                             + d2eda1a2*da1dxib*da2dzib
     &                             + d2eda1a2*da2dxib*da1dzib
                  hessx(2,ib) = hessx(2,ib) + dedang2*dxibyib2
     &                             + d2eda2a2*da2dxib*da2dyib
     &                             + d2eda1a2*da1dxib*da2dyib
     &                             + d2eda1a2*da2dxib*da1dyib
                  hessy(2,ib) = hessy(2,ib) + dedang2*dyibyib2
     &                             + d2eda2a2*da2dyib*da2dyib
     &                             + d2eda1a2*da1dyib*da2dyib
     &                             + d2eda1a2*da2dyib*da1dyib
                  hessz(2,ib) = hessz(2,ib) + dedang2*dyibzib2
     &                             + d2eda2a2*da2dyib*da2dzib
     &                             + d2eda1a2*da1dyib*da2dzib
     &                             + d2eda1a2*da2dyib*da1dzib
                  hessx(3,ib) = hessx(3,ib) + dedang2*dxibzib2
     &                             + d2eda2a2*da2dxib*da2dzib
     &                             + d2eda1a2*da1dxib*da2dzib
     &                             + d2eda1a2*da2dxib*da1dzib
                  hessy(3,ib) = hessy(3,ib) + dedang2*dyibzib2
     &                             + d2eda2a2*da2dyib*da2dzib
     &                             + d2eda1a2*da1dyib*da2dzib
     &                             + d2eda1a2*da2dyib*da1dzib
                  hessz(3,ib) = hessz(3,ib) + dedang2*dzibzib2
     &                             + d2eda2a2*da2dzib*da2dzib
     &                             + d2eda1a2*da1dzib*da2dzib
     &                             + d2eda1a2*da2dzib*da1dzib
                  hessx(1,ia) = hessx(1,ia) + d2eda1a2*da2dxib*da1dxia
                  hessy(1,ia) = hessy(1,ia) + d2eda1a2*da2dyib*da1dxia
                  hessz(1,ia) = hessz(1,ia) + d2eda1a2*da2dzib*da1dxia
                  hessx(2,ia) = hessx(2,ia) + d2eda1a2*da2dxib*da1dyia
                  hessy(2,ia) = hessy(2,ia) + d2eda1a2*da2dyib*da1dyia
                  hessz(2,ia) = hessz(2,ia) + d2eda1a2*da2dzib*da1dyia
                  hessx(3,ia) = hessx(3,ia) + d2eda1a2*da2dxib*da1dzia
                  hessy(3,ia) = hessy(3,ia) + d2eda1a2*da2dyib*da1dzia
                  hessz(3,ia) = hessz(3,ia) + d2eda1a2*da2dzib*da1dzia
                  hessx(1,ic) = hessx(1,ic) + dedang2*dxibxic2
     &                             + d2eda2a2*da2dxib*da2dxic
     &                             + d2eda1a2*da1dxib*da2dxic
     &                             + d2eda1a2*da2dxib*da1dxic
                  hessy(1,ic) = hessy(1,ic) + dedang2*dyibxic2
     &                             + d2eda2a2*da2dyib*da2dxic
     &                             + d2eda1a2*da1dyib*da2dxic
     &                             + d2eda1a2*da2dyib*da1dxic
                  hessz(1,ic) = hessz(1,ic) + dedang2*dzibxic2
     &                             + d2eda2a2*da2dzib*da2dxic
     &                             + d2eda1a2*da1dzib*da2dxic
     &                             + d2eda1a2*da2dzib*da1dxic
                  hessx(2,ic) = hessx(2,ic) + dedang2*dxibyic2
     &                             + d2eda2a2*da2dxib*da2dyic
     &                             + d2eda1a2*da1dxib*da2dyic
     &                             + d2eda1a2*da2dxib*da1dyic
                  hessy(2,ic) = hessy(2,ic) + dedang2*dyibyic2
     &                             + d2eda2a2*da2dyib*da2dyic
     &                             + d2eda1a2*da1dyib*da2dyic
     &                             + d2eda1a2*da2dyib*da1dyic
                  hessz(2,ic) = hessz(2,ic) + dedang2*dzibyic2
     &                             + d2eda2a2*da2dzib*da2dyic
     &                             + d2eda1a2*da1dzib*da2dyic
     &                             + d2eda1a2*da2dzib*da1dyic
                  hessx(3,ic) = hessx(3,ic) + dedang2*dxibzic2
     &                             + d2eda2a2*da2dxib*da2dzic
     &                             + d2eda1a2*da1dxib*da2dzic
     &                             + d2eda1a2*da2dxib*da1dzic
                  hessy(3,ic) = hessy(3,ic) + dedang2*dyibzic2
     &                             + d2eda2a2*da2dyib*da2dzic
     &                             + d2eda1a2*da1dyib*da2dzic
     &                             + d2eda1a2*da2dyib*da1dzic
                  hessz(3,ic) = hessz(3,ic) + dedang2*dzibzic2
     &                             + d2eda2a2*da2dzib*da2dzic
     &                             + d2eda1a2*da1dzib*da2dzic
     &                             + d2eda1a2*da2dzib*da1dzic
                  hessx(1,id) = hessx(1,id) + dedang2*dxibxid2
     &                             + d2eda2a2*da2dxib*da2dxid
     &                             + d2eda1a2*da1dxib*da2dxid
     &                             + d2eda1a2*da2dxib*da1dxid
                  hessy(1,id) = hessy(1,id) + dedang2*dyibxid2
     &                             + d2eda2a2*da2dyib*da2dxid
     &                             + d2eda1a2*da1dyib*da2dxid
     &                             + d2eda1a2*da2dyib*da1dxid
                  hessz(1,id) = hessz(1,id) + dedang2*dzibxid2
     &                             + d2eda2a2*da2dzib*da2dxid
     &                             + d2eda1a2*da1dzib*da2dxid
     &                             + d2eda1a2*da2dzib*da1dxid
                  hessx(2,id) = hessx(2,id) + dedang2*dxibyid2
     &                             + d2eda2a2*da2dxib*da2dyid
     &                             + d2eda1a2*da1dxib*da2dyid
     &                             + d2eda1a2*da2dxib*da1dyid
                  hessy(2,id) = hessy(2,id) + dedang2*dyibyid2
     &                             + d2eda2a2*da2dyib*da2dyid
     &                             + d2eda1a2*da1dyib*da2dyid
     &                             + d2eda1a2*da2dyib*da1dyid
                  hessz(2,id) = hessz(2,id) + dedang2*dzibyid2
     &                             + d2eda2a2*da2dzib*da2dyid
     &                             + d2eda1a2*da1dzib*da2dyid
     &                             + d2eda1a2*da2dzib*da1dyid
                  hessx(3,id) = hessx(3,id) + dedang2*dxibzid2
     &                             + d2eda2a2*da2dxib*da2dzid
     &                             + d2eda1a2*da1dxib*da2dzid
     &                             + d2eda1a2*da2dxib*da1dzid
                  hessy(3,id) = hessy(3,id) + dedang2*dyibzid2
     &                             + d2eda2a2*da2dyib*da2dzid
     &                             + d2eda1a2*da1dyib*da2dzid
     &                             + d2eda1a2*da2dyib*da1dzid
                  hessz(3,id) = hessz(3,id) + dedang2*dzibzid2
     &                             + d2eda2a2*da2dzib*da2dzid
     &                             + d2eda1a2*da1dzib*da2dzid
     &                             + d2eda1a2*da2dzib*da1dzid
                  hessx(1,ie) = hessx(1,ie) + dedang2*dxibxie2
     &                             + d2eda2a2*da2dxib*da2dxie
     &                             + d2eda1a2*da1dxib*da2dxie
                  hessy(1,ie) = hessy(1,ie) + dedang2*dyibxie2
     &                             + d2eda2a2*da2dyib*da2dxie
     &                             + d2eda1a2*da1dyib*da2dxie
                  hessz(1,ie) = hessz(1,ie) + dedang2*dzibxie2
     &                             + d2eda2a2*da2dzib*da2dxie
     &                             + d2eda1a2*da1dzib*da2dxie
                  hessx(2,ie) = hessx(2,ie) + dedang2*dxibyie2
     &                             + d2eda2a2*da2dxib*da2dyie
     &                             + d2eda1a2*da1dxib*da2dyie
                  hessy(2,ie) = hessy(2,ie) + dedang2*dyibyie2
     &                             + d2eda2a2*da2dyib*da2dyie
     &                             + d2eda1a2*da1dyib*da2dyie
                  hessz(2,ie) = hessz(2,ie) + dedang2*dzibyie2
     &                             + d2eda2a2*da2dzib*da2dyie
     &                             + d2eda1a2*da1dzib*da2dyie
                  hessx(3,ie) = hessx(3,ie) + dedang2*dxibzie2
     &                             + d2eda2a2*da2dxib*da2dzie
     &                             + d2eda1a2*da1dxib*da2dzie
                  hessy(3,ie) = hessy(3,ie) + dedang2*dyibzie2
     &                             + d2eda2a2*da2dyib*da2dzie
     &                             + d2eda1a2*da1dyib*da2dzie
                  hessz(3,ie) = hessz(3,ie) + dedang2*dzibzie2
     &                             + d2eda2a2*da2dzib*da2dzie
     &                             + d2eda1a2*da1dzib*da2dzie
               else if (i .eq. ic) then
                  hessx(1,ic) = hessx(1,ic) + dedang2*dxicxic2
     &                             + d2eda2a2*da2dxic*da2dxic
     &                             + d2eda1a2*da1dxic*da2dxic
     &                             + d2eda1a2*da2dxic*da1dxic
                  hessy(1,ic) = hessy(1,ic) + dedang2*dxicyic2
     &                             + d2eda2a2*da2dxic*da2dyic
     &                             + d2eda1a2*da1dxic*da2dyic
     &                             + d2eda1a2*da2dxic*da1dyic
                  hessz(1,ic) = hessz(1,ic) + dedang2*dxiczic2
     &                             + d2eda2a2*da2dxic*da2dzic
     &                             + d2eda1a2*da1dxic*da2dzic
     &                             + d2eda1a2*da2dxic*da1dzic
                  hessx(2,ic) = hessx(2,ic) + dedang2*dxicyic2
     &                             + d2eda2a2*da2dxic*da2dyic
     &                             + d2eda1a2*da1dxic*da2dyic
     &                             + d2eda1a2*da2dxic*da1dyic
                  hessy(2,ic) = hessy(2,ic) + dedang2*dyicyic2
     &                             + d2eda2a2*da2dyic*da2dyic
     &                             + d2eda1a2*da1dyic*da2dyic
     &                             + d2eda1a2*da2dyic*da1dyic
                  hessz(2,ic) = hessz(2,ic) + dedang2*dyiczic2
     &                             + d2eda2a2*da2dyic*da2dzic
     &                             + d2eda1a2*da1dyic*da2dzic
     &                             + d2eda1a2*da2dyic*da1dzic
                  hessx(3,ic) = hessx(3,ic) + dedang2*dxiczic2
     &                             + d2eda2a2*da2dxic*da2dzic
     &                             + d2eda1a2*da1dxic*da2dzic
     &                             + d2eda1a2*da2dxic*da1dzic
                  hessy(3,ic) = hessy(3,ic) + dedang2*dyiczic2
     &                             + d2eda2a2*da2dyic*da2dzic
     &                             + d2eda1a2*da1dyic*da2dzic
     &                             + d2eda1a2*da2dyic*da1dzic
                  hessz(3,ic) = hessz(3,ic) + dedang2*dziczic2
     &                             + d2eda2a2*da2dzic*da2dzic
     &                             + d2eda1a2*da1dzic*da2dzic
     &                             + d2eda1a2*da2dzic*da1dzic
                  hessx(1,ia) = hessx(1,ia) + d2eda1a2*da2dxic*da1dxia
                  hessy(1,ia) = hessy(1,ia) + d2eda1a2*da2dyic*da1dxia
                  hessz(1,ia) = hessz(1,ia) + d2eda1a2*da2dzic*da1dxia
                  hessx(2,ia) = hessx(2,ia) + d2eda1a2*da2dxic*da1dyia
                  hessy(2,ia) = hessy(2,ia) + d2eda1a2*da2dyic*da1dyia
                  hessz(2,ia) = hessz(2,ia) + d2eda1a2*da2dzic*da1dyia
                  hessx(3,ia) = hessx(3,ia) + d2eda1a2*da2dxic*da1dzia
                  hessy(3,ia) = hessy(3,ia) + d2eda1a2*da2dyic*da1dzia
                  hessz(3,ia) = hessz(3,ia) + d2eda1a2*da2dzic*da1dzia
                  hessx(1,ib) = hessx(1,ib) + dedang2*dxibxic2
     &                             + d2eda2a2*da2dxic*da2dxib
     &                             + d2eda1a2*da1dxic*da2dxib
     &                             + d2eda1a2*da2dxic*da1dxib
                  hessy(1,ib) = hessy(1,ib) + dedang2*dxibyic2
     &                             + d2eda2a2*da2dyic*da2dxib
     &                             + d2eda1a2*da1dyic*da2dxib
     &                             + d2eda1a2*da2dyic*da1dxib
                  hessz(1,ib) = hessz(1,ib) + dedang2*dxibzic2
     &                             + d2eda2a2*da2dzic*da2dxib
     &                             + d2eda1a2*da1dzic*da2dxib
     &                             + d2eda1a2*da2dzic*da1dxib
                  hessx(2,ib) = hessx(2,ib) + dedang2*dyibxic2
     &                             + d2eda2a2*da2dxic*da2dyib
     &                             + d2eda1a2*da1dxic*da2dyib
     &                             + d2eda1a2*da2dxic*da1dyib
                  hessy(2,ib) = hessy(2,ib) + dedang2*dyibyic2
     &                             + d2eda2a2*da2dyic*da2dyib
     &                             + d2eda1a2*da1dyic*da2dyib
     &                             + d2eda1a2*da2dyic*da1dyib
                  hessz(2,ib) = hessz(2,ib) + dedang2*dyibzic2
     &                             + d2eda2a2*da2dzic*da2dyib
     &                             + d2eda1a2*da1dzic*da2dyib
     &                             + d2eda1a2*da2dzic*da1dyib
                  hessx(3,ib) = hessx(3,ib) + dedang2*dzibxic2
     &                             + d2eda2a2*da2dxic*da2dzib
     &                             + d2eda1a2*da1dxic*da2dzib
     &                             + d2eda1a2*da2dxic*da1dzib
                  hessy(3,ib) = hessy(3,ib) + dedang2*dzibyic2
     &                             + d2eda2a2*da2dyic*da2dzib
     &                             + d2eda1a2*da1dyic*da2dzib
     &                             + d2eda1a2*da2dyic*da1dzib
                  hessz(3,ib) = hessz(3,ib) + dedang2*dzibzic2
     &                             + d2eda2a2*da2dzic*da2dzib
     &                             + d2eda1a2*da1dzic*da2dzib
     &                             + d2eda1a2*da2dzic*da1dzib
                  hessx(1,id) = hessx(1,id) + dedang2*dxicxid2
     &                             + d2eda2a2*da2dxic*da2dxid
     &                             + d2eda1a2*da1dxic*da2dxid
     &                             + d2eda1a2*da2dxic*da1dxid
                  hessy(1,id) = hessy(1,id) + dedang2*dyicxid2
     &                             + d2eda2a2*da2dyic*da2dxid
     &                             + d2eda1a2*da1dyic*da2dxid
     &                             + d2eda1a2*da2dyic*da1dxid
                  hessz(1,id) = hessz(1,id) + dedang2*dzicxid2
     &                             + d2eda2a2*da2dzic*da2dxid
     &                             + d2eda1a2*da1dzic*da2dxid
     &                             + d2eda1a2*da2dzic*da1dxid
                  hessx(2,id) = hessx(2,id) + dedang2*dxicyid2
     &                             + d2eda2a2*da2dxic*da2dyid
     &                             + d2eda1a2*da1dxic*da2dyid
     &                             + d2eda1a2*da2dxic*da1dyid
                  hessy(2,id) = hessy(2,id) + dedang2*dyicyid2
     &                             + d2eda2a2*da2dyic*da2dyid
     &                             + d2eda1a2*da1dyic*da2dyid
     &                             + d2eda1a2*da2dyic*da1dyid
                  hessz(2,id) = hessz(2,id) + dedang2*dzicyid2
     &                             + d2eda2a2*da2dzic*da2dyid
     &                             + d2eda1a2*da1dzic*da2dyid
     &                             + d2eda1a2*da2dzic*da1dyid
                  hessx(3,id) = hessx(3,id) + dedang2*dxiczid2
     &                             + d2eda2a2*da2dxic*da2dzid
     &                             + d2eda1a2*da1dxic*da2dzid
     &                             + d2eda1a2*da2dxic*da1dzid
                  hessy(3,id) = hessy(3,id) + dedang2*dyiczid2
     &                             + d2eda2a2*da2dyic*da2dzid
     &                             + d2eda1a2*da1dyic*da2dzid
     &                             + d2eda1a2*da2dyic*da1dzid
                  hessz(3,id) = hessz(3,id) + dedang2*dziczid2
     &                             + d2eda2a2*da2dzic*da2dzid
     &                             + d2eda1a2*da1dzic*da2dzid
     &                             + d2eda1a2*da2dzic*da1dzid
                  hessx(1,ie) = hessx(1,ie) + dedang2*dxicxie2
     &                             + d2eda2a2*da2dxic*da2dxie
     &                             + d2eda1a2*da1dxic*da2dxie
                  hessy(1,ie) = hessy(1,ie) + dedang2*dyicxie2
     &                             + d2eda2a2*da2dyic*da2dxie
     &                             + d2eda1a2*da1dyic*da2dxie
                  hessz(1,ie) = hessz(1,ie) + dedang2*dzicxie2
     &                             + d2eda2a2*da2dzic*da2dxie
     &                             + d2eda1a2*da1dzic*da2dxie
                  hessx(2,ie) = hessx(2,ie) + dedang2*dxicyie2
     &                             + d2eda2a2*da2dxic*da2dyie
     &                             + d2eda1a2*da1dxic*da2dyie
                  hessy(2,ie) = hessy(2,ie) + dedang2*dyicyie2
     &                             + d2eda2a2*da2dyic*da2dyie
     &                             + d2eda1a2*da1dyic*da2dyie
                  hessz(2,ie) = hessz(2,ie) + dedang2*dzicyie2
     &                             + d2eda2a2*da2dzic*da2dyie
     &                             + d2eda1a2*da1dzic*da2dyie
                  hessx(3,ie) = hessx(3,ie) + dedang2*dxiczie2
     &                             + d2eda2a2*da2dxic*da2dzie
     &                             + d2eda1a2*da1dxic*da2dzie
                  hessy(3,ie) = hessy(3,ie) + dedang2*dyiczie2
     &                             + d2eda2a2*da2dyic*da2dzie
     &                             + d2eda1a2*da1dyic*da2dzie
                  hessz(3,ie) = hessz(3,ie) + dedang2*dziczie2
     &                             + d2eda2a2*da2dzic*da2dzie
     &                             + d2eda1a2*da1dzic*da2dzie
               else if (i .eq. id) then
                  hessx(1,id) = hessx(1,id) + dedang2*dxidxid2
     &                             + d2eda2a2*da2dxid*da2dxid
     &                             + d2eda1a2*da1dxid*da2dxid
     &                             + d2eda1a2*da2dxid*da1dxid
                  hessy(1,id) = hessy(1,id) + dedang2*dxidyid2
     &                             + d2eda2a2*da2dxid*da2dyid
     &                             + d2eda1a2*da1dxid*da2dyid
     &                             + d2eda1a2*da2dxid*da1dyid
                  hessz(1,id) = hessz(1,id) + dedang2*dxidzid2
     &                             + d2eda2a2*da2dxid*da2dzid
     &                             + d2eda1a2*da1dxid*da2dzid
     &                             + d2eda1a2*da2dxid*da1dzid
                  hessx(2,id) = hessx(2,id) + dedang2*dxidyid2
     &                             + d2eda2a2*da2dxid*da2dyid
     &                             + d2eda1a2*da1dxid*da2dyid
     &                             + d2eda1a2*da2dxid*da1dyid
                  hessy(2,id) = hessy(2,id) + dedang2*dyidyid2
     &                             + d2eda2a2*da2dyid*da2dyid
     &                             + d2eda1a2*da1dyid*da2dyid
     &                             + d2eda1a2*da2dyid*da1dyid
                  hessz(2,id) = hessz(2,id) + dedang2*dyidzid2
     &                             + d2eda2a2*da2dyid*da2dzid
     &                             + d2eda1a2*da1dyid*da2dzid
     &                             + d2eda1a2*da2dyid*da1dzid
                  hessx(3,id) = hessx(3,id) + dedang2*dxidzid2
     &                             + d2eda2a2*da2dxid*da2dzid
     &                             + d2eda1a2*da1dxid*da2dzid
     &                             + d2eda1a2*da2dxid*da1dzid
                  hessy(3,id) = hessy(3,id) + dedang2*dyidzid2
     &                             + d2eda2a2*da2dyid*da2dzid
     &                             + d2eda1a2*da1dyid*da2dzid
     &                             + d2eda1a2*da2dyid*da1dzid
                  hessz(3,id) = hessz(3,id) + dedang2*dzidzid2
     &                             + d2eda2a2*da2dzid*da2dzid
     &                             + d2eda1a2*da1dzid*da2dzid
     &                             + d2eda1a2*da2dzid*da1dzid
                  hessx(1,ia) = hessx(1,ia) + d2eda1a2*da2dxid*da1dxia
                  hessy(1,ia) = hessy(1,ia) + d2eda1a2*da2dyid*da1dxia
                  hessz(1,ia) = hessz(1,ia) + d2eda1a2*da2dzid*da1dxia
                  hessx(2,ia) = hessx(2,ia) + d2eda1a2*da2dxid*da1dyia
                  hessy(2,ia) = hessy(2,ia) + d2eda1a2*da2dyid*da1dyia
                  hessz(2,ia) = hessz(2,ia) + d2eda1a2*da2dzid*da1dyia
                  hessx(3,ia) = hessx(3,ia) + d2eda1a2*da2dxid*da1dzia
                  hessy(3,ia) = hessy(3,ia) + d2eda1a2*da2dyid*da1dzia
                  hessz(3,ia) = hessz(3,ia) + d2eda1a2*da2dzid*da1dzia
                  hessx(1,ib) = hessx(1,ib) + dedang2*dxibxid2
     &                             + d2eda2a2*da2dxid*da2dxib
     &                             + d2eda1a2*da1dxid*da2dxib
     &                             + d2eda1a2*da2dxid*da1dxib
                  hessy(1,ib) = hessy(1,ib) + dedang2*dxibyid2
     &                             + d2eda2a2*da2dyid*da2dxib
     &                             + d2eda1a2*da1dyid*da2dxib
     &                             + d2eda1a2*da2dyid*da1dxib
                  hessz(1,ib) = hessz(1,ib) + dedang2*dxibzid2
     &                             + d2eda2a2*da2dzid*da2dxib
     &                             + d2eda1a2*da1dzid*da2dxib
     &                             + d2eda1a2*da2dzid*da1dxib
                  hessx(2,ib) = hessx(2,ib) + dedang2*dyibxid2
     &                             + d2eda2a2*da2dxid*da2dyib
     &                             + d2eda1a2*da1dxid*da2dyib
     &                             + d2eda1a2*da2dxid*da1dyib
                  hessy(2,ib) = hessy(2,ib) + dedang2*dyibyid2
     &                             + d2eda2a2*da2dyid*da2dyib
     &                             + d2eda1a2*da1dyid*da2dyib
     &                             + d2eda1a2*da2dyid*da1dyib
                  hessz(2,ib) = hessz(2,ib) + dedang2*dyibzid2
     &                             + d2eda2a2*da2dzid*da2dyib
     &                             + d2eda1a2*da1dzid*da2dyib
     &                             + d2eda1a2*da2dzid*da1dyib
                  hessx(3,ib) = hessx(3,ib) + dedang2*dzibxid2
     &                             + d2eda2a2*da2dxid*da2dzib
     &                             + d2eda1a2*da1dxid*da2dzib
     &                             + d2eda1a2*da2dxid*da1dzib
                  hessy(3,ib) = hessy(3,ib) + dedang2*dzibyid2
     &                             + d2eda2a2*da2dyid*da2dzib
     &                             + d2eda1a2*da1dyid*da2dzib
     &                             + d2eda1a2*da2dyid*da1dzib
                  hessz(3,ib) = hessz(3,ib) + dedang2*dzibzid2
     &                             + d2eda2a2*da2dzid*da2dzib
     &                             + d2eda1a2*da1dzid*da2dzib
     &                             + d2eda1a2*da2dzid*da1dzib
                  hessx(1,ic) = hessx(1,ic) + dedang2*dxicxid2
     &                             + d2eda2a2*da2dxid*da2dxic
     &                             + d2eda1a2*da1dxid*da2dxic
     &                             + d2eda1a2*da2dxid*da1dxic
                  hessy(1,ic) = hessy(1,ic) + dedang2*dxicyid2
     &                             + d2eda2a2*da2dyid*da2dxic
     &                             + d2eda1a2*da1dyid*da2dxic
     &                             + d2eda1a2*da2dyid*da1dxic
                  hessz(1,ic) = hessz(1,ic) + dedang2*dxiczid2
     &                             + d2eda2a2*da2dzid*da2dxic
     &                             + d2eda1a2*da1dzid*da2dxic
     &                             + d2eda1a2*da2dzid*da1dxic
                  hessx(2,ic) = hessx(2,ic) + dedang2*dyicxid2
     &                             + d2eda2a2*da2dxid*da2dyic
     &                             + d2eda1a2*da1dxid*da2dyic
     &                             + d2eda1a2*da2dxid*da1dyic
                  hessy(2,ic) = hessy(2,ic) + dedang2*dyicyid2
     &                             + d2eda2a2*da2dyid*da2dyic
     &                             + d2eda1a2*da1dyid*da2dyic
     &                             + d2eda1a2*da2dyid*da1dyic
                  hessz(2,ic) = hessz(2,ic) + dedang2*dyiczid2
     &                             + d2eda2a2*da2dzid*da2dyic
     &                             + d2eda1a2*da1dzid*da2dyic
     &                             + d2eda1a2*da2dzid*da1dyic
                  hessx(3,ic) = hessx(3,ic) + dedang2*dzicxid2
     &                             + d2eda2a2*da2dxid*da2dzic
     &                             + d2eda1a2*da1dxid*da2dzic
     &                             + d2eda1a2*da2dxid*da1dzic
                  hessy(3,ic) = hessy(3,ic) + dedang2*dzicyid2
     &                             + d2eda2a2*da2dyid*da2dzic
     &                             + d2eda1a2*da1dyid*da2dzic
     &                             + d2eda1a2*da2dyid*da1dzic
                  hessz(3,ic) = hessz(3,ic) + dedang2*dziczid2
     &                             + d2eda2a2*da2dzid*da2dzic
     &                             + d2eda1a2*da1dzid*da2dzic
     &                             + d2eda1a2*da2dzid*da1dzic
                  hessx(1,ie) = hessx(1,ie) + dedang2*dxidxie2
     &                             + d2eda2a2*da2dxid*da2dxie
     &                             + d2eda1a2*da1dxid*da2dxie
                  hessy(1,ie) = hessy(1,ie) + dedang2*dyidxie2
     &                             + d2eda2a2*da2dyid*da2dxie
     &                             + d2eda1a2*da1dyid*da2dxie
                  hessz(1,ie) = hessz(1,ie) + dedang2*dzidxie2
     &                             + d2eda2a2*da2dzid*da2dxie
     &                             + d2eda1a2*da1dzid*da2dxie
                  hessx(2,ie) = hessx(2,ie) + dedang2*dxidyie2
     &                             + d2eda2a2*da2dxid*da2dyie
     &                             + d2eda1a2*da1dxid*da2dyie
                  hessy(2,ie) = hessy(2,ie) + dedang2*dyidyie2
     &                             + d2eda2a2*da2dyid*da2dyie
     &                             + d2eda1a2*da1dyid*da2dyie
                  hessz(2,ie) = hessz(2,ie) + dedang2*dzidyie2
     &                             + d2eda2a2*da2dzid*da2dyie
     &                             + d2eda1a2*da1dzid*da2dyie
                  hessx(3,ie) = hessx(3,ie) + dedang2*dxidzie2
     &                             + d2eda2a2*da2dxid*da2dzie
     &                             + d2eda1a2*da1dxid*da2dzie
                  hessy(3,ie) = hessy(3,ie) + dedang2*dyidzie2
     &                             + d2eda2a2*da2dyid*da2dzie
     &                             + d2eda1a2*da1dyid*da2dzie
                  hessz(3,ie) = hessz(3,ie) + dedang2*dzidzie2
     &                             + d2eda2a2*da2dzid*da2dzie
     &                             + d2eda1a2*da1dzid*da2dzie
               else if (i .eq. ie) then
                  hessx(1,ie) = hessx(1,ie) + dedang2*dxiexie2
     &                             + d2eda2a2*da2dxie*da2dxie
                  hessy(1,ie) = hessy(1,ie) + dedang2*dxieyie2
     &                             + d2eda2a2*da2dxie*da2dyie
                  hessz(1,ie) = hessz(1,ie) + dedang2*dxiezie2
     &                             + d2eda2a2*da2dxie*da2dzie
                  hessx(2,ie) = hessx(2,ie) + dedang2*dxieyie2
     &                             + d2eda2a2*da2dxie*da2dyie
                  hessy(2,ie) = hessy(2,ie) + dedang2*dyieyie2
     &                             + d2eda2a2*da2dyie*da2dyie
                  hessz(2,ie) = hessz(2,ie) + dedang2*dyiezie2
     &                             + d2eda2a2*da2dyie*da2dzie
                  hessx(3,ie) = hessx(3,ie) + dedang2*dxiezie2
     &                             + d2eda2a2*da2dxie*da2dzie
                  hessy(3,ie) = hessy(3,ie) + dedang2*dyiezie2
     &                             + d2eda2a2*da2dyie*da2dzie
                  hessz(3,ie) = hessz(3,ie) + dedang2*dziezie2
     &                             + d2eda2a2*da2dzie*da2dzie
                  hessx(1,ia) = hessx(1,ia) + d2eda1a2*da2dxie*da1dxia
                  hessy(1,ia) = hessy(1,ia) + d2eda1a2*da2dyie*da1dxia
                  hessz(1,ia) = hessz(1,ia) + d2eda1a2*da2dzie*da1dxia
                  hessx(2,ia) = hessx(2,ia) + d2eda1a2*da2dxie*da1dyia
                  hessy(2,ia) = hessy(2,ia) + d2eda1a2*da2dyie*da1dyia
                  hessz(2,ia) = hessz(2,ia) + d2eda1a2*da2dzie*da1dyia
                  hessx(3,ia) = hessx(3,ia) + d2eda1a2*da2dxie*da1dzia
                  hessy(3,ia) = hessy(3,ia) + d2eda1a2*da2dyie*da1dzia
                  hessz(3,ia) = hessz(3,ia) + d2eda1a2*da2dzie*da1dzia
                  hessx(1,ib) = hessx(1,ib) + dedang2*dxibxie2
     &                             + d2eda2a2*da2dxie*da2dxib
     &                             + d2eda1a2*da2dxie*da1dxib
                  hessy(1,ib) = hessy(1,ib) + dedang2*dxibyie2
     &                             + d2eda2a2*da2dyie*da2dxib
     &                             + d2eda1a2*da2dyie*da1dxib
                  hessz(1,ib) = hessz(1,ib) + dedang2*dxibzie2
     &                             + d2eda2a2*da2dzie*da2dxib
     &                             + d2eda1a2*da2dzie*da1dxib
                  hessx(2,ib) = hessx(2,ib) + dedang2*dyibxie2
     &                             + d2eda2a2*da2dxie*da2dyib
     &                             + d2eda1a2*da2dxie*da1dyib
                  hessy(2,ib) = hessy(2,ib) + dedang2*dyibyie2
     &                             + d2eda2a2*da2dyie*da2dyib
     &                             + d2eda1a2*da2dyie*da1dyib
                  hessz(2,ib) = hessz(2,ib) + dedang2*dyibzie2
     &                             + d2eda2a2*da2dzie*da2dyib
     &                             + d2eda1a2*da2dzie*da1dyib
                  hessx(3,ib) = hessx(3,ib) + dedang2*dzibxie2
     &                             + d2eda2a2*da2dxie*da2dzib
     &                             + d2eda1a2*da2dxie*da1dzib
                  hessy(3,ib) = hessy(3,ib) + dedang2*dzibyie2
     &                             + d2eda2a2*da2dyie*da2dzib
     &                             + d2eda1a2*da2dyie*da1dzib
                  hessz(3,ib) = hessz(3,ib) + dedang2*dzibzie2
     &                             + d2eda2a2*da2dzie*da2dzib
     &                             + d2eda1a2*da2dzie*da1dzib
                  hessx(1,ic) = hessx(1,ic) + dedang2*dxicxie2
     &                             + d2eda2a2*da2dxie*da2dxic
     &                             + d2eda1a2*da2dxie*da1dxic
                  hessy(1,ic) = hessy(1,ic) + dedang2*dxicyie2
     &                             + d2eda2a2*da2dyie*da2dxic
     &                             + d2eda1a2*da2dyie*da1dxic
                  hessz(1,ic) = hessz(1,ic) + dedang2*dxiczie2
     &                             + d2eda2a2*da2dzie*da2dxic
     &                             + d2eda1a2*da2dzie*da1dxic
                  hessx(2,ic) = hessx(2,ic) + dedang2*dyicxie2
     &                             + d2eda2a2*da2dxie*da2dyic
     &                             + d2eda1a2*da2dxie*da1dyic
                  hessy(2,ic) = hessy(2,ic) + dedang2*dyicyie2
     &                             + d2eda2a2*da2dyie*da2dyic
     &                             + d2eda1a2*da2dyie*da1dyic
                  hessz(2,ic) = hessz(2,ic) + dedang2*dyiczie2
     &                             + d2eda2a2*da2dzie*da2dyic
     &                             + d2eda1a2*da2dzie*da1dyic
                  hessx(3,ic) = hessx(3,ic) + dedang2*dzicxie2
     &                             + d2eda2a2*da2dxie*da2dzic
     &                             + d2eda1a2*da2dxie*da1dzic
                  hessy(3,ic) = hessy(3,ic) + dedang2*dzicyie2
     &                             + d2eda2a2*da2dyie*da2dzic
     &                             + d2eda1a2*da2dyie*da1dzic
                  hessz(3,ic) = hessz(3,ic) + dedang2*dziczie2
     &                             + d2eda2a2*da2dzie*da2dzic
     &                             + d2eda1a2*da2dzie*da1dzic
                  hessx(1,id) = hessx(1,id) + dedang2*dxidxie2
     &                             + d2eda2a2*da2dxid*da2dxie
     &                             + d2eda1a2*da1dxid*da2dxie
                  hessy(1,id) = hessy(1,id) + dedang2*dxidyie2
     &                             + d2eda2a2*da2dxid*da2dyie
     &                             + d2eda1a2*da1dxid*da2dyie
                  hessz(1,id) = hessz(1,id) + dedang2*dxidzie2
     &                             + d2eda2a2*da2dxid*da2dzie
     &                             + d2eda1a2*da1dxid*da2dzie
                  hessx(2,id) = hessx(2,id) + dedang2*dyidxie2
     &                             + d2eda2a2*da2dyid*da2dxie
     &                             + d2eda1a2*da1dyid*da2dxie
                  hessy(2,id) = hessy(2,id) + dedang2*dyidyie2
     &                             + d2eda2a2*da2dyid*da2dyie
     &                             + d2eda1a2*da1dyid*da2dyie
                  hessz(2,id) = hessz(2,id) + dedang2*dyidzie2
     &                             + d2eda2a2*da2dyid*da2dzie
     &                             + d2eda1a2*da1dyid*da2dzie
                  hessx(3,id) = hessx(3,id) + dedang2*dzidxie2
     &                             + d2eda2a2*da2dzid*da2dxie
     &                             + d2eda1a2*da1dzid*da2dxie
                  hessy(3,id) = hessy(3,id) + dedang2*dzidyie2
     &                             + d2eda2a2*da2dzid*da2dyie
     &                             + d2eda1a2*da1dzid*da2dyie
                  hessz(3,id) = hessz(3,id) + dedang2*dzidzie2
     &                             + d2eda2a2*da2dzid*da2dzie
     &                             + d2eda1a2*da1dzid*da2dzie
               end if
            end if
         end if
      end do
      return
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 2003 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine etortor3  --  torsion-torsion energy & analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "etortor3" calculates the torsion-torsion potential energy;
c     also partitions the energy terms among the atoms
c
c
      subroutine etortor3
      use action
      use analyz
      use atoms
      use bitor
      use bound
      use energi
      use group
      use inform
      use iounit
      use ktrtor
      use math
      use torpot
      use tortor
      use usage
      implicit none
      integer i,k,itortor
      integer pos1,pos2
      integer ia,ib,ic,id,ie
      integer nlo,nhi,nt
      integer xlo,ylo
      real*8 e,fgrp,sign
      real*8 angle1,angle2
      real*8 value1,value2
      real*8 cosine1,cosine2
      real*8 xt,yt,zt,rt2
      real*8 xu,yu,zu,ru2
      real*8 xv,yv,zv,rv2
      real*8 rtru,rurv
      real*8 x1l,x1u
      real*8 y1l,y1u
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xie,yie,zie
      real*8 xba,yba,zba
      real*8 xdc,ydc,zdc
      real*8 xcb,ycb,zcb
      real*8 xed,yed,zed
      real*8 ftt(4),ft12(4)
      real*8 ft1(4),ft2(4)
      logical proceed
      logical header,huge
c
c
c     zero out the torsion-torsion energy and partitioning terms
c
      nett = 0
      ett = 0.0d0
      do i = 1, n
         aett(i) = 0.0d0
      end do
      if (ntortor .eq. 0)  return
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. ntortor.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Torsion-Torsion Interactions :',
     &           //,' Type',17x,'Atom Numbers',16x,'Angle1',
     &              4x,'Angle2',6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ntortor,itt,ibitor,
!$OMP& use,x,y,z,tnx,ttx,tny,tty,tbf,tbx,tby,tbxy,ttorunit,
!$OMP& use_group,use_polymer,verbose,debug,header,iout)
!$OMP& shared(ett,nett,aett)
!$OMP DO reduction(+:ett,nett,aett)
c
c     calculate the torsion-torsion interaction energy term
c
      do itortor = 1, ntortor
         i = itt(1,itortor)
         k = itt(2,itortor)
         if (itt(3,itortor) .eq. 1) then
            ia = ibitor(1,i)
            ib = ibitor(2,i)
            ic = ibitor(3,i)
            id = ibitor(4,i)
            ie = ibitor(5,i)
         else
            ia = ibitor(5,i)
            ib = ibitor(4,i)
            ic = ibitor(3,i)
            id = ibitor(2,i)
            ie = ibitor(1,i)
         end if
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ib,ic,id,ie,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or. use(ic)
     &                               .or. use(id) .or. use(ie))
c
c     compute the value of the torsional angles
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)
            xie = x(ie)
            yie = y(ie)
            zie = z(ie)
            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
            xed = xie - xid
            yed = yie - yid
            zed = zie - zid
            if (use_polymer) then
               call image (xba,yba,zba)
               call image (xcb,ycb,zcb)
               call image (xdc,ydc,zdc)
               call image (xed,yed,zed)
            end if
            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
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            xv = ydc*zed - yed*zdc
            yv = zdc*xed - zed*xdc
            zv = xdc*yed - xed*ydc
            rv2 = xv*xv + yv*yv + zv*zv
            rurv = sqrt(ru2 * rv2)
            if (rtru.ne.0.0d0 .and. rurv.ne.0.0d0) then
               cosine1 = (xt*xu + yt*yu + zt*zu) / rtru
               cosine1 = min(1.0d0,max(-1.0d0,cosine1))
               angle1 = radian * acos(cosine1)
               sign = xba*xu + yba*yu + zba*zu
               if (sign .lt. 0.0d0)  angle1 = -angle1
               value1 = angle1
               cosine2 = (xu*xv + yu*yv + zu*zv) / rurv
               cosine2 = min(1.0d0,max(-1.0d0,cosine2))
               angle2 = radian * acos(cosine2)
               sign = xcb*xv + ycb*yv + zcb*zv
               if (sign .lt. 0.0d0)  angle2 = -angle2
               value2 = angle2
c
c     check for inverted chirality at the central atom
c
               call chkttor (ib,ic,id,sign,value1,value2)
c
c     use bicubic interpolation to compute spline values
c
               nlo = 1
               nhi = tnx(k)
               do while (nhi-nlo .gt. 1)
                  nt = (nhi+nlo) / 2
                  if (ttx(nt,k) .gt. value1) then
                     nhi = nt
                  else
                     nlo = nt
                  end if
               end do
               xlo = nlo
               nlo = 1
               nhi = tny(k)
               do while (nhi-nlo .gt. 1)
                  nt = (nhi + nlo)/2
                  if (tty(nt,k) .gt. value2) then
                     nhi = nt
                  else
                     nlo = nt
                  end if
               end do
               ylo = nlo
               x1l = ttx(xlo,k)
               x1u = ttx(xlo+1,k)
               y1l = tty(ylo,k)
               y1u = tty(ylo+1,k)
               pos2 = ylo*tnx(k) + xlo
               pos1 = pos2 - tnx(k)
               ftt(1) = tbf(pos1,k)
               ftt(2) = tbf(pos1+1,k)
               ftt(3) = tbf(pos2+1,k)
               ftt(4) = tbf(pos2,k)
               ft1(1) = tbx(pos1,k)
               ft1(2) = tbx(pos1+1,k)
               ft1(3) = tbx(pos2+1,k)
               ft1(4) = tbx(pos2,k)
               ft2(1) = tby(pos1,k)
               ft2(2) = tby(pos1+1,k)
               ft2(3) = tby(pos2+1,k)
               ft2(4) = tby(pos2,k)
               ft12(1) = tbxy(pos1,k)
               ft12(2) = tbxy(pos1+1,k)
               ft12(3) = tbxy(pos2+1,k)
               ft12(4) = tbxy(pos2,k)
               call bcuint (ftt,ft1,ft2,ft12,x1l,x1u,
     &                      y1l,y1u,value1,value2,e)
               e = ttorunit * e
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the total torsion-torsion energy
c
               nett = nett + 1
               ett = ett + e
               aett(ib) = aett(ib) + e/3.0d0
               aett(ic) = aett(ic) + e/3.0d0
               aett(id) = aett(id) + e/3.0d0
c
c     print a message if the energy of this interaction is large
c
               huge = (e .gt. 5.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Individual Torsion-Torsion',
     &                          ' Interactions :',
     &                       //,' Type',17x,'Atom Numbers',16x,'Angle1',
     &                          4x,'Angle2',6x,'Energy',/)
                  end if
                  write (iout,30)  ia,ib,ic,id,ie,angle1,angle2,e
   30             format (' TorTor',2x,5i7,2x,2f10.4,f12.4)
               end if
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine eurey  --  Urey-Bradley potential energy  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "eurey" calculates the Urey-Bradley 1-3 interaction energy
c
c
      subroutine eurey
      use atoms
      use bound
      use energi
      use group
      use urey
      use urypot
      use usage
      implicit none
      integer i,ia,ic
      real*8 e,ideal,force
      real*8 dt,dt2,fgrp
      real*8 xac,yac,zac,rac
      logical proceed
c
c
c     zero out the Urey-Bradley interaction energy
c
      eub = 0.0d0
      if (nurey .eq. 0)  return
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nurey,iury,ul,uk,
!$OMP& use,x,y,z,cury,qury,ureyunit,use_group,use_polymer)
!$OMP& shared(eub)
!$OMP DO reduction(+:eub)
c
c     calculate the Urey-Bradley 1-3 energy term
c
      do i = 1, nurey
         ia = iury(1,i)
         ic = iury(3,i)
         ideal = ul(i)
         force = uk(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ic,0,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ic))
c
c     compute the value of the 1-3 distance deviation
c
         if (proceed) then
            xac = x(ia) - x(ic)
            yac = y(ia) - y(ic)
            zac = z(ia) - z(ic)
            if (use_polymer)  call image (xac,yac,zac)
            rac = sqrt(xac*xac + yac*yac + zac*zac)
            dt = rac - ideal
            dt2 = dt * dt
c
c     calculate the Urey-Bradley energy for this interaction
c
            e = ureyunit * force * dt2 * (1.0d0+cury*dt+qury*dt2)
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total Urey-Bradley energy
c
            eub = eub + e
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eurey1  --  bond stretch energy & derivatives  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "eurey1" calculates the Urey-Bradley interaction energy and
c     its first derivatives with respect to Cartesian coordinates
c
c
      subroutine eurey1
      use atoms
      use bound
      use deriv
      use energi
      use group
      use urey
      use urypot
      use usage
      use virial
      implicit none
      integer i,ia,ic
      real*8 e,de
      real*8 ideal,force
      real*8 dt,dt2,deddt,fgrp
      real*8 dedx,dedy,dedz
      real*8 xac,yac,zac,rac
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical proceed
c
c
c     zero out the Urey-Bradley energy and first derivatives
c
      eub = 0.0d0
      do i = 1, n
         deub(1,i) = 0.0d0
         deub(2,i) = 0.0d0
         deub(3,i) = 0.0d0
      end do
      if (nurey .eq. 0)  return
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nurey,iury,ul,uk,
!$OMP& use,x,y,z,cury,qury,ureyunit,use_group,use_polymer)
!$OMP& shared(eub,deub,vir)
!$OMP DO reduction(+:eub,deub,vir)
c
c     calculate the Urey-Bradley 1-3 energy and first derivatives
c
      do i = 1, nurey
         ia = iury(1,i)
         ic = iury(3,i)
         ideal = ul(i)
         force = uk(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ic,0,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ic))
c
c     compute the value of the 1-3 distance deviation
c
         if (proceed) then
            xac = x(ia) - x(ic)
            yac = y(ia) - y(ic)
            zac = z(ia) - z(ic)
            if (use_polymer)  call image (xac,yac,zac)
            rac = sqrt(xac*xac + yac*yac + zac*zac)
            dt = rac - ideal
            dt2 = dt * dt
            e = ureyunit * force * dt2 * (1.0d0+cury*dt+qury*dt2)
            deddt = 2.0d0 * ureyunit * force * dt
     &                 * (1.0d0+1.5d0*cury*dt+2.0d0*qury*dt2)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               e = e * fgrp
               deddt = deddt * fgrp
            end if
c
c     compute chain rule terms needed for derivatives
c
            de = deddt / rac
            dedx = de * xac
            dedy = de * yac
            dedz = de * zac
c
c     increment the total Urey-Bradley energy and first derivatives
c
            eub = eub + e
            deub(1,ia) = deub(1,ia) + dedx
            deub(2,ia) = deub(2,ia) + dedy
            deub(3,ia) = deub(3,ia) + dedz
            deub(1,ic) = deub(1,ic) - dedx
            deub(2,ic) = deub(2,ic) - dedy
            deub(3,ic) = deub(3,ic) - dedz
c
c     increment the internal virial tensor components
c
            vxx = xac * dedx
            vyx = yac * dedx
            vzx = zac * dedx
            vyy = yac * dedy
            vzy = zac * dedy
            vzz = zac * dedz
            vir(1,1) = vir(1,1) + vxx
            vir(2,1) = vir(2,1) + vyx
            vir(3,1) = vir(3,1) + vzx
            vir(1,2) = vir(1,2) + vyx
            vir(2,2) = vir(2,2) + vyy
            vir(3,2) = vir(3,2) + vzy
            vir(1,3) = vir(1,3) + vzx
            vir(2,3) = vir(2,3) + vzy
            vir(3,3) = vir(3,3) + vzz
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eurey2  --  atom-by-atom Urey-Bradley Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "eurey2" calculates second derivatives of the Urey-Bradley
c     interaction energy for a single atom at a time
c
c
      subroutine eurey2 (i)
      use atoms
      use bound
      use couple
      use group
      use hessn
      use urey
      use urypot
      implicit none
      integer i,j,ia,ic,iurey
      real*8 ideal,force,fgrp
      real*8 xac,yac,zac
      real*8 rac,rac2
      real*8 dt,dt2,term
      real*8 termx,termy,termz
      real*8 de,deddt,d2eddt2
      real*8 d2e(3,3)
      logical proceed
c
c
c     calculate the Urey-Bradley interaction Hessian elements
c
      do iurey = 1, nurey
         ia = iury(1,iurey)
         ic = iury(3,iurey)
         ideal = ul(iurey)
         force = uk(iurey)
c
c     decide whether to compute the current interaction
c
         proceed = (i.eq.ia .or. i.eq.ic)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,ia,ic,0,0,0,0)
c
c     compute the value of the 1-3 distance deviation
c
         if (proceed) then
            if (i .eq. ic) then
               ic = ia
               ia = i
            end if
            xac = x(ia) - x(ic)
            yac = y(ia) - y(ic)
            zac = z(ia) - z(ic)
            if (use_polymer)  call image (xac,yac,zac)
            rac2 = xac*xac + yac*yac + zac*zac
            rac = sqrt(rac2)
            dt = rac - ideal
            dt2 = dt * dt
            deddt = 2.0d0 * ureyunit * force * dt
     &                 * (1.0d0+1.5d0*cury*dt+2.0d0*qury*dt2)
            d2eddt2 = 2.0d0 * ureyunit * force
     &                   * (1.0d0+3.0d0*cury*dt+6.0d0*qury*dt2)
c
c     scale the interaction based on its group membership
c
            if (use_group) then
               deddt = deddt * fgrp
               d2eddt2 = d2eddt2 * fgrp
            end if
c
c     set the chain rule terms for the Hessian elements
c
            de = deddt / rac
            term = (d2eddt2-de) / rac2
            termx = term * xac
            termy = term * yac
            termz = term * zac
            d2e(1,1) = termx*xac + de
            d2e(1,2) = termx*yac
            d2e(1,3) = termx*zac
            d2e(2,1) = d2e(1,2)
            d2e(2,2) = termy*yac + de
            d2e(2,3) = termy*zac
            d2e(3,1) = d2e(1,3)
            d2e(3,2) = d2e(2,3)
            d2e(3,3) = termz*zac + de
c
c     increment diagonal and off-diagonal Hessian elements
c
            do j = 1, 3
               hessx(j,ia) = hessx(j,ia) + d2e(1,j)
               hessy(j,ia) = hessy(j,ia) + d2e(2,j)
               hessz(j,ia) = hessz(j,ia) + d2e(3,j)
               hessx(j,ic) = hessx(j,ic) - d2e(1,j)
               hessy(j,ic) = hessy(j,ic) - d2e(2,j)
               hessz(j,ic) = hessz(j,ic) - d2e(3,j)
            end do
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine eurey3  --  Urey-Bradley energy & analysis  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "eurey3" calculates the Urey-Bradley energy; also
c     partitions the energy among the atoms
c
c
      subroutine eurey3
      use action
      use analyz
      use atomid
      use atoms
      use bound
      use energi
      use group
      use inform
      use iounit
      use urey
      use urypot
      use usage
      implicit none
      integer i,ia,ib,ic
      real*8 e,ideal,force
      real*8 dt,dt2,fgrp
      real*8 xac,yac,zac,rac
      logical proceed
      logical header,huge
c
c
c     zero out the Urey-Bradley energy and partitioning terms
c
      neub = 0
      eub = 0.0d0
      do i = 1, n
         aeub(i) = 0.0d0
      end do
      if (nurey .eq. 0)  return
c
c     print header information if debug output was requested
c
      header = .true.
      if (debug .and. nurey.ne.0) then
         header = .false.
         write (iout,10)
   10    format (/,' Individual Urey-Bradley Interactions :',
     &           //,' Type',18x,'Atom Names',18x,'Ideal',
     &              4x,'Actual',6x,'Energy',/)
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nurey,iury,ul,uk,
!$OMP& use,x,y,z,cury,qury,ureyunit,use_group,use_polymer,
!$OMP& name,verbose,debug,header,iout)
!$OMP& shared(eub,neub,aeub)
!$OMP DO reduction(+:eub,neub,aeub)
c
c     calculate the Urey-Bradley 1-3 energy term
c
      do i = 1, nurey
         ia = iury(1,i)
         ib = iury(2,i)
         ic = iury(3,i)
         ideal = ul(i)
         force = uk(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,ia,ic,0,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ic))
c
c     compute the value of the 1-3 distance deviation
c
         if (proceed) then
            xac = x(ia) - x(ic)
            yac = y(ia) - y(ic)
            zac = z(ia) - z(ic)
            if (use_polymer)  call image (xac,yac,zac)
            rac = sqrt(xac*xac + yac*yac + zac*zac)
            dt = rac - ideal
            dt2 = dt * dt
c
c     calculate the Urey-Bradley energy for this interaction
c
            e = ureyunit * force * dt2 * (1.0d0+cury*dt+qury*dt2)
c
c     scale the interaction based on its group membership
c
            if (use_group)  e = e * fgrp
c
c     increment the total Urey-Bradley energy
c
            neub = neub + 1
            eub = eub + e
            aeub(ia) = aeub(ia) + 0.5d0*e
            aeub(ic) = aeub(ic) + 0.5d0*e
c
c     print a message if the energy of this interaction is large
c
            huge = (e .gt. 5.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Individual Urey-Bradley Interactions :',
     &                    //,' Type',18x,'Atom Names',18x,'Ideal',
     &                       4x,'Actual',6x,'Energy',/)
               end if
               write (iout,30)  ia,name(ia),ib,name(ib),
     &                          ic,name(ic),ideal,rac,e
   30          format (' UreyBrad',2x,i7,'-',a3,i7,'-',a3,
     &                    i7,'-',a3,2x,2f10.4,f12.4)
            end if
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2010 by Chuanjie Wu and Jay William Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine evcorr  --  long range correction to energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "evcorr" computes a long range correction for van der Waals
c     or dispersion energy via numerical integration
c
c     literature reference:
c
c     M. P. Allen and D. J. Tildesley, "Computer Simulation of
c     Liquids, 2nd Ed.", Oxford University Press, 2017, Section 2.8
c
c
      subroutine evcorr (mode,elrc)
      use atomid
      use atoms
      use bound
      use boxes
      use kdsp
      use limits
      use math
      use mutant
      use potent
      use shunt
      use vdw
      use vdwpot
      implicit none
      integer i,j,k,it,kt
      integer nstep,ndelta,nvt
      integer, allocatable :: ivt(:)
      integer, allocatable :: jvt(:)
      integer, allocatable :: mvt(:)
      real*8 elrc,etot
      real*8 range,rdelta
      real*8 fi,fk,fim,fkm,fik
      real*8 e,eps,vlam1
      real*8 offset,taper
      real*8 rv,rv2,rv6,rv7
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7
      real*8 cik,p,p6,p12
      real*8 rho,tau,tau7
      real*8 expterm
      character*6 mode
c
c
c     zero out the long range van der Waals correction
c
      elrc = 0.0d0
c
c     only applicable if periodic boundaries are in use
c
      if (.not. use_bounds)  return
c
c     set the coefficients for the switching function
c
      call switch (mode)
c
c     set number of steps and range for numerical integration
c
      nstep = 2
      range = 100.0d0
      ndelta = int(dble(nstep)*(range-cut))
      rdelta = (range-cut) / dble(ndelta)
      offset = cut - 0.5d0*rdelta
      vlam1 = 1.0d0 - vlambda
c
c     perform dynamic allocation of some local arrays
c
      allocate (ivt(n))
      allocate (jvt(n))
      allocate (mvt(n))
c
c     count the number of types and their frequencies
c
      nvt = 0
      do i = 1, n
         if (use_vdw)  it = jvdw(i)
         if (use_disp)  it = class(i)
         do k = 1, nvt
            if (ivt(k) .eq. it) then
               jvt(k) = jvt(k) + 1
               if (mut(i))  mvt(k) = mvt(k) + 1
               goto 10
            end if
         end do
         nvt = nvt + 1
         ivt(nvt) = it
         jvt(nvt) = 1
         mvt(nvt) = 0
         if (mut(i))  mvt(nvt) = 1
   10    continue
      end do
c
c     find the correction energy via double loop search
c
      do i = 1, nvt
         it = ivt(i)
         fi = 4.0d0 * pi * dble(jvt(i))
         fim = 4.0d0 * pi * dble(mvt(i))
         do k = i, nvt
            kt = ivt(k)
            fk = dble(jvt(k))
            fkm = dble(mvt(k))
c
c     set decoupling or annihilation for intraligand interactions
c
            if (vcouple .eq. 0) then
               fik = fi*fk - vlam1*(fim*(fk-fkm)+(fi-fim)*fkm)
            else
               fik = vlambda*fi*fk + vlam1*(fi-fim)*(fk-fkm)
            end if
            if (k .eq. i)  fik = 0.5d0 * fik
            if (use_disp) then
               cik = dspsix(it) * dspsix(kt)
            else
               rv = radmin(kt,it)
               eps = epsilon(kt,it)
               rv2 = rv * rv
               rv6 = rv2 * rv2 * rv2
               rv7 = rv6 * rv
            end if
            etot = 0.0d0
            do j = 1, ndelta
               r = offset + dble(j)*rdelta
               r2 = r * r
               r3 = r2 * r
               r6 = r3 * r3
               r7 = r6 * r
               e = 0.0d0
               if (use_disp) then
                  e = -cik / r6
               else if (vdwtyp .eq. 'LENNARD-JONES') then
                  p6 = rv6 / r6
                  p12 = p6 * p6
                  e = eps * (p12 - 2.0d0*p6)
               else if (vdwtyp .eq. 'BUFFERED-14-7') then
                  rho = r7 + ghal*rv7
                  tau = (dhal+1.0d0) / (r+dhal*rv)
                  tau7 = tau**7
                  e = eps * rv7 * tau7
     &                   * ((ghal+1.0d0)*rv7/rho-2.0d0)
               else if (vdwtyp.eq.'BUCKINGHAM' .or.
     &                  vdwtyp.eq.'MM3-HBOND') then
                  p = sqrt(rv2/r2)
                  p6 = rv6 / r6
                  expterm = abuck * exp(-bbuck/p)
                  e = eps * (expterm - cbuck*p6)
               end if
               if (r .lt. off) then
                  r4 = r2 * r2
                  r5 = r2 * r3
                  taper = c5*r5 + c4*r4 + c3*r3 + c2*r2 + c1*r + c0
                  e = e * (1.0d0-taper)
               end if
               etot = etot + e*rdelta*r2
            end do
            elrc = elrc + fik*etot
         end do
      end do
      elrc = elrc / volbox
c
c     perform deallocation of some local arrays
c
      deallocate (ivt)
      deallocate (jvt)
      deallocate (mvt)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine evcorr1  --  long range energy & virial term  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "evcorr1" computes a long range correction for van der Waals
c     or dispersion energy and virial via numerical integration
c
c     literature reference:
c
c     M. P. Allen and D. J. Tildesley, "Computer Simulation of
c     Liquids, 2nd Ed.", Oxford University Press, 2017, Section 2.8
c
c
      subroutine evcorr1 (mode,elrc,vlrc)
      use atomid
      use atoms
      use bound
      use boxes
      use kdsp
      use limits
      use math
      use mutant
      use potent
      use shunt
      use vdw
      use vdwpot
      implicit none
      integer i,j,k,it,kt
      integer nstep,ndelta,nvt
      integer, allocatable :: ivt(:)
      integer, allocatable :: jvt(:)
      integer, allocatable :: mvt(:)
      real*8 elrc,vlrc
      real*8 etot,vtot
      real*8 range,rdelta
      real*8 fi,fk,fim,fkm,fik
      real*8 e,de,eps
      real*8 offset,vlam1
      real*8 taper,dtaper
      real*8 rv,rv2,rv6,rv7
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7
      real*8 cik,p,p6,p12
      real*8 rho,tau,tau7
      real*8 dtau,gtau
      real*8 rvterm,expterm
      character*6 mode
c
c
c     zero out the long range van der Waals corrections
c
      elrc = 0.0d0
      vlrc = 0.0d0
c
c     only applicable if periodic boundaries are in use
c
      if (.not. use_bounds)  return
c
c     set the coefficients for the switching function
c
      call switch (mode)
c
c     set number of steps and range for numerical integration
c
      nstep = 2
      range = 100.0d0
      ndelta = int(dble(nstep)*(range-cut))
      rdelta = (range-cut) / dble(ndelta)
      offset = cut - 0.5d0*rdelta
      vlam1 = 1.0d0 - vlambda
c
c     perform dynamic allocation of some local arrays
c
      allocate (ivt(n))
      allocate (jvt(n))
      allocate (mvt(n))
c
c     count the number of vdw types and their frequencies
c
      nvt = 0
      do i = 1, n
         if (use_vdw)  it = jvdw(i)
         if (use_disp)  it = class(i)
         do k = 1, nvt
            if (ivt(k) .eq. it) then
               jvt(k) = jvt(k) + 1
               if (mut(i))  mvt(k) = mvt(k) + 1
               goto 10
            end if
         end do
         nvt = nvt + 1
         ivt(nvt) = it
         jvt(nvt) = 1
         mvt(nvt) = 0
         if (mut(i))  mvt(nvt) = 1
   10    continue
      end do
c
c     find the van der Waals energy via double loop search
c
      do i = 1, nvt
         it = ivt(i)
         fi = 4.0d0 * pi * dble(jvt(i))
         fim = 4.0d0 * pi * dble(mvt(i))
         do k = i, nvt
            kt = ivt(k)
            fk = dble(jvt(k))
            fkm = dble(mvt(k))
c
c     set decoupling or annihilation for intraligand interactions
c
            if (vcouple .eq. 0) then
               fik = fi*fk - vlam1*(fim*(fk-fkm)+(fi-fim)*fkm)
            else
               fik = vlambda*fi*fk + vlam1*(fi-fim)*(fk-fkm)
            end if
            if (k .eq. i)  fik = 0.5d0 * fik
            if (use_disp) then
               cik = dspsix(it) * dspsix(kt)
            else
               rv = radmin(kt,it)
               eps = epsilon(kt,it)
               rv2 = rv * rv
               rv6 = rv2 * rv2 * rv2
               rv7 = rv6 * rv
            end if
            etot = 0.0d0
            vtot = 0.0d0
            do j = 1, ndelta
               r = offset + dble(j)*rdelta
               r2 = r * r
               r3 = r2 * r
               r6 = r3 * r3
               r7 = r6 * r
               e = 0.0d0
               de = 0.0d0
               if (use_disp) then
                  e = -cik / r6
                  de = 6.0d0 * cik / r7
               else if (vdwtyp .eq. 'LENNARD-JONES') then
                  p6 = rv6 / r6
                  p12 = p6 * p6
                  e = eps * (p12 - 2.0d0*p6)
                  de = eps * (p12-p6) * (-12.0d0/r)
               else if (vdwtyp .eq. 'BUFFERED-14-7') then
                  rho = r7 + ghal*rv7
                  tau = (dhal+1.0d0) / (r+dhal*rv)
                  tau7 = tau**7
                  dtau = tau / (dhal+1.0d0)
                  gtau = eps*tau7*r6*(ghal+1.0d0)*(rv7/rho)**2
                  e = eps * rv7 * tau7 * ((ghal+1.0d0)*rv7/rho-2.0d0)
                  de = -7.0d0 * (dtau*e+gtau)
               else if (vdwtyp.eq.'BUCKINGHAM' .or.
     &                  vdwtyp.eq.'MM3-HBOND') then
                  p = sqrt(rv2/r2)
                  p6 = rv6 / r6
                  rvterm = -bbuck / rv
                  expterm = abuck * exp(-bbuck/p)
                  e = eps * (expterm - cbuck*p6)
                  de = eps * (rvterm*expterm+6.0d0*cbuck*p6/r)
               end if
               if (r .lt. off) then
                  r4 = r2 * r2
                  r5 = r2 * r3
                  taper = c5*r5 + c4*r4 + c3*r3 + c2*r2 + c1*r + c0
                  dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                        + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                  de = de*(1.0d0-taper) - e*dtaper
                  e = e*(1.0d0-taper)
               end if
               etot = etot + e*rdelta*r2
               vtot = vtot + de*rdelta*r3
            end do
            elrc = elrc + fik*etot
            vlrc = vlrc + fik*vtot
         end do
      end do
      elrc = elrc / volbox
      vlrc = vlrc / (3.0d0*volbox)
c
c     perform deallocation of some local arrays
c
      deallocate (ivt)
      deallocate (jvt)
      deallocate (mvt)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2001  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module ewald  --  Ewald summation parameters and options  ##
c     ##                                                            ##
c     ################################################################
c
c
c     aewald     current value of Ewald convergence coefficient
c     aeewald    Ewald convergence coefficient for electrostatics
c     apewald    Ewald convergence coefficient for polarization
c     adewald    Ewald convergence coefficient for dispersion
c     boundary   Ewald boundary condition; none, tinfoil or vacuum
c
c
      module ewald
      implicit none
      real*8 aewald
      real*8 aeewald
      real*8 apewald
      real*8 adewald
      character*7 boundary
      save
      end
c
c
c     ######################################################
c     ##  COPYRIGHT (C) 2023 by Zhi Wang & Jay W. Ponder  ##
c     ##                All Rights Reserved               ##
c     ######################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine exfield  --  external electric field energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "exfield" calculates the electrostatic energy due to an
c     external electric field applied to the system
c
c
      subroutine exfield (mode,exf)
      use atoms
      use charge
      use chgpot
      use energi
      use extfld
      use mpole
      use usage
      implicit none
      integer i,ii
      real*8 exf,e,f,phi
      real*8 xi,yi,zi
      real*8 ci,dix,diy,diz
      character*6 mode
c
c
c     zero out the external electric field energy
c
      exf = 0.0d0
      f = electric / dielec
c
c     calculate external field energy over partial charges
c
      if (mode .eq. 'CHARGE') then
!$OMP    PARALLEL default(private) shared(nion,iion,use,
!$OMP&    x,y,z,f,pchg,exfld,exf)
!$OMP    DO reduction(+:exf)
         do ii = 1, nion
            i = iion(ii)
            if (use(i)) then
               xi = x(i)
               yi = y(i)
               zi = z(i)
               ci = pchg(i)
               phi = xi*exfld(1) + yi*exfld(2) + zi*exfld(3)
               e = -f * ci * phi
               exf = exf + e
            end if
         end do
!$OMP    END DO
!$OMP    END PARALLEL
      end if
c
c     calculate external field energy over atomic multipoles
c
      if (mode .eq. 'MPOLE') then
!$OMP    PARALLEL default(private) shared(npole,ipole,use,
!$OMP&    x,y,z,f,rpole,exfld,exf)
!$OMP    DO reduction(+:exf)
         do ii = 1, npole
            i = ipole(ii)
            if (use(i)) then
               xi = x(i)
               yi = y(i)
               zi = z(i)
               ci = rpole(1,i)
               phi = xi*exfld(1) + yi*exfld(2) + zi*exfld(3)
               dix = rpole(2,i)
               diy = rpole(3,i)
               diz = rpole(4,i)
               e = -f * (ci*phi + dix*exfld(1)
     &                      + diy*exfld(2) + diz*exfld(3))
               exf = exf + e
            end if
         end do
!$OMP    END DO
!$OMP    END PARALLEL
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine exfield1  --  external field energy & gradient  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "exfield1" calculates the electrostatic energy, gradient and
c     virial due to an external electric field applied to the system
c
c
      subroutine exfield1 (mode,exf)
      use atoms
      use charge
      use chgpot
      use deriv
      use energi
      use extfld
      use mpole
      use usage
      use virial
      implicit none
      integer i,ii
      integer ix,iy,iz
      real*8 exf,e,f,phi
      real*8 xi,yi,zi
      real*8 ci,dix,diy,diz
      real*8 xix,yix,zix
      real*8 xiy,yiy,ziy
      real*8 xiz,yiz,ziz
      real*8 frx,fry,frz
      real*8 vxx,vyy,vzz
      real*8 vxy,vxz,vyz
      real*8 fix(3),fiy(3)
      real*8 fiz(3),tem(3)
      character*6 mode
c
c
c     zero out the external electric field energy
c
      exf = 0.0d0
      f = electric / dielec
c
c     calculate energy and derivatives over partial charges
c
      if (mode .eq. 'CHARGE') then
!$OMP    PARALLEL default(private) shared(nion,iion,use,
!$OMP&    x,y,z,f,pchg,exfld,exf,dec,vir)
!$OMP    DO reduction(+:exf,dec,vir)
         do ii = 1, nion
            i = iion(ii)
            if (use(i)) then
               xi = x(i)
               yi = y(i)
               zi = z(i)
               ci = pchg(i)
               phi = xi*exfld(1) + yi*exfld(2) + zi*exfld(3)
               e = -f * ci * phi
               exf = exf + e
c
c     gradient and virial components from charge interactions
c
               frx = -f * exfld(1) * ci
               fry = -f * exfld(2) * ci
               frz = -f * exfld(3) * ci
               dec(1,i) = dec(1,i) + frx
               dec(2,i) = dec(2,i) + fry
               dec(3,i) = dec(3,i) + frz
               vxx = xi * frx
               vyy = yi * fry
               vzz = zi * frz
               vxy = 0.5d0 * (yi*frx+xi*fry)
               vxz = 0.5d0 * (zi*frx+xi*frz)
               vyz = 0.5d0 * (zi*fry+yi*frz)
c
c     increment the total internal virial tensor components
c
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
         end do
!$OMP    END DO
!$OMP    END PARALLEL
      end if
c
c     calculate energy and derivatives over atomic multipoles
c
      if (mode .eq. 'MPOLE') then
!$OMP    PARALLEL default(private) shared(npole,ipole,use,
!$OMP&    x,y,z,xaxis,yaxis,zaxis,f,rpole,exfld,exf,dem,vir)
!$OMP    DO reduction(+:exf,dem,vir)
         do ii = 1, npole
            i = ipole(ii)
            if (use(i)) then
               xi = x(i)
               yi = y(i)
               zi = z(i)
               ci = rpole(1,i)
               dix = rpole(2,i)
               diy = rpole(3,i)
               diz = rpole(4,i)
               phi = xi*exfld(1) + yi*exfld(2) + zi*exfld(3)
               e = -f * (ci*phi + dix*exfld(1)
     &                      + diy*exfld(2) + diz*exfld(3))
               exf = exf + e
c
c     gradient and virial components from dipole interactions
c
               tem(1) = f * (diy*exfld(3)-diz*exfld(2))
               tem(2) = f * (diz*exfld(1)-dix*exfld(3))
               tem(3) = f * (dix*exfld(2)-diy*exfld(1))
               call torque (i,tem,fix,fiy,fiz,dem)
               iz = zaxis(i)
               ix = xaxis(i)
               iy = abs(yaxis(i))
               if (iz .eq. 0)  iz = i
               if (ix .eq. 0)  ix = i
               if (iy .eq. 0)  iy = i
               xiz = x(iz) - x(i)
               yiz = y(iz) - y(i)
               ziz = z(iz) - z(i)
               xix = x(ix) - x(i)
               yix = y(ix) - y(i)
               zix = z(ix) - z(i)
               xiy = x(iy) - x(i)
               yiy = y(iy) - y(i)
               ziy = z(iy) - z(i)
               vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1)
               vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1)
     &                           + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2))
               vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1)
     &                           + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3))
               vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2)
               vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2)
     &                           + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3))
               vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3)
c
c     gradient and virial components from monopole interactions
c
               frx = -f * exfld(1) * ci
               fry = -f * exfld(2) * ci
               frz = -f * exfld(3) * ci
               dem(1,i) = dem(1,i) + frx
               dem(2,i) = dem(2,i) + fry
               dem(3,i) = dem(3,i) + frz
               vxx = vxx + xi*frx
               vyy = vyy + yi*fry
               vzz = vzz + zi*frz
               vxy = vxy + 0.5d0*(yi*frx+xi*fry)
               vxz = vxz + 0.5d0*(zi*frx+xi*frz)
               vyz = vyz + 0.5d0*(zi*fry+yi*frz)
c
c     increment the total internal virial tensor components
c
               vir(1,1) = vir(1,1) + vxx
               vir(2,1) = vir(2,1) + vxy
               vir(3,1) = vir(3,1) + vxz
               vir(1,2) = vir(1,2) + vxy
               vir(2,2) = vir(2,2) + vyy
               vir(3,2) = vir(3,2) + vyz
               vir(1,3) = vir(1,3) + vxz
               vir(2,3) = vir(2,3) + vyz
               vir(3,3) = vir(3,3) + vzz
            end if
         end do
!$OMP    END DO
!$OMP    END PARALLEL
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine exfield3  --  electric field energy & analysis  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "exfield3" calculates the electrostatic energy and partitions
c     the energy among the atomsdue to an external electric field
c     applied to the system
c
c
      subroutine exfield3 (mode,exf)
      use action
      use analyz
      use atoms
      use charge
      use chgpot
      use energi
      use extfld
      use mpole
      use usage
      implicit none
      integer i,ii
      real*8 exf,e,f,phi
      real*8 xi,yi,zi
      real*8 ci,dix,diy,diz
      character*6 mode
c
c
c     zero out the external electric field energy
c
      exf = 0.0d0
      f = electric / dielec
c
c     calculate energy and partitioning over partial charges
c
      if (mode .eq. 'CHARGE') then
!$OMP    PARALLEL default(private) shared(nion,iion,use,
!$OMP&    x,y,z,f,pchg,exfld,exf,nec,aec)
!$OMP    DO reduction(+:exf,nec,aec)
         do ii = 1, nion
            i = iion(ii)
            if (use(i)) then
               xi = x(i)
               yi = y(i)
               zi = z(i)
               ci = pchg(i)
               phi = xi*exfld(1) + yi*exfld(2) + zi*exfld(3)
               e = -f * ci * phi
               exf = exf + e
               nec = nec + 1
               aec(i) = aec(i) + e
            end if
         end do
!$OMP    END DO
!$OMP    END PARALLEL
      end if
c
c     calculate energy and partitioning over atomic multipoles
c
      if (mode .eq. 'MPOLE') then
!$OMP    PARALLEL default(private) shared(npole,ipole,use,
!$OMP&    x,y,z,f,rpole,exfld,exf,nem,aem)
!$OMP    DO reduction(+:exf,nem,aem)
         do ii = 1, npole
            i = ipole(ii)
            if (use(i)) then
               xi = x(i)
               yi = y(i)
               zi = z(i)
               ci = rpole(1,i)
               phi = xi*exfld(1) + yi*exfld(2) + zi*exfld(3)
               dix = rpole(2,i)
               diy = rpole(3,i)
               diz = rpole(4,i)
               e = -f * (ci*phi + dix*exfld(1)
     &                      + diy*exfld(2) + diz*exfld(3))
               exf = exf + e
               nem = nem + 1
               aem(i) = aem(i) + e
            end if
         end do
!$OMP    END DO
!$OMP    END PARALLEL
      end if
      return
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2022 by Moses Chung, Zhi Wang & Jay Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module expol  --  exch-polarization in current structure  ##
c     ##                                                            ##
c     ################################################################
c
c
c     nexpol     total number of exch polarization sites in system
c     kpep       exchange polarization spring constant at each site
c     prepep     exchange polarization prefactor at each site
c     dmppep     exchange polarization damping alpha at each site
c     polscale   scale matrix for use in exchange polarization
c     polinv     scale matrix inverse for exchange polarization
c     lpep       flag to use exchange polarization at each site
c
c
      module expol
      implicit none
      integer nexpol
      real*8, allocatable :: kpep(:)
      real*8, allocatable :: prepep(:)
      real*8, allocatable :: dmppep(:)
      real*8, allocatable :: polscale(:,:,:)
      real*8, allocatable :: polinv(:,:,:)
      logical, allocatable :: lpep(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2023  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module extfld  --  applied external electric field vector  ##
c     ##                                                             ##
c     #################################################################
c
c
c     exfld       components of applied external electric field
c     use_exfld   flag to include applied external electric field
c
c
      module extfld
      implicit none
      real*8 exfld(3)
      logical use_exfld
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine extra  --  user defined extra potentials  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "extra" calculates any additional user defined potential
c     energy contribution
c
c
      subroutine extra
      use energi
      implicit none
c
c
c     zero out the energy due to extra potential terms
c
      ex = 0.0d0
c
c     add any user-defined extra potentials below here
c
c     e = ......
c     ex = ex + e
c
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine extra1  --  user defined extra potentials  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "extra1" calculates any additional user defined potential
c     energy contribution and its first derivatives
c
c
      subroutine extra1
      use atoms
      use deriv
      use energi
      implicit none
      integer i
c
c
c     zero out the extra energy term and first derivatives
c
      ex = 0.0d0
      do i = 1, n
         dex(1,i) = 0.0d0
         dex(2,i) = 0.0d0
         dex(3,i) = 0.0d0
      end do
c
c     add any user-defined extra potentials and derivatives;
c     also increment intermolecular energy and virial as needed
c
c     e = ......
c     ex = ex + e
c     do i = 1, n
c        dex(1,i) = ......
c        dex(2,i) = ......
c        dex(3,i) = ......
c     end do
c
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine extra2  --  atomwise user defined Hessian  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "extra2" calculates second derivatives of any additional
c     user defined potential energy contribution for a single
c     atom at a time
c
c
      subroutine extra2 (i)
      use atoms
      use hessn
      implicit none
      integer i
c
c
c     compute the Hessian elements for extra energy terms
c
c     do j = 1, n
c        hessx(1,j) = hessx(1,j) + ......
c        hessy(2,j) = hessy(2,j) + ......
c        hessz(3,j) = hessz(3,j) + ......
c     end do
c
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine extra3  --  user defined extra potentials  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "extra3" calculates any additional user defined potential
c     contribution and also partitions the energy among the atoms
c
c
      subroutine extra3
      use action
      use analyz
      use atoms
      use energi
      implicit none
      integer i
c
c
c     zero out energy and partitioning due to extra potential terms
c
      nex = 0
      ex = 0.0d0
      do i = 1, n
         aex(i) = 0.0d0
      end do
c
c     add any user-defined extra potentials and partitioning
c
c     e = ......
c     nex = nex + 1
c     ex = ex + e
c     aex(i) = ......
c
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module faces  --  Connolly area and volume variables  ##
c     ##                                                        ##
c     ############################################################
c
c
c     maxcls   maximum number of neighboring atom pairs
c     maxtt    maximum number of temporary tori
c     maxt     maximum number of total tori
c     maxp     maximum number of probe positions
c     maxv     maximum number of vertices
c     maxen    maximum number of concave edges
c     maxfn    maximum number of concave faces
c     maxc     maximum number of circles
c     maxeq    maximum number of convex edges
c     maxfs    maximum number of saddle faces
c     maxfq    maximum number of convex faces
c     maxcy    maximum number of cycles
c     mxcyeq   maximum number of convex edge cycles
c     mxfqcy   maximum number of convex face cycles
c
c
      module faces
      implicit none
      integer maxcls,maxtt
      integer maxt,maxp
      integer maxv,maxen
      integer maxfn,maxc
      integer maxeq,maxfs
      integer maxfq,maxcy
      integer mxcyeq,mxfqcy
c
c
c     na       number of atoms
c     pr       probe radius
c     ar       atomic radii
c     axyz     atomic coordinates
c
c
      integer na
      real*8 pr
      real*8, allocatable :: ar(:)
      real*8, allocatable :: axyz(:,:)
c
c
c     skip     if true, atom is not used
c     nosurf   if true, atom has no free surface
c     afree    atom free of neighbors
c     abur     atom buried
c
c
      logical, allocatable :: skip(:)
      logical, allocatable :: nosurf(:)
      logical, allocatable :: afree(:)
      logical, allocatable :: abur(:)
c
c
c     cls      atom numbers of neighbors
c     clst     pointer from neighbor to torus
c     acls     begin and end pointers for atoms neighbors
c
c
      integer, allocatable :: cls(:)
      integer, allocatable :: clst(:)
      integer, allocatable :: acls(:,:)
c
c
c     ntt      number of temporary tori
c     ttfe     first edge of each temporary torus
c     ttle     last edge of each temporary torus
c     enext    pointer to next edge of temporary torus
c     tta      temporary torus atom numbers
c     ttbur    temporary torus buried
c     ttfree   temporary torus free
c
c
      integer ntt
      integer, allocatable :: ttfe(:)
      integer, allocatable :: ttle(:)
      integer, allocatable :: enext(:)
      integer, allocatable :: tta(:,:)
      logical, allocatable :: ttbur(:)
      logical, allocatable :: ttfree(:)
c
c
c     nt       number of tori
c     tfe      torus first edge
c     ta       torus atom numbers
c     tr       torus radius
c     t        torus center
c     tax      torus axis
c     tfree    torus free of neighbors
c
c
      integer nt
      integer, allocatable :: tfe(:)
      integer, allocatable :: ta(:,:)
      real*8, allocatable :: tr(:)
      real*8, allocatable :: t(:,:)
      real*8, allocatable :: tax(:,:)
      logical, allocatable :: tfree(:)
c
c
c     np       number of probe positions
c     pa       probe position atom numbers
c     p        probe position coordinates
c
c
      integer np
      integer, allocatable :: pa(:,:)
      real*8, allocatable :: p(:,:)
c
c
c     nv       number of vertices
c     va       vertex atom number
c     vp       vertex probe number
c     vxyz     vertex coordinates
c
c
      integer nv
      integer, allocatable :: va(:)
      integer, allocatable :: vp(:)
      real*8, allocatable :: vxyz(:,:)
c
c
c     nen      number of concave edges
c     nfn      number of concave faces
c     env      vertex numbers for each concave edge
c     fnen     concave face concave edge numbers
c
c
      integer nen
      integer nfn
      integer, allocatable :: env(:,:)
      integer, allocatable :: fnen(:,:)
c
c
c     nc       number of circles
c     ca       circle atom number
c     ct       circle torus number
c     cr       circle radius
c     c        circle center
c
c
      integer nc
      integer, allocatable :: ca(:)
      integer, allocatable :: ct(:)
      real*8, allocatable :: cr(:)
      real*8, allocatable :: c(:,:)
c
c
c     neq      number of convex edges
c     eqc      convex edge circle number
c     eqv      convex edge vertex numbers
c     afe      first convex edge of each atom
c     ale      last convex edge of each atom
c     eqnext   pointer to next convex edge of atom
c
c
      integer neq
      integer, allocatable :: eqc(:)
      integer, allocatable :: eqv(:,:)
      integer, allocatable :: afe(:)
      integer, allocatable :: ale(:)
      integer, allocatable :: eqnext(:)
c
c
c     nfs      number of saddle faces
c     fsen     saddle face concave edge numbers
c     fseq     saddle face convex edge numbers
c
c
      integer nfs
      integer, allocatable :: fsen(:,:)
      integer, allocatable :: fseq(:,:)
c
c
c     ncy      number of cycles
c     cyneq    number of convex edges in cycle
c     cyeq     cycle convex edge numbers
c
c
      integer ncy
      integer, allocatable :: cyneq(:)
      integer, allocatable :: cyeq(:,:)
c
c
c     nfq      number of convex faces
c     fqa      atom number of convex face
c     fqncy    number of cycles bounding convex face
c     fqcy     convex face cycle numbers
c
c
      integer nfq
      integer, allocatable :: fqa(:)
      integer, allocatable :: fqncy(:)
      integer, allocatable :: fqcy(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine fatal  --  terminate the program abnormally  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "fatal" terminates execution due to a user request, a severe
c     error or some other nonstandard condition
c
c
      subroutine fatal
      use iounit
      implicit none
c
c
c     print a final warning message, then do final cleanup
c
      write (iout,10)
   10 format (/,' Tinker is Unable to Continue; Terminating',
     &           ' the Current Calculation')
      call final
c
c     exit is not standard Fortran, but stop can give errors
c
      call exit
c     stop
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2010  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module fft  --  Fast Fourier transform control values  ##
c     ##                                                         ##
c     #############################################################
c
c
c     maxprime   maximum number of prime factors of FFT dimension
c
c     iprime     prime factorization of each FFT dimension (FFTPACK)
c     planf      pointer to forward transform data structure (FFTW)
c     planb      pointer to backward transform data structure (FFTW)
c     ffttable   intermediate array used by the FFT routine (FFTPACK)
c     ffttyp     type of FFT package; currently FFTPACK or FFTW
c
c
      module fft
      implicit none
      integer maxprime
      parameter (maxprime=15)
      integer iprime(maxprime,3)
      integer*8 planf
      integer*8 planb
      real*8, allocatable :: ffttable(:,:)
      character*7 ffttyp
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine fftsetup  --  setup 3-D Fast Fourier transform  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "fftsetup" does initialization for a 3-D FFT to be computed
c     via either the FFTPACK or FFTW libraries
c
c
      subroutine fftsetup
      use fft
      use openmp
      use pme
      implicit none
      integer maxtable
!$    integer ifront,iback
!$    integer error,iguess
c
c
c     perform dynamic allocation of some global arrays
c
      allocate (qgrid(2,nfft1,nfft2,nfft3))
c
c     initialization of Fast Fourier transform using FFTW;
c     comment "dfftw_init_threads" and "dfftw_plan_with_nthreads"
c     if serial FFTW is wanted in place of OpenMP-parallel FFTW
c
!$    if (ffttyp .eq. 'FFTW') then
!$       ifront = -1
!$       iback = 1
!$       error = 0
!$       iguess = 0
!$       call dfftw_init_threads (error)
!$       call dfftw_plan_with_nthreads (nthread)
!$       call dfftw_plan_dft_3d (planf,nfft1,nfft2,nfft3,qgrid,
!$   &                              qgrid,ifront,iguess)
!$       call dfftw_plan_dft_3d (planb,nfft1,nfft2,nfft3,qgrid,
!$   &                              qgrid,iback,iguess)
c
c     initialization of Fast Fourier transform using FFTPACK
c
!$    else
         maxtable = 4 * max(nfft1,nfft2,nfft3)
         if (allocated(ffttable)) then
            if (size(ffttable) .ne. maxtable)  deallocate (ffttable)
         end if
         if (.not. allocated(ffttable))  allocate (ffttable(maxtable,3))
         call cffti (nfft1,ffttable(1,1),iprime(1,1))
         call cffti (nfft2,ffttable(1,2),iprime(1,2))
         call cffti (nfft3,ffttable(1,3),iprime(1,3))
!$    end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine fftfront  --  forward Fast Fourier transform  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "fftfront" performs a 3-D FFT forward transform via a single
c     3-D transform or three separate 1-D transforms
c
c
      subroutine fftfront
      use fft
      use pme
      implicit none
      integer i,j,k
      real*8, allocatable :: work(:,:)
c
c
c     perform a single 3-D forward transform using FFTW
c
!$    if (ffttyp .eq. 'FFTW') then
!$       call dfftw_execute_dft (planf,qgrid,qgrid)
!$    else
c
c     perform three 1-D forward transforms using FFTPACK
c
         allocate (work(2,max(nfft1,nfft2,nfft3)))
         do k = 1, nfft3
            do j = 1, nfft2
               do i = 1, nfft1
                  work(1,i) = qgrid(1,i,j,k)
                  work(2,i) = qgrid(2,i,j,k)
               end do
               call cfftf (nfft1,work,ffttable(1,1),iprime(1,1))
               do i = 1, nfft1
                  qgrid(1,i,j,k) = work(1,i)
                  qgrid(2,i,j,k) = work(2,i)
               end do
            end do
         end do
         do k = 1, nfft3
            do i = 1, nfft1
               do j = 1, nfft2
                  work(1,j) = qgrid(1,i,j,k)
                  work(2,j) = qgrid(2,i,j,k)
               end do
               call cfftf (nfft2,work,ffttable(1,2),iprime(1,2))
               do j = 1, nfft2
                  qgrid(1,i,j,k) = work(1,j)
                  qgrid(2,i,j,k) = work(2,j)
               end do
            end do
         end do
         do i = 1, nfft1
            do j = 1, nfft2
               do k = 1, nfft3
                  work(1,k) = qgrid(1,i,j,k)
                  work(2,k) = qgrid(2,i,j,k)
               end do
               call cfftf (nfft3,work,ffttable(1,3),iprime(1,3))
               do k = 1, nfft3
                  qgrid(1,i,j,k) = work(1,k)
                  qgrid(2,i,j,k) = work(2,k)
               end do
            end do
         end do
         deallocate (work)
!$    end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine fftback  --  backward Fast Fourier transform  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "fftback" performs a 3-D FFT backward transform via a single
c     3-D transform or three separate 1-D transforms
c
c
      subroutine fftback
      use fft
      use pme
      implicit none
      integer i,j,k
      real*8, allocatable :: work(:,:)
c
c
c     perform a single 3-D backward transform using FFTW
c
!$    if (ffttyp .eq. 'FFTW') then
!$       call dfftw_execute_dft (planb,qgrid,qgrid)
!$    else
c
c     perform three 1-D backward transforms using FFTPACK
c
         allocate (work(2,max(nfft1,nfft2,nfft3)))
         do k = 1, nfft3
            do j = 1, nfft2
               do i = 1, nfft1
                  work(1,i) = qgrid(1,i,j,k)
                  work(2,i) = qgrid(2,i,j,k)
               end do
               call cfftb (nfft1,work,ffttable(1,1),iprime(1,1))
               do i = 1, nfft1
                  qgrid(1,i,j,k) = work(1,i)
                  qgrid(2,i,j,k) = work(2,i)
               end do
            end do
         end do
         do k = 1, nfft3
            do i = 1, nfft1
               do j = 1, nfft2
                  work(1,j) = qgrid(1,i,j,k)
                  work(2,j) = qgrid(2,i,j,k)
               end do
               call cfftb (nfft2,work,ffttable(1,2),iprime(1,2))
               do j = 1, nfft2
                  qgrid(1,i,j,k) = work(1,j)
                  qgrid(2,i,j,k) = work(2,j)
               end do
            end do
         end do
         do i = 1, nfft1
            do j = 1, nfft2
               do k = 1, nfft3
                  work(1,k) = qgrid(1,i,j,k)
                  work(2,k) = qgrid(2,i,j,k)
               end do
               call cfftb (nfft3,work,ffttable(1,3),iprime(1,3))
               do k = 1, nfft3
                  qgrid(1,i,j,k) = work(1,k)
                  qgrid(2,i,j,k) = work(2,k)
               end do
            end do
         end do
         deallocate (work)
!$    end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine fftclose  --  close 3-D Fast Fourier transform  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "fftclose" does cleanup after performing a 3-D FFT by destroying
c     the FFTW plans for the forward and backward transforms
c
c
      subroutine fftclose
      use fft
      use pme
      implicit none
c
c
c     remove the FFTW plans to avoid a cumulative memory leak
c
!$    if (ffttyp .eq. 'FFTW') then
!$       call dfftw_destroy_plan (planf)
!$       call dfftw_destroy_plan (planb)
!$    end if
c
c     perform deallocation of some global arrays
c
      if (allocated(qgrid))  deallocate (qgrid)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  routines below implement a 1-D Fast Fourier Transform;  ##
c     ##  code is modified from FFTPACK as obtained from Netlib;  ##
c     ##  original due to Paul N. Swarztrauber, NCAR, Boulder CO  ##
c     ##                                                          ##
c     ##############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine cffti  --  1-D FFT setup and initialization  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "cffti" initializes arrays used in both forward and backward
c     transforms; "ifac" is the prime factorization of "n", and
c     "wsave" contains a tabulation of trigonometric functions
c
c
      subroutine cffti (n,wsave,ifac)
      implicit none
      integer n,iw
      integer ifac(*)
      real*8 wsave(*)
c
c
      if (n .gt. 1) then
         iw = n + n + 1
         call cffti1 (n,wsave(iw),ifac)
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine cffti1  ##
c     ##                     ##
c     #########################
c
c
      subroutine cffti1 (n,wa,ifac)
      use math
      implicit none
      integer i,j,ii,n,ip,ipm
      integer ib,ido,idot
      integer i1,k1,l1,l2,ld
      integer nl,nf,nq,nr
      integer ntry,ntryh(4)
      integer ifac(*)
      real*8 arg,argh,argld,fi
      real*8 wa(*)
      data ntryh  / 3, 4, 2, 5 /
c
c
      nl = n
      nf = 0
      j = 1
      ntry = ntryh(j)
      do while (nl .ne. 1)
         nq = nl / ntry
         nr = nl - ntry*nq
         if (nr .eq. 0) then
            nf = nf + 1
            ifac(nf+2) = ntry
            nl = nq
            if (ntry .eq. 2) then
               if (nf .ne. 1) then
                  do i = 2, nf
                     ib = nf - i + 2
                     ifac(ib+2) = ifac(ib+1)
                  end do
                  ifac(3) = 2
               end if
            end if
         else
            j = j + 1
            if (j .le. 4) then
               ntry = ntryh(j)
            else
               ntry = ntry + 2
            end if
         end if
      end do
      ifac(1) = n
      ifac(2) = nf
      argh = 2.0d0 * pi / dble(n)
      i = 2
      l1 = 1
      do k1 = 1, nf
         ip = ifac(k1+2)
         ld = 0
         l2 = l1 * ip
         ido = n / l2
         idot = ido + ido + 2
         ipm = ip - 1
         do j = 1, ipm
            i1 = i
            wa(i-1) = 1.0d0
            wa(i) = 0.0d0
            ld = ld + l1
            fi = 0.0d0
            argld = dble(ld) * argh
            do ii = 4, idot, 2
               i = i + 2
               fi = fi + 1.0d0
               arg = fi * argld
               wa(i-1) = cos(arg)
               wa(i) = sin(arg)
            end do
            if (ip .gt. 5) then
               wa(i1-1) = wa(i-1)
               wa(i1) = wa(i)
            end if
         end do
         l1 = l2
      end do
      return
      end
c
c
c     #######################################################
c     ##                                                   ##
c     ##  subroutine cfftf  --  1-D FFT forward transform  ##
c     ##                                                   ##
c     #######################################################
c
c
c     "cfftf" computes the forward complex discrete Fourier
c     transform, the Fourier analysis
c
c
      subroutine cfftf (n,c,wsave,ifac)
      implicit none
      integer n,iw
      integer ifac(*)
      real*8 c(*)
      real*8 wsave(*)
c
c
      if (n .gt. 1) then
         iw = n + n + 1
         call cfftf1 (n,c,wsave,wsave(iw),ifac)
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine cfftf1  ##
c     ##                     ##
c     #########################
c
c
      subroutine cfftf1 (n,c,ch,wa,ifac)
      implicit none
      integer i,n,k1,l1,l2
      integer na,nac,nf,n2
      integer ido,idot,idl1,ip
      integer iw,ix2,ix3,ix4
      integer ifac(*)
      real*8 c(*),ch(*),wa(*)
c
c
      nf = ifac(2)
      na = 0
      l1 = 1
      iw = 1
      do k1 = 1, nf
         ip = ifac(k1+2)
         l2 = ip * l1
         ido = n / l2
         idot = ido + ido
         idl1 = idot * l1
         if (ip .eq. 5) then
            ix2 = iw + idot
            ix3 = ix2 + idot
            ix4 = ix3 + idot
            if (na .eq. 0) then
               call passf5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4))
            else
               call passf5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4))
            end if
            na = 1 - na
         else if (ip .eq. 4) then
            ix2 = iw + idot
            ix3 = ix2 + idot
            if (na .eq. 0) then
               call passf4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3))
            else
               call passf4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3))
            end if
            na = 1 - na
         else if (ip .eq. 3) then
            ix2 = iw + idot
            if (na .eq. 0) then
               call passf3 (idot,l1,c,ch,wa(iw),wa(ix2))
            else
               call passf3 (idot,l1,ch,c,wa(iw),wa(ix2))
            end if
            na = 1 - na
         else if (ip .eq. 2) then
            if (na .eq. 0) then
               call passf2 (idot,l1,c,ch,wa(iw))
            else
               call passf2 (idot,l1,ch,c,wa(iw))
            end if
            na = 1 - na
         else
            if (na .eq. 0) then
               call passf (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw))
            else
               call passf (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw))
            end if
            if (nac .ne. 0)  na = 1 - na
         end if
         l1 = l2
         iw = iw + (ip-1)*idot
      end do
      if (na .ne. 0) then
         n2 = n + n
         do i = 1, n2
            c(i) = ch(i)
         end do
      end if
      return
      end
c
c
c     ########################################################
c     ##                                                    ##
c     ##  subroutine cfftb  --  1-D FFT backward transform  ##
c     ##                                                    ##
c     ########################################################
c
c
c     "cfftb" computes the backward complex discrete Fourier
c     transform, the Fourier synthesis
c
c
      subroutine cfftb (n,c,wsave,ifac)
      implicit none
      integer n,iw
      integer ifac(*)
      real*8 c(*)
      real*8 wsave(*)
c
c
      if (n .gt. 1) then
         iw = n + n + 1
         call cfftb1 (n,c,wsave,wsave(iw),ifac)
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine cfftb1  ##
c     ##                     ##
c     #########################
c
c
      subroutine cfftb1 (n,c,ch,wa,ifac)
      implicit none
      integer i,n,k1,l1,l2
      integer na,nac,nf,n2
      integer ido,idot,idl1,ip
      integer iw,ix2,ix3,ix4
      integer ifac(*)
      real*8 c(*),ch(*),wa(*)
c
c
      nf = ifac(2)
      na = 0
      l1 = 1
      iw = 1
      do k1 = 1, nf
         ip = ifac(k1+2)
         l2 = ip * l1
         ido = n / l2
         idot = ido + ido
         idl1 = idot * l1
         if (ip .eq. 5) then
            ix2 = iw + idot
            ix3 = ix2 + idot
            ix4 = ix3 + idot
            if (na .eq. 0) then
               call passb5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4))
            else
               call passb5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4))
            end if
            na = 1 - na
         else if (ip .eq. 4) then
            ix2 = iw + idot
            ix3 = ix2 + idot
            if (na .eq. 0) then
               call passb4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3))
            else
               call passb4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3))
            end if
            na = 1 - na
         else if (ip .eq. 3) then
            ix2 = iw + idot
            if (na .eq. 0) then
               call passb3 (idot,l1,c,ch,wa(iw),wa(ix2))
            else
               call passb3 (idot,l1,ch,c,wa(iw),wa(ix2))
            end if
            na = 1 - na
         else if (ip .eq. 2) then
            if (na .eq. 0) then
               call passb2 (idot,l1,c,ch,wa(iw))
            else
               call passb2 (idot,l1,ch,c,wa(iw))
            end if
            na = 1 - na
         else
            if (na .eq. 0) then
               call passb (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw))
            else
               call passb (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw))
            end if
            if (nac .ne. 0)  na = 1 - na
         end if
         l1 = l2
         iw = iw + (ip-1)*idot
      end do
      if (na .ne. 0) then
         n2 = n + n
         do i = 1, n2
            c(i) = ch(i)
         end do
      end if
      return
      end
c
c
c     ########################
c     ##                    ##
c     ##  subroutine passf  ##
c     ##                    ##
c     ########################
c
c
      subroutine passf (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa)
      implicit none
      integer nac,ido,ip
      integer l1,idl1
      integer i,j,k,l
      integer ik,jc,lc
      integer idj,idl,idp
      integer idij,idlj
      integer inc,idot,nt
      integer ipp2,ipph
      real*8 wai,war
      real*8 cc(ido,ip,l1)
      real*8 c1(ido,l1,ip)
      real*8 c2(idl1,ip)
      real*8 ch(ido,l1,ip)
      real*8 ch2(idl1,ip)
      real*8 wa(*)
c
c
      idot = ido / 2
      nt = ip * idl1
      ipp2 = ip + 2
      ipph = (ip+1) / 2
      idp = ip * ido
      if (ido .ge. l1) then
         do j = 2, ipph
            jc = ipp2 - j
            do k = 1, l1
               do i = 1, ido
                  ch(i,k,j) = cc(i,j,k) + cc(i,jc,k)
                  ch(i,k,jc) = cc(i,j,k) - cc(i,jc,k)
               end do
            end do
         end do
         do k = 1, l1
            do i = 1, ido
               ch(i,k,1) = cc(i,1,k)
            end do
         end do
      else
         do j = 2, ipph
            jc = ipp2 - j
            do i = 1, ido
               do k = 1, l1
                  ch(i,k,j) = cc(i,j,k) + cc(i,jc,k)
                  ch(i,k,jc) = cc(i,j,k) - cc(i,jc,k)
               end do
            end do
         end do
         do i = 1, ido
            do k = 1, l1
               ch(i,k,1) = cc(i,1,k)
            end do
         end do
      end if
      idl = 2 - ido
      inc = 0
      do l = 2, ipph
         lc = ipp2 - l
         idl = idl + ido
         do ik = 1, idl1
            c2(ik,l) = ch2(ik,1) + wa(idl-1)*ch2(ik,2)
            c2(ik,lc) = -wa(idl) * ch2(ik,ip)
         end do
         idlj = idl
         inc = inc + ido
         do j = 3, ipph
            jc = ipp2 - j
            idlj = idlj + inc
            if (idlj .gt. idp)  idlj = idlj - idp
            war = wa(idlj-1)
            wai = wa(idlj)
            do ik = 1, idl1
               c2(ik,l) = c2(ik,l) + war*ch2(ik,j)
               c2(ik,lc) = c2(ik,lc) - wai*ch2(ik,jc)
            end do
         end do
      end do
      do j = 2, ipph
         do ik = 1, idl1
            ch2(ik,1) = ch2(ik,1) + ch2(ik,j)
         end do
      end do
      do j = 2, ipph
         jc = ipp2 - j
         do ik = 2, idl1, 2
            ch2(ik-1,j) = c2(ik-1,j) - c2(ik,jc)
            ch2(ik-1,jc) = c2(ik-1,j) + c2(ik,jc)
            ch2(ik,j) = c2(ik,j) + c2(ik-1,jc)
            ch2(ik,jc) = c2(ik,j) - c2(ik-1,jc)
         end do
      end do
      nac = 1
      if (ido .ne. 2) then
         nac = 0
         do ik = 1, idl1
            c2(ik,1) = ch2(ik,1)
         end do
         do j = 2, ip
            do k = 1, l1
               c1(1,k,j) = ch(1,k,j)
               c1(2,k,j) = ch(2,k,j)
            end do
         end do
         if (idot .le. l1) then
            idij = 0
            do j = 2, ip
               idij = idij + 2
               do i = 4, ido, 2
                  idij = idij + 2
                  do k = 1, l1
                     c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)
     &                                + wa(idij)*ch(i,k,j)
                     c1(i,k,j) = wa(idij-1)*ch(i,k,j)
     &                              - wa(idij)*ch(i-1,k,j)
                  end do
               end do
            end do
         else
            idj = 2 - ido
            do j = 2, ip
               idj = idj + ido
               do k = 1, l1
                  idij = idj
                  do i = 4, ido, 2
                     idij = idij + 2
                     c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)
     &                                + wa(idij)*ch(i,k,j)
                     c1(i,k,j) = wa(idij-1)*ch(i,k,j)
     &                              - wa(idij)*ch(i-1,k,j)
                  end do
               end do
            end do
         end if
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passf2  ##
c     ##                     ##
c     #########################
c
c
      subroutine passf2 (ido,l1,cc,ch,wa1)
      implicit none
      integer i,k,ido,l1
      real*8 ti2,tr2
      real*8 cc(ido,2,l1)
      real*8 ch(ido,l1,2)
      real*8 wa1(*)
c
c
      if (ido .le. 2) then
         do k = 1, l1
            ch(1,k,1) = cc(1,1,k) + cc(1,2,k)
            ch(1,k,2) = cc(1,1,k) - cc(1,2,k)
            ch(2,k,1) = cc(2,1,k) + cc(2,2,k)
            ch(2,k,2) = cc(2,1,k) - cc(2,2,k)
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               ch(i-1,k,1) = cc(i-1,1,k) + cc(i-1,2,k)
               tr2 = cc(i-1,1,k) - cc(i-1,2,k)
               ch(i,k,1) = cc(i,1,k) + cc(i,2,k)
               ti2 = cc(i,1,k) - cc(i,2,k)
               ch(i,k,2) = wa1(i-1)*ti2 - wa1(i)*tr2
               ch(i-1,k,2) = wa1(i-1)*tr2 + wa1(i)*ti2
            end do
         end do
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passf3  ##
c     ##                     ##
c     #########################
c
c
      subroutine passf3 (ido,l1,cc,ch,wa1,wa2)
      implicit none
      integer i,k,ido,l1
      real*8 ti2,tr2,taur,taui
      real*8 ci2,ci3,cr2,cr3
      real*8 di2,di3,dr2,dr3
      real*8 cc(ido,3,l1)
      real*8 ch(ido,l1,3)
      real*8 wa1(*)
      real*8 wa2(*)
      data taur  / -0.5d0 /
      data taui  / -0.866025403784438647d0 /  !! -sqrt(3)/2
c
c
      if (ido .eq. 2) then
         do k = 1, l1
            tr2 = cc(1,2,k) + cc(1,3,k)
            cr2 = cc(1,1,k) + taur*tr2
            ch(1,k,1) = cc(1,1,k) + tr2
            ti2 = cc(2,2,k) + cc(2,3,k)
            ci2 = cc(2,1,k) + taur*ti2
            ch(2,k,1) = cc(2,1,k) + ti2
            cr3 = taui * (cc(1,2,k)-cc(1,3,k))
            ci3 = taui * (cc(2,2,k)-cc(2,3,k))
            ch(1,k,2) = cr2 - ci3
            ch(1,k,3) = cr2 + ci3
            ch(2,k,2) = ci2 + cr3
            ch(2,k,3) = ci2 - cr3
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               tr2 = cc(i-1,2,k) + cc(i-1,3,k)
               cr2 = cc(i-1,1,k) + taur*tr2
               ch(i-1,k,1) = cc(i-1,1,k) + tr2
               ti2 = cc(i,2,k) + cc(i,3,k)
               ci2 = cc(i,1,k) + taur*ti2
               ch(i,k,1) = cc(i,1,k) + ti2
               cr3 = taui * (cc(i-1,2,k)-cc(i-1,3,k))
               ci3 = taui * (cc(i,2,k)-cc(i,3,k))
               dr2 = cr2 - ci3
               dr3 = cr2 + ci3
               di2 = ci2 + cr3
               di3 = ci2 - cr3
               ch(i,k,2) = wa1(i-1)*di2 - wa1(i)*dr2
               ch(i-1,k,2) = wa1(i-1)*dr2 + wa1(i)*di2
               ch(i,k,3) = wa2(i-1)*di3 - wa2(i)*dr3
               ch(i-1,k,3) = wa2(i-1)*dr3 + wa2(i)*di3
            end do
         end do
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passf4  ##
c     ##                     ##
c     #########################
c
c
      subroutine passf4 (ido,l1,cc,ch,wa1,wa2,wa3)
      implicit none
      integer i,k,ido,l1
      real*8 ci2,ci3,ci4
      real*8 cr2,cr3,cr4
      real*8 ti1,ti2,ti3,ti4
      real*8 tr1,tr2,tr3,tr4
      real*8 cc(ido,4,l1)
      real*8 ch(ido,l1,4)
      real*8 wa1(*)
      real*8 wa2(*)
      real*8 wa3(*)
c
c
      if (ido .eq. 2) then
         do k = 1, l1
            ti1 = cc(2,1,k) - cc(2,3,k)
            ti2 = cc(2,1,k) + cc(2,3,k)
            tr4 = cc(2,2,k) - cc(2,4,k)
            ti3 = cc(2,2,k) + cc(2,4,k)
            tr1 = cc(1,1,k) - cc(1,3,k)
            tr2 = cc(1,1,k) + cc(1,3,k)
            ti4 = cc(1,4,k) - cc(1,2,k)
            tr3 = cc(1,2,k) + cc(1,4,k)
            ch(1,k,1) = tr2 + tr3
            ch(1,k,3) = tr2 - tr3
            ch(2,k,1) = ti2 + ti3
            ch(2,k,3) = ti2 - ti3
            ch(1,k,2) = tr1 + tr4
            ch(1,k,4) = tr1 - tr4
            ch(2,k,2) = ti1 + ti4
            ch(2,k,4) = ti1 - ti4
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               ti1 = cc(i,1,k) - cc(i,3,k)
               ti2 = cc(i,1,k) + cc(i,3,k)
               ti3 = cc(i,2,k) + cc(i,4,k)
               tr4 = cc(i,2,k) - cc(i,4,k)
               tr1 = cc(i-1,1,k) - cc(i-1,3,k)
               tr2 = cc(i-1,1,k) + cc(i-1,3,k)
               ti4 = cc(i-1,4,k) - cc(i-1,2,k)
               tr3 = cc(i-1,2,k) + cc(i-1,4,k)
               ch(i-1,k,1) = tr2 + tr3
               cr3 = tr2 - tr3
               ch(i,k,1) = ti2 + ti3
               ci3 = ti2 - ti3
               cr2 = tr1 + tr4
               cr4 = tr1 - tr4
               ci2 = ti1 + ti4
               ci4 = ti1 - ti4
               ch(i-1,k,2) = wa1(i-1)*cr2 + wa1(i)*ci2
               ch(i,k,2) = wa1(i-1)*ci2 - wa1(i)*cr2
               ch(i-1,k,3) = wa2(i-1)*cr3 + wa2(i)*ci3
               ch(i,k,3) = wa2(i-1)*ci3 - wa2(i)*cr3
               ch(i-1,k,4) = wa3(i-1)*cr4 + wa3(i)*ci4
               ch(i,k,4) = wa3(i-1)*ci4 - wa3(i)*cr4
            end do
         end do
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passf5  ##
c     ##                     ##
c     #########################
c
c
      subroutine passf5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4)
      implicit none
      integer i,k,ido,l1
      real*8 ci2,ci3,ci4,ci5
      real*8 cr2,cr3,cr4,cr5
      real*8 di2,di3,di4,di5
      real*8 dr2,dr3,dr4,dr5
      real*8 ti2,ti3,ti4,ti5
      real*8 tr2,tr3,tr4,tr5
      real*8 tr11,ti11
      real*8 tr12,ti12
      real*8 cc(ido,5,l1)
      real*8 ch(ido,l1,5)
      real*8 wa1(*)
      real*8 wa2(*)
      real*8 wa3(*)
      real*8 wa4(*)
      data tr11  /  0.309016994374947424d0 /  !! sine 9*pi/10
      data ti11  / -0.951056516295153572d0 /  !! cosine 9*pi/10
      data tr12  / -0.809016994374947424d0 /  !! cosine -pi/5
      data ti12  / -0.587785252292473129d0 /  !! sine -pi/5
c
c
      if (ido .eq. 2) then
         do k = 1, l1
            ti5 = cc(2,2,k) - cc(2,5,k)
            ti2 = cc(2,2,k) + cc(2,5,k)
            ti4 = cc(2,3,k) - cc(2,4,k)
            ti3 = cc(2,3,k) + cc(2,4,k)
            tr5 = cc(1,2,k) - cc(1,5,k)
            tr2 = cc(1,2,k) + cc(1,5,k)
            tr4 = cc(1,3,k) - cc(1,4,k)
            tr3 = cc(1,3,k) + cc(1,4,k)
            ch(1,k,1) = cc(1,1,k) + tr2 + tr3
            ch(2,k,1) = cc(2,1,k) + ti2 + ti3
            cr2 = cc(1,1,k) + tr11*tr2 + tr12*tr3
            ci2 = cc(2,1,k) + tr11*ti2 + tr12*ti3
            cr3 = cc(1,1,k) + tr12*tr2 + tr11*tr3
            ci3 = cc(2,1,k) + tr12*ti2 + tr11*ti3
            cr5 = ti11*tr5 + ti12*tr4
            ci5 = ti11*ti5 + ti12*ti4
            cr4 = ti12*tr5 - ti11*tr4
            ci4 = ti12*ti5 - ti11*ti4
            ch(1,k,2) = cr2 - ci5
            ch(1,k,5) = cr2 + ci5
            ch(2,k,2) = ci2 + cr5
            ch(2,k,3) = ci3 + cr4
            ch(1,k,3) = cr3 - ci4
            ch(1,k,4) = cr3 + ci4
            ch(2,k,4) = ci3 - cr4
            ch(2,k,5) = ci2 - cr5
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               ti5 = cc(i,2,k) - cc(i,5,k)
               ti2 = cc(i,2,k) + cc(i,5,k)
               ti4 = cc(i,3,k) - cc(i,4,k)
               ti3 = cc(i,3,k) + cc(i,4,k)
               tr5 = cc(i-1,2,k) - cc(i-1,5,k)
               tr2 = cc(i-1,2,k) + cc(i-1,5,k)
               tr4 = cc(i-1,3,k) - cc(i-1,4,k)
               tr3 = cc(i-1,3,k) + cc(i-1,4,k)
               ch(i-1,k,1) = cc(i-1,1,k) + tr2 + tr3
               ch(i,k,1) = cc(i,1,k) + ti2 + ti3
               cr2 = cc(i-1,1,k) + tr11*tr2 + tr12*tr3
               ci2 = cc(i,1,k) + tr11*ti2 + tr12*ti3
               cr3 = cc(i-1,1,k) + tr12*tr2 + tr11*tr3
               ci3 = cc(i,1,k) + tr12*ti2 + tr11*ti3
               cr5 = ti11*tr5 + ti12*tr4
               ci5 = ti11*ti5 + ti12*ti4
               cr4 = ti12*tr5 - ti11*tr4
               ci4 = ti12*ti5 - ti11*ti4
               dr3 = cr3 - ci4
               dr4 = cr3 + ci4
               di3 = ci3 + cr4
               di4 = ci3 - cr4
               dr5 = cr2 + ci5
               dr2 = cr2 - ci5
               di5 = ci2 - cr5
               di2 = ci2 + cr5
               ch(i-1,k,2) = wa1(i-1)*dr2 + wa1(i)*di2
               ch(i,k,2) = wa1(i-1)*di2 - wa1(i)*dr2
               ch(i-1,k,3) = wa2(i-1)*dr3 + wa2(i)*di3
               ch(i,k,3) = wa2(i-1)*di3 - wa2(i)*dr3
               ch(i-1,k,4) = wa3(i-1)*dr4 + wa3(i)*di4
               ch(i,k,4) = wa3(i-1)*di4 - wa3(i)*dr4
               ch(i-1,k,5) = wa4(i-1)*dr5 + wa4(i)*di5
               ch(i,k,5) = wa4(i-1)*di5 - wa4(i)*dr5
            end do
         end do
      end if
      return
      end
c
c
c     ########################
c     ##                    ##
c     ##  subroutine passb  ##
c     ##                    ##
c     ########################
c
c
      subroutine passb (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa)
      implicit none
      integer nac,ido,ip,l1,idl1
      integer i,j,k,l,ik,jc,lc
      integer idj,idl,idp,idij,idlj
      integer inc,idot,nt,ipp2,ipph
      real*8 wai,war
      real*8 cc(ido,ip,l1)
      real*8 c1(ido,l1,ip)
      real*8 c2(idl1,ip)
      real*8 ch(ido,l1,ip)
      real*8 ch2(idl1,ip)
      real*8 wa(*)
c
c
      idot = ido / 2
      nt = ip * idl1
      ipp2 = ip + 2
      ipph = (ip+1) / 2
      idp = ip * ido
      if (ido .ge. l1) then
         do j = 2, ipph
            jc = ipp2 - j
            do k = 1, l1
               do i = 1, ido
                  ch(i,k,j) = cc(i,j,k) + cc(i,jc,k)
                  ch(i,k,jc) = cc(i,j,k) - cc(i,jc,k)
               end do
            end do
         end do
         do k = 1, l1
            do i = 1, ido
               ch(i,k,1) = cc(i,1,k)
            end do
         end do
      else
         do j = 2, ipph
            jc = ipp2 - j
            do i = 1, ido
               do k = 1, l1
                  ch(i,k,j) = cc(i,j,k) + cc(i,jc,k)
                  ch(i,k,jc) = cc(i,j,k) - cc(i,jc,k)
               end do
            end do
         end do
         do i = 1, ido
            do k = 1, l1
               ch(i,k,1) = cc(i,1,k)
            end do
         end do
      end if
      idl = 2 - ido
      inc = 0
      do l = 2, ipph
         lc = ipp2 - l
         idl = idl + ido
         do ik = 1, idl1
            c2(ik,l) = ch2(ik,1) + wa(idl-1)*ch2(ik,2)
            c2(ik,lc) = wa(idl) * ch2(ik,ip)
         end do
         idlj = idl
         inc = inc + ido
         do j = 3, ipph
            jc = ipp2 - j
            idlj = idlj + inc
            if (idlj .gt. idp)  idlj = idlj - idp
            war = wa(idlj-1)
            wai = wa(idlj)
            do ik = 1, idl1
               c2(ik,l) = c2(ik,l) + war*ch2(ik,j)
               c2(ik,lc) = c2(ik,lc) + wai*ch2(ik,jc)
            end do
         end do
      end do
      do j = 2, ipph
         do ik = 1, idl1
            ch2(ik,1) = ch2(ik,1) + ch2(ik,j)
         end do
      end do
      do j = 2, ipph
         jc = ipp2 - j
         do ik = 2, idl1, 2
            ch2(ik-1,j) = c2(ik-1,j) - c2(ik,jc)
            ch2(ik-1,jc) = c2(ik-1,j) + c2(ik,jc)
            ch2(ik,j) = c2(ik,j) + c2(ik-1,jc)
            ch2(ik,jc) = c2(ik,j) - c2(ik-1,jc)
         end do
      end do
      nac = 1
      if (ido .ne. 2) then
         nac = 0
         do ik = 1, idl1
            c2(ik,1) = ch2(ik,1)
         end do
         do j = 2, ip
            do k = 1, l1
               c1(1,k,j) = ch(1,k,j)
               c1(2,k,j) = ch(2,k,j)
            end do
         end do
         if (idot .le. l1) then
            idij = 0
            do j = 2, ip
               idij = idij + 2
               do i = 4, ido, 2
                  idij = idij + 2
                  do k = 1, l1
                     c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)
     &                                - wa(idij)*ch(i,k,j)
                     c1(i,k,j) = wa(idij-1)*ch(i,k,j)
     &                              + wa(idij)*ch(i-1,k,j)
                  end do
               end do
            end do
         else
            idj = 2 - ido
            do j = 2, ip
               idj = idj + ido
               do k = 1, l1
                  idij = idj
                  do i = 4, ido, 2
                     idij = idij + 2
                     c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)
     &                                - wa(idij)*ch(i,k,j)
                     c1(i,k,j) = wa(idij-1)*ch(i,k,j)
     &                              + wa(idij)*ch(i-1,k,j)
                  end do
               end do
            end do
         end if
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passb2  ##
c     ##                     ##
c     #########################
c
c
      subroutine passb2 (ido,l1,cc,ch,wa1)
      implicit none
      integer i,k,ido,l1
      real*8 ti2,tr2
      real*8 cc(ido,2,l1)
      real*8 ch(ido,l1,2)
      real*8 wa1(*)
c
c
      if (ido .le. 2) then
         do k = 1, l1
            ch(1,k,1) = cc(1,1,k) + cc(1,2,k)
            ch(1,k,2) = cc(1,1,k) - cc(1,2,k)
            ch(2,k,1) = cc(2,1,k) + cc(2,2,k)
            ch(2,k,2) = cc(2,1,k) - cc(2,2,k)
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               ch(i-1,k,1) = cc(i-1,1,k) + cc(i-1,2,k)
               tr2 = cc(i-1,1,k) - cc(i-1,2,k)
               ch(i,k,1) = cc(i,1,k) + cc(i,2,k)
               ti2 = cc(i,1,k) - cc(i,2,k)
               ch(i,k,2) = wa1(i-1)*ti2 + wa1(i)*tr2
               ch(i-1,k,2) = wa1(i-1)*tr2 - wa1(i)*ti2
            end do
         end do
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passb3  ##
c     ##                     ##
c     #########################
c
c
      subroutine passb3 (ido,l1,cc,ch,wa1,wa2)
      implicit none
      integer i,k,ido,l1
      real*8 ti2,tr2,taur,taui
      real*8 ci2,ci3,cr2,cr3
      real*8 di2,di3,dr2,dr3
      real*8 cc(ido,3,l1)
      real*8 ch(ido,l1,3)
      real*8 wa1(*)
      real*8 wa2(*)
      data taur  / -0.5d0 /
      data taui  /  0.866025403784438647d0 /  !! sqrt(3)/2
c
c
      if (ido .eq. 2) then
         do k = 1, l1
            tr2 = cc(1,2,k) + cc(1,3,k)
            cr2 = cc(1,1,k) + taur*tr2
            ch(1,k,1) = cc(1,1,k) + tr2
            ti2 = cc(2,2,k) + cc(2,3,k)
            ci2 = cc(2,1,k) + taur*ti2
            ch(2,k,1) = cc(2,1,k) + ti2
            cr3 = taui * (cc(1,2,k)-cc(1,3,k))
            ci3 = taui * (cc(2,2,k)-cc(2,3,k))
            ch(1,k,2) = cr2 - ci3
            ch(1,k,3) = cr2 + ci3
            ch(2,k,2) = ci2 + cr3
            ch(2,k,3) = ci2 - cr3
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               tr2 = cc(i-1,2,k) + cc(i-1,3,k)
               cr2 = cc(i-1,1,k) + taur*tr2
               ch(i-1,k,1) = cc(i-1,1,k) + tr2
               ti2 = cc(i,2,k) + cc(i,3,k)
               ci2 = cc(i,1,k) + taur*ti2
               ch(i,k,1) = cc(i,1,k) + ti2
               cr3 = taui * (cc(i-1,2,k)-cc(i-1,3,k))
               ci3 = taui * (cc(i,2,k)-cc(i,3,k))
               dr2 = cr2 - ci3
               dr3 = cr2 + ci3
               di2 = ci2 + cr3
               di3 = ci2 - cr3
               ch(i,k,2) = wa1(i-1)*di2 + wa1(i)*dr2
               ch(i-1,k,2) = wa1(i-1)*dr2 - wa1(i)*di2
               ch(i,k,3) = wa2(i-1)*di3 + wa2(i)*dr3
               ch(i-1,k,3) = wa2(i-1)*dr3 - wa2(i)*di3
            end do
         end do
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passb4  ##
c     ##                     ##
c     #########################
c
c
      subroutine passb4 (ido,l1,cc,ch,wa1,wa2,wa3)
      implicit none
      integer i,k,ido,l1
      real*8 ci2,ci3,ci4
      real*8 cr2,cr3,cr4
      real*8 ti1,ti2,ti3,ti4
      real*8 tr1,tr2,tr3,tr4
      real*8 cc(ido,4,l1)
      real*8 ch(ido,l1,4)
      real*8 wa1(*)
      real*8 wa2(*)
      real*8 wa3(*)
c
c
      if (ido .eq. 2) then
         do k = 1, l1
            ti1 = cc(2,1,k) - cc(2,3,k)
            ti2 = cc(2,1,k) + cc(2,3,k)
            tr4 = cc(2,4,k) - cc(2,2,k)
            ti3 = cc(2,2,k) + cc(2,4,k)
            tr1 = cc(1,1,k) - cc(1,3,k)
            tr2 = cc(1,1,k) + cc(1,3,k)
            ti4 = cc(1,2,k) - cc(1,4,k)
            tr3 = cc(1,2,k) + cc(1,4,k)
            ch(1,k,1) = tr2 + tr3
            ch(1,k,3) = tr2 - tr3
            ch(2,k,1) = ti2 + ti3
            ch(2,k,3) = ti2 - ti3
            ch(1,k,2) = tr1 + tr4
            ch(1,k,4) = tr1 - tr4
            ch(2,k,2) = ti1 + ti4
            ch(2,k,4) = ti1 - ti4
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               ti1 = cc(i,1,k) - cc(i,3,k)
               ti2 = cc(i,1,k) + cc(i,3,k)
               ti3 = cc(i,2,k) + cc(i,4,k)
               tr4 = cc(i,4,k) - cc(i,2,k)
               tr1 = cc(i-1,1,k) - cc(i-1,3,k)
               tr2 = cc(i-1,1,k) + cc(i-1,3,k)
               ti4 = cc(i-1,2,k) - cc(i-1,4,k)
               tr3 = cc(i-1,2,k) + cc(i-1,4,k)
               ch(i-1,k,1) = tr2 + tr3
               cr3 = tr2 - tr3
               ch(i,k,1) = ti2 + ti3
               ci3 = ti2 - ti3
               cr2 = tr1 + tr4
               cr4 = tr1 - tr4
               ci2 = ti1 + ti4
               ci4 = ti1 - ti4
               ch(i-1,k,2) = wa1(i-1)*cr2 - wa1(i)*ci2
               ch(i,k,2) = wa1(i-1)*ci2 + wa1(i)*cr2
               ch(i-1,k,3) = wa2(i-1)*cr3 - wa2(i)*ci3
               ch(i,k,3) = wa2(i-1)*ci3 + wa2(i)*cr3
               ch(i-1,k,4) = wa3(i-1)*cr4 - wa3(i)*ci4
               ch(i,k,4) = wa3(i-1)*ci4 + wa3(i)*cr4
            end do
         end do
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passb5  ##
c     ##                     ##
c     #########################
c
c
      subroutine passb5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4)
      implicit none
      integer i,k,ido,l1
      real*8 ci2,ci3,ci4,ci5
      real*8 cr2,cr3,cr4,cr5
      real*8 di2,di3,di4,di5
      real*8 dr2,dr3,dr4,dr5
      real*8 ti2,ti3,ti4,ti5
      real*8 tr2,tr3,tr4,tr5
      real*8 tr11,ti11
      real*8 tr12,ti12
      real*8 cc(ido,5,l1)
      real*8 ch(ido,l1,5)
      real*8 wa1(*)
      real*8 wa2(*)
      real*8 wa3(*)
      real*8 wa4(*)
      data tr11  /  0.309016994374947424d0 /  !! sine pi/10
      data ti11  /  0.951056516295153572d0 /  !! cosine pi/10
      data tr12  / -0.809016994374947424d0 /  !! cosine 4*pi/5
      data ti12  /  0.587785252292473129d0 /  !! sine 4*pi/5
c
c
      if (ido .eq. 2) then
         do k = 1, l1
            ti5 = cc(2,2,k) - cc(2,5,k)
            ti2 = cc(2,2,k) + cc(2,5,k)
            ti4 = cc(2,3,k) - cc(2,4,k)
            ti3 = cc(2,3,k) + cc(2,4,k)
            tr5 = cc(1,2,k) - cc(1,5,k)
            tr2 = cc(1,2,k) + cc(1,5,k)
            tr4 = cc(1,3,k) - cc(1,4,k)
            tr3 = cc(1,3,k) + cc(1,4,k)
            ch(1,k,1) = cc(1,1,k) + tr2 + tr3
            ch(2,k,1) = cc(2,1,k) + ti2 + ti3
            cr2 = cc(1,1,k) + tr11*tr2 + tr12*tr3
            ci2 = cc(2,1,k) + tr11*ti2 + tr12*ti3
            cr3 = cc(1,1,k) + tr12*tr2 + tr11*tr3
            ci3 = cc(2,1,k) + tr12*ti2 + tr11*ti3
            cr5 = ti11*tr5 + ti12*tr4
            ci5 = ti11*ti5 + ti12*ti4
            cr4 = ti12*tr5 - ti11*tr4
            ci4 = ti12*ti5 - ti11*ti4
            ch(1,k,2) = cr2 - ci5
            ch(1,k,5) = cr2 + ci5
            ch(2,k,2) = ci2 + cr5
            ch(2,k,3) = ci3 + cr4
            ch(1,k,3) = cr3 - ci4
            ch(1,k,4) = cr3 + ci4
            ch(2,k,4) = ci3 - cr4
            ch(2,k,5) = ci2 - cr5
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               ti5 = cc(i,2,k) - cc(i,5,k)
               ti2 = cc(i,2,k) + cc(i,5,k)
               ti4 = cc(i,3,k) - cc(i,4,k)
               ti3 = cc(i,3,k) + cc(i,4,k)
               tr5 = cc(i-1,2,k) - cc(i-1,5,k)
               tr2 = cc(i-1,2,k) + cc(i-1,5,k)
               tr4 = cc(i-1,3,k) - cc(i-1,4,k)
               tr3 = cc(i-1,3,k) + cc(i-1,4,k)
               ch(i-1,k,1) = cc(i-1,1,k) + tr2 + tr3
               ch(i,k,1) = cc(i,1,k) + ti2 + ti3
               cr2 = cc(i-1,1,k) + tr11*tr2 + tr12*tr3
               ci2 = cc(i,1,k) + tr11*ti2 + tr12*ti3
               cr3 = cc(i-1,1,k) + tr12*tr2 + tr11*tr3
               ci3 = cc(i,1,k) + tr12*ti2 + tr11*ti3
               cr5 = ti11*tr5 + ti12*tr4
               ci5 = ti11*ti5 + ti12*ti4
               cr4 = ti12*tr5 - ti11*tr4
               ci4 = ti12*ti5 - ti11*ti4
               dr3 = cr3 - ci4
               dr4 = cr3 + ci4
               di3 = ci3 + cr4
               di4 = ci3 - cr4
               dr5 = cr2 + ci5
               dr2 = cr2 - ci5
               di5 = ci2 - cr5
               di2 = ci2 + cr5
               ch(i-1,k,2) = wa1(i-1)*dr2 - wa1(i)*di2
               ch(i,k,2) = wa1(i-1)*di2 + wa1(i)*dr2
               ch(i-1,k,3) = wa2(i-1)*dr3 - wa2(i)*di3
               ch(i,k,3) = wa2(i-1)*di3 + wa2(i)*dr3
               ch(i-1,k,4) = wa3(i-1)*dr4 - wa3(i)*di4
               ch(i,k,4) = wa3(i-1)*di4 + wa3(i)*dr4
               ch(i-1,k,5) = wa4(i-1)*dr5 - wa4(i)*di5
               ch(i,k,5) = wa4(i-1)*di5 + wa4(i)*dr5
            end do
         end do
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine field  --  get the potential energy functions  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "field" sets the force field potential energy functions from
c     a parameter file and modifications specified in a keyfile
c
c
      subroutine field
      use fields
      use inform
      use iounit
      use keys
      use potent
      use sizes
      implicit none
      integer i,next
      integer ia,ib
      logical header
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set the default values for the active potentials
c
      use_bond = .true.
      use_angle = .true.
      use_strbnd = .true.
      use_urey = .true.
      use_angang = .true.
      use_opbend = .true.
      use_opdist = .true.
      use_improp = .true.
      use_imptor = .true.
      use_tors = .true.
      use_pitors = .true.
      use_strtor = .true.
      use_angtor = .true.
      use_tortor = .true.
      use_vdw = .true.
      use_repel = .true.
      use_disp = .true.
      use_charge = .true.
      use_chgdpl = .true.
      use_dipole = .true.
      use_mpole = .true.
      use_polar = .true.
      use_chgtrn = .true.
      use_chgflx = .true.
      use_rxnfld = .false.
      use_solv = .true.
      use_metal = .false.
      use_geom = .true.
      use_extra = .true.
c
c     read the potential energy force field parameter file
c
      call getprm
c
c     check keywords for biopolymer atom type definitions
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:8) .eq. 'BIOTYPE ') then
            ia = 0
            ib = 0
            string = record(next:240)
            read (string,*,err=10,end=10)  ia
            call getword (record,string,next)
            call getstring (record,string,next)
            string = record(next:240)
            read (string,*,err=10,end=10)  ib
   10       continue
            if (ia.ge.0 .and. ia.le.maxbio) then
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Biopolymer Type Definitions',
     &                    //,5x,'BioType',10x,'Atom Type',/)
               end if
               biotyp(ia) = ib
               if (.not. silent) then
                  write (iout,30)  ia,ib
   30             format (1x,i8,8x,i8)
               end if

            else if (ia .gt. maxbio) then
               write (iout,40)
   40          format (/,' FIELDS  --  Too many Biopolymer Types;',
     &                    ' Increase MAXBIO')
               call fatal
            end if
         end if
      end do
c
c     check keywords for potential function control parameters
c
      do i = 1, nkey
         record = keyline(i)
         call prmkey (record)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module fields  --  molecular mechanics force field type  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     biotyp       force field atom type of each biopolymer type
c     forcefield   string used to describe the current forcefield
c
c
      module fields
      implicit none
      integer, allocatable :: biotyp(:)
      character*20 forcefield
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module files  --  name & number of current structure file  ##
c     ##                                                             ##
c     #################################################################
c
c
c     nprior     number of previously existing cycle files
c     ldir       length in characters of the directory name
c     leng       length in characters of the base filename
c     filename   full filename including any extension or version
c     outfile    output filename used for intermediate results
c
c
      module files
      implicit none
      integer nprior
      integer ldir,leng
      character*240 filename
      character*240 outfile
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine final  --  final actions before program exit  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "final" performs any final program actions such as deallocation
c     of global memory, prints a status message, and then pauses if
c     necessary to avoid closing the execution window
c
c
      subroutine final
      use align
      use analyz
      use angang
      use angbnd
      use angtor
      use atmlst
      use bitor
      use bndstr
      use cell
      use cflux
      use charge
      use chgpen
      use chgtrn
      use chunks
      use couple
      use deriv
      use dipole
      use disgeo
      use domega
      use expol
      use faces
      use fft
      use fields
      use fracs
      use freeze
      use group
      use hessn
      use hpmf
      use ielscf
      use improp
      use imptor
      use inform
      use iounit
      use kanang
      use kangs
      use kantor
      use katoms
      use kbonds
      use kcflux
      use kchrge
      use kcpen
      use kctrn
      use kdipol
      use kdsp
      use kexpl
      use keys
      use khbond
      use kiprop
      use kitors
      use kmulti
      use kopbnd
      use kopdst
      use korbs
      use kpitor
      use kpolpr
      use kpolr
      use krepl
      use ksolut
      use kstbnd
      use ksttor
      use ktorsn
      use ktrtor
      use kurybr
      use kvdwpr
      use kvdws
      use light
      use limits
      use merck
      use molcul
      use moldyn
      use mpole
      use mrecip
      use mutant
      use neigh
      use nonpol
      use omega
      use opbend
      use opdist
      use orbits
      use params
      use paths
      use pbstuf
      use pdb
      use piorbs
      use pistuf
      use pitors
      use pme
      use polar
      use polgrp
      use polopt
      use polpcg
      use poltcg
      use potfit
      use qmstuf
      use refer
      use repel
      use restrn
      use rgddyn
      use rigid
      use ring
      use rotbnd
      use shapes
      use socket
      use solpot
      use solute
      use stodyn
      use strbnd
      use strtor
      use syntrn
      use tarray
      use tettor
      use tors
      use tortor
      use tritor
      use uprior
      use urey
      use usage
      use vdw
      use vibs
      use warp
      implicit none
c
c
c     free memory used by the APBS Poisson-Boltzmann solver
c
      if (solvtyp(1:2) .eq. 'PB') then
         call apbsfinal
      end if
c
c     free memory used by the Fourier transform routines
c
      if (use_ewald .or. use_dewald) then
         call fftclose
      end if
c
c     close any open socket used for external communication
c
      if (use_socket) then
         call sktkill
      end if
c
c     print a final status message before exiting Tinker
c
      if (debug) then
         write (iout,10)
   10    format (/,' Tinker is Exiting following Normal Termination')
      end if
c
c     ensure any output is written to the storage device
c
      flush (iout)
c
c     deallocation of global arrays from module align
c
      if (allocated(ifit))  deallocate (ifit)
      if (allocated(wfit))  deallocate (wfit)
c
c     deallocation of global arrays from module analyz
c
      if (allocated(aesum))  deallocate (aesum)
      if (allocated(aeb))  deallocate (aeb)
      if (allocated(aea))  deallocate (aea)
      if (allocated(aeba))  deallocate (aeba)
      if (allocated(aeub))  deallocate (aeub)
      if (allocated(aeaa))  deallocate (aeaa)
      if (allocated(aeopb))  deallocate (aeopb)
      if (allocated(aeopd))  deallocate (aeopd)
      if (allocated(aeid))  deallocate (aeid)
      if (allocated(aeit))  deallocate (aeit)
      if (allocated(aet))  deallocate (aet)
      if (allocated(aept))  deallocate (aept)
      if (allocated(aebt))  deallocate (aebt)
      if (allocated(aeat))  deallocate (aeat)
      if (allocated(aett))  deallocate (aett)
      if (allocated(aev))  deallocate (aev)
      if (allocated(aer))  deallocate (aer)
      if (allocated(aedsp))  deallocate (aedsp)
      if (allocated(aec))  deallocate (aec)
      if (allocated(aecd))  deallocate (aecd)
      if (allocated(aed))  deallocate (aed)
      if (allocated(aem))  deallocate (aem)
      if (allocated(aep))  deallocate (aep)
      if (allocated(aect))  deallocate (aect)
      if (allocated(aerxf))  deallocate (aerxf)
      if (allocated(aes))  deallocate (aes)
      if (allocated(aelf))  deallocate (aelf)
      if (allocated(aeg))  deallocate (aeg)
      if (allocated(aex))  deallocate (aex)
c
c     deallocation of global arrays from module angang
c
      if (allocated(iaa))  deallocate (iaa)
      if (allocated(kaa))  deallocate (kaa)
c
c     deallocation of global arrays from module angbnd
c
      if (allocated(iang))  deallocate (iang)
      if (allocated(ak))  deallocate (ak)
      if (allocated(anat))  deallocate (anat)
      if (allocated(afld))  deallocate (afld)
c
c     deallocation of global arrays from module angtor
c
      if (allocated(iat))  deallocate (iat)
      if (allocated(kant))  deallocate (kant)
c
c     deallocation of global arrays from module atmlst
c
      if (allocated(bndlist))  deallocate (bndlist)
      if (allocated(anglist))  deallocate (anglist)
      if (allocated(balist))  deallocate (balist)
c
c     deallocation of global arrays from module bitor
c
      if (allocated(ibitor))  deallocate (ibitor)
c
c     deallocation of global arrays from module bndstr
c
      if (allocated(ibnd))  deallocate (ibnd)
      if (allocated(bk))  deallocate (bk)
      if (allocated(bl))  deallocate (bl)
c
c     deallocation of global arrays from module cell
c
      if (allocated(icell))  deallocate (icell)
c
c     deallocation of global arrays from module cflux
c
      if (allocated(bflx))  deallocate (bflx)
      if (allocated(aflx))  deallocate (aflx)
      if (allocated(abflx))  deallocate (abflx)
c
c     deallocation of global arrays from module charge
c
      if (allocated(iion))  deallocate (iion)
      if (allocated(jion))  deallocate (jion)
      if (allocated(kion))  deallocate (kion)
      if (allocated(pchg))  deallocate (pchg)
      if (allocated(pchg0))  deallocate (pchg0)
c
c     deallocation of global arrays from module chgpen
c
      if (allocated(pcore))  deallocate (pcore)
      if (allocated(pval))  deallocate (pval)
      if (allocated(pval0))  deallocate (pval0)
      if (allocated(palpha))  deallocate (palpha)
c
c     deallocation of global arrays from module chgtrn
c
      if (allocated(chgct))  deallocate (chgct)
      if (allocated(dmpct))  deallocate (dmpct)
c
c     deallocation of global arrays from module chunks
c
      if (allocated(pmetable))  deallocate (pmetable)
c
c     deallocation of global arrays from module couple
c
      if (allocated(n13))  deallocate (n13)
      if (allocated(n14))  deallocate (n14)
      if (allocated(n15))  deallocate (n15)
      if (allocated(i13))  deallocate (i13)
      if (allocated(i14))  deallocate (i14)
      if (allocated(i15))  deallocate (i15)
c
c     deallocation of global arrays from module deriv
c
      if (allocated(desum))  deallocate (desum)
      if (allocated(deb))  deallocate (deb)
      if (allocated(dea))  deallocate (dea)
      if (allocated(deba))  deallocate (deba)
      if (allocated(deub))  deallocate (deub)
      if (allocated(deaa))  deallocate (deaa)
      if (allocated(deopb))  deallocate (deopb)
      if (allocated(deopd))  deallocate (deopd)
      if (allocated(deid))  deallocate (deid)
      if (allocated(deit))  deallocate (deit)
      if (allocated(det))  deallocate (det)
      if (allocated(dept))  deallocate (dept)
      if (allocated(debt))  deallocate (debt)
      if (allocated(deat))  deallocate (deat)
      if (allocated(dett))  deallocate (dett)
      if (allocated(dev))  deallocate (dev)
      if (allocated(der))  deallocate (der)
      if (allocated(dedsp))  deallocate (dedsp)
      if (allocated(dec))  deallocate (dec)
      if (allocated(decd))  deallocate (decd)
      if (allocated(ded))  deallocate (ded)
      if (allocated(dem))  deallocate (dem)
      if (allocated(dep))  deallocate (dep)
      if (allocated(dect))  deallocate (dect)
      if (allocated(derxf))  deallocate (derxf)
      if (allocated(des))  deallocate (des)
      if (allocated(delf))  deallocate (delf)
      if (allocated(deg))  deallocate (deg)
      if (allocated(dex))  deallocate (dex)
c
c     deallocation of global arrays from module dipole
c
      if (allocated(idpl))  deallocate (idpl)
      if (allocated(bdpl))  deallocate (bdpl)
      if (allocated(sdpl))  deallocate (sdpl)
c
c     deallocation of global arrays from module disgeo
c
      if (allocated(dbnd))  deallocate (dbnd)
      if (allocated(georad))  deallocate (georad)
c
c     deallocation of global arrays from module domega
c
      if (allocated(tesum))  deallocate (tesum)
      if (allocated(teb))  deallocate (teb)
      if (allocated(tea))  deallocate (tea)
      if (allocated(teba))  deallocate (teba)
      if (allocated(teub))  deallocate (teub)
      if (allocated(teaa))  deallocate (teaa)
      if (allocated(teopb))  deallocate (teopb)
      if (allocated(teopd))  deallocate (teopd)
      if (allocated(teid))  deallocate (teid)
      if (allocated(teit))  deallocate (teit)
      if (allocated(tet))  deallocate (tet)
      if (allocated(tept))  deallocate (tept)
      if (allocated(tebt))  deallocate (tebt)
      if (allocated(teat))  deallocate (teat)
      if (allocated(tett))  deallocate (tett)
      if (allocated(tev))  deallocate (tev)
      if (allocated(ter))  deallocate (ter)
      if (allocated(tedsp))  deallocate (tedsp)
      if (allocated(tec))  deallocate (tec)
      if (allocated(tecd))  deallocate (tecd)
      if (allocated(ted))  deallocate (ted)
      if (allocated(tem))  deallocate (tem)
      if (allocated(tep))  deallocate (tep)
      if (allocated(tect))  deallocate (tect)
      if (allocated(terxf))  deallocate (terxf)
      if (allocated(tes))  deallocate (tes)
      if (allocated(telf))  deallocate (telf)
      if (allocated(teg))  deallocate (teg)
      if (allocated(tex))  deallocate (tex)
c
c     deallocation of global arrays from module expol
c
      if (allocated(kpep))  deallocate (kpep)
      if (allocated(prepep))  deallocate (prepep)
      if (allocated(dmppep))  deallocate (dmppep)
      if (allocated(lpep))  deallocate (lpep)
      if (allocated(polscale))  deallocate (polscale)
      if (allocated(polinv))  deallocate (polinv)
c
c     deallocation of global arrays from module faces
c
      if (allocated(ar))  deallocate (ar)
      if (allocated(axyz))  deallocate (axyz)
      if (allocated(skip))  deallocate (skip)
      if (allocated(nosurf))  deallocate (nosurf)
      if (allocated(afree))  deallocate (afree)
      if (allocated(abur))  deallocate (abur)
      if (allocated(cls))  deallocate (cls)
      if (allocated(clst))  deallocate (clst)
      if (allocated(acls))  deallocate (acls)
      if (allocated(ttfe))  deallocate (ttfe)
      if (allocated(ttle))  deallocate (ttle)
      if (allocated(enext))  deallocate (enext)
      if (allocated(tta))  deallocate (tta)
      if (allocated(ttbur))  deallocate (ttbur)
      if (allocated(ttfree))  deallocate (ttfree)
      if (allocated(tfe))  deallocate (tfe)
      if (allocated(ta))  deallocate (ta)
      if (allocated(tr))  deallocate (tr)
      if (allocated(t))  deallocate (t)
      if (allocated(tax))  deallocate (tax)
      if (allocated(tfree))  deallocate (tfree)
      if (allocated(pa))  deallocate (pa)
      if (allocated(p))  deallocate (p)
      if (allocated(va))  deallocate (va)
      if (allocated(vp))  deallocate (vp)
      if (allocated(vxyz))  deallocate (vxyz)
      if (allocated(env))  deallocate (env)
      if (allocated(fnen))  deallocate (fnen)
      if (allocated(ca))  deallocate (ca)
      if (allocated(ct))  deallocate (ct)
      if (allocated(cr))  deallocate (cr)
      if (allocated(c))  deallocate (c)
      if (allocated(eqc))  deallocate (eqc)
      if (allocated(eqv))  deallocate (eqv)
      if (allocated(afe))  deallocate (afe)
      if (allocated(ale))  deallocate (ale)
      if (allocated(eqnext))  deallocate (eqnext)
      if (allocated(fsen))  deallocate (fsen)
      if (allocated(fseq))  deallocate (fseq)
      if (allocated(cyneq))  deallocate (cyneq)
      if (allocated(cyeq))  deallocate (cyeq)
      if (allocated(fqa))  deallocate (fqa)
      if (allocated(fqncy))  deallocate (fqncy)
      if (allocated(fqcy))  deallocate (fqcy)
c
c     deallocation of global arrays from module fft
c
      if (allocated(ffttable))  deallocate (ffttable)
c
c     deallocation of global arrays from module fields
c
      if (allocated(biotyp))  deallocate (biotyp)
c
c     deallocation of global arrays from module fracs
c
      if (allocated(xfrac))  deallocate (xfrac)
      if (allocated(yfrac))  deallocate (yfrac)
      if (allocated(zfrac))  deallocate (zfrac)
c
c     deallocation of global arrays from module freeze
c
      if (allocated(iratx))  deallocate (iratx)
      if (allocated(kratx))  deallocate (kratx)
      if (allocated(irat))  deallocate (irat)
      if (allocated(iwat))  deallocate (iwat)
      if (allocated(iwat4))  deallocate (iwat4)
      if (allocated(krat))  deallocate (krat)
      if (allocated(kwat))  deallocate (kwat)
      if (allocated(kwat4))  deallocate (kwat4)
      if (allocated(frzimage))  deallocate (frzimage)
c
c     deallocation of global arrays from module group
c
      if (allocated(kgrp))  deallocate (kgrp)
      if (allocated(grplist))  deallocate (grplist)
      if (allocated(igrp))  deallocate (igrp)
      if (allocated(grpmass))  deallocate (grpmass)
      if (allocated(wgrp))  deallocate (wgrp)
c
c     deallocation of global arrays from module hessn
c
      if (allocated(hessx))  deallocate (hessx)
      if (allocated(hessy))  deallocate (hessy)
      if (allocated(hessz))  deallocate (hessz)
c
c     deallocation of global arrays from module hpmf
c
      if (allocated(ipmf))  deallocate (ipmf)
      if (allocated(rpmf))  deallocate (rpmf)
      if (allocated(acsa))  deallocate (acsa)
c
c     deallocation of global arrays from module ielscf
c
      if (allocated(uaux))  deallocate (uaux)
      if (allocated(upaux))  deallocate (upaux)
      if (allocated(vaux))  deallocate (vaux)
      if (allocated(vpaux))  deallocate (vpaux)
      if (allocated(aaux))  deallocate (aaux)
      if (allocated(apaux))  deallocate (apaux)
c
c     deallocation of global arrays from module improp
c
      if (allocated(iiprop))  deallocate (iiprop)
      if (allocated(kprop))  deallocate (kprop)
      if (allocated(vprop))  deallocate (vprop)
c
c     deallocation of global arrays from module imptor
c
      if (allocated(iitors))  deallocate (iitors)
      if (allocated(itors1))  deallocate (itors1)
      if (allocated(itors2))  deallocate (itors2)
      if (allocated(itors3))  deallocate (itors3)
c
c     deallocation of global arrays from module kanang
c
      if (allocated(anan))  deallocate (anan)
c
c     deallocation of global arrays from module kangs
c
      if (allocated(acon))  deallocate (acon)
      if (allocated(acon5))  deallocate (acon5)
      if (allocated(acon4))  deallocate (acon4)
      if (allocated(acon3))  deallocate (acon3)
      if (allocated(aconp))  deallocate (aconp)
      if (allocated(aconf))  deallocate (aconf)
      if (allocated(ang))  deallocate (ang)
      if (allocated(ang5))  deallocate (ang5)
      if (allocated(ang4))  deallocate (ang4)
      if (allocated(ang3))  deallocate (ang3)
      if (allocated(angp))  deallocate (angp)
      if (allocated(angf))  deallocate (angf)
      if (allocated(ka))  deallocate (ka)
      if (allocated(ka5))  deallocate (ka5)
      if (allocated(ka4))  deallocate (ka4)
      if (allocated(ka3))  deallocate (ka3)
      if (allocated(kap))  deallocate (kap)
      if (allocated(kaf))  deallocate (kaf)
c
c     deallocation of global arrays from module kantor
c
      if (allocated(atcon))  deallocate (atcon)
      if (allocated(kat))  deallocate (kat)
c
c     deallocation of global arrays from module katoms
c
      if (allocated(atmcls))  deallocate (atmcls)
      if (allocated(atmnum))  deallocate (atmnum)
      if (allocated(ligand))  deallocate (ligand)
      if (allocated(weight))  deallocate (weight)
      if (allocated(symbol))  deallocate (symbol)
      if (allocated(describe))  deallocate (describe)
c
c     deallocation of global arrays from module kbonds
c
      if (allocated(bcon))  deallocate (bcon)
      if (allocated(bcon5))  deallocate (bcon5)
      if (allocated(bcon4))  deallocate (bcon4)
      if (allocated(bcon3))  deallocate (bcon3)
      if (allocated(blen))  deallocate (blen)
      if (allocated(blen5))  deallocate (blen5)
      if (allocated(blen4))  deallocate (blen4)
      if (allocated(blen3))  deallocate (blen3)
      if (allocated(dlen))  deallocate (dlen)
      if (allocated(kb))  deallocate (kb)
      if (allocated(kb5))  deallocate (kb5)
      if (allocated(kb4))  deallocate (kb4)
      if (allocated(kb3))  deallocate (kb3)
      if (allocated(kel))  deallocate (kel)
c
c     deallocation of global arrays from module kcflux
c
      if (allocated(cflb))  deallocate (cflb)
      if (allocated(cfla))  deallocate (cfla)
      if (allocated(cflab))  deallocate (cflab)
      if (allocated(kcfb))  deallocate (kcfb)
      if (allocated(kcfa))  deallocate (kcfa)
c
c     deallocation of global arrays from module kchrge
c
      if (allocated(chg))  deallocate (chg)
c
c     deallocation of global arrays from module kcpen
c
      if (allocated(cpele))  deallocate (cpele)
      if (allocated(cpalp))  deallocate (cpalp)
c
c     deallocation of global arrays from module kctrn
c
      if (allocated(ctchg))  deallocate (ctchg)
      if (allocated(ctdmp))  deallocate (ctdmp)
c
c     deallocation of global arrays from module kdipol
c
      if (allocated(dpl))  deallocate (dpl)
      if (allocated(dpl5))  deallocate (dpl5)
      if (allocated(dpl4))  deallocate (dpl4)
      if (allocated(dpl3))  deallocate (dpl3)
      if (allocated(pos))  deallocate (pos)
      if (allocated(pos5))  deallocate (pos5)
      if (allocated(pos4))  deallocate (pos4)
      if (allocated(pos3))  deallocate (pos3)
      if (allocated(kd))  deallocate (kd)
      if (allocated(kd5))  deallocate (kd5)
      if (allocated(kd4))  deallocate (kd4)
      if (allocated(kd3))  deallocate (kd3)
c
c     deallocation of global arrays from module kdsp
c
      if (allocated(dspsix))  deallocate (dspsix)
      if (allocated(dspdmp))  deallocate (dspdmp)
c
c     deallocation of global arrays from module kexpl
c
      if (allocated(pepk))  deallocate (pepk)
      if (allocated(peppre))  deallocate (peppre)
      if (allocated(pepdmp))  deallocate (pepdmp)
      if (allocated(pepl))  deallocate (pepl)
c
c     deallocation of global arrays from module keys
c
      if (allocated(keyline))  deallocate (keyline)
c
c     deallocation of global arrays from module khbond
c
      if (allocated(radhb))  deallocate (radhb)
      if (allocated(epshb))  deallocate (epshb)
      if (allocated(khb))  deallocate (khb)
c
c     deallocation of global arrays from module kiprop
c
      if (allocated(dcon))  deallocate (dcon)
      if (allocated(tdi))  deallocate (tdi)
      if (allocated(kdi))  deallocate (kdi)
c
c     deallocation of global arrays from module kitors
c
      if (allocated(ti1))  deallocate (ti1)
      if (allocated(ti2))  deallocate (ti2)
      if (allocated(ti3))  deallocate (ti3)
      if (allocated(kti))  deallocate (kti)
c
c     deallocation of global arrays from module kmulti
c
      if (allocated(multip))  deallocate (multip)
      if (allocated(mpaxis))  deallocate (mpaxis)
      if (allocated(kmp))  deallocate (kmp)
c
c     deallocation of global arrays from module kopbnd
c
      if (allocated(opbn))  deallocate (opbn)
      if (allocated(kopb))  deallocate (kopb)
c
c     deallocation of global arrays from module kopdst
c
      if (allocated(opds))  deallocate (opds)
      if (allocated(kopd))  deallocate (kopd)
c
c     deallocation of global arrays from module korbs
c
      if (allocated(electron))  deallocate (electron)
      if (allocated(ionize))  deallocate (ionize)
      if (allocated(repulse))  deallocate (repulse)
      if (allocated(sslope))  deallocate (sslope)
      if (allocated(sslope5))  deallocate (sslope5)
      if (allocated(sslope4))  deallocate (sslope4)
      if (allocated(tslope))  deallocate (tslope)
      if (allocated(tslope5))  deallocate (tslope5)
      if (allocated(tslope4))  deallocate (tslope4)
      if (allocated(kpi))  deallocate (kpi)
      if (allocated(kpi5))  deallocate (kpi5)
      if (allocated(kpi4))  deallocate (kpi4)
c
c     deallocation of global arrays from module kpitor
c
      if (allocated(ptcon))  deallocate (ptcon)
      if (allocated(kpt))  deallocate (kpt)
c
c     deallocation of global arrays from module kpolpr
c
      if (allocated(thlpr))  deallocate (thlpr)
      if (allocated(thdpr))  deallocate (thdpr)
      if (allocated(kppr))  deallocate (kppr)
c
c     deallocation of global arrays from module kpolr
c
      if (allocated(pgrp))  deallocate (pgrp)
      if (allocated(polr))  deallocate (polr)
      if (allocated(athl))  deallocate (athl)
      if (allocated(dthl))  deallocate (dthl)
c
c     deallocation of global arrays from module krepl
c
      if (allocated(prsiz))  deallocate (prsiz)
      if (allocated(prdmp))  deallocate (prdmp)
      if (allocated(prele))  deallocate (prele)
c
c     deallocation of global arrays from module ksolut
c
      if (allocated(pbr))  deallocate (pbr)
      if (allocated(csr))  deallocate (csr)
      if (allocated(gkr))  deallocate (gkr)
      if (allocated(snk))  deallocate (snk)
c
c     deallocation of global arrays from module kstbnd
c
      if (allocated(stbn))  deallocate (stbn)
      if (allocated(ksb))  deallocate (ksb)
c
c     deallocation of global arrays from module ksttor
c
      if (allocated(btcon))  deallocate (btcon)
      if (allocated(kbt))  deallocate (kbt)
c
c     deallocation of global arrays from module ktorsn
c
      if (allocated(t1))  deallocate (t1)
      if (allocated(t2))  deallocate (t2)
      if (allocated(t3))  deallocate (t3)
      if (allocated(t4))  deallocate (t4)
      if (allocated(t5))  deallocate (t5)
      if (allocated(t6))  deallocate (t6)
      if (allocated(t15))  deallocate (t15)
      if (allocated(t25))  deallocate (t25)
      if (allocated(t35))  deallocate (t35)
      if (allocated(t45))  deallocate (t45)
      if (allocated(t55))  deallocate (t55)
      if (allocated(t65))  deallocate (t65)
      if (allocated(t14))  deallocate (t14)
      if (allocated(t24))  deallocate (t24)
      if (allocated(t34))  deallocate (t34)
      if (allocated(t44))  deallocate (t44)
      if (allocated(t54))  deallocate (t54)
      if (allocated(t64))  deallocate (t64)
      if (allocated(kt))  deallocate (kt)
      if (allocated(kt5))  deallocate (kt5)
      if (allocated(kt4))  deallocate (kt4)
c
c     deallocation of global arrays from module ktrtor
c
      if (allocated(tnx))  deallocate (tnx)
      if (allocated(tny))  deallocate (tny)
      if (allocated(ttx))  deallocate (ttx)
      if (allocated(tty))  deallocate (tty)
      if (allocated(tbf))  deallocate (tbf)
      if (allocated(tbx))  deallocate (tbx)
      if (allocated(tby))  deallocate (tby)
      if (allocated(tbxy))  deallocate (tbxy)
      if (allocated(ttier))  deallocate (ttier)
      if (allocated(ktt))  deallocate (ktt)
c
c     deallocation of global arrays from module kurybr
c
      if (allocated(ucon))  deallocate (ucon)
      if (allocated(dst13))  deallocate (dst13)
      if (allocated(ku))  deallocate (ku)
c
c     deallocation of global arrays from module kvdwpr
c
      if (allocated(radpr))  deallocate (radpr)
      if (allocated(epspr))  deallocate (epspr)
      if (allocated(kvpr))  deallocate (kvpr)
c
c     deallocation of global arrays from module kvdws
c
      if (allocated(rad))  deallocate (rad)
      if (allocated(eps))  deallocate (eps)
      if (allocated(rad4))  deallocate (rad4)
      if (allocated(eps4))  deallocate (eps4)
      if (allocated(reduct))  deallocate (reduct)
c
c     deallocation of global arrays from module light
c
      if (allocated(kbx))  deallocate (kbx)
      if (allocated(kby))  deallocate (kby)
      if (allocated(kbz))  deallocate (kbz)
      if (allocated(kex))  deallocate (kex)
      if (allocated(key))  deallocate (key)
      if (allocated(kez))  deallocate (kez)
      if (allocated(locx))  deallocate (locx)
      if (allocated(locy))  deallocate (locy)
      if (allocated(locz))  deallocate (locz)
      if (allocated(rgx))  deallocate (rgx)
      if (allocated(rgy))  deallocate (rgy)
      if (allocated(rgz))  deallocate (rgz)
c
c     deallocation of global arrays from module merck
c
      if (allocated(mmff_ka))  deallocate (mmff_ka)
      if (allocated(mmff_ka1))  deallocate (mmff_ka1)
      if (allocated(mmff_ka2))  deallocate (mmff_ka2)
      if (allocated(mmff_ka3))  deallocate (mmff_ka3)
      if (allocated(mmff_ka4))  deallocate (mmff_ka4)
      if (allocated(mmff_ka5))  deallocate (mmff_ka5)
      if (allocated(mmff_ka6))  deallocate (mmff_ka6)
      if (allocated(mmff_ka7))  deallocate (mmff_ka7)
      if (allocated(mmff_ka8))  deallocate (mmff_ka8)
      if (allocated(mmff_ang0))  deallocate (mmff_ang0)
      if (allocated(mmff_ang1))  deallocate (mmff_ang1)
      if (allocated(mmff_ang2))  deallocate (mmff_ang2)
      if (allocated(mmff_ang3))  deallocate (mmff_ang3)
      if (allocated(mmff_ang4))  deallocate (mmff_ang4)
      if (allocated(mmff_ang5))  deallocate (mmff_ang5)
      if (allocated(mmff_ang6))  deallocate (mmff_ang6)
      if (allocated(mmff_ang7))  deallocate (mmff_ang7)
      if (allocated(mmff_ang8))  deallocate (mmff_ang8)
      if (allocated(stbn_abc))  deallocate (stbn_abc)
      if (allocated(stbn_cba))  deallocate (stbn_cba)
      if (allocated(stbn_abc1))  deallocate (stbn_abc1)
      if (allocated(stbn_cba1))  deallocate (stbn_cba1)
      if (allocated(stbn_abc2))  deallocate (stbn_abc2)
      if (allocated(stbn_cba2))  deallocate (stbn_cba2)
      if (allocated(stbn_abc3))  deallocate (stbn_abc3)
      if (allocated(stbn_cba3))  deallocate (stbn_cba3)
      if (allocated(stbn_abc4))  deallocate (stbn_abc4)
      if (allocated(stbn_cba4))  deallocate (stbn_cba4)
      if (allocated(stbn_abc5))  deallocate (stbn_abc5)
      if (allocated(stbn_cba5))  deallocate (stbn_cba5)
      if (allocated(stbn_abc6))  deallocate (stbn_abc6)
      if (allocated(stbn_cba6))  deallocate (stbn_cba6)
      if (allocated(stbn_abc7))  deallocate (stbn_abc7)
      if (allocated(stbn_cba7))  deallocate (stbn_cba7)
      if (allocated(stbn_abc8))  deallocate (stbn_abc8)
      if (allocated(stbn_cba8))  deallocate (stbn_cba8)
      if (allocated(stbn_abc9))  deallocate (stbn_abc9)
      if (allocated(stbn_cba9))  deallocate (stbn_cba9)
      if (allocated(stbn_abc10))  deallocate (stbn_abc10)
      if (allocated(stbn_cba10))  deallocate (stbn_cba10)
      if (allocated(stbn_abc11))  deallocate (stbn_abc11)
      if (allocated(stbn_cba11))  deallocate (stbn_cba11)
c
c     deallocation of global arrays from module molcul
c
      if (allocated(imol))  deallocate (imol)
      if (allocated(kmol))  deallocate (kmol)
      if (allocated(molcule))  deallocate (molcule)
      if (allocated(molmass))  deallocate (molmass)
c
c     deallocation of global arrays from module moldyn
c
      if (allocated(v))  deallocate (v)
      if (allocated(a))  deallocate (a)
      if (allocated(aalt))  deallocate (aalt)
      if (allocated(aslow))  deallocate (aslow)
      if (allocated(afast))  deallocate (afast)
c
c     deallocation of global arrays from module mpole
c
      if (allocated(ipole))  deallocate (ipole)
      if (allocated(polsiz))  deallocate (polsiz)
      if (allocated(pollist))  deallocate (pollist)
      if (allocated(zaxis))  deallocate (zaxis)
      if (allocated(xaxis))  deallocate (xaxis)
      if (allocated(yaxis))  deallocate (yaxis)
      if (allocated(pole))  deallocate (pole)
      if (allocated(rpole))  deallocate (rpole)
      if (allocated(mono0))  deallocate (mono0)
      if (allocated(polaxe))  deallocate (polaxe)
c
c     deallocation of global arrays from module mrecip
c
      if (allocated(cmp))  deallocate (cmp)
      if (allocated(fmp))  deallocate (fmp)
      if (allocated(cphi))  deallocate (cphi)
      if (allocated(fphi))  deallocate (fphi)
c
c     deallocation of global arrays from module mutant
c
      if (allocated(imut))  deallocate (imut)
      if (allocated(type0))  deallocate (type0)
      if (allocated(class0))  deallocate (class0)
      if (allocated(type1))  deallocate (type1)
      if (allocated(class1))  deallocate (class1)
      if (allocated(mut))  deallocate (mut)
c
c     deallocation of global arrays from module neigh
c
      if (allocated(nvlst))  deallocate (nvlst)
      if (allocated(vlst))  deallocate (vlst)
      if (allocated(nelst))  deallocate (nelst)
      if (allocated(elst))  deallocate (elst)
      if (allocated(nulst))  deallocate (nulst)
      if (allocated(ulst))  deallocate (ulst)
      if (allocated(xvold))  deallocate (xvold)
      if (allocated(yvold))  deallocate (yvold)
      if (allocated(zvold))  deallocate (zvold)
      if (allocated(xeold))  deallocate (xeold)
      if (allocated(yeold))  deallocate (yeold)
      if (allocated(zeold))  deallocate (zeold)
      if (allocated(xuold))  deallocate (xuold)
      if (allocated(yuold))  deallocate (yuold)
      if (allocated(zuold))  deallocate (zuold)
c
c     deallocation of global arrays from module nonpol
c
      if (allocated(radcav))  deallocate (radcav)
      if (allocated(raddsp))  deallocate (raddsp)
      if (allocated(epsdsp))  deallocate (epsdsp)
      if (allocated(cdsp))  deallocate (cdsp)
c
c     deallocation of global arrays from module omega
c
      if (allocated(iomega))  deallocate (iomega)
      if (allocated(zline))  deallocate (zline)
      if (allocated(dihed))  deallocate (dihed)
c
c     deallocation of global arrays from module opbend
c
      if (allocated(iopb))  deallocate (iopb)
      if (allocated(opbk))  deallocate (opbk)
c
c     deallocation of global arrays from module opdist
c
      if (allocated(iopd))  deallocate (iopd)
      if (allocated(opdk))  deallocate (opdk)
c
c     deallocation of global arrays from module orbits
c
      if (allocated(qorb))  deallocate (qorb)
      if (allocated(worb))  deallocate (worb)
      if (allocated(emorb))  deallocate (emorb)
c
c     deallocation of global arrays from module params
c
      if (allocated(prmline))  deallocate (prmline)
c
c     deallocation of global arrays from module paths
c
      if (allocated(pc0))  deallocate (pc0)
      if (allocated(pc1))  deallocate (pc1)
      if (allocated(pvect))  deallocate (pvect)
      if (allocated(pstep))  deallocate (pstep)
      if (allocated(pzet))  deallocate (pzet)
      if (allocated(gc))  deallocate (gc)
c
c     deallocation of global arrays from module pbstuf
c
      if (allocated(apbe))  deallocate (apbe)
      if (allocated(pbep))  deallocate (pbep)
      if (allocated(pbfp))  deallocate (pbfp)
      if (allocated(pbtp))  deallocate (pbtp)
      if (allocated(pbeuind))  deallocate (pbeuind)
      if (allocated(pbeuinp))  deallocate (pbeuinp)
c
c     deallocation of global arrays from module pdb
c
      if (allocated(resnum))  deallocate (resnum)
      if (allocated(resatm))  deallocate (resatm)
      if (allocated(npdb12))  deallocate (npdb12)
      if (allocated(ipdb12))  deallocate (ipdb12)
      if (allocated(pdbmod))  deallocate (pdbmod)
      if (allocated(pdblist))  deallocate (pdblist)
      if (allocated(xpdb))  deallocate (xpdb)
      if (allocated(ypdb))  deallocate (ypdb)
      if (allocated(zpdb))  deallocate (zpdb)
      if (allocated(pdbres))  deallocate (pdbres)
      if (allocated(pdbsym))  deallocate (pdbsym)
      if (allocated(pdbatm))  deallocate (pdbatm)
      if (allocated(pdbrec))  deallocate (pdbrec)
c
c     deallocation of global arrays from module piorbs
c
      if (allocated(iorbit))  deallocate (iorbit)
      if (allocated(iconj))  deallocate (iconj)
      if (allocated(kconj))  deallocate (kconj)
      if (allocated(piperp))  deallocate (piperp)
      if (allocated(ibpi))  deallocate (ibpi)
      if (allocated(itpi))  deallocate (itpi)
      if (allocated(pbpl))  deallocate (pbpl)
      if (allocated(pnpl))  deallocate (pnpl)
      if (allocated(listpi))  deallocate (listpi)
c
c     deallocation of global arrays from module pistuf
c
      if (allocated(bkpi))  deallocate (bkpi)
      if (allocated(blpi))  deallocate (blpi)
      if (allocated(kslope))  deallocate (kslope)
      if (allocated(lslope))  deallocate (lslope)
      if (allocated(torsp2))  deallocate (torsp2)
c
c     deallocation of global arrays from module pitors
c
      if (allocated(ipit))  deallocate (ipit)
      if (allocated(kpit))  deallocate (kpit)
c
c     deallocation of global arrays from module pme
c
      if (allocated(igrid))  deallocate (igrid)
      if (allocated(thetai1))  deallocate (thetai1)
      if (allocated(thetai2))  deallocate (thetai2)
      if (allocated(thetai3))  deallocate (thetai3)
      if (allocated(qgrid))  deallocate (qgrid)
      if (allocated(qfac))  deallocate (qfac)
c
c     deallocation of global arrays from module polar
c
      if (allocated(ipolar))  deallocate (ipolar)
      if (allocated(polarity))  deallocate (polarity)
      if (allocated(thole))  deallocate (thole)
      if (allocated(tholed))  deallocate (tholed)
      if (allocated(pdamp))  deallocate (pdamp)
      if (allocated(thlval))  deallocate (thlval)
      if (allocated(thdval))  deallocate (thdval)
      if (allocated(udir))  deallocate (udir)
      if (allocated(udirp))  deallocate (udirp)
      if (allocated(udirs))  deallocate (udirs)
      if (allocated(udirps))  deallocate (udirps)
      if (allocated(uind))  deallocate (uind)
      if (allocated(uinp))  deallocate (uinp)
      if (allocated(uinds))  deallocate (uinds)
      if (allocated(uinps))  deallocate (uinps)
      if (allocated(uexact))  deallocate (uexact)
      if (allocated(douind))  deallocate (douind)
c
c     deallocation of global arrays from module polgrp
c
      if (allocated(ip11))  deallocate (ip11)
      if (allocated(ip12))  deallocate (ip12)
      if (allocated(ip13))  deallocate (ip13)
      if (allocated(ip14))  deallocate (ip14)
c
c     deallocation of global arrays from module polopt
c
      if (allocated(copt))  deallocate (copt)
      if (allocated(copm))  deallocate (copm)
      if (allocated(uopt))  deallocate (uopt)
      if (allocated(uoptp))  deallocate (uoptp)
      if (allocated(uopts))  deallocate (uopts)
      if (allocated(uoptps))  deallocate (uoptps)
c
c     deallocation of global arrays from module polpcg
c
      if (allocated(mindex))  deallocate (mindex)
      if (allocated(minv))  deallocate (minv)
c
c     deallocation of global arrays from module poltcg
c
      if (allocated(uad))  deallocate (uad)
      if (allocated(uap))  deallocate (uap)
      if (allocated(ubd))  deallocate (ubd)
      if (allocated(ubp))  deallocate (ubp)
c
c     deallocation of global arrays from module potfit
c
      if (allocated(ipgrid))  deallocate (ipgrid)
      if (allocated(fit0))  deallocate (fit0)
      if (allocated(fchg))  deallocate (fchg)
      if (allocated(fpol))  deallocate (fpol)
      if (allocated(pgrid))  deallocate (pgrid)
      if (allocated(epot))  deallocate (epot)
      if (allocated(fitchg))  deallocate (fitchg)
      if (allocated(fitpol))  deallocate (fitpol)
      if (allocated(fitpol))  deallocate (fitcpen)
      if (allocated(gatm))  deallocate (gatm)
      if (allocated(fatm))  deallocate (fatm)
      if (allocated(fxdpl))  deallocate (fxdpl)
      if (allocated(fydpl))  deallocate (fydpl)
      if (allocated(fzdpl))  deallocate (fzdpl)
      if (allocated(vchg))  deallocate (vchg)
      if (allocated(vpol))  deallocate (vpol)
      if (allocated(vcpen))  deallocate (vcpen)
      if (allocated(varpot))  deallocate (varpot)
c
c     deallocation of global arrays from module qmstuf
c
      if (allocated(gx))  deallocate (gx)
      if (allocated(gy))  deallocate (gy)
      if (allocated(gz))  deallocate (gz)
      if (allocated(gfreq))  deallocate (gfreq)
      if (allocated(gforce))  deallocate (gforce)
      if (allocated(gh))  deallocate (gh)
c
c     deallocation of global arrays from module refer
c
      if (allocated(reftyp))  deallocate (reftyp)
      if (allocated(n12ref))  deallocate (n12ref)
      if (allocated(i12ref))  deallocate (i12ref)
      if (allocated(xref))  deallocate (xref)
      if (allocated(yref))  deallocate (yref)
      if (allocated(zref))  deallocate (zref)
      if (allocated(refnam))  deallocate (refnam)
c
c     deallocation of global arrays from module repel
c
      if (allocated(irep))  deallocate (irep)
      if (allocated(replist))  deallocate (replist)
      if (allocated(sizpr))  deallocate (sizpr)
      if (allocated(dmppr))  deallocate (dmppr)
      if (allocated(elepr))  deallocate (elepr)
      if (allocated(repole))  deallocate (repole)
      if (allocated(rrepole))  deallocate (rrepole)
c
c     deallocation of global arrays from module restrn
c
      if (allocated(ipfix))  deallocate (ipfix)
      if (allocated(kpfix))  deallocate (kpfix)
      if (allocated(idfix))  deallocate (idfix)
      if (allocated(iafix))  deallocate (iafix)
      if (allocated(itfix))  deallocate (itfix)
      if (allocated(igfix))  deallocate (igfix)
      if (allocated(ichir))  deallocate (ichir)
      if (allocated(xpfix))  deallocate (xpfix)
      if (allocated(ypfix))  deallocate (ypfix)
      if (allocated(zpfix))  deallocate (zpfix)
      if (allocated(pfix))  deallocate (pfix)
      if (allocated(dfix))  deallocate (dfix)
      if (allocated(afix))  deallocate (afix)
      if (allocated(tfix))  deallocate (tfix)
      if (allocated(gfix))  deallocate (gfix)
      if (allocated(chir))  deallocate (chir)
c
c     deallocation of global arrays from module rgddyn
c
      if (allocated(xcmo))  deallocate (xcmo)
      if (allocated(ycmo))  deallocate (ycmo)
      if (allocated(zcmo))  deallocate (zcmo)
      if (allocated(vcm))  deallocate (vcm)
      if (allocated(wcm))  deallocate (wcm)
      if (allocated(lm))  deallocate (lm)
      if (allocated(vc))  deallocate (vc)
      if (allocated(wc))  deallocate (wc)
      if (allocated(linear))  deallocate (linear)
c
c     deallocation of global arrays from module rigid
c
      if (allocated(xrb))  deallocate (xrb)
      if (allocated(yrb))  deallocate (yrb)
      if (allocated(zrb))  deallocate (zrb)
      if (allocated(rbc))  deallocate (rbc)
c
c     deallocation of global arrays from module ring
c
      if (allocated(iring3))  deallocate (iring3)
      if (allocated(iring4))  deallocate (iring4)
      if (allocated(iring5))  deallocate (iring5)
      if (allocated(iring6))  deallocate (iring6)
      if (allocated(iring7))  deallocate (iring7)
c
c     deallocation of global arrays from module rotbnd
c
      if (allocated(rot))  deallocate (rot)
c
c     deallocation of global arrays from module shapes
c
      if (allocated(newlist))  deallocate (newlist)
      if (allocated(freespace))  deallocate (freespace)
      if (allocated(killspace))  deallocate (killspace)
      if (allocated(vinfo))  deallocate (vinfo)
      if (allocated(tedge))  deallocate (tedge)
      if (allocated(tinfo))  deallocate (tinfo)
      if (allocated(tnindex))  deallocate (tnindex)
      if (allocated(tetra))  deallocate (tetra)
      if (allocated(tneighbor))  deallocate (tneighbor)
      if (allocated(linkfacet))  deallocate (linkfacet)
      if (allocated(linkindex))  deallocate (linkindex)
      if (allocated(crdball))  deallocate (crdball)
      if (allocated(radball))  deallocate (radball)
      if (allocated(wghtball))  deallocate (wghtball)
c
c     deallocation of global arrays from module solute
c
      if (allocated(rsolv))  deallocate (rsolv)
      if (allocated(asolv))  deallocate (asolv)
      if (allocated(rborn))  deallocate (rborn)
      if (allocated(drb))  deallocate (drb)
      if (allocated(drbp))  deallocate (drbp)
      if (allocated(drobc))  deallocate (drobc)
      if (allocated(gpol))  deallocate (gpol)
      if (allocated(shct))  deallocate (shct)
      if (allocated(aobc))  deallocate (aobc)
      if (allocated(bobc))  deallocate (bobc)
      if (allocated(gobc))  deallocate (gobc)
      if (allocated(vsolv))  deallocate (vsolv)
      if (allocated(wace))  deallocate (wace)
      if (allocated(s2ace))  deallocate (s2ace)
      if (allocated(uace))  deallocate (uace)
      if (allocated(sneck))  deallocate (sneck)
      if (allocated(bornint))  deallocate (bornint)
c
c     deallocation of global arrays from module stodyn
c
      if (allocated(fgamma))  deallocate (fgamma)
c
c     deallocation of global arrays from module strbnd
c
      if (allocated(isb))  deallocate (isb)
      if (allocated(sbk))  deallocate (sbk)
c
c     deallocation of global arrays from module strtor
c
      if (allocated(ist))  deallocate (ist)
      if (allocated(kst))  deallocate (kst)
c
c     deallocation of global arrays from module syntrn
c
      if (allocated(xmin1))  deallocate (xmin1)
      if (allocated(xmin2))  deallocate (xmin2)
      if (allocated(xm))  deallocate (xm)
c
c     deallocation of global arrays from module tarray
c
      if (allocated(tindex))  deallocate (tindex)
      if (allocated(tdipdip))  deallocate (tdipdip)
c
c     deallocation of global arrays from module tettor
c
      if (allocated(ibitor))  deallocate (itettor)
c
c     deallocation of global arrays from module tors
c
      if (allocated(itors))  deallocate (itors)
      if (allocated(tors1))  deallocate (tors1)
      if (allocated(tors2))  deallocate (tors2)
      if (allocated(tors3))  deallocate (tors3)
      if (allocated(tors4))  deallocate (tors4)
      if (allocated(tors5))  deallocate (tors5)
      if (allocated(tors6))  deallocate (tors6)
c
c     deallocation of global arrays from module tortor
c
      if (allocated(itt))  deallocate (itt)
c
c     deallocation of global arrays from module tritor
c
      if (allocated(ibitor))  deallocate (itritor)
c
c     deallocation of global arrays from module uprior
c
      if (allocated(udalt))  deallocate (udalt)
      if (allocated(upalt))  deallocate (upalt)
      if (allocated(usalt))  deallocate (usalt)
      if (allocated(upsalt))  deallocate (upsalt)
c
c     deallocation of global arrays from module urey
c
      if (allocated(iury))  deallocate (iury)
      if (allocated(uk))  deallocate (uk)
      if (allocated(ul))  deallocate (ul)
c
c     deallocation of global arrays from module usage
c
      if (allocated(iuse))  deallocate (iuse)
      if (allocated(use))  deallocate (use)
c
c     deallocation of global arrays from module vdw
c
      if (allocated(ivdw))  deallocate (ivdw)
      if (allocated(jvdw))  deallocate (jvdw)
      if (allocated(mvdw))  deallocate (mvdw)
      if (allocated(ired))  deallocate (ired)
      if (allocated(kred))  deallocate (kred)
      if (allocated(radmin))  deallocate (radmin)
      if (allocated(epsilon))  deallocate (epsilon)
      if (allocated(radmin4))  deallocate (radmin4)
      if (allocated(epsilon4))  deallocate (epsilon4)
      if (allocated(radhbnd))  deallocate (radhbnd)
      if (allocated(epshbnd))  deallocate (epshbnd)
c
c     deallocation of global arrays from module vibs
c
      if (allocated(rho))  deallocate (rho)
      if (allocated(rhok))  deallocate (rhok)
      if (allocated(rwork))  deallocate (rwork)
c
c     deallocation of global arrays from module warp
c
      if (allocated(m2))  deallocate (m2)
c
c     may need a pause to avoid closing the execution window
c
      if (holdup) then
         read (input,20)
   20    format ()
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2025  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine findnuc  --  search for RNA & DNA nucleotides  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "findnuc" locates and stores the atoms in nucleotide units
c     based on atomic element and connectivity information
c
c     note this routine assumes an all-atom model with hydrogen 
c     atoms explicitly represented
c
c
      subroutine findnuc
      use atomid
      use atoms
      use bitor
      use couple
      implicit none
      integer i,j,k
      integer nhyd,nphos
      integer ia,ib,ic
      integer id,ie,ij,ik
      integer nia,nib,nic
      integer nid,nie,nij
      integer aia,aib,aic
      integer aid,aie
      integer aij,aik
      integer ic1s,ic2s,ic3s
      integer ic4s,ic5s,io2s
      integer io3s,io4s,io5s
      integer ipo,iop1
      integer iop2,iop3
      integer in1,in3,in4,in5
      integer in6,in7,in8,in9
      integer ic2,ic3,ic4,ic5
      integer ic6,ic7,ic9
      integer icm,io4,io9
      logical proceed
      logical deoxy
      character*3 label
c
c
c     cycle over bitorsions to search for nucleotides
c
      do i = 1, nbitor
         ia = ibitor(1,i)
         ib = ibitor(2,i)
         ic = ibitor(3,i)
         id = ibitor(4,i)
         ie = ibitor(5,i)
         nia = n12(ia)
         nib = n12(ib)
         nic = n12(ic)
         nid = n12(id)
         nie = n12(ie)
         aia = atomic(ia)
         aib = atomic(ib)
         aic = atomic(ic)
         aid = atomic(id)
         aie = atomic(ie)
c
c     check for five-atom stretch from 5' to 3' sugar oxygens
c
         proceed = .true.
         if (aia.ne.8 .or. aib.ne.6 .or. aic.ne.6
     &          .or. aid.ne.6 .or. aie.ne.8)  proceed = .false.
         if (proceed) then
            if (nia.ne.2 .or. nib.ne.4 .or. nic.ne.4
     &             .or. nid.ne.4 .or. nie.ne.2)  proceed = .false.
         end if
c
c     test for phosphorus atoms including uncapped termini
c
         if (proceed) then
            proceed = .false.
            nhyd = 0
            nphos = 0
            do j = 1, n12(ia)
               ij = i12(j,ia)
               aij = atomic(ij)
               if (aij .eq. 1)  nhyd = nhyd + 1
               if (aij .eq. 15)  nphos = nphos + 1
            end do 
            do j = 1, n12(ie)
               ij = i12(j,ie)
               aij = atomic(ij)
               if (aij .eq. 1)  nhyd = nhyd + 1
               if (aij .eq. 15)  nphos = nphos + 1
            end do
            if (nphos.eq.1 .and. nhyd.eq.1)  proceed = .true.
            if (nphos.eq.2 .and. nhyd.eq.0)  proceed = .true.
         end if
         if (.not. proceed)  goto 10
c
c     zero out residue name and possible nucleotide atoms
c
         label = '   '
         ic1s = 0
         ic2s = 0
         ic3s = 0
         ic4s = 0
         ic5s = 0
         io2s = 0
         io3s = 0
         io4s = 0
         io5s = 0
         ipo = 0
         iop1 = 0
         iop2 = 0
         iop3 = 0
         ic2 = 0
         ic3 = 0
         ic4 = 0
         ic5 = 0
         ic6 = 0
         ic7 = 0
         ic9 = 0
         icm = 0
         in1 = 0
         in3 = 0
         in4 = 0
         in5 = 0
         in6 = 0
         in7 = 0
         in8 = 0
         in9 = 0
         io4 = 0
         io9 = 0
c
c     locate sugar ring and assign corresponding atom names
c
         nhyd = 0
         do j = 1, n12(ib)
            ij = i12(j,ib)
            aij = atomic(ij)
            if (aij .eq. 1)  nhyd = nhyd + 1
         end do
         if (nhyd .eq. 2) then
            io5s = ia
            ic5s = ib
            ic4s = ic
            ic3s = id
            io3s = ie
         else
            io5s = ie
            ic5s = id
            ic4s = ic
            ic3s = ib
            io3s = ia
         end if
         do j = 1, n12(ic4s)
            ij = i12(j,ic4s)
            aij = atomic(ij)
            if (aij .eq. 8)  io4s = ij
         end do
         do j = 1, n12(ic3s)
            ij = i12(j,ic3s)
            aij = atomic(ij)
            if (ij.ne.ic4s .and. aij.eq.6)  ic2s = ij
         end do
         deoxy = .true.
         if (ic2s .ne. 0) then
            do j = 1, n12(ic2s)
               ij = i12(j,ic2s)
               aij = atomic(ij)
               if (aij .eq. 8) then
                  io2s = ij
                  deoxy = .false.
               end if
            end do
         end if
         if (io4s .ne. 0) then
            do j = 1, n12(io4s)
               ij = i12(j,io4s)
               aij = atomic(ij)
               if (ij.ne.ic4s .and. aij.eq.6)  ic1s = ij
            end do
         end if
c
c     find phosphate group attached at 5' sugar oxygen
c
         do j = 1, n12(io5s)
            ij = i12(j,io5s)
            aij = atomic(ij)
            if (aij .eq. 15) then
               ipo = ij
            end if
         end do
         if (ipo .ne. 0) then
            do j = 1, n12(ipo)
               ij = i12(j,ipo)
               nij = n12(ij)
               aij = atomic(ij)
               if (nij.eq.1 .and. aij.eq.8) then
                  if (iop2 .ne. 0)  iop3 = ij
                  if (iop1 .ne. 0)  iop2 = ij
                  if (iop1 .eq. 0)  iop1 = ij
               end if
            end do
         end if
c
c     decide if the nucleobase is purine or pyrimidine
c
         if (ic1s .ne. 0) then
            do j = 1, n12(ic1s)
               ij = i12(j,ic1s)
               aij = atomic(ij)
               if (aij .eq. 7)  in1 = ij
            end do
         end if
         if (in1 .ne. 0) then 
            do j = 1, n12(in1)
               ij = i12(j,in1)
               nij = n12(ij)
               aij = atomic(ij)
               if (ij.ne.ic1s .and. aij.eq.6) then
                  do k = 1, n12(ij)
                     ik = i12(k,ij)
                     aik = atomic(ik)
                     if (aik .eq. 1)  ic2 = ij
                     if (aik .eq. 8) then
                        label= 'PYR'
                        ic6 = ij
                     end if
                  end do
                  if (ic6 .eq. 0) then
                     label = 'PUR'
                     ic5 = ij
                  end if
               end if
            end do
         end if
c
c     identify additional atoms of a purine base    
c
         if (label .eq. 'PUR') then
            if (ic2 .ne. 0) then
               do j = 1, n12(ic2)
                  ij = i12(j,ic2)
                  aij = atomic(ij)
                  if (ij.ne.in1 .and. aij.eq.7)  in3 = ij
               end do
            end if
            if (in3 .ne. 0) then
               do j = 1, n12(in3)
                  ij = i12(j,in3)
                  aij = atomic(ij)
                  if (ij.ne.ic2 .and. aij.eq.6)  ic4 = ij
               end do
            end if
            if (ic5 .ne. 0) then
               do j = 1, n12(ic5)
                  ij = i12(j,ic5)
                  aij = atomic(ij)
                  if (ij.ne.in1 .and. aij.eq.7)  in6 = ij
               end do
            end if
            if (in6 .ne. 0) then
               do j = 1, n12(in6)
                  ij = i12(j,in6)
                  aij = atomic(ij)
                  if (ij.ne.ic5 .and. aij.eq.6)  ic7 = ij
               end do
            end if
            if (ic7 .ne. 0) then
               do j = 1, n12(ic7)
                  ij = i12(j,ic7)
                  aij = atomic(ij)
                  if (ij.ne.in6 .and. aij.eq.7) then
                     nhyd = 0
                     do k = 1, n12(ij)
                        ik = i12(k,ij)
                        aik = atomic(ik)
                        if (aik .eq. 1)  nhyd = nhyd + 1
                     end do
                     if (nhyd .le. 1)  in8 = ij
                     if (nhyd .eq. 2)  in7 = ij
                  end if
               end do
            end if
            if (in8 .ne. 0) then
               do j = 1, n12(in8)
                  ij = i12(j,in8)
                  aij = atomic(ij)
                  if (ij.ne.ic7 .and. aij.eq.6)  ic9 = ij
               end do
            end if
            if (ic9 .ne. 0) then
               do j = 1, n12(ic9)
                  ij = i12(j,ic9)
                  aij = atomic(ij)
                  if (ij.ne.in8 .and. aij.eq.7)  in9 = ij
                  if (aij .eq. 8)  io9 = ij
               end do
            end if
            if (io9 .ne. 0) then
               label = '  G'
               if (deoxy)  label = ' DG'
            end if
            if (in9 .ne. 0) then
               label = '  A'
               if (deoxy)  label = ' DA'
            end if
         end if
c
c     identify additional atoms of a pyrimidine base    
c
         if (label .eq. 'PYR') then
            if (ic6 .ne. 0) then
               do j = 1, n12(ic6)
                  ij = i12(j,ic6)
                  aij = atomic(ij)
                  if (ij.ne.in1 .and. aij.eq.7)  in5 = ij
               end do
            end if
            if (in5 .ne. 0) then
               do j = 1, n12(in5)
                  ij = i12(j,in5)
                  aij = atomic(ij)
                  if (ij.ne.ic6 .and. aij.eq.6)  ic4 = ij
               end do
            end if
            if (ic4 .ne. 0) then
               do j = 1, n12(ic4)
                  ij = i12(j,ic4)
                  aij = atomic(ij)
                  if (aij .eq. 6)  ic3 = ij
                  if (ij.ne.in5 .and. aij.eq.7)  in4 = ij
                  if (aij .eq. 8)  io4 = ij
               end do
            end if
            label = '  U'
            if (in5 .ne. 0) then
               if (n12(in5) .eq. 2) then
                  label = '  C'
                  if (deoxy)  label = ' DC'
               end if
            end if
            if (ic3 .ne. 0) then
               do j = 1, n12(ic3)
                  ij = i12(j,ic3)
                  aij = atomic(ij)
                  if (ij.ne.ic2 .and. ij.ne.ic4 .and. aij.eq.6) then
                     label = '  T'
                     icm = ij
                  end if
               end do
            end if
         end if
c
c     propagate the tier name to all atoms of the nucleotide
c
         if (ipo .ne. 0)  tier(ipo) = label
         if (iop1 .ne. 0) then
            tier(iop1) = label
            do j = 1, n12(iop1)
               ij = i12(j,iop1)
               tier(ij) = label
            end do
         end if
         if (iop2 .ne. 0) then
            tier(iop2) = label
            do j = 1, n12(iop2)
               ij = i12(j,iop2)
               tier(ij) = label
            end do
         end if
         if (iop3 .ne. 0) then
            tier(iop3) = label
            do j = 1, n12(iop3)
               ij = i12(j,iop3)
               tier(ij) = label
            end do
         end if
         tier(io5s) = label
         do j = 1, n12(io5s)
            ij = i12(j,io5s)
            tier(ij) = label
         end do
         tier(ic5s) = label
         do j = 1, n12(ic5s)
            ij = i12(j,ic5s)
            tier(ij) = label
         end do
         tier(ic4s) = label
         do j = 1, n12(ic4s)
            ij = i12(j,ic4s)
            tier(ij) = label
         end do
         if (io4s .ne. 0) then
            tier(io4s) = label
            do j = 1, n12(io4s)
               ij = i12(j,io4s)
               tier(ij) = label
            end do
         end if
         tier(ic3s) = label
         do j = 1, n12(ic3s)
            ij = i12(j,ic3s)
            tier(ij) = label
         end do
         tier(io3s) = label
         do j = 1, n12(io3s)
            ij = i12(j,io3s)
            tier(ij) = label
         end do
         if (ic2s .ne. 0) then
            tier(ic2s) = label
            do j = 1, n12(ic2s)
               ij = i12(j,ic2s)
               tier(ij) = label
            end do
         end if
         if (io2s .ne. 0) then
            tier(io2s) = label
            do j = 1, n12(io2s)
               ij = i12(j,io2s)
               tier(ij) = label
            end do
         end if
         if (ic1s .ne. 0) then
            tier(ic1s) = label
            do j = 1, n12(ic1s)
               ij = i12(j,ic1s)
               tier(ij) = label
            end do
         end if
         if (in1 .ne. 0) then
            tier(in1) = label
            do j = 1, n12(in1)
               ij = i12(j,in1)
               tier(ij) = label
            end do
         end if
         if (ic2 .ne. 0) then
            tier(ic2) = label
            do j = 1, n12(ic2)
               ij = i12(j,ic2)
               tier(ij) = label
            end do
         end if
         if (ic3 .ne. 0) then
            tier(ic3) = label
            do j = 1, n12(ic3)
               ij = i12(j,ic3)
               tier(ij) = label
            end do
         end if
         if (in3 .ne. 0) then
            tier(in3) = label
            do j = 1, n12(in3)
               ij = i12(j,in3)
               tier(ij) = label
            end do
         end if
         if (ic4 .ne. 0) then
            tier(ic4) = label
            do j = 1, n12(ic4)
               ij = i12(j,ic4)
               tier(ij) = label
            end do
         end if
         if (in4 .ne. 0) then
            tier(in4) = label
            do j = 1, n12(in4)
               ij = i12(j,in4)
               tier(ij) = label
            end do
         end if
         if (ic5 .ne. 0) then
            tier(ic5) = label
            do j = 1, n12(ic5)
               ij = i12(j,ic5)
               tier(ij) = label
            end do
         end if
         if (in5 .ne. 0) then
            tier(in5) = label
            do j = 1, n12(in5)
               ij = i12(j,in5)
               tier(ij) = label
            end do
         end if
         if (ic6 .ne. 0) then
            tier(ic6) = label
            do j = 1, n12(ic6)
               ij = i12(j,ic6)
               tier(ij) = label
            end do
         end if
         if (in6 .ne. 0) then
            tier(in6) = label
            do j = 1, n12(in6)
               ij = i12(j,in6)
               tier(ij) = label
            end do
         end if
         if (ic7 .ne. 0) then
            tier(ic7) = label
            do j = 1, n12(ic7)
               ij = i12(j,ic7)
               tier(ij) = label
            end do
         end if
         if (in7 .ne. 0) then
            tier(in7) = label
            do j = 1, n12(in7)
               ij = i12(j,in7)
               tier(ij) = label
            end do
         end if
         if (in8 .ne. 0) then
            tier(in8) = label
            do j = 1, n12(in8)
               ij = i12(j,in8)
               tier(ij) = label
            end do
         end if
         if (ic9 .ne. 0) then
            tier(ic9) = label
            do j = 1, n12(ic9)
               ij = i12(j,ic9)
               tier(ij) = label
            end do
         end if
         if (in9 .ne. 0) then
            tier(in9) = label
            do j = 1, n12(in9)
               ij = i12(j,in9)
               tier(ij) = label
            end do
         end if
         if (icm .ne. 0) then
            tier(icm) = label
            do j = 1, n12(icm)
               ij = i12(j,icm)
               tier(ij) = label
            end do
         end if
   10    continue
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2025  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine findpro  --  search for amino acid residues  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "findpro" locates and stores the atoms in amino acid residues
c     based on atomic element and connectivity information
c
c     note this routine assumes an all-atom model with hydrogen
c     atoms explicitly represented
c
c
      subroutine findpro
      use atomid
      use atoms
      use bitor
      use couple
      implicit none
      integer i,j,nhyd
      integer ia,ib,ic
      integer id,ie,ij
      integer nia,nib,nic
      integer nid,nie,nij
      integer aia,aib,aic
      integer aid,aie,aij
      integer icb1,icb2
      integer icg1,icg2
      integer icd1,icd2
      integer ice1,ice2
      integer icz1,icz2
      integer ich,ind
      integer ine,inz
      integer inh1,inh2
      integer iog,ioh
      integer iod1,iod2
      integer ioe1,ioe2
      integer isg,isd
      integer nha,nhb
      integer nhg,nhd
      logical proceed
      character*3 label
c
c
c     initialize the tier name associated with each atom
c
      do i = 1, n
         tier(i) = '   '
      end do
c
c     cycle over bitorsions to search for amino acids
c
      do i = 1, nbitor
         ia = ibitor(1,i)
         ib = ibitor(2,i)
         ic = ibitor(3,i)
         id = ibitor(4,i)
         ie = ibitor(5,i)
         nia = n12(ia)
         nib = n12(ib)
         nic = n12(ic)
         nid = n12(id)
         nie = n12(ie)
         aia = atomic(ia)
         aib = atomic(ib)
         aic = atomic(ic)
         aid = atomic(id)
         aie = atomic(ie)
c
c     check for five-atom stretch of polypeptide backbone
c
         proceed = .false.
         if (nia.eq.3 .and. nib.eq.3 .and. nic.eq.4
     &          .and. nid.eq.3 .and. nie.eq.3) then
            if ((aia.eq.6 .and. aib.eq.7 .and. aic.eq.6
     &              .and. aid.eq.6 .and. aie.eq.7) .or.
     &          (aia.eq.7 .and. aib.eq.6 .and. aic.eq.6
     &              .and. aid.eq.7 .and. aie.eq.6)) then
               if (.not.proceed .and. aia.eq.6) then
                  do j = 1, n12(ia)
                     ij = i12(j,ia)
                     nij = n12(ij)
                     aij = atomic(ij)
                     if (nij.eq.1 .and. aij.eq.8)  proceed = .true.
                  end do 
               end if
               if (.not.proceed .and. aib.eq.6) then
                  do j = 1, n12(ib)
                     ij = i12(j,ib)
                     nij = n12(ij)
                     aij = atomic(ij)
                     if (nij.eq.1 .and. aij.eq.8)  proceed = .true.
                  end do 
               end if
               if (.not.proceed .and. aid.eq.6) then
                  do j = 1, n12(id)
                     ij = i12(j,id)
                     nij = n12(ij)
                     aij = atomic(ij)
                     if (nij.eq.1 .and. aij.eq.8)  proceed = .true.
                  end do 
               end if
               if (.not.proceed .and. aie.eq.6) then
                  do j = 1, n12(ie)
                     ij = i12(j,ie)
                     nij = n12(ij)
                     aij = atomic(ij)
                     if (nij.eq.1 .and. aij.eq.8)  proceed = .true.
                  end do 
               end if
            end if
         end if
c
c     check for N-terminal and C-terminal residues
c
         if (.not. proceed) then
            if (nia.eq.1 .and. nib.eq.4 .and. nic.eq.4
     &             .and. nid.eq.3 .and. nie.eq.3 .and.
     &          aia.eq.1 .and. aib.eq.7 .and. aic.eq.6
     &             .and. aid.eq.6 .and. aie.eq.7)  proceed = .true.
         end if
         if (.not. proceed) then
            if (nia.eq.3 .and. nib.eq.3 .and. nic.eq.4
     &             .and. nid.eq.4 .and. nie.eq.1 .and.
     &          aia.eq.7 .and. aib.eq.6 .and. aic.eq.6
     &             .and. aid.eq.7 .and. aie.eq.1)  proceed = .true.
         end if
         if (.not. proceed) then
            if (nia.eq.3 .and. nib.eq.3 .and. nic.eq.4
     &             .and. nid.eq.3 .and. nie.eq.1 .and.
     &          aia.eq.6 .and. aib.eq.7 .and. aic.eq.6
     &              .and. aid.eq.6 .and. aie.eq.8)  proceed = .true.
         end if
         if (.not. proceed) then
            if (nia.eq.1 .and. nib.eq.3 .and. nic.eq.4
     &             .and. nid.eq.3 .and. nie.eq.3 .and.
     &          aia.eq.8 .and. aib.eq.6 .and. aic.eq.6
     &             .and. aid.eq.7 .and. aie.eq.6)  proceed = .true.
         end if
c
c     check for N-terminal ACE chain capping group
c
         if (.not. proceed) then
            if (nia.eq.4 .and. nib.eq.3 .and. nic.eq.3
     &             .and. nid.eq.4 .and. nie.eq.3 .and.
     &          aia.eq.6 .and. aib.eq.6 .and. aic.eq.7
     &             .and. aid.eq.6 .and. aie.eq.6) then
               nhyd = 0
               do j = 1, n12(ia)
                  ij = i12(j,ia)
                  aij = atomic(ij)
                  if (aij .eq. 1)  nhyd = nhyd + 1
               end do
               if (nhyd .eq. 3) then
                  tier(ia) = 'ACE'
                  do j = 1, n12(ia)
                     ij = i12(j,ia)
                     aij = atomic(ij)
                     if (aij .eq. 1)  tier(ij) = 'ACE'
                  end do
                  tier(ib) = 'ACE'
                  do j = 1, n12(ib)
                     ij = i12(j,ib)
                     aij = atomic(ij)
                     if (aij .eq. 8)  tier(ij) = 'ACE'
                  end do
               end if
            end if
         end if
         if (.not. proceed) then
            if (nia.eq.3 .and. nib.eq.4 .and. nic.eq.3
     &             .and. nid.eq.3 .and. nie.eq.4 .and.
     &          aia.eq.6 .and. aib.eq.6 .and. aic.eq.7
     &             .and. aid.eq.6 .and. aie.eq.6) then
               nhyd = 0
               do j = 1, n12(ie)
                  ij = i12(j,ie)
                  aij = atomic(ij)
                  if (aij .eq. 1)  nhyd = nhyd + 1
               end do
               if (nhyd .eq. 3) then
                  tier(ia) = 'ACE'
                  do j = 1, n12(ie)
                     ij = i12(j,ie)
                     aij = atomic(ij)
                     if (aij .eq. 1)  tier(ij) = 'ACE'
                  end do
                  tier(ib) = 'ACE'
                  do j = 1, n12(id)
                     ij = i12(j,id)
                     aij = atomic(ij)
                     if (aij .eq. 8)  tier(ij) = 'ACE'
                  end do
               end if
            end if
         end if
c
c     check for C-terminal NME chain capping group
c
         if (.not. proceed) then
            if (nia.eq.3 .and. nib.eq.4 .and. nic.eq.3
     &             .and. nid.eq.3 .and. nie.eq.4 .and.
     &          aia.eq.7 .and. aib.eq.6 .and. aic.eq.6
     &             .and. aid.eq.7 .and. aie.eq.6) then
               nhyd = 0
               do j = 1, n12(ie)
                  ij = i12(j,ie)
                  aij = atomic(ij)
                  if (aij .eq. 1)  nhyd = nhyd + 1
               end do
               if (nhyd .eq. 3) then
                  tier(id) = 'NME'
                  do j = 1, n12(id)
                     ij = i12(j,id)
                     aij = atomic(ij)
                     if (aij .eq. 1)  tier(ij) = 'NME'
                  end do
                  tier(ie) = 'NME'
                  do j = 1, n12(ie)
                     ij = i12(j,ie)
                     aij = atomic(ij)
                     if (aij .eq. 1)  tier(ij) = 'NME'
                  end do
               end if
            end if
         end if
         if (.not. proceed) then
            if (nia.eq.4 .and. nib.eq.3 .and. nic.eq.3
     &             .and. nid.eq.4 .and. nie.eq.3 .and.
     &          aia.eq.6 .and. aib.eq.7 .and. aic.eq.6
     &             .and. aid.eq.6 .and. aie.eq.7) then
               nhyd = 0
               do j = 1, n12(ia)
                  ij = i12(j,ia)
                  aij = atomic(ij)
                  if (aij .eq. 1)  nhyd = nhyd + 1
               end do
               if (nhyd .eq. 3) then
                  tier(ia) = 'NME'
                  do j = 1, n12(ia)
                     ij = i12(j,ia)
                     aij = atomic(ij)
                     if (aij .eq. 1)  tier(ij) = 'NME'
                  end do
                  tier(ib) = 'NME'
                  do j = 1, n12(ib)
                     ij = i12(j,ib)
                     aij = atomic(ij)
                     if (aij .eq. 1)  tier(ij) = 'NME'
                  end do
               end if
            end if
         end if
         if (.not. proceed)  goto 10
c
c     zero out residue name and possible side chain atoms
c
         label = '   '
         icb1 = 0
         icb2 = 0
         icg1 = 0
         icg2 = 0
         iog = 0
         isg = 0
         icd1 = 0
         icd2 = 0
         ind = 0
         iod1 = 0
         iod2 = 0
         isd = 0
         ice1 = 0
         ice2 = 0
         ine = 0
         ioe1 = 0
         ioe2 = 0
         icz1 = 0
         icz2 = 0
         inz = 0
         ich = 0
         inh1 = 0
         inh2 = 0
         ioh = 0
c
c     inspect the beta position of amino acid residue
c
         if (label .eq. '   ') then
            nha = 0
            do j = 1, n12(ic)
               ij = i12(j,ic)
               aij = atomic(ij)
               if (aij .eq. 1)  nha = nha + 1
               if (ij.ne.ib .and. ij.ne.id .and. aij.eq.6) then
                  if (icb1 .ne. 0)  icb2 = ij
                  if (icb1 .eq. 0)  icb1 = ij
               end if
            end do
            if (nha .eq. 2)  label = 'GLY'
            if (icb2 .ne. 0)  label = 'AIB'
         end if
c
c     inspect the gamma position of amino acid residue
c
         if (label.eq.'   ' .and. icb1.ne.0) then
            nhb = 0
            do j = 1, n12(icb1)
               ij = i12(j,icb1)
               aij = atomic(ij)
               if (aij .eq. 1)  nhb = nhb + 1
               if (ij.ne.ic .and. aij.eq.6) then
                  if (icg1 .ne. 0)  icg2 = ij
                  if (icg1 .eq. 0)  icg1 = ij
               end if
               if (aij .eq. 8)  iog = ij
               if (aij .eq. 16)  isg = ij
            end do
            if (nhb .eq. 3)  label = 'ALA'
            if (iog.ne.0 .and. icg1.eq.0)  label = 'SER'
            if (iog.ne.0 .and. icg1.ne.0)  label = 'THR'
            if (isg .ne. 0) then
               if (n12(isg) .eq. 1) then
                  label = 'CYD'
               else
                  do j = 1, n12(isg)
                     ij = i12(j,isg)
                     aij = atomic(ij)
                     if (aij .eq. 1)  label = 'CYS'
                     if (aij .eq. 16)  label = 'CYX'
                  end do
               end if
            end if
            if (min(icg1,icg2) .ne. 0) then
               nhg = 0
               do j = 1, n12(icg1)
                  ij = i12(j,icg1)
                  aij = atomic(ij)
                  if (aij .eq. 1)  nhg = nhg + 1
                  if (ij.ne.icb1 .and. aij.eq.6)  icd1 = ij
               end do
               do j = 1, n12(icg2)
                  ij = i12(j,icg2)
                  aij = atomic(ij)
                  if (aij .eq. 1)  nhg = nhg + 1
                  if (ij.ne.icb1 .and. aij.eq.6)  icd1 = ij
               end do
               if (nhg .eq. 5)  label = 'ILE'
               if (nhg .eq. 6)  label = 'VAL'
            end if
         end if
c
c     inspect the delta position of amino acid residue
c
         if (label.eq.'   ' .and. icg1.ne.0) then
            do j = 1, n12(icg1)
               ij = i12(j,icg1)
               aij = atomic(ij)
               if (ij.ne.icb1 .and. aij.eq.6) then
                  if (icd1 .ne. 0)  icd2 = ij
                  if (icd1 .eq. 0)  icd1 = ij
               end if
               if (aij .eq. 7)  ind = ij
               if (aij .eq. 8) then
                  if (iod1 .ne. 0)  iod2 = ij
                  if (iod1 .eq. 0)  iod1 = ij
               end if
               if (aij .eq. 16)  isd = ij
            end do
            if (iod1.ne.0 .and. ind.ne.0)  label = 'ASN'
            if (iod2 .ne. 0) then
               if (n12(iod1).eq.1 .and. n12(iod2).eq.1) then
                  label = 'ASP'
               else
                  label = 'ASH'
               end if
            end if
            if (isd .ne. 0) then
               label = 'MET'
               do j = 1, n12(isd)
                  ij = i12(j,isd)
                  aij = atomic(ij)
                  if (ij.ne.icg1 .and. aij.eq.6)  ice1 = ij
               end do
            end if
            if (min(icd1,icd2) .ne. 0) then
               nhd = 0
               do j = 1, n12(icd1)
                  ij = i12(j,icd1)
                  aij = atomic(ij)
                  if (aij .eq. 1)  nhd = nhd + 1
               end do
               do j = 1, n12(icd2)
                  ij = i12(j,icd2)
                  aij = atomic(ij)
                  if (aij .eq. 1)  nhd = nhd + 1
               end do
               if (nhd .eq. 6)  label = 'LEU'
            end if
            if (icd1 .ne. 0) then
               do j = 1, n12(icd1)
                  ij = i12(j,icd1)
                  if (ij.eq.ib .or. ij.eq.id)  label = 'PRO'
               end do
            end if
         end if
c
c     inspect the epsilon position of amino acid residue
c
         if (label.eq.'   ' .and. icd1.ne.0) then
            do j = 1, n12(icd1)
               ij = i12(j,icd1)
               aij = atomic(ij)
               if (ij.ne.icg1 .and. aij.eq.6) then
                  if (ice1 .ne. 0)  ice2 = ij
                  if (ice1 .eq. 0)  ice1 = ij
               end if
               if (aij .eq. 7)  ine = ij
               if (aij .eq. 8) then
                  if (ioe1 .ne. 0)  ioe2 = ij
                  if (ioe1 .eq. 0)  ioe1 = ij
               end if
            end do
            if (ine .ne. 0) then
               if (n12(ine) .eq. 4)  label = 'ORN'
            end if
            if (ioe1.ne.0 .and. ine.ne.0)  label = 'GLN'
            if (ioe2 .ne. 0) then
               if (n12(ioe1).eq.1 .and. n12(ioe2).eq.1) then
                  label = 'GLU'
               else
                  label = 'GLH'
               end if
            end if
         end if
         if (label.eq.'   ' .and. icd2.ne.0) then
            do j = 1, n12(icd2)
               ij = i12(j,icd2)
               aij = atomic(ij)
               if (ij.ne.icg1 .and. aij.eq.6) then
                  if (ice1 .ne. 0)  ice2 = ij
                  if (ice1 .eq. 0)  ice1 = ij
               end if
               if (aij .eq. 7)  ine = ij
            end do
         end if
         if (label.eq.'   ' .and. ind.ne.0) then
            do j = 1, n12(ind)
               ij = i12(j,ind)
               aij = atomic(ij)
               if (ij.ne.icg1 .and. aij.eq.6) then
                  if (ice1 .ne. 0)  ice2 = ij
                  if (ice1 .eq. 0)  ice1 = ij
               end if
            end do
         end if
         if (label.eq.'   ' .and. min(ind,ine).ne.0) then
            do j = 1, n12(ine)
               ij = i12(j,ine)
               if (ij .eq. ice1) then
                  label = 'HIS'
                  if (n12(ind) .eq. 2)  label = 'HIE'
                  if (n12(ine) .eq. 2)  label = 'HID'
               end if
            end do
         end if
         if (label.eq.'   ' .and. ine.ne.0) then
            do j = 1, n12(ine)
               ij = i12(j,ine)
               if (ij .eq. ice1)  label = 'TRP'
               if (ij .eq. ice2)  label = 'TRP'
            end do
            if (ice1 .ne.  0) then
               do j = 1, n12(ice1)
                  ij = i12(j,ice1)
                  aij = atomic(ij)
                  if (ij.ne.icd1 .and. ij.ne.icd2 .and. aij.eq.6) then
                     if (icz1 .ne. 0)  icz2 = ij
                     if (icz1 .eq. 0)  icz1 = ij
                  end if
               end do
            end if
            if (ice2 .ne.  0) then
               do j = 1, n12(ice2)
                  ij = i12(j,ice2)
                  aij = atomic(ij)
                  if (ij.ne.icd1 .and. ij.ne.icd2 .and. aij.eq.6) then
                     if (icz1 .ne. 0)  icz2 = ij
                     if (icz1 .eq. 0)  icz1 = ij
                  end if
               end do
            end if
            if (icz1 .ne.  0) then
               do j = 1, n12(icz1)
                  ij = i12(j,icz1)
                  aij = atomic(ij)
                  if (ij.ne.ice1 .and. ij.ne.ice2 .and. aij.eq.6) then
                     ich = ij
                  end if
               end do
            end if
         end if
c
c     inspect the zeta position of amino acid residue
c
         if (label.eq.'   ' .and. ice1.ne.0) then
            do j = 1, n12(ice1)
               ij = i12(j,ice1)
               aij = atomic(ij)
               if (ij.ne.icd1 .and. aij.eq.6) then
                  if (icz1 .ne. 0)  icz2 = ij
                  if (icz1 .eq. 0)  icz1 = ij
               end if
               if (aij .eq. 7)  inz = ij
            end do
            if (inz.ne.0 .and. n12(ice1).eq.4) then
               if (n12(inz) .eq. 3)  label = 'LYD'
               if (n12(inz) .eq. 4)  label = 'LYS'
            end if
         end if
         if (label.eq.'   ' .and. ice2.ne.0) then
            do j = 1, n12(ice2)
               ij = i12(j,ice2)
               aij = atomic(ij)
               if (ij.ne.icd2 .and. aij.eq.6) then
                  if (icz1 .ne. 0)  icz2 = ij
                  if (icz1 .eq. 0)  icz1 = ij
               end if
            end do
            if (icz1 .eq. icz2) then
               icz2 = 0
               label = 'PHE'
               do j = 1, n12(icz1)
                  ij = i12(j,icz1)
                  aij = atomic(ij)
                  if (aij .eq. 8) then
                     ioh = ij
                     if (n12(ij) .eq. 1)  label = 'TYD'
                     if (n12(ij) .eq. 2)  label = 'TYR'
                  end if
               end do
            end if
         end if
         if (label.eq.'   ' .and. ine.ne.0) then
            do j = 1, n12(ine)
               ij = i12(j,ine)
               aij = atomic(ij)
               if (ij.ne.icd1 .and. aij.eq.6) then
                  if (icz1 .ne. 0)  icz2 = ij
                  if (icz1 .eq. 0)  icz1 = ij
               end if
            end do
            if (icz1 .ne. 0) then
               label = 'ARG'
               do j = 1, n12(icz1)
                  ij = i12(j,icz1)
                  aij = atomic(ij)
                  if (aij .ne. 7) then
                     label = '   '
                  else if (ij .ne. ine) then
                     if (inh1 .ne. 0)  inh2 = ij
                     if (inh1 .eq. 0)  inh1 = ij
                  end if
               end do
            end if
         end if
c
c     propagate the tier name to all atoms of the residue
c
         if (label .ne. '   ') then
            tier(ic) = label
            do j = 1, n12(ic)
               ij = i12(j,ic)
               tier(ij) = label
            end do
            tier(ib) = label
            do j = 1, n12(ib)
               ij = i12(j,ib)
               aij = atomic(ij)
               if (aij .eq. 1)  tier(ij) = label
               if (aij .eq. 8)  tier(ij) = label
            end do
            tier(id) = label
            do j = 1, n12(id)
               ij = i12(j,id)
               aij = atomic(ij)
               if (aij .eq. 1)  tier(ij) = label
               if (aij .eq. 8)  tier(ij) = label
            end do
            if (icb1 .ne. 0) then
               tier(icb1) = label
               do j = 1, n12(icb1)
                  ij = i12(j,icb1)
                  tier(ij) = label
               end do
            end if
            if (icb2 .ne. 0) then
               tier(icb2) = label
               do j = 1, n12(icb2)
                  ij = i12(j,icb2)
                  tier(ij) = label
               end do
            end if
            if (icg1 .ne. 0) then
               tier(icg1) = label
               do j = 1, n12(icg1)
                  ij = i12(j,icg1)
                  tier(ij) = label
               end do
            end if
            if (icg2 .ne. 0) then
               tier(icg2) = label
               do j = 1, n12(icg2)
                  ij = i12(j,icg2)
                  tier(ij) = label
               end do
            end if
            if (icd1 .ne. 0) then
               tier(icd1) = label
               do j = 1, n12(icd1)
                  ij = i12(j,icd1)
                  tier(ij) = label
               end do
            end if
            if (icd2 .ne. 0) then
               tier(icd2) = label
               do j = 1, n12(icd2)
                  ij = i12(j,icd2)
                  tier(ij) = label
               end do
            end if
            if (ice1 .ne. 0) then
               tier(ice1) = label
               do j = 1, n12(ice1)
                  ij = i12(j,ice1)
                  tier(ij) = label
               end do
            end if
            if (ice2 .ne. 0) then
               tier(ice2) = label
               do j = 1, n12(ice2)
                  ij = i12(j,ice2)
                  tier(ij) = label
               end do
            end if
            if (icz1 .ne. 0) then
               tier(icz1) = label
               do j = 1, n12(icz1)
                  ij = i12(j,icz1)
                  tier(ij) = label
               end do
            end if
            if (icz2 .ne. 0) then
               tier(icz2) = label
               do j = 1, n12(icz2)
                  ij = i12(j,icz2)
                  tier(ij) = label
               end do
            end if
            if (ich .ne. 0) then
               tier(ich) = label
               do j = 1, n12(ich)
                  ij = i12(j,ich)
                  tier(ij) = label
               end do
            end if
            if (ind .ne. 0) then
               tier(ind) = label
               do j = 1, n12(ind)
                  ij = i12(j,ind)
                  tier(ij) = label
               end do
            end if
            if (ine .ne. 0) then
               tier(ine) = label
               do j = 1, n12(ine)
                  ij = i12(j,ine)
                  tier(ij) = label
               end do
            end if
            if (inz .ne. 0) then
               tier(inz) = label
               do j = 1, n12(inz)
                  ij = i12(j,inz)
                  tier(ij) = label
               end do
            end if
            if (inh1 .ne. 0) then
               tier(inh1) = label
               do j = 1, n12(inh1)
                  ij = i12(j,inh1)
                  tier(ij) = label
               end do
            end if
            if (inh2 .ne. 0) then
               tier(inh2) = label
               do j = 1, n12(inh2)
                  ij = i12(j,inh2)
                  tier(ij) = label
               end do
            end if
            if (iog .ne. 0) then
               tier(iog) = label
               do j = 1, n12(iog)
                  ij = i12(j,iog)
                  tier(ij) = label
               end do
            end if
            if (iod1 .ne. 0) then
               tier(iod1) = label
               do j = 1, n12(iod1)
                  ij = i12(j,iod1)
                  tier(ij) = label
               end do
            end if
            if (iod2 .ne. 0) then
               tier(iod2) = label
               do j = 1, n12(iod2)
                  ij = i12(j,iod2)
                  tier(ij) = label
               end do
            end if
            if (ioe1 .ne. 0) then
               tier(ioe1) = label
               do j = 1, n12(ioe1)
                  ij = i12(j,ioe1)
                  tier(ij) = label
               end do
            end if
            if (ioe2 .ne. 0) then
               tier(ioe2) = label
               do j = 1, n12(ioe2)
                  ij = i12(j,ioe2)
                  tier(ij) = label
               end do
            end if
            if (ioh .ne. 0) then
               tier(ioh) = label
               do j = 1, n12(ioh)
                  ij = i12(j,ioh)
                  tier(ij) = label
               end do
            end if
            if (isg .ne. 0) then
               tier(isg) = label
               do j = 1, n12(isg)
                  ij = i12(j,isg)
                  tier(ij) = label
               end do
            end if
            if (isd .ne. 0) then
               tier(isd) = label
               do j = 1, n12(isd)
                  ij = i12(j,isd)
                  tier(ij) = label
               end do
            end if
         end if
   10    continue
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2025  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine findseq  --  get protein & nucleotide sequence  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "findseq" locates and stores biopolymer sequences for proteins
c     and nucleic acids from connectivity and residue information
c
c
      subroutine findseq
      use atomid
      use atoms
      use bitor
      use couple
      use inform
      use iounit
      use sequen
      use tettor
      use tritor
      implicit none
      integer i,j,ij,code
      integer nlist,nhyd
      integer ia,ib,ic,id
      integer ie,ig,ih
      integer nia,nib,nic
      integer nid,nie,nig
      integer aia,aib,aic
      integer aid,aie
      integer aig,aih
      integer, allocatable :: flink(:)
      integer, allocatable :: blink(:)
      integer, allocatable :: clink(:)
      integer, allocatable :: list(:,:)
      logical proceed
      character*1 char
      character*1 cnam(52)
      data cnam  / 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
     &             'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R',
     &             'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 'a',
     &             'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
     &             'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's',
     &             't', 'u', 'v', 'w', 'x', 'y', 'z' /
c
c
c     perform dynamic allocation of some local arrays
c
      if (allocated(flink))  deallocate (flink)
      if (allocated(blink))  deallocate (blink)
      if (allocated(clink))  deallocate (clink)
      if (allocated(list))  deallocate (list)
      allocate (flink(n))
      allocate (blink(n))
      allocate (clink(n))
      allocate (list(2,n))
c
c     zero out the sequence length and link arrays
c
      nlist = 0
      do i = 1, n
         flink(i) = 0
         blink(i) = 0
         clink(i) = 0
      end do
c
c     search for alpha carbons along polypeptide backbone
c
      do i = 1, ntritor
         ia = itritor(1,i)
         ib = itritor(2,i)
         ic = itritor(3,i)
         id = itritor(4,i)
         ie = itritor(5,i)
         ig = itritor(6,i)
         nia = n12(ia)
         nib = n12(ib)
         nic = n12(ic)
         nid = n12(id)
         nie = n12(ie)
         nig = n12(ig)
         aia = atomic(ia)
         aib = atomic(ib)
         aic = atomic(ic)
         aid = atomic(id)
         aie = atomic(ie)
         aig = atomic(ig)
         if (aia.eq.7 .and. aib.eq.6 .and. aic.eq.6 .and.
     &       aid.eq.7 .and. aie.eq.6 .and. aig.eq.6) then
            if (nia.ge.3 .and. nib.eq.4 .and. nic.eq.3 .and.
     &          nid.eq.3 .and. nie.eq.4 .and. nig.eq.3) then
               nlist = nlist + 1
               list(1,nlist) = ib
               list(2,nlist) = ie
               flink(ib) = ie
               blink(ie) = ib
               clink(ib) = ib
               clink(ie) = ie
            end if
         end if
         if (aia.eq.6 .and. aib.eq.6 .and. aic.eq.7 .and.
     &       aid.eq.6 .and. aie.eq.6 .and. aig.eq.7) then
            if (nia.eq.3 .and. nib.eq.4 .and. nic.eq.3 .and.
     &          nid.eq.3 .and. nie.eq.4 .and. nig.ge.3) then
               nlist = nlist + 1
               list(1,nlist) = ie
               list(2,nlist) = ib
               flink(ie) = ib
               blink(ib) = ie
               clink(ib) = ib
               clink(ie) = ie
            end if
         end if
      end do
c
c     search for N-terminal ACE capping group at end of chain
c
      do i = 1, nbitor
         ia = ibitor(1,i)
         ib = ibitor(2,i)
         ic = ibitor(3,i)
         id = ibitor(4,i)
         ie = ibitor(5,i)
         nia = n12(ia)
         nib = n12(ib)
         nic = n12(ic)
         nid = n12(id)
         nie = n12(ie)
         aia = atomic(ia)
         aib = atomic(ib)
         aic = atomic(ic)
         aid = atomic(id)
         aie = atomic(ie)
         if (aia.eq.6 .and. aib.eq.6 .and.aic.eq.7
     &       .and. aid.eq.6 .and. aie.eq.6) then
            if (nia.eq.4 .and. nib.eq.3 .and.nic.eq.3
     &          .and. nid.eq.4 .and. nie.eq.3) then
               nhyd = 0
               do j = 1, nia
                  ij = i12(j,ia)
                  if (atomic(ij) .eq. 1)  nhyd = nhyd + 1
               end do
               if (nhyd .eq. 3) then
                  nlist = nlist + 1
                  list(1,nlist) = ia
                  list(2,nlist) = id
                  flink(ia) = id
                  blink(id) = ia
                  clink(ia) = ia
                  clink(id) = id
               end if
            end if
         end if
         if (aia.eq.6 .and. aib.eq.6 .and.aic.eq.7
     &       .and. aid.eq.6 .and. aie.eq.6) then
            if (nia.eq.3 .and. nib.eq.4 .and.nic.eq.3
     &          .and. nid.eq.3 .and. nie.eq.4) then
               nhyd = 0
               do j = 1, nie
                  ij = i12(j,ie)
                  if (atomic(ij) .eq. 1)  nhyd = nhyd + 1
               end do
               if (nhyd .eq. 3) then
                  nlist = nlist + 1
                  list(1,nlist) = ie
                  list(2,nlist) = ib
                  flink(ie) = ib
                  blink(ib) = ie
                  clink(ie) = ie
                  clink(ib) = ib
               end if
            end if
         end if
c
c     search for C-terminal NME capping group at end of chain
c
         if (aia.eq.7 .and. aib.eq.6 .and.aic.eq.6
     &       .and. aid.eq.7 .and. aie.eq.6) then
            if (nia.eq.3 .and. nib.eq.4 .and.nic.eq.3
     &          .and. nid.eq.3 .and. nie.eq.4) then
               nhyd = 0
               do j = 1, nie
                  ij = i12(j,ie)
                  if (atomic(ij) .eq. 1)  nhyd = nhyd + 1
               end do
               if (nhyd .eq. 3) then
                  nlist = nlist + 1
                  list(1,nlist) = ib
                  list(2,nlist) = ie
                  flink(ib) = ie
                  blink(ie) = ib
                  clink(ib) = ib
                  clink(ie) = ie
               end if
            end if
         end if
         if (aia.eq.6 .and. aib.eq.7 .and.aic.eq.6
     &       .and. aid.eq.6 .and. aie.eq.7) then
            if (nia.eq.4 .and. nib.eq.3 .and.nic.eq.3
     &          .and. nid.eq.4 .and. nie.eq.3) then
               nhyd = 0
               do j = 1, nia
                  ij = i12(j,ia)
                  if (atomic(ij) .eq. 1)  nhyd = nhyd + 1
               end do
               if (nhyd .eq. 3) then
                  nlist = nlist + 1
                  list(1,nlist) = id
                  list(2,nlist) = ia
                  flink(id) = ia
                  blink(ia) = id
                  clink(id) = id
                  clink(ia) = ia
               end if
            end if
         end if
      end do
c
c     search for adjacent phosphates at ends of each nucleotide
c
      do i = 1, ntettor
         ia = itettor(1,i)
         ib = itettor(2,i)
         ic = itettor(3,i)
         id = itettor(4,i)
         ie = itettor(5,i)
         ig = itettor(6,i)
         ih = itettor(7,i)
         aia = atomic(ia)
         aib = atomic(ib)
         aid = atomic(id)
         aig = atomic(ig)
         aih = atomic(ih)
         proceed = .false.
         if (aia.eq.15 .and. aih.eq.15)  proceed = .true.
         if (aia.eq.1 .and. aib.eq.8 .and. aih.eq.15)  proceed = .true.
         if (aia.eq.15 .and. aig.eq.8 .and. aih.eq.1)  proceed = .true.
         if (proceed) then
            nhyd = 0
            do j = 1, n12(ic)
               ij = i12(j,ic)
               if (atomic(ij) .eq. 1)  nhyd = nhyd + 1
            end do
            if (nhyd .eq. 2) then
               nlist = nlist + 1
               list(1,nlist) = ia
               list(2,nlist) = ih
               flink(ia) = ih
               blink(ih) = ia
               clink(ia) = id
            end if
            nhyd = 0
            do j = 1, n12(ie)
               ij = i12(j,ie)
               if (atomic(ij) .eq. 1)  nhyd = nhyd + 1
            end do
            if (nhyd .eq. 2) then
               nlist = nlist + 1
               list(1,nlist) = ih
               list(2,nlist) = ia
               flink(ih) = ia
               blink(ia) = ih
               clink(ih) = id
            end if
         end if
      end do
c
c     place the amino acids or nucleotides in sequence order
c
      nseq = 0
      nchain = 0
      code = 1
      do i = 1, nlist
         ia = list(1,i)
         ib = blink(ia)
         if (ib .eq. 0) then
            aia = atomic(ia)
            nseq = nseq + 1
            seq(nseq) = tier(ia)
            seqatm(nseq) = clink(ia)
            nchain = nchain + 1
            ichain(1,nchain) = nseq
            chnnam(nchain) = cnam(code)
            chntyp(nchain) = 'PROTEIN'
            if (aia .eq. 15) then
               chntyp(nchain) = 'NUCLEIC'
            end if
            proceed = .true.
            dowhile (proceed)
               ib = flink(ia)
               ic = 0
               if (ib .ne. 0)  ic = clink(ib)
               if (ib.eq.0 .or. ic.eq.0) then
                  proceed = .false.
                  ichain(2,nchain) = nseq
                  if (code .ge. 52)  code = 0
                  code = code + 1
               else
                  aib = atomic(ib)
                  nseq = nseq + 1
                  seq(nseq) = tier(ib)
                  seqatm(nseq) = ic
                  if (aib .eq. 15) then
                     chntyp(nchain) = 'NUCLEIC'
                  end if
                  ia = ib
               end if
            end do
         end if
      end do
      if (nchain .eq. 1)  chnnam(1) = ' '
c
c     print the biopolymer chain and sequence information
c
      if (debug .and. nseq.ne.0) then
         write (iout,10)
   10    format (/,' Biopolymer Sequence Chains :'
     &           //,3x,'Chain',8x,'Name',6x,'Residue Range',5x,'Type',/)
         do i = 1, nchain
            if (chnnam(i) .eq. ' ') then
               write (iout,20)  i,(ichain(j,i),j=1,2),chntyp(i)
   20          format (i6,12x,'-',4x,2i7,7x,a7)
            else
               write (iout,30)  i,chnnam(i),(ichain(j,i),j=1,2),
     &                          chntyp(i)
   30          format (i6,12x,a1,4x,2i7,7x,a7)
            end if
         end do
         write (iout,40)
   40    format (/,' Biopolymer Sequence Residues :'
     &           //,' Residue',8x,'Name',7x,'Anchor Atom',/)
         do i = 1, nseq
            write (iout,50)  i,seq(i),seqatm(i)
   50       format (i6,11x,a3,7x,i8)
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (flink)
      deallocate (blink)
      deallocate (clink)
      deallocate (list)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1994  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine flatten  --  set potential smoothing parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "flatten" sets the type of smoothing method and the extent of
c     surface deformation for use with potential energy smoothing
c
c
      subroutine flatten
      use atoms
      use fields
      use inform
      use iounit
      use keys
      use warp
      implicit none
      integer i,next
      logical query,exist
      character*7 stype
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set defaults for deformation and diffusion coefficients
c
      query = .true.
      deform = 0.0d0
      difft = 0.0225d0
      diffv = 1.0d0
      diffc = 1.0d0
c
c     get any keywords related to potential energy smoothing
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:10) .eq. 'SMOOTHING ') then
            use_smooth = .true.
            use_dem = .false.
            use_gda = .false.
            use_tophat = .false.
            use_stophat = .false.
            call getword (record,stype,next)
            call upcase (stype)
            if (stype .eq. 'DEM')  use_dem = .true.
            if (stype .eq. 'GDA')  use_gda = .true.
            if (stype .eq. 'TOPHAT')  use_tophat = .true.
            if (stype .eq. 'STOPHAT')  use_stophat = .true.
         else if (keyword(1:7) .eq. 'DEFORM ') then
            read (string,*,err=10,end=10)  deform
            query = .false.
         else if (keyword(1:16) .eq. 'DIFFUSE-TORSION ') then
            read (string,*,err=10,end=10)  difft
         else if (keyword(1:12) .eq. 'DIFFUSE-VDW ') then
            read (string,*,err=10,end=10)  diffv
         else if (keyword(1:15) .eq. 'DIFFUSE-CHARGE ') then
            read (string,*,err=10,end=10)  diffc
         end if
   10    continue
      end do
c
c     try to get the deformation value from the command line
c
      if (use_smooth) then
         if (query) then
            call nextarg (string,exist)
            if (exist) then
               read (string,*,err=20,end=20)  deform
               query = .false.
            end if
   20       continue
         end if
c
c     ask for the potential surface deformation to be used
c
         if (query) then
            if (use_gda) then
               deform = 200.0d0
               write (iout,30)
   30          format (/,' Enter the Initial Mean Squared Gaussian',
     &                    ' Width [200.0] :  ',$)
            else if (use_tophat .or. use_stophat) then
               deform = 0.0d0
               write (iout,40)
   40          format (/,' Enter Length Scale for Potential Surface',
     &                    ' Averaging [0.0] :  ',$)
            else
               deform = 0.0d0
               write (iout,50)
   50          format (/,' Enter the Potential Surface Smoothing',
     &                    ' Parameter [0.0] :  ',$)
            end if
            read (input,60)  record
   60       format (a240)
            read (record,*,err=70,end=70)  deform
   70       continue
         end if
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (use_gda) then
         if (.not. allocated(m2))  allocate (m2(n))
      end if
c
c     set second moment of Gaussian on each atom for GDA methods
c
      if (use_gda) then
         do i = 1, n
            m2(i) = deform
         end do
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module fracs  --  distances to molecular center of mass  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     xfrac   fractional coordinate along a-axis of center of mass
c     yfrac   fractional coordinate along b-axis of center of mass
c     zfrac   fractional coordinate along c-axis of center of mass
c
c
      module fracs
      implicit none
      real*8, allocatable :: xfrac(:)
      real*8, allocatable :: yfrac(:)
      real*8, allocatable :: zfrac(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2016  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program freefix  --  free energy restraint thermodynamics  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "freefix" computes a restraint correction term for a single
c     flat-bottomed harmonic or six translation-rotation restraints
c     used to keep a ligand bound during free energy simulations
c
c
      program freefix
      use iounit
      implicit none
      integer next
      logical exist
      character*1 answer
      character*8 method
      character*240 string
c
c
c     get type of ligand binding restraint to be analyzed
c
      call initial
      method = 'HARMONIC'
      call nextarg (answer,exist)
      if (.not. exist) then
         answer = 'H'
         write (iout,10)  answer
   10    format (/,' Choose Harmonic Restraint or Boresch Restraint',
     &              ' [',a1,'] :  ',$)
         read (input,20)  string
   20    format (a240)
         next = 1
         call gettext (string,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'B')  method = 'BORESCH '
c
c     compute the values of the free energy correction
c
      if (method .eq. 'HARMONIC')  call hfix
      if (method .eq. 'BORESCH ')  call bfix
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine hfix  --  find harmonic restraint correction  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "hfix" computes via a volume integral the free energy, enthalpy
c     and entropy correction for a flat-bottom harmonic restraint
c
c     literature reference:
c
c     D. Hamelberg and J. A. McCammon, "Standard Free Energy of
c     Releasing a Localized Water Molecule from the Binding Pockets
c     of Proteins: Double-Decoupling Method", Journal of the American
c     Chemical Society, 126, 7683-7689 (2004)  [equations 15-19]
c
c     enthalpy and entropy values added by Aaron Gordon, February 2017;
c     analytical volume integral derived by Zhi Wang, December 2017
c
c
      subroutine hfix
      use iounit
      use math
      use units
      implicit none
      integer i,j,k
      integer i2,j2,k2
      integer maxgrid
      real*8 kt,stdcon
      real*8 temp,force
      real*8 ri,ro,fi,fo
      real*8 spacing,cube
      real*8 dist,dist2
      real*8 term,expterm
      real*8 dexpterm
      real*8 v1,v2,v3
      real*8 dv1,dv2,dv3
      real*8 vol,dvol
      real*8 dg,ds,dh
      real*8 erf
      logical exist,donumer
      character*240 string
      external erf
c
c
c     get force constant, restraint radius and temperature values
c
      fi = 0.0d0
      ri = 0.0d0
      fo = 1.0d0
      ro = 0.0d0
      temp = 298.0d0
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  ri
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  fi
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  ro
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  fo
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  temp
   10    continue
      else
         write (iout,20)  ri,fi
   20    format (/,' Enter Inner Radius & Force Constant [',
     &              f4.2,',',f4.1'] :  ',$)
         read (input,30)  string
   30    format (a240)
         read (string,*,err=40,end=40)  ri,fi
   40    continue
         ro = ri
         if (fi .ne. 0.0d0)  fo = fi
         write (iout,50)  ro,fo
   50    format (/,' Enter Outer Radius & Force Constant [',
     &              f4.2,',',f4.1'] :  ',$)
         read (input,60)  string
   60    format (a240)
         read (string,*,err=70,end=70)  ro,fo
   70    continue
         write (iout,80)  temp
   80    format (/,' Enter System Temperature Value [',f5.1,'K] :  ',$)
         read (input,90)  string
   90    format (a240)
         read (string,*,err=100,end=100)  temp
  100    continue
      end if
c
c     print the restraint parameter values and temperature
c
      write (iout,110)  ri
  110 format (/,' Inner Flat-Bottom Radius :',5x,f12.4,' Ang')
      write (iout,120)  fi
  120 format (' Inner Force Constant :',9x,f12.4,
     &           ' Kcal/mole/Ang^2')
      write (iout,130)  ro
  130 format (' Outer Flat-Bottom Radius :',5x,f12.4,' Ang')
      write (iout,140)  fo
  140 format (' Outer Force Constant :',9x,f12.4,
     &           ' Kcal/mole/Ang^2')
      write (iout,150)  temp
  150 format (' System Temperature Value :',5x,f12.4,' Kelvin')
c
c     zero values for force constants are not allowed
c
      if (fi .eq. 0.0d0) then
         fi = 1.0d0
         ri = 0.0d0
      end if
      if (fo .eq. 0.0d0)  fo = 1.0d0
c
c     find RT and Ang^3 per molecule at 1 mole/L concentration
c
      kt = temp * gasconst
      stdcon = 1.0d27 / avogadro
c
c     numerical estimation of the restraint volume integral
c
      donumer = .false.
      if (donumer) then
         spacing = 0.03d0
         cube = spacing**3
         maxgrid = int((10.0d0+ro)/spacing)
         vol = 0.0d0
         dvol = 0.0d0
         do i = -maxgrid, maxgrid
            i2 = i * i
            do j = -maxgrid, maxgrid
               j2 = j * j
               do k = -maxgrid, maxgrid
                  k2 = k * k
                  dist = spacing * sqrt(dble(i2+j2+k2))
                  if (dist .gt. ro) then
                     dist = dist - ro
                     force = fo
                  else if (dist .lt. ri) then
                     dist = ri - dist
                     force = fi
                  else
                     dist = 0.0d0
                     force = 0.0d0
                  end if
                  dist2 = dist * dist
                  term = -force * dist2 / kt
                  expterm = 0.0d0
                  dexpterm = 0.0d0
                  if (term .ge. -20.0d0) then
                     expterm = cube * exp(term)
                     dexpterm = expterm * (force*dist2)/(kt*temp)
                  end if
                  vol = vol + expterm
                  dvol = dvol + dexpterm
               end do
            end do
         end do
         write (iout,160)  spacing
  160    format (/,' Numerical Grid Spacing :',7x,f12.4,' Ang')
         write (iout,170)  vol
  170    format (' Numerical Volume Integral :',4x,f12.4,' Ang^3')
         write (iout,180)  dvol
  180    format (' Numerical dVol/dT Value :',6x,f12.4,' Ang^3/K')
      end if
c
c     analytical evaluation of the restraint volume integral
c
      v1 = 2.0d0*pi*ri*(-2.0d0+exp(-ri**2*fi/kt))*kt/fi
     &        + sqrt(kt*(pi/fi)**3)*(2.0d0*fi*ri*ri+kt)
     &             *erf(ri*sqrt(fi/kt))
      v2 = (4.0d0*pi/3.0d0) * (ro**3-ri**3)
      v3 = sqrt(kt*(pi/fo)**3)
     &        * (2.0d0*fo*ro*ro+kt+4.0d0*ro*sqrt(kt*fo/pi))
      vol = v1 + v2 + v3
      dv1 = 2.0d0*pi*ri**3*exp(-ri**2*fi/kt)/temp
     &         + 2.0d0*pi*ri*(-2.0d0+exp(-ri**2*fi/kt))*kt/(fi*temp)
     &         + 0.5d0*sqrt((pi/fi)**3)*sqrt(kt)*(2.0d0*ri**2*fi+kt)
     &             *erf(ri*sqrt(fi/kt))/temp
     &         - pi*ri*exp(-ri**2*fi/kt)*(2.0d0*ri**2*fi+kt)/(fi*temp)
     &         + sqrt((kt*pi/fi)**3)*erf(ri*sqrt(fi/kt))/temp
      dv2 = 0.0d0
      dv3 = sqrt(kt*(pi/fo)**3)*fo*ro*ro/temp
     &         + 4.0d0*kt*(pi/fo)*ro/temp
     &         + 1.5d0*sqrt((kt*pi/fo)**3)/temp
      dvol = dv1 + dv2 + dv3
      write (iout,190)  vol
  190 format (/,' Analytical Volume Integral :',3x,f12.4,' Ang^3')
      write (iout,200)  dvol
  200 format (' Analytical dVol/dT Value :',5x,f12.4,' Ang^3/K')
c
c     calculate and print the restraint thermodynamic values
c
      dg = -kt * log(vol/stdcon)
      ds = -dg/temp + kt*dvol/vol
      dh = dg + temp*ds
      write (iout,210)  dg
  210 format (/,' Restraint Free Energy :',8x,f12.4,' Kcal/mole')
      write (iout,220)  ds
  220 format (' Restraint Entropy Value :',6x,f12.4,' Kcal/mole/K')
      write (iout,230)  dh
  230 format (' Restraint Enthalpy Value :',5x,f12.4,' Kcal/mole')
      write (iout,240)  -temp*ds
  240 format (' Restraint -T deltaS Value :',4x,f12.4,' Kcal/mole')
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine bfix  --  find Boresch restraint correction  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "bfix" computes via a volume integral the free energy, enthalpy
c     and entropy correction for a set of six harmonic translation-
c     rotation "Boresch" restraints
c
c     literature reference:
c
c     S. Boresch, F. Tettinger, M. Leitgeb and M. Karplus, "Absolute
c     Binding Free Energies: A Quantitative Approach for Their
c     Calculation", Journal of Physical Chemistry B, 107, 9535-9551
c     (2003)  [equation 14]
c
c
      subroutine bfix
      use iounit
      use math
      use units
      implicit none
      real*8 dist,temp
      real*8 ang1,ang2
      real*8 fd,fa1,fa2
      real*8 ft1,ft2,ft3
      real*8 kt,stdcon
      real*8 sine1,sine2
      real*8 term1,term2
      real*8 term3,term4
      real*8 dg,ds,dh
      logical exist
      character*240 string
c
c
c     get distance, angle, force constant and temperature values
c
      dist = 0.0d0
      fd = 0.0d0
      ang1 = 0.0d0
      fa1 = 0.0d0
      ang2 = 0.0d0
      fa2 = 0.0d0
      ft1 = 0.0d0
      ft2 = 0.0d0
      ft3 = 0.0d0
      temp = 298.0d0
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  dist
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  fd
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  ang1
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  fa1
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  ang2
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  fa2
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  ft1
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  ft2
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  ft3
         call nextarg (string,exist)
         read (string,*,err=10,end=10)  temp
   10    continue
      else
         write (iout,20)
   20    format (/,' Enter Distance Value & Force Constant :  ',$)
         read (input,30)  string
   30    format (a240)
         read (string,*,err=40,end=40)  dist,fd
   40    continue
         write (iout,50)
   50    format (/,' Enter 1st Angle Value & Force Constant :  ',$)
         read (input,60)  string
   60    format (a240)
         read (string,*,err=70,end=70)  ang1,fa1
   70    continue
         write (iout,80)
   80    format (/,' Enter 2nd Angle Value & Force Constant :  ',$)
         read (input,90)  string
   90    format (a240)
         read (string,*,err=100,end=100)  ang2,fa2
  100    continue
         write (iout,110)
  110    format (/,' Enter Three Torsional Force Constants :  ',$)
         read (input,120)  string
  120    format (a240)
         read (string,*,err=130,end=130)  ft1,ft2,ft3
  130    continue
         write (iout,140)  temp
  140    format (/,' Enter System Temperature Value [',f5.1,'K] :  ',$)
         read (input,150)  string
  150    format (a240)
         read (string,*,err=160,end=160)  temp
  160    continue
      end if
c
c     print the restraint parameter values and temperature
c
      write (iout,170)  dist
  170 format (/,' Distance Reference Value :',5x,f12.4,' Ang')
      write (iout,180)  fd
  180 format (' Distance Force Constant :',6x,f12.4,' Kcal/mole/Ang^2')
      write (iout,190)  ang1
  190 format (' Angle 1 Reference Value :',6x,f12.4,' Deg')
      write (iout,200)  fa1
  200 format (' Angle 1 Force Constant :',7x,f12.4,' Kcal/mole/Rad^2')
      write (iout,210)  ang2
  210 format (' Angle 2 Reference Value :',6x,f12.4,' Deg')
      write (iout,220)  fa2
  220 format (' Angle 2 Force Constant :',7x,f12.4,' Kcal/mole/Rad^2')
      write (iout,230)  ft1
  230 format (' Torsion 1 Force Constant :',5x,f12.4,' Kcal/mole/Rad^2')
      write (iout,240)  ft2
  240 format (' Torsion 2 Force Constant :',5x,f12.4,' Kcal/mole/Rad^2')
      write (iout,250)  ft3
  250 format (' Torsion 3 Force Constant :',5x,f12.4,' Kcal/mole/Rad^2')
      write (iout,260)  temp
  260 format (' System Temperature Value :',5x,f12.4,' Kelvin')
c
c     find RT and Ang^3 per molecule at 1 mole/L concentration
c
      kt = temp * gasconst
      stdcon = 1.0d27 / avogadro
c
c     compute the free energy correction due to Boresch restraints
c
      sine1 = sin(ang1/radian)
      sine2 = sin(ang2/radian)
      term1 = 8.0d0 * pi * pi * stdcon
      term2 = sqrt(fd*fa1*fa2*ft1*ft2*ft3)
      term3 = dist * dist * sine1 * sine2
      term4 = (2.0d0 * pi * kt)**3
c
c     calculate and print the restraint thermodynamic values
c
      dg = kt * log((term1*term2)/(term3*term4))
      ds = dg/temp - 3.0d0*gasconst
      dh = dg + temp*ds
      write (iout,270)  dg
  270 format (/,' Restraint Free Energy :',8x,f12.4,' Kcal/mole')
      write (iout,280)  ds
  280 format (' Restraint Entropy Value :',6x,f12.4,' Kcal/mole/K')
      write (iout,290)  dh
  290 format (' Restraint Enthalpy Value :',5x,f12.4,' Kcal/mole')
      write (iout,300)  -temp*ds
  300 format (' Restraint -T deltaS Value :',4x,f12.4,' Kcal/mole')
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  function freeunit  --  gets an unopened logical unit  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "freeunit" finds an unopened Fortran I/O unit and returns
c     its numerical value from 1 to 99; the units already assigned
c     to "input" and "iout" (usually 5 and 6) are skipped since
c     they have special meaning as the default I/O units
c
c
      function freeunit ()
      use iounit
      implicit none
      integer freeunit
      logical used
c
c
c     try each logical unit until an unopened one is found
c
      freeunit = 0
      used = .true.
      do while (used)
         freeunit = freeunit + 1
         if (freeunit.ne.input .and. freeunit.ne.iout) then
            if (freeunit .gt. 99) then
               write (iout,10)
   10          format (/,' FREEUNIT  --  No Available Fortran',
     &                    ' I/O Units')
               call fatal
            end if
            inquire (unit=freeunit,opened=used)
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module freeze  --  definition of holonomic constraints  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     nrat         number of holonomic distance constraints to apply
c     nratx        number of atom group holonomic constraints to apply
c     nwat         number of rigid three- and four-site water molecules
c     nwat4        number of rigid planar four-site water molecules
c     iratx        group number for each group holonomic constraint
c     kratx        spatial constraint type (1=plane, 2=line, 3=point)
c     irat         atom numbers of atoms in each holonomic constraint
c     iwat         atom numbers of O and H atoms in each rigid water
c     iwat4        atom numbers involved in each rigid four-site water
c     rateps       convergence tolerance for holonomic constraints
c     krat         ideal distance value for each holonomic constraint
c     kwat         ideal distances for O-H and H-H in rigid water
c     kwat4        geometry scaling values for rigid four-site water
c     use_freeze   logical flag to set use of holonomic contraints
c     frzimage     flag to use minimum image for holonomic constraint
c
c
      module freeze
      implicit none
      integer nrat,nratx
      integer nwat,nwat4
      integer, allocatable :: iratx(:)
      integer, allocatable :: kratx(:)
      integer, allocatable :: irat(:,:)
      integer, allocatable :: iwat(:,:)
      integer, allocatable :: iwat4(:,:)
      real*8 rateps
      real*8, allocatable :: krat(:)
      real*8, allocatable :: kwat(:,:)
      real*8, allocatable :: kwat4(:,:)
      logical use_freeze
      logical, allocatable :: frzimage(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program gda  --  simulated annealing on gaussian density  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "gda" implements Gaussian Density Annealing (GDA) algorithm
c     for global optimization via simulated annealing
c
c     literature reference:
c
c     J. Ma and J. E. Straub, "Simulated Annealing using the
c     Classical Density Distribution", Journal of Chemical Physics,
c     101, 533-541 (1994)
c
c
      program gda
      use atoms
      use files
      use iounit
      use minima
      use potent
      use vdwpot
      use warp
      implicit none
      integer i,igda,itrial,ntrial
      integer nstep,nvar,nok,nbad
      integer lext,next,freeunit
      real*8 bstart,bstop
      real*8 random,boxsize
      real*8 eps,h1,hmin,gda2
      real*8 minimum,grdmin
      real*8 xcm,ycm,zcm
      real*8, allocatable :: m2init(:)
      real*8, allocatable :: xx(:)
      logical exist,randomize
      character*1 answer
      character*6 mode,method
      character*7 ext,status
      character*240 gdafile
      character*240 record
      character*240 string
      external gda1,gda2,gda3
      external random,optsave
c
c
c     set up the structure, mechanics calculation and smoothing
c
      call initial
      call getxyz
      use_smooth = .true.
      use_gda = .true.
      call mechanic
c
c     get the number of optimized structures to be constructed
c
      ntrial = 0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  ntrial
   10 continue
      if (ntrial .le. 0) then
         write (iout,20)
   20    format (/,' Enter Number of Annealing Trials [1] :  ',$)
         read (input,30)  ntrial
   30    format (i10)
      end if
      if (ntrial .le. 0)  ntrial = 1
c
c     see if random coordinates are desired as starting structures
c
      randomize = .true.
      if (ntrial .eq. 1) then
         randomize = .false.
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,40)
   40       format (/,' Use Randomized Initial Coordinates [N] :  ',$)
            read (input,50)  record
   50       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  randomize = .true.
      end if
      if (randomize)  boxsize = 10.0d0 * (dble(n))**(1.0d0/3.0d0)
c
c     get initial and final values of inverse temperature
c
      bstart = -1.0d0
      bstop = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=60,end=60)  bstart
      call nextarg (string,exist)
      if (exist)  read (string,*,err=60,end=60)  bstop
   60 continue
      if (bstart.le.0.0d0 .or. bstop.le.0.0d0) then
         write (iout,70)
   70    format (/,' Enter Initial and Final Beta [0.01, 10**10] :  ',$)
         read (input,80)  record
   80    format (a240)
         read (record,*,err=90,end=90)  bstart,bstop
   90    continue
      end if
      if (bstart .le. 0.0d0)  bstart = 0.01d0
      if (bstop .le. 0.0d0)  bstop = 1.0d10
c
c     perform dynamic allocation of some local arrays
c
      allocate (m2init(n))
      allocate (xx(4*n))
c
c     store the initial values of the squared mean Gaussian width
c
      do i = 1, n
         m2init(i) = m2(1)
      end do
c
c     write out a copy of coordinates for later update
c
      do itrial = 1, ntrial
         lext = 3
         call numeral (itrial,ext,lext)
         gdafile = filename(1:leng)//'.'//ext(1:lext)
         call version (gdafile,'new')
         igda = freeunit ()
         open (unit=igda,file=gdafile,status='new')
         call prtxyz (igda)
         close (unit=igda)
         outfile = gdafile
c
c     set an initial box size and generate random coordinates
c
         if (randomize) then
            do i = 1, n
               x(i) = boxsize * random ()
               y(i) = boxsize * random ()
               z(i) = boxsize * random ()
            end do
         end if
c
c     convert coordinates and M2's to optimization parameters
c
         nvar = 0
         do i = 1, n
            nvar = nvar + 1
            xx(nvar) = x(i)
            nvar = nvar + 1
            xx(nvar) = y(i)
            nvar = nvar + 1
            xx(nvar) = z(i)
         end do
         do i = 1, n
            nvar = nvar + 1
            xx(nvar) = m2init(i)
         end do
c
c     make changes to the potential to use potential smoothing
c
         use_smooth = .true.
         use_geom = .true.
         vdwtyp = 'GAUSSIAN'
c
c     make the call to the Bulirsch-Stoer integration routine
c
         nstep = 0
         status = '       '
         eps = 1.0d-8
         h1 = 0.01d0
         hmin = 0.0d0
         write (iout,100)
  100    format (/,' Gaussian Density Annealing Global Optimization :',
     &           //,' BS Step',5x,'Log(Beta)',6x,'Energy',
     &              9x,'Rg',8x,'Log(M2)',7x,'Status',/)
         call gdastat (nstep,bstart,xx,status)
         call diffeq (nvar,xx,bstart,bstop,eps,h1,hmin,nok,nbad,gda1)
         nstep = nok + nbad
c
c     make changes to the potential for standard optimization
c
         use_smooth = .false.
         use_geom = .false.
         vdwtyp = 'LENNARD-JONES'
c
c     make the call to the energy minimization routine
c
         mode = 'DTNCG'
         method = 'AUTO'
         nvar = 3 * n
         grdmin = 0.0001d0
         nextiter = nstep + 1
         call tncg (mode,method,nvar,xx,minimum,grdmin,
     &                     gda2,gda3,optsave)
c        call lbfgs (nvar,xx,minimum,grdmin,gda2,optsave)
         write (iout,110)  itrial,minimum
  110    format (/,' Global Energy Minimum for Trial',i4,' :',f15.4)
c
c     convert optimization parameters into atomic coordinates
c
         nvar = 0
         do i = 1, n
            nvar = nvar + 1
            x(i) = xx(nvar)
            nvar = nvar + 1
            y(i) = xx(nvar)
            nvar = nvar + 1
            z(i) = xx(nvar)
         end do
c
c     move the center of mass to the origin
c
         xcm = 0.0d0
         ycm = 0.0d0
         zcm = 0.0d0
         do i = 1, n
            xcm = xcm + x(i)
            ycm = ycm + y(i)
            zcm = zcm + z(i)
         end do
         xcm = xcm / dble(n)
         ycm = ycm / dble(n)
         zcm = zcm / dble(n)
         do i = 1, n
            x(i) = x(i) - xcm
            y(i) = y(i) - xcm
            z(i) = z(i) - xcm
         end do
c
c     write the final coordinates into a file
c
         igda = freeunit ()
         open (unit=igda,file=gdafile,status='old')
         rewind (unit=igda)
         call prtxyz (igda)
         close (unit=igda)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (m2init)
      deallocate (xx)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine gda1  --  gaussian density annealing gradient  ##
c     ##                                                            ##
c     ################################################################
c
c
      subroutine gda1 (beta,xx,g)
      use atoms
      use iounit
      use warp
      implicit none
      integer i,nvar
      integer, allocatable :: hinit(:)
      integer, allocatable :: hstop(:)
      integer, allocatable :: hindex(:)
      real*8 beta,e,sum
      real*8, allocatable :: hdiag(:)
      real*8, allocatable :: h(:)
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to coordinates and M2's
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
      do i = 1, n
         nvar = nvar + 1
         m2(i) = xx(nvar)
         if (m2(i) .lt. 0.0d0) then
            write (iout,10)  i,m2(i)
   10       format (' GDA1  --  Warning, Negative M2 at Atom',i6,
     &                  ' with Value',d12.4)
            m2(i) = -m2(i)
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the Cartesian energy gradient vector
c
      call gradient (e,derivs)
c
c     convert the gradient components into a dr/dbeta vector
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         g(nvar) = -(m2(i)/3.0d0) * derivs(1,i)
         nvar = nvar + 1
         g(nvar) = -(m2(i)/3.0d0) * derivs(2,i)
         nvar = nvar + 1
         g(nvar) = -(m2(i)/3.0d0) * derivs(3,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
c
c     perform dynamic allocation of some local arrays
c
      allocate (hinit(3*n))
      allocate (hstop(3*n))
      allocate (hindex((3*n*(3*n-1))/2))
      allocate (hdiag(3*n))
      allocate (h((3*n*(3*n-1))/2))
c
c     compute and store the Hessian elements
c
      call hessian (h,hinit,hstop,hindex,hdiag)
c
c     convert the Hessian diagonal into a dM2/dbeta vector
c
      do i = 1, n
         nvar = nvar + 1
         sum = hdiag(3*i-2) + hdiag(3*i-1) + hdiag(3*i)
         g(nvar) = -(m2(i)/3.0d0)**2 * sum
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (hinit)
      deallocate (hstop)
      deallocate (hindex)
      deallocate (hdiag)
      deallocate (h)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function gda2  --  energy/gradient for TNCG optimization  ##
c     ##                                                            ##
c     ################################################################
c
c
      function gda2 (xx,g)
      use atoms
      implicit none
      integer i,nvar
      real*8 gda2,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the energy and gradient
c
      call gradient (e,derivs)
      gda2 = e
c
c     convert gradient components to optimization parameters
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         g(nvar) = derivs(1,i)
         nvar = nvar + 1
         g(nvar) = derivs(2,i)
         nvar = nvar + 1
         g(nvar) = derivs(3,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine gda3  --  Hessian values for TNCG optimization  ##
c     ##                                                             ##
c     #################################################################
c
c
      subroutine gda3 (mode,xx,h,hinit,hstop,hindex,hdiag)
      use atoms
      implicit none
      integer i,nvar
      integer hinit(*)
      integer hstop(*)
      integer hindex(*)
      real*8 xx(*)
      real*8 hdiag(*)
      real*8 h(*)
      character*4 mode
c
c
c     convert optimization parameters to atomic coordinates
c
      if (mode .eq. 'NONE')  return
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     compute and store the Hessian elements
c
      call hessian (h,hinit,hstop,hindex,hdiag)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  function geometry  --  evaluate distance, angle, torsion  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "geometry" finds the value of the interatomic distance, angle
c     or dihedral angle defined by two to four input atoms
c
c
      function geometry (ia,ib,ic,id)
      use atoms
      use math
      implicit none
      integer ia,ib,ic,id
      real*8 xab,yab,zab
      real*8 xba,yba,zba
      real*8 xcb,ycb,zcb
      real*8 xdc,ydc,zdc
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 rab2,rcb2,rabc
      real*8 rt2,ru2,rtru
      real*8 cosine,sign
      real*8 geometry
c
c
c     set default in case atoms are coincident or colinear
c
      geometry = 0.0d0
c
c     compute the value of the distance in angstroms
c
      if (ic .eq. 0) then
         xab = x(ia) - x(ib)
         yab = y(ia) - y(ib)
         zab = z(ia) - z(ib)
         geometry = sqrt(xab*xab + yab*yab + zab*zab)
c
c     compute the value of the angle in degrees
c
      else if (id .eq. 0) then
         xab = x(ia) - x(ib)
         yab = y(ia) - y(ib)
         zab = z(ia) - z(ib)
         xcb = x(ic) - x(ib)
         ycb = y(ic) - y(ib)
         zcb = z(ic) - z(ib)
         rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
         rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
         rabc = sqrt(rab2*rcb2)
         cosine = (xab*xcb + yab*ycb + zab*zcb) / rabc
         cosine = min(1.0d0,max(-1.0d0,cosine))
         geometry = radian * acos(cosine)
c
c     compute the value of the dihedral angle in degrees
c
      else
         xba = x(ib) - x(ia)
         yba = y(ib) - y(ia)
         zba = z(ib) - z(ia)
         xcb = x(ic) - x(ib)
         ycb = y(ic) - y(ib)
         zcb = z(ic) - z(ib)
         xdc = x(id) - x(ic)
         ydc = y(id) - y(ic)
         zdc = z(id) - z(ic)
         xt = yba*zcb - ycb*zba
         yt = xcb*zba - xba*zcb
         zt = xba*ycb - xcb*yba
         xu = ycb*zdc - ydc*zcb
         yu = xdc*zcb - xcb*zdc
         zu = xcb*ydc - xdc*ycb
         rt2 = max(xt*xt+yt*yt+zt*zt,0.0001d0)
         ru2 = max(xu*xu+yu*yu+zu*zu,0.0001d0)
         rtru = sqrt(rt2*ru2)
         cosine = (xt*xu + yt*yu + zt*zu) / rtru
         cosine = min(1.0d0,max(-1.0d0,cosine))
         geometry = radian * acos(cosine)
         sign = xba*xu + yba*yu + zba*zu
         if (sign .lt. 0.0d0)  geometry = -geometry
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2018  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine getarc  --  get a coordinates archive file  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "getarc" asks for a coordinate archive or trajectory file
c     name, then reads the formatted or binary archive file
c
c
      subroutine getarc (iarc)
      use files
      use inform
      use iounit
      use output
      implicit none
      integer iarc,iaux
      integer nask
      integer freeunit
      logical exist,first
      character*1 letter
      character*240 arcfile
      character*240 auxfile
c
c
c     try to get a filename from the command line arguments
c
      call nextarg (arcfile,exist)
      if (exist) then
         call basefile (arcfile)
         call suffix (arcfile,'arc','old')
         inquire (file=arcfile,exist=exist)
      end if
c
c     ask for the user specified input structure filename
c
      nask = 0
      do while (.not.exist .and. nask.lt.maxask)
         nask = nask + 1
         write (iout,10)
   10    format (/,' Enter Coordinate Archive File Name :  ',$)
         read (input,20)  arcfile
   20    format (a240)
         call basefile (arcfile)
         call suffix (arcfile,'arc','old')
         inquire (file=arcfile,exist=exist)
      end do
      if (.not. exist)  call fatal
c
c     open file the file and read the first set of coordinates
c
      filename = arcfile
      coordtype = 'CARTESIAN'
      iarc = freeunit ()
      open (unit=iarc,file=arcfile,status='old')
      rewind (unit=iarc)
      read (iarc,30)  letter
   30 format (a1)
      archive = .false.
      if (letter .eq. ' ')  archive = .true.
      if (letter.ge.'0' .and. letter.le.'9')  archive = .true.
      binary = (.not. archive)
c
c     read initial Cartesian coordinates from formatted file
c
      if (archive) then
         rewind (unit=iarc)
         call readxyz (iarc)
      end if
c
c     get atom types and connectivity from formatted file
c
      if (binary) then
         call nextarg (auxfile,exist)
         if (exist) then
            call basefile (auxfile)
            call suffix (auxfile,'xyz','old')
            inquire (file=auxfile,exist=exist)
         end if
         nask = 0
         do while (.not.exist .and. nask.lt.maxask)
            nask = nask + 1
            write (iout,40)
   40       format (/,' Enter Formatted Coordinate File Name :  ',$)
            read (input,50)  auxfile
   50       format (a240)
            call basefile (auxfile)
            call suffix (auxfile,'xyz','old')
            inquire (file=auxfile,exist=exist)
         end do
         if (.not. exist)  call fatal
         iaux = freeunit ()
         open (unit=iaux,file=auxfile,status='old')
         rewind (unit=iaux)
         call readxyz (iaux)
         close (unit=iaux)
c
c     read initial Cartesian coordinates from binary file
c
         filename = arcfile
         close (unit=iarc)
         iarc = freeunit ()
         open (unit=iarc,file=arcfile,form='unformatted',status='old')
         rewind (unit=iarc)
         first = .true.
         call readdcd (iarc,first)
      end if
c
c     quit if the coordinates archive file contains no atoms
c
      if (abort) then
         write (iout,60)
   60    format (/,' GETARC  --  Coordinate Archive File',
     &              ' was not Read Correctly')
         close (unit=iarc)
         call fatal
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2022  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine getcart  --  get a Cartesian coordinates file  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "getcart" asks for a Cartesian coordinate file name, then
c     reads the formatted or binary coordinates file
c
c
      subroutine getcart (ixyz)
      use files
      use inform
      use iounit
      use output
      implicit none
      integer ixyz,iaux
      integer nask
      integer freeunit
      logical exist,first
      character*1 letter
      character*240 xyzfile
      character*240 auxfile
c
c
c     try to get a filename from the command line arguments
c
      call nextarg (xyzfile,exist)
      if (exist) then
         call basefile (xyzfile)
         call suffix (xyzfile,'xyz','old')
         inquire (file=xyzfile,exist=exist)
      end if
c
c     ask for the user specified input structure filename
c
      nask = 0
      do while (.not.exist .and. nask.lt.maxask)
         nask = nask + 1
         write (iout,10)
   10    format (/,' Enter Cartesian Coordinate File Name :  ',$)
         read (input,20)  xyzfile
   20    format (a240)
         call basefile (xyzfile)
         call suffix (xyzfile,'xyz','old')
         inquire (file=xyzfile,exist=exist)
      end do
      if (.not. exist)  call fatal
c
c     open the file and get format by inspecting first character
c
      filename = xyzfile
      coordtype = 'CARTESIAN'
      ixyz = freeunit ()
      open (unit=ixyz,file=xyzfile,status='old')
      rewind (unit=ixyz)
      read (ixyz,30)  letter
   30 format (a1)
      archive = .false.
      if (letter .eq. ' ')  archive = .true.
      if (letter.ge.'0' .and. letter.le.'9')  archive = .true.
      binary = (.not. archive)
c
c     read initial Cartesian coordinates from formatted file
c
      if (archive) then
         rewind (unit=ixyz)
         call readxyz (ixyz)
      end if
c
c     get atom types and connectivity from formatted file
c
      if (binary) then
         call nextarg (auxfile,exist)
         if (exist) then
            call basefile (auxfile)
            call suffix (auxfile,'xyz','old')
            inquire (file=auxfile,exist=exist)
         end if
         nask = 0
         do while (.not.exist .and. nask.lt.maxask)
            nask = nask + 1
            write (iout,40)
   40       format (/,' Enter Formatted Coordinate File Name :  ',$)
            read (input,50)  auxfile
   50       format (a240)
            call basefile (auxfile)
            call suffix (auxfile,'xyz','old')
            inquire (file=auxfile,exist=exist)
         end do
         if (.not. exist)  call fatal
         iaux = freeunit ()
         open (unit=iaux,file=auxfile,status='old')
         rewind (unit=iaux)
         call readxyz (iaux)
         close (unit=iaux)
c
c     read initial Cartesian coordinates from binary file
c
         filename = xyzfile
         close (unit=ixyz)
         ixyz = freeunit ()
         open (unit=ixyz,file=xyzfile,form='unformatted',status='old')
         rewind (unit=ixyz)
         first = .true.
         call readdcd (ixyz,first)
      end if
c
c     quit if the Cartesian coordinates file contains no atoms
c
      if (abort) then
         write (iout,60)
   60    format (/,' GETCART  --  Cartesian Coordinate File',
     &              ' was not Read Correctly')
         close (unit=ixyz)
         call fatal
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2022  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################        
c     ##                                                          ##
c     ##  subroutine getdcd  --  get DCD coordinate archive file  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "getdcd" asks for a binary DCD trajectory file name and the
c     corresponding Tinker coordinates file, then reads the initial
c     set of DCD coordinates
c
c
      subroutine getdcd (idcd)
      use files
      use inform
      use iounit
      use output
      implicit none
      integer idcd,ixyz,nask
      integer freeunit
      logical exist
      character*240 dcdfile
      character*240 xyzfile
c
c
c     try to get a DCD filename from the command line arguments
c
      call nextarg (dcdfile,exist)
      if (exist) then
         call basefile (dcdfile)
         call suffix (dcdfile,'dcd','old')
         inquire (file=dcdfile,exist=exist)
      end if
c
c     ask for the user specified input DCD trajectory filename
c
      nask = 0
      do while (.not.exist .and. nask.lt.maxask)
         nask = nask + 1
         write (iout,10)
   10    format (/,' Enter DCD Coordinate Archive File Name :  ',$)
         read (input,20)  dcdfile
   20    format (a240)
         call basefile (dcdfile)
         call suffix (dcdfile,'dcd','old')
         inquire (file=dcdfile,exist=exist)
      end do
      if (.not. exist)  call fatal
c
c     try to get a coordinates file from the command line arguments
c
      call nextarg (xyzfile,exist)
      if (exist) then
         call basefile (xyzfile)
         call suffix (xyzfile,'xyz','old')
         inquire (file=xyzfile,exist=exist)
      end if
c
c     ask for the user specified input coordinates filename
c
      nask = 0
      do while (.not.exist .and. nask.lt.maxask)
         nask = nask + 1
         write (iout,30)
   30    format (/,' Enter Formatted Coordinate File Name :  ',$)
         read (input,40)  xyzfile
   40    format (a240)
         call basefile (xyzfile)
         call suffix (xyzfile,'xyz','old')
         inquire (file=xyzfile,exist=exist)
      end do
      if (.not. exist)  call fatal
c
c     first open and then read the Cartesian coordinates file
c
      coordtype = 'CARTESIAN'
      ixyz = freeunit ()
      open (unit=ixyz,file=xyzfile,status='old')
      rewind (unit=ixyz)
      call readxyz (ixyz)
      close (unit=ixyz)
c
c     next read the initial set of coordinates from the DCD file
c
      archive = .false.
      binary = .true.
      filename = dcdfile
      idcd = freeunit ()
      open (unit=idcd,file=dcdfile,form='unformatted',status='old')
      rewind (unit=idcd)
      call readdcd (idcd)
c
c     quit if the DCD trajectory archive file contains no atoms
c
      if (abort) then
         write (iout,50)
   50    format (/,' GETDCD  --  Binary DCD Trajectory File',
     &              ' was not Read Correctly')
         close (unit=idcd)
         call fatal
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2025  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine getfloat  --  extract float from a string  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "getfloat" searches an input string for the first floating
c     point number and puts the numeric value in "number"; returns
c     zero with "next" unchanged if no floating point value is found
c
c     variables and parameters:
c
c     string    input character string to be searched
c     number    output with the first number in the variable
c     next      input with first position of search string;
c                 output with the position following the number
c
c
      subroutine getfloat (string,number,next)
      implicit none
      integer next
      integer initial
      real*8 number
      logical numeral
      character*40 text
      character*(*) string
c
c
c     initialize number and flag for presence of a number
c
      number = 0.0d0
      numeral = .false.
c
c     search the string for the first floating point number
c
      initial = next
      call gettext (string,text,next)
      read (text,*,err=10,end=10)  number
      numeral = .true.
   10 continue
      if (.not. numeral)  next = initial
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine getint  --  get internal coordinate structure  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "getint" asks for an internal coordinate file name, then reads
c     the internal coordinates and computes Cartesian coordinates
c
c
      subroutine getint
      use atoms
      use files
      use inform
      use iounit
      use output
      implicit none
      integer izmt,nask
      integer freeunit
      logical exist
      logical clash
      character*240 intfile
c
c
c     try to get a filename from the command line arguments
c
      call nextarg (intfile,exist)
      if (exist) then
         call basefile (intfile)
         call suffix (intfile,'int','old')
         inquire (file=intfile,exist=exist)
      end if
c
c     ask for the user specified input structure filename
c
      nask = 0
      do while (.not.exist .and. nask.lt.maxask)
         nask = nask + 1
         write (iout,10)
   10    format (/,' Enter Internal Coordinate File Name :  ',$)
         read (input,20)  intfile
   20    format (a240)
         call basefile (intfile)
         call suffix (intfile,'int','old')
         inquire (file=intfile,exist=exist)
      end do
      if (.not. exist)  call fatal
c
c     first open and then read the internal coordinates file
c
      filename = intfile
      coordtype = 'INTERNAL'
      izmt = freeunit ()
      open (unit=izmt,file=intfile,status='old')
      rewind (unit=izmt)
      call readint (izmt)
      close (unit=izmt)
c
c     quit if the internal coordinates file contains no atoms
c
      if (abort) then
         write (iout,30)
   30    format (/,' GETINT  --  Internal Coordinates File',
     &              ' was not Read Correctly')
         call fatal
      end if
c
c     convert internal to Cartesian coordinates
c
      call connect
      call makexyz
c
c     check for atoms with identical coordinates
c
      clash = .false.
      if (n .le. 10000)  call chkxyz (clash)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine getkey  --  find and store contents of keyfile  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "getkey" finds a valid keyfile and stores its contents as
c     line images for subsequent keyword parameter searching
c
c
      subroutine getkey
      use argue
      use files
      use iounit
      use keys
      use openmp
      implicit none
      integer i,j,ikey
      integer next,length
      integer freeunit
      integer trimtext
      logical exist,header
      character*20 keyword
      character*240 keyfile
      character*240 comment
      character*240 record
      character*240 string
c
c
c     check for a keyfile specified on command line
c
      exist = .false.
      do i = 1, narg-1
         string = arg(i)
         call upcase (string)
         if (string(1:2) .eq. '-K') then
            keyfile = arg(i+1)
            call suffix (keyfile,'key','old')
            inquire (file=keyfile,exist=exist)
            if (.not. exist) then
               write (iout,10)
   10          format (/,' GETKEY  --  Keyfile Specified',
     &                    ' on Command Line was not Found')
               call fatal
            end if
         end if
      end do
c
c     check for a keyfile with base name of current system
c
      if (.not. exist) then
         keyfile = filename(1:leng)//'.key'
         call version (keyfile,'old')
         inquire (file=keyfile,exist=exist)
      end if
c
c     check for the existence of a generic keyfile
c
      if (.not. exist) then
         if (ldir .eq. 0) then
            keyfile = 'tinker.key'
         else
            keyfile = filename(1:ldir)//'tinker.key'
         end if
         call version (keyfile,'old')
         inquire (file=keyfile,exist=exist)
      end if
c
c     read the keyfile to get number of lines
c
      nkey = 0
      if (exist) then
         ikey = freeunit ()
         open (unit=ikey,file=keyfile,status='old')
         rewind (unit=ikey)
         do while (.true.)
            read (ikey,20,err=30,end=30)
   20       format ()
            nkey = nkey + 1
         end do
   30    continue
         rewind (unit=ikey)
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(keyline))  deallocate (keyline)
      allocate (keyline(nkey))
c
c     reread the keyfile and store for latter use
c
      do i = 1, nkey
         read (ikey,40,err=50,end=50)  record
   40    format (a240)
         keyline(i) = record
      end do
   50 continue
      close (unit=ikey)
c
c     convert underbar characters to dashes in all keywords
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         do j = 1, next-1
            if (record(j:j) .eq. '_')  record(j:j) = '-'
         end do
         keyline(i) = record
      end do
c
c     check for comment lines to be echoed to the output
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:5) .eq. 'ECHO ') then
            comment = record(next:240)
            length = trimtext (comment)
            if (header) then
               header = .false.
               write (iout,60)
   60          format ()
            end if
            if (length .eq. 0) then
               write (iout,70)
   70          format ()
            else
               write (iout,80)  comment(1:length)
   80          format (a)
            end if
         end if
      end do
c
c     set number of OpenMP threads for parallelization
c
!$    do i = 1, nkey
!$       next = 1
!$       record = keyline(i)
!$       call upcase (record)
!$       call gettext (record,keyword,next)
!$       string = record(next:240)
!$       if (keyword(1:15) .eq. 'OPENMP-THREADS ') then
!$          read (string,*,err=90,end=90)  nthread
!$          call omp_set_num_threads (nthread)
!$       end if
!$ 90    continue
!$    end do
c
c     check for number of OpenMP threads on command line
c
!$    do i = 1, narg-1
!$       string = arg(i)
!$       call upcase (string)
!$       if (string(1:2) .eq. '-T') then
!$          next = 1
!$          string = arg(i+1)
!$          call getnumb (string,nthread,next)
!$          if (nthread .eq. 0)  nthread = 1
!$          call omp_set_num_threads (nthread)
!$       end if
!$    end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2012  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ########################################################
c     ##                                                    ##
c     ##  subroutine getmol  --  get a MDL MOL format file  ##
c     ##                                                    ##
c     ########################################################
c
c
c     "getmol" asks for a MDL MOL molecule file name,
c     then reads the coordinates from the file
c
c
      subroutine getmol
      use files
      use inform
      use iounit
      implicit none
      integer imdl,nask
      integer freeunit
      logical exist
      character*240 mdlfile
c
c
c     try to get a filename from the command line arguments
c
      call nextarg (mdlfile,exist)
      if (exist) then
         call basefile (mdlfile)
         call suffix (mdlfile,'mol','old')
         inquire (file=mdlfile,exist=exist)
      end if
c
c     ask for the user specified input structure filename
c
      nask = 0
      do while (.not.exist .and. nask.lt.maxask)
         nask = nask + 1
         write (iout,10)
   10    format (/,' Enter a MDL MOL File Name :  ',$)
         read (input,20)  mdlfile
   20    format (a240)
         call basefile (mdlfile)
         call suffix (mdlfile,'mol','old')
         inquire (file=mdlfile,exist=exist)
      end do
      if (.not. exist)  call fatal
c
c     first open and then read the MDL MOL coordinates file
c
      filename = mdlfile
      imdl = freeunit ()
      open (unit=imdl,file=mdlfile,status='old')
      rewind (unit=imdl)
      call readmol (imdl)
      close (unit=imdl)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine getmol2  --  get a Tripos MOL2 format file  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "getmol2" asks for a Tripos MOL2 molecule file name,
c     then reads the coordinates from the file
c
c
      subroutine getmol2
      use files
      use inform
      use iounit
      implicit none
      integer imol2,nask
      integer freeunit
      logical exist
      character*240 mol2file
c
c
c     try to get a filename from the command line arguments
c
      call nextarg (mol2file,exist)
      if (exist) then
         call basefile (mol2file)
         call suffix (mol2file,'mol2','old')
         inquire (file=mol2file,exist=exist)
      end if
c
c     ask for the user specified input structure filename
c
      nask = 0
      do while (.not.exist .and. nask.lt.maxask)
         nask = nask + 1
         write (iout,10)
   10    format (/,' Enter a Tripos MOL2 File Name :  ',$)
         read (input,20)  mol2file
   20    format (a240)
         call basefile (mol2file)
         call suffix (mol2file,'mol2','old')
         inquire (file=mol2file,exist=exist)
      end do
      if (.not. exist)  call fatal
c
c     first open and then read the Tripos MOL2 coordinates file
c
      filename = mol2file
      imol2 = freeunit ()
      open (unit=imol2,file=mol2file,status='old')
      rewind (unit=imol2)
      call readmol2 (imol2)
      close (unit=imol2)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine getnumb  --  extract an integer from a string  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "getnumb" searches an input string from left to right for an
c     integer and puts the numeric value in "number"; returns zero
c     with "next" unchanged if no integer value is found
c
c     variables and parameters:
c
c     string    input character string to be searched
c     number    output with the first integer in the string
c     next      input with first position of search string;
c                 output with the position following the number
c
c
      subroutine getnumb (string,number,next)
      use ascii
      implicit none
      integer i,j,length
      integer number,digit
      integer next,trimtext
      integer first,last,code
      integer initial,final
      integer place(10)
      logical positive
      logical negative
      logical numeral
      character*1 letter
      character*(*) string
      data place  / 1, 10, 100, 1000, 10000, 100000, 1000000,
     &              10000000, 100000000, 1000000000 /
c
c
c     initialize number and get the input text string length
c
      number = 0
      positive = .false.
      negative = .false.
      numeral = .false.
      length = trimtext(string(next:))
c
c     search the string for the first run of numeric characters
c
      first = next
      last = 0
      initial = next
      final = next + length - 1
      do i = initial, final
         letter = string(i:i)
         code = ichar(letter)
         if (letter.ge.'0' .and. letter.le.'9') then
            if (.not. numeral) then
               numeral = .true.
               first = i
            end if
            if (i .eq. final) then
               last = final
               next = i + 1
            end if
         else if (code.eq.plus .and. .not.positive) then
            positive = .true.
         else if (code.eq.minus .and. .not.negative) then
            negative = .true.
         else if (numeral) then
            if (code.eq.space .or. code.eq.tab .or.
     &          code.eq.comma .or. code.eq.semicolon .or.
     &          code.eq.colon .or. code.eq.underbar) then
               last = i - 1
               next = i
            else
               numeral = .false.
            end if
            goto 10
         else if (positive .or. negative) then
            numeral = .false.
            goto 10
         else if (code.ne.space .and. code.ne.tab) then
            numeral = .false.
            goto 10
         end if
      end do
   10 continue
c
c     trim the actual number if it is too big to return
c
      if (.not. numeral)  next = initial
      last = min(last,first+9)
c
c     convert the text numeral into an integer number
c
      j = 0
      do i = last, first, -1
         j = j + 1
         if (string(i:i) .eq. '0') then
            digit = 0
         else if (string(i:i) .eq. '1') then
            digit = 1
         else if (string(i:i) .eq. '2') then
            digit = 2
         else if (string(i:i) .eq. '3') then
            digit = 3
         else if (string(i:i) .eq. '4') then
            digit = 4
         else if (string(i:i) .eq. '5') then
            digit = 5
         else if (string(i:i) .eq. '6') then
            digit = 6
         else if (string(i:i) .eq. '7') then
            digit = 7
         else if (string(i:i) .eq. '8') then
            digit = 8
         else if (string(i:i) .eq. '9') then
            digit = 9
         end if
         number = number + digit * place(j)
      end do
      if (negative)  number = -number
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine getpdb  --  get a Protein Data Bank file  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "getpdb" asks for a Protein Data Bank file name, gets the
c     format type, and then reads in the coordinates file
c
c
      subroutine getpdb
      use files
      use inform
      use iounit
      use pdb
      implicit none
      integer ipdb,nask
      integer next,last,temp
      integer freeunit
      logical exist,done
      real*8 crd
      character*1 letter1
      character*3 letter3
      character*4 letter4
      character*6 remark
      character*240 pdbfile
      character*240 record
      character*240 string
c
c
c     try to get a filename from the command line arguments
c
      call nextarg (pdbfile,exist)
      if (exist) then
         call basefile (pdbfile)
         call suffix (pdbfile,'pdb','old')
         inquire (file=pdbfile,exist=exist)
      end if
c
c     ask for the user specified input structure filename
c
      nask = 0
      do while (.not.exist .and. nask.lt.maxask)
         nask = nask + 1
         pdbfile = ' '
         write (iout,10)
   10    format (/,' Enter Protein Data Bank File Name :  ',$)
         read (input,20)  pdbfile
   20    format (a240)
         call basefile (pdbfile)
         call suffix (pdbfile,'pdb','old')
         inquire (file=pdbfile,exist=exist)
      end do
      if (.not. exist)  call fatal
c
c     open the coordinates file with PDB format as default
c
      pdbtyp = 'PDB'
      filename = pdbfile
      ipdb = freeunit ()
      open (unit=ipdb,file=pdbfile,status='old')
      rewind (unit=ipdb)
c
c     check format by trying to read coordinates in PDB format
c
      done = .false.
      do while (.not. done)
         read (ipdb,30,err=130,end=130)  record
   30    format (a240)
         remark = record(1:6)
         call upcase (remark)
         if (remark(1:5).eq.'ATOM ' .or. remark.eq.'HETATM' ) then
            done = .true.
            pdbtyp = 'CIF'
            next = 6
            if (remark .eq. 'HETATM')  next = 7
            call getnumb (record,temp,next)
            string = record(next+1:next+4)
            read (string,40,err=120,end=120)  letter4
   40       format (a4)
            string = record(next+5:next+5)
            read (string,50,err=120,end=120)  letter1
   50       format (a1)
            string = record(next+6:next+8)
            read (string,60,err=120,end=120)  letter3
   60       format (a3)
            string = record(next+10:next+10)
            read (string,70,err=120,end=120)  letter1
   70       format (a1)
            next = next + 11
            last = next
            call getnumb (record,temp,next)
            if (next .eq. last) then
               string = record(next:next+3)
               read (string,80,err=120,end=120)  temp
   80          format (i4)
               next = next + 4
            end if
            string = record(next:next)
            read (string,90,err=120,end=120)  letter1
   90       format (a1)
            string = record(next+1:240)
            read (string,*,err=100,end=100)  crd,crd,crd
            goto 110
  100       continue
            string = record(31:38)
            read (string,*,err=120,end=120)  crd
            string = record(39:46)
            read (string,*,err=120,end=120)  crd
            string = record(47:54)
            read (string,*,err=120,end=120)  crd
  110       continue
            pdbtyp = 'PDB'
  120       continue
         end if
      end do
  130 continue
      rewind (unit=ipdb)
c
c     read the coordinates file in either PDB or CIF format
c
      if (pdbtyp .eq. 'PDB')  call readpdb (ipdb)
      if (pdbtyp .eq. 'CIF')  call readcif (ipdb)
      close (unit=ipdb)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine getprm  --  get force field parameter files  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "getprm" finds any potential energy parameter files and
c     then opens and reads the parameters
c
c
      subroutine getprm
      use argue
      use files
      use inform
      use iounit
      use keys
      use params
      implicit none
      integer maxfile
      parameter (maxfile=12)
      integer i,j,iprm
      integer nfile,nask
      integer trimtext,next
      integer freeunit
      logical exist,useprm
      character*4 none
      character*20 keyword
      character*240 prmfile
      character*240 prefix
      character*240 record
      character*240 string
      character*240 ifile(maxfile)
c
c
c     set default usage and number of parameter files
c
      useprm = .true.
      nfile = 0
c
c     check for parameter file with base name of current system
c
      prmfile = filename(1:leng)//'.prm'
      call version (prmfile,'old')
      inquire (file=prmfile,exist=exist)
      if (exist) then
         nfile = nfile + 1
         ifile(nfile) = prmfile
      end if
c
c     check for the existence of a generic parameter file
c
      if (ldir .eq. 0) then
         prmfile = 'tinker.prm'
      else
         prmfile = filename(1:ldir)//'tinker.prm'
      end if
      call version (prmfile,'old')
      inquire (file=prmfile,exist=exist)
      if (exist) then
         nfile = nfile + 1
         ifile(nfile) = prmfile
      end if
c
c     try to get a parameter filename from the command line
c
      do i = 1, narg-1
         string = arg(i)
         call upcase (string)
         if (string(1:2) .eq. '-P') then
            prmfile = arg(i+1)
            if (prmfile(1:2) .eq. '~/') then
               call getenv ('HOME',prefix)
               prmfile = prefix(1:trimtext(prefix))//
     &                      prmfile(2:trimtext(prmfile))
            end if
            call suffix (prmfile,'prm','old')
            inquire (file=prmfile,exist=exist)
            if (exist) then
               nfile = nfile + 1
               ifile(nfile) = prmfile
            else
               write (iout,10)
   10          format (/,' GETPRM  --  Parameter File Named on',
     &                    ' Command Line not Found')
               call fatal
            end if
         end if
      end do
c
c     search the keyword list for the parameter filename
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:11).eq.'PARAMETERS '
     &          .or. keyword(1:10).eq.'PARAMETER ') then
            string = record(next:240)
            next = 1
            call getstring (string,prmfile,next)
            if (next .eq. 1)  call gettext (string,prmfile,next)
            if (prmfile(1:2) .eq. '~/') then
               call getenv ('HOME',prefix)
               prmfile = prefix(1:trimtext(prefix))//
     &                      prmfile(2:trimtext(prmfile))
            end if
            call suffix (prmfile,'prm','old')
            inquire (file=prmfile,exist=exist)
            if (exist) then
               do j = 1, nfile
                  if (prmfile .eq. ifile(j))  goto 20
               end do
               nfile = nfile + 1
               ifile(nfile) = prmfile
   20          continue
            else
               none = prmfile(1:4)
               call upcase (none)
               if (none .eq. 'NONE')  useprm = .false.
            end if
         end if
      end do
      if (.not. useprm)  nfile = 0
c
c     if necessary, ask for the parameter filename
c
      if (useprm .and. nfile.eq.0) then
         nask = 0
         exist = .false.
         do while (.not.exist .and. nask.lt.maxask)
            nask = nask + 1
            write (iout,30)
   30       format (/,' Enter Parameter File Name [<Enter>=NONE] :  ',$)
            read (input,40)  prmfile
   40       format (a240)
            next = 1
            call getword (prmfile,none,next)
            call upcase (none)
            if (next.eq.1 .or. none.eq.'NONE') then
               exist = .true.
               useprm = .false.
            else
               if (prmfile(1:2) .eq. '~/') then
                  call getenv ('HOME',prefix)
                  prmfile = prefix(1:trimtext(prefix))//
     &                         prmfile(2:trimtext(prmfile))
               end if
               call suffix (prmfile,'prm','old')
               inquire (file=prmfile,exist=exist)
               if (exist) then
                  nfile = nfile + 1
                  ifile(nfile) = prmfile
               end if
            end if
         end do
      end if
c
c     check to make sure a parameter file is available
c
      if (useprm .and. nfile.eq.0) then
         write (iout,50)
   50    format (/,' GETPRM  --  A Valid Parameter File',
     &              ' was not Provided')
         call fatal
      end if
c
c     read the parameter files and count the total lines
c
      nprm = 0
      if (useprm) then
         do i = 1, nfile
            iprm = freeunit ()
            prmfile = ifile(i)
            open (unit=iprm,file=prmfile,status='old')
            rewind (unit=iprm)
            do while (.true.)
               read (iprm,60,err=70,end=70)
   60          format ()
               nprm = nprm + 1
            end do
   70       continue
            close (unit=iprm)
         end do
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(prmline))  deallocate (prmline)
      allocate (prmline(nprm))
c
c     reread the parameter files and store for latter use
c
      nprm = 0
      do i = 1, nfile
         iprm = freeunit ()
         prmfile = ifile(i)
         open (unit=iprm,file=prmfile,status='old')
         rewind (unit=iprm)
         dowhile (.true.)
            read (iprm,80,err=90,end=90)  record
   80       format (a240)
            nprm = nprm + 1
            prmline(nprm) = record
         end do
   90    continue
         close (unit=iprm)
      end do
c
c     convert underbar characters to dashes in all keywords
c
      do i = 1, nprm
         next = 1
         record = prmline(i)
         call gettext (record,keyword,next)
         do j = 1, next-1
            if (record(j:j) .eq. '_')  record(j:j) = '-'
         end do
         prmline(i) = record
      end do
c
c     count and allocate memory for the parameter values
c
      call setprm
c
c     initialize force field control and parameter values
c
      call initprm
c
c     get control and parameter values from the parameter file
c
      if (useprm)  call readprm
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine getref  --  get structure from reference area  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "getref" copies structure information from the reference area
c     into the standard variables for the current system structure
c
c
      subroutine getref (iref)
      use atomid
      use atoms
      use boxes
      use couple
      use files
      use refer
      use titles
      implicit none
      integer i,j,iref
c
c
c     retrieve the filename and title line for the structure
c
      filename = reffile(iref)
      leng = refleng(iref)
      title = reftitle(iref)
      ltitle = refltitle(iref)
c
c     retrieve the coordinates, type and connectivity of each atom
c
      n = nref(iref)
      do i = 1, n
         name(i) = refnam(i,iref)
         x(i) = xref(i,iref)
         y(i) = yref(i,iref)
         z(i) = zref(i,iref)
         type(i) = reftyp(i,iref)
         n12(i) = n12ref(i,iref)
         do j = 1, n12(i)
            i12(j,i) = i12ref(j,i,iref)
         end do
      end do
c
c     retrieve any unit cell parameters defining a periodic box
c
      xbox = xboxref(iref)
      ybox = yboxref(iref)
      zbox = zboxref(iref)
      alpha = alpharef(iref)
      beta = betaref(iref)
      gamma = gammaref(iref)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine getstring  --  extract quoted text from string  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "getstring" searches for a quoted text string within an input
c     character string; the region between the first double or single
c     quoted region is returned as the "text"; if the actual text is
c     too long, only the first part is returned
c
c     variables and parameters:
c
c     string    input character string to be searched
c     text      the quoted text found in the input string
c     next      input with first position of search string;
c                 output with the position following text
c
c
      subroutine getstring (string,text,next)
      use ascii
      implicit none
      integer i,j,k,m
      integer len,length
      integer size,next
      integer code,extent
      integer initial,final
      integer first,last
      integer maxascii
      character*(*) string
      character*(*) text
c
c
c     get the length of input string and output text
c
      length = len(string(next:))
      size = len(text)
      first = next
      last = 0
c
c     convert first two non-ascii regions to delimiting quotes
c
      maxascii = 126
      initial = next
      final = next + length - 1
      do i = initial, final
         code = ichar(string(i:i))
         if (code .gt. maxascii) then
            string(i:i) = ' '
            do j = i+1, final
               code = ichar(string(j:j))
               if (code .le. maxascii) then
                  string(j-1:j-1) = '"'
                  do k = j+1, final
                     code = ichar(string(k:k))
                     if (code .gt. maxascii) then
                        string(k:k) = '"'
                        do m = k+1, final
                           code = ichar(string(m:m))
                           if (code .gt. maxascii) then
                              string(m:m) = ' '
                           end if
                        end do
                        goto 10
                     end if
                  end do
               end if
            end do
         end if
      end do
   10 continue
c
c     search the string for double quoted region of text
c
      do i = initial, final
         code = ichar(string(i:i))
         if (code .eq. quote) then
            first = i + 1
            do j = first, final
               code = ichar(string(j:j))
               if (code .eq. quote) then
                  last = j - 1
                  next = j + 1
                  goto 20
               end if
            end do
         end if
      end do
      first = next
c
c     search the string for single quoted region of text
c
      do i = initial, final
         code = ichar(string(i:i))
         if (code .eq. apostrophe) then
            first = i + 1
            do j = first, final
               code = ichar(string(j:j))
               if (code .eq. apostrophe) then
                  last = j - 1
                  next = j + 1
                  goto 20
               end if
            end do
         end if
      end do
      first = next
   20 continue
c
c     trim the actual word if it is too long to return
c
      extent = last - first + 1
      final = first + size - 1
      if (extent .gt. size)  last = final
c
c     transfer the text into the return string
c
      j = 0
      do i = first, last
         j = j + 1
         text(j:j) = string(i:i)
      end do
      do i = last+1, final
         j = j + 1
         text(j:j) = ' '
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine gettext  --  extract text from a string  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "gettext" searches an input string for the first string of
c     non-blank characters; the region from a non-blank character
c     to the first space or tab is returned as "text"; if the
c     actual text is too long, only the first part is returned
c
c     variables and parameters:
c
c     string    input character string to be searched
c     text      output with the first text string found
c     next      input with first position of search string;
c                 output with the position following text
c
c
      subroutine gettext (string,text,next)
      use ascii
      implicit none
      integer i,j
      integer len,length
      integer size,next
      integer first,last
      integer code,extent
      integer initial,final
      character*(*) string
      character*(*) text
c
c
c     get the length of input string and output text
c
      length = len(string(next:))
      size = len(text)
c
c     search the string for the first non-blank character
c
      first = next
      last = 0
      initial = next
      final = next + length - 1
      do i = initial, final
         code = ichar(string(i:i))
         if (code.ne.space .and. code.ne.tab) then
            first = i
            do j = i+1, final
               code = ichar(string(j:j))
               if (code.eq.space .or. code.eq.tab) then
                  last = j - 1
                  next = j
                  goto 10
               end if
            end do
            last = final
            next = last + 1
         end if
      end do
   10 continue
c
c     trim the actual text if it is too long to return
c
      extent = next - first
      final = first + size - 1
      if (extent .gt. size)  last = final
c
c     transfer the text into the return string
c
      j = 0
      do i = first, last
         j = j + 1
         text(j:j) = string(i:i)
      end do
      do i = next, final
         j = j + 1
         text(j:j) = ' '
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine getword  --  extract first word from a string  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "getword" searches an input string for the first alphabetic
c     character (A-Z or a-z); the region from this first character
c     to the first blank space or separator is returned as a "word";
c     if the actual word is too long, only the first part is returned
c
c     variables and parameters:
c
c     string    input character string to be searched
c     word      output with the first word in the string
c     next      input with first position of search string;
c                 output with the position following word
c
c
      subroutine getword (string,word,next)
      use ascii
      implicit none
      integer i,j
      integer len,length
      integer size,next
      integer first,last
      integer code,extent
      integer initial,final
      character*1 letter
      character*(*) string
      character*(*) word
c
c
c     get the length of input string and output word
c
      length = len(string(next:))
      size = len(word)
c
c     search the string for the first alphabetic character
c
      first = next
      last = 0
      initial = next
      final = next + length - 1
      do i = initial, final
         letter = string(i:i)
         if ((letter.ge.'A' .and. letter.le.'Z') .or.
     &       (letter.ge.'a' .and. letter.le.'z')) then
            first = i
            do j = i+1, final
               code = ichar(string(j:j))
               if (code.eq.space .or. code.eq.tab .or.
     &             code.eq.comma .or. code.eq.colon .or.
     &             code.eq.semicolon) then
                  last = j - 1
                  next = j
                  goto 10
               end if
            end do
            last = final
            next = last + 1
         end if
      end do
   10 continue
c
c     trim the actual word if it is too long to return
c
      extent = next - first
      final = first + size - 1
      if (extent .gt. size)  last = final
c
c     transfer the word into the return string
c
      j = 0
      do i = first, last
         j = j + 1
         word(j:j) = string(i:i)
      end do
      do i = next, final
         j = j + 1
         word(j:j) = ' '
      end do
c
c     skip over the next character when it is a separator
c
      code = ichar(string(next:next))
      if (code.eq.tab .or. code.eq.comma .or.
     &    code.eq.colon .or. code.eq.semicolon) then
          next = next + 1
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine getxyz  --  get XYZ-format coordinates file  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "getxyz" asks for a Cartesian coordinate file name,
c     then reads in the coordinates file
c
c
      subroutine getxyz
      use files
      use inform
      use iounit
      use output
      implicit none
      integer ixyz,nask
      integer freeunit
      logical exist
      character*240 xyzfile
c
c
c     try to get a filename from the command line arguments
c
      call nextarg (xyzfile,exist)
      if (exist) then
         call basefile (xyzfile)
         call suffix (xyzfile,'xyz','old')
         inquire (file=xyzfile,exist=exist)
      end if
c
c     ask for the user specified input structure filename
c
      nask = 0
      do while (.not.exist .and. nask.lt.maxask)
         nask = nask + 1
         write (iout,10)
   10    format (/,' Enter Cartesian Coordinate File Name :  ',$)
         read (input,20)  xyzfile
   20    format (a240)
         call basefile (xyzfile)
         call suffix (xyzfile,'xyz','old')
         inquire (file=xyzfile,exist=exist)
      end do
      if (.not. exist)  call fatal
c
c     first open and then read the Cartesian coordinates file
c
      filename = xyzfile
      coordtype = 'CARTESIAN'
      ixyz = freeunit ()
      open (unit=ixyz,file=xyzfile,status='old')
      rewind (unit=ixyz)
      call readxyz (ixyz)
      close (unit=ixyz)
c
c     quit if the Cartesian coordinates file contains no atoms
c
      if (abort) then
         write (iout,30)
   30    format (/,' GETXYZ  --  Cartesian Coordinate File',
     &              ' was not Read Correctly')
         call fatal
      end if
      return
      end
c
c
c     ###############################################################
c     ##  COPYRIGHT (C) 2011 by John Chodera & Jay William Ponder  ##
c     ##                    All Rights Reserved                    ##
c     ###############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ghmcstep  --  generalized hybrid Monte Carlo  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ghmcstep" performs a stochastic dynamics step via a generalized
c     hybrid Monte Carlo (GHMC) algorithm that ensures exact sampling
c     from the Boltzmann density
c
c     literature references:
c
c     T. Lelievre, M. Rousset and G. Stoltz, "Free Energy Computations:
c     A Mathematical Perspective", Imperial College Press, London, 2010
c     [Algorithm 2.11]
c
c     T. Lelievre, M. Rousset and G. Stoltz, "Langevin Dynamics
c     with Constraints and Computation of Free Energy Differences",
c     Mathematics of Computation, 81, 2071-2125 (2012) [eq 3.16-3.18]
c
c     original version written by John D. Chodera, University of
c     California, Berkeley, November 2010
c
c
      subroutine ghmcstep (istep,dt)
      use atoms
      use atomid
      use bath
      use freeze
      use inform
      use iounit
      use moldyn
      use units
      use usage
      use virial
      implicit none
      integer i,j,k
      integer istep
      integer nreject
      real*8 dt,dt_2
      real*8 energy
      real*8 epot,etot
      real*8 epold,etold
      real*8 eksum,de
      real*8 temp,pres
      real*8 random,ratio
      real*8 ekin(3,3)
      real*8 stress(3,3)
      real*8, allocatable :: xold(:)
      real*8, allocatable :: yold(:)
      real*8, allocatable :: zold(:)
      real*8, allocatable :: vold(:,:)
      real*8, allocatable :: aold(:,:)
      real*8, allocatable :: derivs(:,:)
      real*8, allocatable :: alpha(:,:)
      real*8, allocatable :: beta(:,:)
      logical first
      external energy
      external random
      save nreject
      save epot
      save first
      data first  / .true. /
c
c
c     set some time values for the dynamics integration
c
      dt_2 = 0.5d0 * dt
c
c     use current energy as previous value for initial step
c
      if (first) then
         first = .false.
         nreject = 0
         epot = energy ()
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (xold(n))
      allocate (yold(n))
      allocate (zold(n))
      allocate (vold(3,n))
      allocate (aold(3,n))
      allocate (derivs(3,n))
      allocate (alpha(3,n))
      allocate (beta(3,n))
c
c     evolve velocities according to midpoint Euler for half-step
c
      call ghmcterm (istep,dt,alpha,beta)
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            v(j,k) = v(j,k)*alpha(j,k) + beta(j,k)
         end do
      end do
c
c     find constraint-corrected velocities prior to Verlet step
c
      if (use_freeze)  call rattle2 (dt)
c
c     find the kinetic energy and store the energy values
c
      call kinetic (eksum,ekin,temp)
      epold = epot
      etold = eksum + epot
c
c     store the current positions and derivatives, find half-step
c     velocities and full-step positions via Verlet recursion
c
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            vold(j,k) = v(j,k)
            aold(j,k) = a(j,k)
            v(j,k) = v(j,k) + a(j,k)*dt_2
         end do
         xold(k) = x(k)
         yold(k) = y(k)
         zold(k) = z(k)
         x(k) = x(k) + v(1,k)*dt
         y(k) = y(k) + v(2,k)*dt
         z(k) = z(k) + v(3,k)*dt
      end do
c
c     get constraint-corrected positions and half-step velocities
c
      if (use_freeze)  call rattle (dt,xold,yold,zold)
c
c     get the potential energy and atomic forces
c
      call gradient (epot,derivs)
c
c     use Newton's second law to get the next accelerations;
c     find the full-step velocities using the Verlet recursion
c
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            a(j,k) = -ekcal * derivs(j,k) / mass(k)
            v(j,k) = v(j,k) + a(j,k)*dt_2
         end do
      end do
c
c     find the constraint-corrected full-step velocities
c
      if (use_freeze)  call rattle2 (dt)
c
c     compute kinetic energy, temperature and total energy
c
      call kinetic (eksum,ekin,temp)
      etot = eksum + epot
c
c     accept or reject according to the Metropolis criterion;
c     note velocities have flipped sign upon rejection
c
      de = (etot-etold) / (gasconst*kelvin)
      if (de.gt.0.0d0 .and. random().gt.exp(-de)) then
         nreject = nreject + 1
         epot = epold
         do i = 1, nuse
            k = iuse(i)
            x(k) = xold(k)
            y(k) = yold(k)
            z(k) = zold(k)
            do j = 1, 3
               v(j,k) = -vold(j,k)
               a(j,k) = aold(j,k)
            end do
         end do
      end if
      if (mod(istep,1000) .eq. 0) then
         ratio = 1.0d0 - dble(nreject)/1000.0d0
         nreject = 0
         write (iout,10)  ratio
   10    format (/,' GHMC Acceptance Ratio',6x,f8.3,
     &              ' for the Last 1000 Steps')
      end if
c
c     update velocities using midpoint Euler for half-step
c
      call ghmcterm (istep,dt,alpha,beta)
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            v(j,k) = v(j,k)*alpha(j,k) + beta(j,k)
         end do
      end do
c
c     update the constraint-corrected full-step velocities
c
      if (use_freeze) then
         call rattle2 (dt)
         do i = 1, nuse
            k = iuse(i)
            xold(k) = x(k)
            yold(k) = y(k)
            zold(k) = z(k)
         end do
      end if
c
c     compute full-step kinetic energy and pressure correction
c
      call kinetic (eksum,ekin,temp)
      call pressure (dt,ekin,pres,stress)
      call pressure2 (epot,temp)
c
c     final constraint step to enforce position convergence
c
      if (use_freeze)  call shake (xold,yold,zold)
c
c     perform deallocation of some local arrays
c
      deallocate (xold)
      deallocate (yold)
      deallocate (zold)
      deallocate (vold)
      deallocate (aold)
      deallocate (derivs)
      deallocate (alpha)
      deallocate (beta)
c
c     total energy is sum of kinetic and potential energies
c
      etot = eksum + epot
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,eksum,temp,pres)
      call mdsave (istep,dt,epot,eksum)
      call mdrest (istep)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ghmcterm  --  GHMC friction & fluctuation terms  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ghmcterm" finds the friction and fluctuation terms needed
c     to update velocities during GHMC stochastic dynamics
c
c
      subroutine ghmcterm (istep,dt,alpha,beta)
      use atoms
      use atomid
      use bath
      use stodyn
      use units
      use usage
      implicit none
      integer i,j,k
      integer istep
      real*8 dt,dt_4
      real*8 gamma,sigma
      real*8 term,normal
      real*8 alpha(3,*)
      real*8 beta(3,*)
      logical first
      external normal
      save first
      data first  / .true. /
c
c
c     perform dynamic allocation of some global arrays
c
      if (first) then
         first = .false.
         if (.not. allocated(fgamma))  allocate (fgamma(n))
c
c     set atomic friction coefficients to the global value
c
         do i = 1, n
            fgamma(i) = friction
         end do
      end if
c
c     find friction coefficients scaled by accessibility
c
      if (use_sdarea)  call sdarea (istep)
c
c     compute the viscous friction and fluctuation terms
c
      dt_4 = 0.25d0 * dt
      term = sqrt(boltzmann*kelvin*dt)
      do i = 1, nuse
         k = iuse(i)
         gamma = dt_4 * fgamma(k)
         sigma = term * sqrt(fgamma(k)/mass(k))
         do j = 1, 3
            alpha(j,k) = (1.0d0-gamma) / (1.0d0+gamma)
            beta(j,k) = normal() * sigma / (1.0d0+gamma)
         end do
      end do
      return
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2006 by Michael Schnieders & Jay W. Ponder  ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module gkstuf  --  generalized Kirkwood solvation values  ##
c     ##                                                            ##
c     ################################################################
c
c
c     gkc      tuning parameter exponent in the f(GB) function
c
c
      module gkstuf
      use sizes
      implicit none
      real*8 gkc
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine gradient  --  find energy & gradient components  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "gradient" calls subroutines to calculate the potential energy
c     and first derivatives with respect to Cartesian coordinates
c
c
      subroutine gradient (energy,derivs)
      use atoms
      use couple
      use deriv
      use energi
      use inform
      use inter
      use iounit
      use limits
      use potent
      use vdwpot
      use virial
      implicit none
      integer i,j
      real*8 energy,cutoff
      real*8 derivs(3,*)
c
c
c     zero out each of the potential energy components
c
      esum = 0.0d0
      eb = 0.0d0
      ea = 0.0d0
      eba = 0.0d0
      eub = 0.0d0
      eaa = 0.0d0
      eopb = 0.0d0
      eopd = 0.0d0
      eid = 0.0d0
      eit = 0.0d0
      et = 0.0d0
      ept = 0.0d0
      ebt = 0.0d0
      eat = 0.0d0
      ett = 0.0d0
      ev = 0.0d0
      er = 0.0d0
      edsp = 0.0d0
      ec = 0.0d0
      ecd = 0.0d0
      ed = 0.0d0
      em = 0.0d0
      ep = 0.0d0
      ect = 0.0d0
      erxf = 0.0d0
      es = 0.0d0
      elf = 0.0d0
      eg = 0.0d0
      ex = 0.0d0
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(desum)) then
         if (size(desum) .lt. 3*n) then
            deallocate (desum)
            deallocate (deb)
            deallocate (dea)
            deallocate (deba)
            deallocate (deub)
            deallocate (deaa)
            deallocate (deopb)
            deallocate (deopd)
            deallocate (deid)
            deallocate (deit)
            deallocate (det)
            deallocate (dept)
            deallocate (debt)
            deallocate (deat)
            deallocate (dett)
            deallocate (dev)
            deallocate (der)
            deallocate (dedsp)
            deallocate (dec)
            deallocate (decd)
            deallocate (ded)
            deallocate (dem)
            deallocate (dep)
            deallocate (dect)
            deallocate (derxf)
            deallocate (des)
            deallocate (delf)
            deallocate (deg)
            deallocate (dex)
         end if
      end if
      if (.not. allocated(desum)) then
         allocate (desum(3,n))
         allocate (deb(3,n))
         allocate (dea(3,n))
         allocate (deba(3,n))
         allocate (deub(3,n))
         allocate (deaa(3,n))
         allocate (deopb(3,n))
         allocate (deopd(3,n))
         allocate (deid(3,n))
         allocate (deit(3,n))
         allocate (det(3,n))
         allocate (dept(3,n))
         allocate (debt(3,n))
         allocate (deat(3,n))
         allocate (dett(3,n))
         allocate (dev(3,n))
         allocate (der(3,n))
         allocate (dedsp(3,n))
         allocate (dec(3,n))
         allocate (decd(3,n))
         allocate (ded(3,n))
         allocate (dem(3,n))
         allocate (dep(3,n))
         allocate (dect(3,n))
         allocate (derxf(3,n))
         allocate (des(3,n))
         allocate (delf(3,n))
         allocate (deg(3,n))
         allocate (dex(3,n))
      end if
c
c     zero out each of the first derivative components
c
      do i = 1, n
         do j = 1, 3
            derivs(j,i) = 0.0d0
            desum(j,i) = 0.0d0
            deb(j,i) = 0.0d0
            dea(j,i) = 0.0d0
            deba(j,i) = 0.0d0
            deub(j,i) = 0.0d0
            deaa(j,i) = 0.0d0
            deopb(j,i) = 0.0d0
            deopd(j,i) = 0.0d0
            deid(j,i) = 0.0d0
            deit(j,i) = 0.0d0
            det(j,i) = 0.0d0
            dept(j,i) = 0.0d0
            debt(j,i) = 0.0d0
            deat(j,i) = 0.0d0
            dett(j,i) = 0.0d0
            dev(j,i) = 0.0d0
            der(j,i) = 0.0d0
            dedsp(j,i) = 0.0d0
            dec(j,i) = 0.0d0
            decd(j,i) = 0.0d0
            ded(j,i) = 0.0d0
            dem(j,i) = 0.0d0
            dep(j,i) = 0.0d0
            dect(j,i) = 0.0d0
            derxf(j,i) = 0.0d0
            des(j,i) = 0.0d0
            delf(j,i) = 0.0d0
            deg(j,i) = 0.0d0
            dex(j,i) = 0.0d0
         end do
      end do
c
c     zero out the virial and the intermolecular energy
c
      do i = 1, 3
         do j = 1, 3
            vir(j,i) = 0.0d0
         end do
      end do
      einter = 0.0d0
c
c     skip gradient calculation when using GPU coprocessor
c
      if (gpucard .ne. 0)  return
c
c     update the pairwise interaction neighbor lists
c
      if (use_list)  call nblist
c
c     remove any previous use of the replicates method
c
      cutoff = 0.0d0
      call replica (cutoff)
c
c     many implicit solvation models require Born radii
c
      if (use_born)  call born
c
c     alter partial charges and multipoles for charge flux
c
      if (use_chgflx)  call alterchg
c
c     modify bond and torsion constants for pisystem
c
      if (use_orbit)  call picalc
c
c     call the local geometry energy and gradient routines
c
      if (use_bond)  call ebond1
      if (use_angle)  call eangle1
      if (use_strbnd)  call estrbnd1
      if (use_urey)  call eurey1
      if (use_angang)  call eangang1
      if (use_opbend)  call eopbend1
      if (use_opdist)  call eopdist1
      if (use_improp)  call eimprop1
      if (use_imptor)  call eimptor1
      if (use_tors)  call etors1
      if (use_pitors)  call epitors1
      if (use_strtor)  call estrtor1
      if (use_angtor)  call eangtor1
      if (use_tortor)  call etortor1
c
c     call the electrostatic energy and gradient routines
c
      if (use_charge)  call echarge1
      if (use_chgdpl)  call echgdpl1
      if (use_dipole)  call edipole1
      if (use_mpole)  call empole1
      if (use_polar)  call epolar1
      if (use_chgtrn)  call echgtrn1
      if (use_rxnfld)  call erxnfld1
c
c     call the van der Waals energy and gradient routines
c
      if (use_vdw) then
         if (vdwtyp .eq. 'LENNARD-JONES')  call elj1
         if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck1
         if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb1
         if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal1
         if (vdwtyp .eq. 'GAUSSIAN')  call egauss1
      end if
      if (use_repel)  call erepel1
      if (use_disp)  call edisp1
c
c     call any miscellaneous energy and gradient routines
c
      if (use_solv)  call esolv1
      if (use_metal)  call emetal1
      if (use_geom)  call egeom1
      if (use_extra)  call extra1
c
c     sum up to get the total energy and first derivatives
c
      esum = eb + ea + eba + eub + eaa + eopb + eopd + eid + eit
     &          + et + ept + ebt + eat + ett + ev + er + edsp
     &          + ec+ ecd + ed + em + ep + ect + erxf + es + elf
     &          + eg + ex
      energy = esum
      do i = 1, n
         do j = 1, 3
            desum(j,i) = deb(j,i) + dea(j,i) + deba(j,i)
     &                      + deub(j,i) + deaa(j,i) + deopb(j,i)
     &                      + deopd(j,i) + deid(j,i) + deit(j,i)
     &                      + det(j,i) + dept(j,i) + debt(j,i)
     &                      + deat(j,i) + dett(j,i) + dev(j,i)
     &                      + der(j,i) + dedsp(j,i) + dec(j,i)
     &                      + decd(j,i) + ded(j,i) + dem(j,i)
     &                      + dep(j,i) + dect(j,i) + derxf(j,i)
     &                      + des(j,i) + delf(j,i)
     &                      + deg(j,i) + dex(j,i)
            derivs(j,i) = desum(j,i)
         end do
      end do
c
c     distribute gradient on four-site water extra centers
c
      call watfour2 (derivs)
c
c     check for an illegal value for the total energy
c
c     if (isnan(esum)) then
      if (esum .ne. esum) then
         write (iout,10)
   10    format (/,' GRADIENT  --  Illegal Value for the Total',
     &              ' Potential Energy')
         call fatal
      end if
      return
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 1997 by Rohit Pappu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine gradrgd  --  energy & gradient of rigid body  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "gradrgd" calls subroutines to calculate the potential energy
c     and first derivatives with respect to rigid body coordinates
c
c
      subroutine gradrgd (energy,derivs)
      use atoms
      use group
      use rigid
      implicit none
      integer i,j,k
      integer init,stop
      real*8 energy
      real*8 xcm,ycm,zcm
      real*8 xterm,yterm,zterm
      real*8 phi,cphi,sphi
      real*8 theta,ctheta,stheta
      real*8 ephi(3),etheta(3)
      real*8 epsi(3),tau(3)
      real*8 derivs(6,*)
      real*8, allocatable :: g(:,:)
c
c
c     zero out the total of rigid body derivative components
c
      do i = 1, ngrp
         do j = 1, 6
            derivs(j,i) = 0.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (g(3,n))
c
c     calculate the energy and Cartesian first derivatives
c
      call gradient (energy,g)
c
c     compute the rigid body gradient components for each group
c
      do i = 1, ngrp
         init = igrp(1,i)
         stop = igrp(2,i)
         xcm = rbc(1,i)
         ycm = rbc(2,i)
         zcm = rbc(3,i)
         phi = rbc(4,i)
         theta = rbc(5,i)
         cphi = cos(phi)
         sphi = sin(phi)
         ctheta = cos(theta)
         stheta = sin(theta)
c
c     get unit vectors along the phi, theta and psi rotation axes
c
         ephi(1) = 0.0d0
         ephi(2) = 0.0d0
         ephi(3) = 1.0d0
         etheta(1) = -sphi
         etheta(2) = cphi
         etheta(3) = 0.0d0
         epsi(1) = ctheta * cphi
         epsi(2) = ctheta * sphi
         epsi(3) = -stheta
c
c     find the rigid body gradients for translations
c
         do j = init, stop
            k = kgrp(j)
            derivs(1,i) = derivs(1,i) + g(1,k)
            derivs(2,i) = derivs(2,i) + g(2,k)
            derivs(3,i) = derivs(3,i) + g(3,k)
         end do
c
c     accumulate the moment arm along each axis of rotation
c
         do j = 1, 3
            tau(j) = 0.0d0
         end do
         do j = init, stop
            k = kgrp(j)
            xterm = x(k) - xcm
            yterm = y(k) - ycm
            zterm = z(k) - zcm
            tau(1) = tau(1) + yterm*g(3,k) - zterm*g(2,k)
            tau(2) = tau(2) + zterm*g(1,k) - xterm*g(3,k)
            tau(3) = tau(3) + xterm*g(2,k) - yterm*g(1,k)
         end do
c
c     find the rigid body gradients for rotations
c
         do j = 1, 3
            derivs(4,i) = derivs(4,i) + tau(j)*ephi(j)
            derivs(5,i) = derivs(5,i) + tau(j)*etheta(j)
            derivs(6,i) = derivs(6,i) + tau(j)*epsi(j)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (g)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine gradrot  --  energy and torsional derivs  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "gradrot" calls subroutines to calculate the potential
c     energy and its torsional first derivatives
c
c
      subroutine gradrot (energy,derivs)
      use atoms
      use deriv
      use domega
      use omega
      use potent
      use rotbnd
      implicit none
      integer i,j,k
      integer base,partner
      real*8 energy,norm
      real*8 xatom,yatom,zatom
      real*8 xdist,ydist,zdist
      real*8 xterm,yterm,zterm
      real*8 derivs(*)
      real*8, allocatable :: g(:,:)
c
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(tesum)) then
         if (size(tesum) .lt. nomega) then
            deallocate (tesum)
            deallocate (teb)
            deallocate (tea)
            deallocate (teba)
            deallocate (teub)
            deallocate (teaa)
            deallocate (teopb)
            deallocate (teopd)
            deallocate (teid)
            deallocate (teit)
            deallocate (tet)
            deallocate (tept)
            deallocate (tebt)
            deallocate (teat)
            deallocate (tett)
            deallocate (tev)
            deallocate (ter)
            deallocate (tedsp)
            deallocate (tec)
            deallocate (tecd)
            deallocate (ted)
            deallocate (tem)
            deallocate (tep)
            deallocate (tect)
            deallocate (terxf)
            deallocate (tes)
            deallocate (telf)
            deallocate (teg)
            deallocate (tex)
         end if
      end if
      if (.not. allocated(tesum)) then
         allocate (tesum(nomega))
         allocate (teb(nomega))
         allocate (tea(nomega))
         allocate (teba(nomega))
         allocate (teub(nomega))
         allocate (teaa(nomega))
         allocate (teopb(nomega))
         allocate (teopd(nomega))
         allocate (teid(nomega))
         allocate (teit(nomega))
         allocate (tet(nomega))
         allocate (tept(nomega))
         allocate (tebt(nomega))
         allocate (teat(nomega))
         allocate (tett(nomega))
         allocate (tev(nomega))
         allocate (ter(nomega))
         allocate (tedsp(nomega))
         allocate (tec(nomega))
         allocate (tecd(nomega))
         allocate (ted(nomega))
         allocate (tem(nomega))
         allocate (tep(nomega))
         allocate (tect(nomega))
         allocate (terxf(nomega))
         allocate (tes(nomega))
         allocate (telf(nomega))
         allocate (teg(nomega))
         allocate (tex(nomega))
      end if
c
c     zero out individual components of torsional derivatives
c
      do i = 1, nomega
         derivs(i) = 0.0d0
         tesum(i) = 0.0d0
         teb(i) = 0.0d0
         tea(i) = 0.0d0
         teba(i) = 0.0d0
         teub(i) = 0.0d0
         teaa(i) = 0.0d0
         teopb(i) = 0.0d0
         teopd(i) = 0.0d0
         teid(i) = 0.0d0
         teit(i) = 0.0d0
         tet(i) = 0.0d0
         tept(i) = 0.0d0
         tebt(i) = 0.0d0
         teat(i) = 0.0d0
         tett(i) = 0.0d0
         tev(i) = 0.0d0
         ter(i) = 0.0d0
         tedsp(i) = 0.0d0
         tec(i) = 0.0d0
         tecd(i) = 0.0d0
         ted(i) = 0.0d0
         tem(i) = 0.0d0
         tep(i) = 0.0d0
         tect(i) = 0.0d0
         terxf(i) = 0.0d0
         tes(i) = 0.0d0
         telf(i) = 0.0d0
         teg(i) = 0.0d0
         tex(i) = 0.0d0
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (g(3,n))
c
c     calculate the energy and Cartesian first derivatives
c
      call gradient (energy,g)
c
c     perform deallocation of some local arrays
c
      deallocate (g)
c
c     transform Cartesian derivatives to torsional space
c
      do i = 1, nomega
         base = iomega(1,i)
         partner = iomega(2,i)
         call rotlist (base,partner)
         xdist = x(base) - x(partner)
         ydist = y(base) - y(partner)
         zdist = z(base) - z(partner)
         norm = sqrt(xdist**2 + ydist**2 + zdist**2)
         xdist = xdist / norm
         ydist = ydist / norm
         zdist = zdist / norm
         do j = 1, nrot
            k = rot(j)
            xatom = x(k) - x(base)
            yatom = y(k) - y(base)
            zatom = z(k) - z(base)
            xterm = ydist*zatom - zdist*yatom
            yterm = zdist*xatom - xdist*zatom
            zterm = xdist*yatom - ydist*xatom
            teb(i) = teb(i) + deb(1,k)*xterm + deb(2,k)*yterm
     &                              + deb(3,k)*zterm
            tea(i) = tea(i) + dea(1,k)*xterm + dea(2,k)*yterm
     &                              + dea(3,k)*zterm
            teba(i) = teba(i) + deba(1,k)*xterm + deba(2,k)*yterm
     &                              + deba(3,k)*zterm
            teub(i) = teub(i) + deub(1,k)*xterm + deub(2,k)*yterm
     &                              + deub(3,k)*zterm
            teaa(i) = teaa(i) + deaa(1,k)*xterm + deaa(2,k)*yterm
     &                              + deaa(3,k)*zterm
            teopb(i) = teopb(i) + deopb(1,k)*xterm + deopb(2,k)*yterm
     &                              + deopb(3,k)*zterm
            teopd(i) = teopd(i) + deopd(1,k)*xterm + deopd(2,k)*yterm
     &                              + deopd(3,k)*zterm
            teid(i) = teid(i) + deid(1,k)*xterm + deid(2,k)*yterm
     &                              + deid(3,k)*zterm
            teit(i) = teit(i) + deit(1,k)*xterm + deit(2,k)*yterm
     &                              + deit(3,k)*zterm
            tet(i) = tet(i) + det(1,k)*xterm + det(2,k)*yterm
     &                              + det(3,k)*zterm
            tept(i) = tept(i) + dept(1,k)*xterm + dept(2,k)*yterm
     &                              + dept(3,k)*zterm
            tebt(i) = tebt(i) + debt(1,k)*xterm + debt(2,k)*yterm
     &                              + debt(3,k)*zterm
            teat(i) = teat(i) + deat(1,k)*xterm + deat(2,k)*yterm
     &                              + deat(3,k)*zterm
            tett(i) = tett(i) + dett(1,k)*xterm + dett(2,k)*yterm
     &                              + dett(3,k)*zterm
            tev(i) = tev(i) + dev(1,k)*xterm + dev(2,k)*yterm
     &                              + dev(3,k)*zterm
            ter(i) = ter(i) + der(1,k)*xterm + der(2,k)*yterm
     &                              + der(3,k)*zterm
            tedsp(i) = tedsp(i) + dedsp(1,k)*xterm + dedsp(2,k)*yterm
     &                              + dedsp(3,k)*zterm
            tec(i) = tec(i) + dec(1,k)*xterm + dec(2,k)*yterm
     &                              + dec(3,k)*zterm
            tecd(i) = tecd(i) + decd(1,k)*xterm + decd(2,k)*yterm
     &                              + decd(3,k)*zterm
            ted(i) = ted(i) + ded(1,k)*xterm + ded(2,k)*yterm
     &                              + ded(3,k)*zterm
            tem(i) = tem(i) + dem(1,k)*xterm + dem(2,k)*yterm
     &                              + dem(3,k)*zterm
            tep(i) = tep(i) + dep(1,k)*xterm + dep(2,k)*yterm
     &                              + dep(3,k)*zterm
            tect(i) = tect(i) + dect(1,k)*xterm + dect(2,k)*yterm
     &                              + dect(3,k)*zterm
            terxf(i) = terxf(i) + derxf(1,k)*xterm + derxf(2,k)*yterm
     &                              + derxf(3,k)*zterm
            tes(i) = tes(i) + des(1,k)*xterm + des(2,k)*yterm
     &                              + des(3,k)*zterm
            telf(i) = telf(i) + delf(1,k)*xterm + delf(2,k)*yterm
     &                              + delf(3,k)*zterm
            teg(i) = teg(i) + deg(1,k)*xterm + deg(2,k)*yterm
     &                              + deg(3,k)*zterm
            tex(i) = tex(i) + dex(1,k)*xterm + dex(2,k)*yterm
     &                              + dex(3,k)*zterm
         end do
      end do
c
c     sum up to give the total torsional first derivatives
c
      do i = 1, nomega
         tesum(i) = teb(i) + tea(i) + teba(i) + teub(i) + teaa(i)
     &                 + teopb(i) + teopd(i) + teid(i) + teit(i)
     &                 + tet(i) + tept(i) + tebt(i) + teat(i) + tett(i)
     &                 + tev(i) + ter(i) + tedsp(i) + tec(i) + tecd(i)
     &                 + ted(i) + tem(i) + tep(i) + tect(i) + terxf(i)
     &                 + tes(i) + telf(i) + teg(i) + tex(i)
         derivs(i) = tesum(i)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module group  --  partitioning of system into atom groups  ##
c     ##                                                             ##
c     #################################################################
c
c
c     ngrp        total number of atom groups in the system
c     kgrp        contiguous list of the atoms in each group
c     grplist     number of the group to which each atom belongs
c     igrp        first and last atom of each group in the list
c     grpmass     total mass of all the atoms in each group
c     wgrp        weight for each set of group-group interactions
c     use_group   flag to use partitioning of system into groups
c     use_intra   flag to include only intragroup interactions
c     use_inter   flag to include only intergroup interactions
c
c
      module group
      implicit none
      integer ngrp
      integer, allocatable :: kgrp(:)
      integer, allocatable :: grplist(:)
      integer, allocatable :: igrp(:,:)
      real*8, allocatable :: grpmass(:)
      real*8, allocatable :: wgrp(:,:)
      logical use_group
      logical use_intra
      logical use_inter
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine groups  --  group membership of set of atoms  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "groups" tests a set of atoms to see if all are members of a
c     single atom group or a pair of atom groups; if so, then the
c     correct intra- or intergroup weight is assigned
c
c     note the default group-based interaction weight is 1.0; only
c     interactions involving two or fewer groups can be scaled
c
c
      subroutine groups (proceed,weigh,ia,ib,ic,id,ie,ig)
      use group
      implicit none
      integer ia,ib,ic
      integer id,ie,ig
      integer iga,igb,igc
      integer igd,ige,igg
      integer nset
      integer gmax,gmin
      real*8 weigh
      logical proceed
c
c
c     determine the number of atoms in the set to be compared
c
      nset = 0
      weigh = 1.0d0
      if (ig .ne. 0) then
         nset = 6
      else if (ie .ne. 0) then
         nset = 5
      else if (id .ne. 0) then
         nset = 4
      else if (ic .ne. 0) then
         nset = 3
      else if (ib .ne. 0) then
         nset = 2
      else if (ia .ne. 0) then
         nset = 1
      end if
c
c     check group membership for a set containing one atom
c
      if (nset .eq. 1) then
         iga = grplist(ia)
         weigh = wgrp(iga,iga)
c
c     check group membership for a set containing two atoms
c
      else if (nset .eq. 2) then
         iga = grplist(ia)
         igb = grplist(ib)
         weigh = wgrp(iga,igb)
c
c     check group membership for a set containing three atoms
c
      else if (nset .eq. 3) then
         iga = grplist(ia)
         igb = grplist(ib)
         igc = grplist(ic)
         if (iga.eq.igb .or. igb.eq.igc) then
            weigh = wgrp(iga,igc)
         else if (iga .eq. igc) then
            weigh = wgrp(iga,igb)
         end if
c
c     check group membership for a set containing four atoms
c
      else if (nset .eq. 4) then
         iga = grplist(ia)
         igb = grplist(ib)
         igc = grplist(ic)
         igd = grplist(id)
         gmin = min(iga,igb,igc,igd)
         gmax = max(iga,igb,igc,igd)
         if ((iga.eq.gmin .or. iga.eq.gmax) .and.
     &       (igb.eq.gmin .or. igb.eq.gmax) .and.
     &       (igc.eq.gmin .or. igc.eq.gmax) .and.
     &       (igd.eq.gmin .or. igd.eq.gmax))  weigh = wgrp(gmin,gmax)
c
c     check group membership for a set containing five atoms
c
      else if (nset .eq. 5) then
         iga = grplist(ia)
         igb = grplist(ib)
         igc = grplist(ic)
         igd = grplist(id)
         ige = grplist(ie)
         gmin = min(iga,igb,igc,igd,ige)
         gmax = max(iga,igb,igc,igd,ige)
         if ((iga.eq.gmin .or. iga.eq.gmax) .and.
     &       (igb.eq.gmin .or. igb.eq.gmax) .and.
     &       (igc.eq.gmin .or. igc.eq.gmax) .and.
     &       (igd.eq.gmin .or. igd.eq.gmax) .and.
     &       (ige.eq.gmin .or. ige.eq.gmax))  weigh = wgrp(gmin,gmax)
c
c     check group membership for a set containing five atoms
c
      else if (nset .eq. 6) then
         iga = grplist(ia)
         igb = grplist(ib)
         igc = grplist(ic)
         igd = grplist(id)
         ige = grplist(ie)
         igg = grplist(ig)
         gmin = min(iga,igb,igc,igd,ige,igg)
         gmax = max(iga,igb,igc,igd,ige,igg)
         if ((iga.eq.gmin .or. iga.eq.gmax) .and.
     &       (igb.eq.gmin .or. igb.eq.gmax) .and.
     &       (igc.eq.gmin .or. igc.eq.gmax) .and.
     &       (igd.eq.gmin .or. igd.eq.gmax) .and.
     &       (ige.eq.gmin .or. ige.eq.gmax) .and.
     &       (igg.eq.gmin .or. igg.eq.gmax))  weigh = wgrp(gmin,gmax)
      end if
c
c     interaction will be used if its group has nonzero weight
c
      if (weigh .eq. 0.0d0) then
         proceed = .false.
      else
         proceed = .true.
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2001  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine grpline  --  test atom groups for linearity  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "grpline" tests each atom group for linearity of the sites
c     contained in the group
c
c
      subroutine grpline
      use atomid
      use atoms
      use group
      use rgddyn
      implicit none
      integer i,j,k,size
      integer start,stop
      real*8 xx,yy,zz
      real*8 x2,y2,z2
      real*8 eps,det
      real*8 weigh
      real*8 rcm(3)
      real*8 inert(6)
      real*8, allocatable :: xcm(:)
      real*8, allocatable :: ycm(:)
      real*8, allocatable :: zcm(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xcm(n))
      allocate (ycm(n))
      allocate (zcm(n))
c
c     get atomic coordinates relative to group center of mass
c
      do i = 1, ngrp
         start = igrp(1,i)
         stop = igrp(2,i)
         do j = 1, 3
            rcm(j) = 0.0d0
         end do
         do j = start, stop
            k = kgrp(j)
            weigh = mass(k)
            rcm(1) = rcm(1) + x(k)*weigh
            rcm(2) = rcm(2) + y(k)*weigh
            rcm(3) = rcm(3) + z(k)*weigh
         end do
         weigh = max(1.0d0,grpmass(i))
         do j = 1, 3
            rcm(j) = rcm(j) / weigh
         end do
         do j = start, stop
            k = kgrp(j)
            xcm(k) = x(k) - rcm(1)
            ycm(k) = y(k) - rcm(2)
            zcm(k) = z(k) - rcm(3)
         end do
      end do
c
c     compute the moments of inertia and check for linearity
c
      eps = 1.0d-8
      do i = 1, ngrp
         size = igrp(2,i) - igrp(1,i) + 1
         linear(i) = .false.
         if (size .eq. 2) then
            linear(i) = .true.
         else if (size .gt. 2) then
            do j = 1, 6
               inert(j) = 0.0d0
            end do
            do j = igrp(1,i), igrp(2,i)
               k = kgrp(j)
               xx = xcm(k)
               yy = ycm(k)
               zz = zcm(k)
               x2 = xx * xx
               y2 = yy * yy
               z2 = zz * zz
               weigh = mass(k)
               inert(1) = inert(1) + weigh*(y2+z2)
               inert(2) = inert(2) - weigh*xx*yy
               inert(3) = inert(3) + weigh*(x2+z2)
               inert(4) = inert(4) - weigh*xx*zz
               inert(5) = inert(5) - weigh*yy*zz
               inert(6) = inert(6) + weigh*(x2+y2)
            end do
            det = inert(1)*inert(3)*inert(6)
     &               + 2.0d0*inert(2)*inert(5)*inert(4)
     &               - inert(3)*inert(4)*inert(4)
     &               - inert(1)*inert(5)*inert(5)
     &               - inert(2)*inert(2)*inert(6)
            if (abs(det) .lt. eps)  linear(i) = .true.
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xcm)
      deallocate (ycm)
      deallocate (zcm)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine gyrate  --  compute the radius of gyration  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "gyrate" computes the radius of gyration of a molecular system
c     from its atomic coordinates; only active atoms are included
c
c
      subroutine gyrate (rg)
      use atoms
      use usage
      implicit none
      integer i,k
      real*8 rg,xc,yc,zc
c
c
c     find the centroid of the atomic coordinates
c
      xc = 0.0d0
      yc = 0.0d0
      zc = 0.0d0
      do i = 1, nuse
         k = iuse(i)
         xc = xc + x(k)
         yc = yc + y(k)
         zc = zc + z(k)
      end do
      xc = xc / dble(nuse)
      yc = yc / dble(nuse)
      zc = zc / dble(nuse)
c
c     compute and print out the radius of gyration
c
      rg = 0.0d0
      do i = 1, nuse
         k = iuse(i)
         rg = rg + (x(k)-xc)**2 + (y(k)-yc)**2 + (z(k)-zc)**2
      end do
      rg = sqrt(rg/dble(nuse))
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module hescut  --  cutoff for Hessian matrix elements  ##
c     ##                                                         ##
c     #############################################################
c
c
c     hesscut   magnitude of smallest allowed Hessian element
c
c
      module hescut
      implicit none
      real*8 hesscut
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine hessian  --  atom-by-atom Hessian elements  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "hessian" calls subroutines to calculate the Hessian elements
c     for each atom in turn with respect to Cartesian coordinates
c
c
      subroutine hessian (h,hinit,hstop,hindex,hdiag)
      use atoms
      use couple
      use hescut
      use hessn
      use inform
      use iounit
      use limits
      use mpole
      use potent
      use usage
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,nhess
      integer hindex(*)
      integer hinit(3,*)
      integer hstop(3,*)
      real*8 rdn,cutoff
      real*8 hmax,percent
      real*8 h(*)
      real*8 hdiag(3,*)
      logical first
      logical, allocatable :: keep(:)
      save first
      data first  / .true. /
c
c
c     zero out total number of indexed Hessian elements
c
      nhess = 0
      do i = 1, n
         do j = 1, 3
            hinit(j,i) = 1
            hstop(j,i) = 0
            hdiag(j,i) = 0.0d0
         end do
      end do
c
c     update the pairwise interaction neighbor lists
c
      if (use_list)  call nblist
c
c     many implicit solvation models require Born radii
c
      if (use_born)  call born
c
c     alter partial charges and multipoles for charge flux
c
      if (use_chgflx)  call alterchg
c
c     modify bond and torsion constants for pisystem
c
      if (use_orbit)  call picalc
c
c     compute the induced dipoles at polarizable atoms
c
      if (use_polar) then
         call chkpole
         call rotpole ('MPOLE')
         call induce
      end if
c
c     calculate the reduced atomic coordinates
c
      if (use_vdw) then
         do i = 1, n
            ii = ired(i)
            rdn = kred(i)
            xred(i) = rdn*(x(i)-x(ii)) + x(ii)
            yred(i) = rdn*(y(i)-y(ii)) + y(ii)
            zred(i) = rdn*(z(i)-z(ii)) + z(ii)
         end do
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (first) then
         first = .false.
         if (.not. allocated(hessx))  allocate (hessx(3,n))
         if (.not. allocated(hessy))  allocate (hessy(3,n))
         if (.not. allocated(hessz))  allocate (hessz(3,n))
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (keep(n))
c
c     zero out the Hessian elements for the current atom
c
      do i = 1, n
         if (use(i)) then
            do k = 1, n
               do j = 1, 3
                  hessx(j,k) = 0.0d0
                  hessy(j,k) = 0.0d0
                  hessz(j,k) = 0.0d0
               end do
            end do
c
c     remove any previous use of the replicates method
c
            cutoff = 0.0d0
            call replica (cutoff)
c
c     call the local geometry Hessian component routines
c
            if (use_bond)  call ebond2 (i)
            if (use_angle)  call eangle2 (i)
            if (use_strbnd)  call estrbnd2 (i)
            if (use_urey)  call eurey2 (i)
            if (use_angang)  call eangang2 (i)
            if (use_opbend)  call eopbend2 (i)
            if (use_opdist)  call eopdist2 (i)
            if (use_improp)  call eimprop2 (i)
            if (use_imptor)  call eimptor2 (i)
            if (use_tors)  call etors2 (i)
            if (use_pitors)  call epitors2 (i)
            if (use_strtor)  call estrtor2 (i)
            if (use_angtor)  call eangtor2 (i)
            if (use_tortor)  call etortor2 (i)
c
c     call the electrostatic Hessian component routines
c
            if (use_charge)  call echarge2 (i)
            if (use_chgdpl)  call echgdpl2 (i)
            if (use_dipole)  call edipole2 (i)
            if (use_mpole)  call empole2 (i)
            if (use_polar)  call epolar2 (i)
            if (use_chgtrn)  call echgtrn2 (i)
            if (use_rxnfld)  call erxnfld2 (i)
c
c     call the van der Waals Hessian component routines
c
            if (use_vdw) then
               if (vdwtyp .eq. 'LENNARD-JONES')  call elj2 (i)
               if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck2 (i)
               if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb2 (i)
               if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal2 (i)
               if (vdwtyp .eq. 'GAUSSIAN')  call egauss2 (i)
            end if
            if (use_repel)  call erepel2 (i)
            if (use_disp)  call edisp2 (i)
c
c     call any miscellaneous Hessian component routines
c
            if (use_solv)  call esolv2 (i)
            if (use_metal)  call emetal2 (i)
            if (use_geom)  call egeom2 (i)
            if (use_extra)  call extra2 (i)
c
c     set the diagonal Hessian matrix elements
c
            hdiag(1,i) = hdiag(1,i) + hessx(1,i)
            hdiag(2,i) = hdiag(2,i) + hessy(2,i)
            hdiag(3,i) = hdiag(3,i) + hessz(3,i)
c
c     search each 3x3 block to see which blocks will be kept
c
            do k = i+1, n
               keep(k) = .false.
               if (use(k)) then
                  hmax = max(abs(hessx(1,k)),abs(hessx(2,k)),
     &                       abs(hessx(3,k)),abs(hessy(1,k)),
     &                       abs(hessy(2,k)),abs(hessy(3,k)),
     &                       abs(hessz(1,k)),abs(hessz(2,k)),
     &                       abs(hessz(3,k)))
                  if (hmax .ge. hesscut)  keep(k) = .true.
               end if
            end do
c
c     copy selected off-diagonal Hessian elements for current
c     atom into an indexed master list of Hessian elements;
c     if any elements of 3x3 block are kept, keep them all
c
            hinit(1,i) = nhess + 1
            do j = 2, 3
               nhess = nhess + 1
               hindex(nhess) = 3*i + j - 3
               h(nhess) = hessx(j,i)
            end do
            do k = i+1, n
               if (keep(k)) then
                  do j = 1, 3
                     nhess = nhess + 1
                     hindex(nhess) = 3*k + j - 3
                     h(nhess) = hessx(j,k)
                  end do
               end if
            end do
            hstop(1,i) = nhess
            hinit(2,i) = nhess + 1
            nhess = nhess + 1
            hindex(nhess) = 3*i
            h(nhess) = hessy(3,i)
            do k = i+1, n
               if (keep(k)) then
                  do j = 1, 3
                     nhess = nhess + 1
                     hindex(nhess) = 3*k + j - 3
                     h(nhess) = hessy(j,k)
                  end do
               end if
            end do
            hstop(2,i) = nhess
            hinit(3,i) = nhess + 1
            do k = i+1, n
               if (keep(k)) then
                  do j = 1, 3
                     nhess = nhess + 1
                     hindex(nhess) = 3*k + j - 3
                     h(nhess) = hessz(j,k)
                  end do
               end if
            end do
            hstop(3,i) = nhess
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (keep)
c
c     print message telling how much storage was finally used
c
      if (verbose) then
         percent = 100.0d0 * dble(nhess)/dble(3*n*(3*n-1)/2)
         write (iout,10)  nhess,percent
   10    format (' HESSIAN  --',i11,' Elements',f9.2,
     &              ' % Off-Diag Hessian Storage')
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module hessn  --  Cartesian Hessian elements for one atom  ##
c     ##                                                             ##
c     #################################################################
c
c
c     hessx   Hessian elements for x-component of current atom
c     hessy   Hessian elements for y-component of current atom
c     hessz   Hessian elements for z-component of current atom
c
c
      module hessn
      implicit none
      real*8, allocatable :: hessx(:,:)
      real*8, allocatable :: hessy(:,:)
      real*8, allocatable :: hessz(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine hessrgd  --  rigid body Hessian elements  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "hessrgd" computes the numerical Hessian elements with
c     respect to rigid body coordinates via 6*ngroup+1 gradient
c     evaluations
c
c
      subroutine hessrgd (hrigid)
      use atoms
      use group
      use rigid
      implicit none
      integer i,j,k,m,nvar
      real*8 e,eps,old
      real*8 hrigid(6*ngrp,*)
      real*8, allocatable :: g(:,:)
      real*8, allocatable :: g0(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (g(6,ngrp))
      allocate (g0(6,ngrp))
c
c     calculate base values for the rigid body gradient
c
      eps = 0.00001d0
      call gradrgd (e,g0)
c
c     compute one-sided numerical Hessian from gradient values;
c     set off-diagonal elements to the average symmetric value
c
      nvar = 6 * ngrp
      do i = 1, nvar
         j = (i-1)/6 + 1
         k = mod(i-1,6) + 1
         old = rbc(k,j)
         rbc(k,j) = rbc(k,j) + eps
         call rigidxyz
         call gradrgd (e,g)
         rbc(k,j) = old
         do m = 1, nvar
            j = (m-1)/6 + 1
            k = mod(m-1,6) + 1
            hrigid(m,i) = (g(k,j)-g0(k,j)) / eps
         end do
         do m = 1, i-1
            hrigid(m,i) = 0.5d0 * (hrigid(m,i)+hrigid(i,m))
            hrigid(i,m) = hrigid(m,i)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (g)
      deallocate (g0)
c
c     restore the Cartesian coordinates to original values
c
      call rigidxyz
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine hessrot  --  torsional Hessian elements  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "hessrot" computes numerical Hessian elements with respect
c     to torsional angles; either the diagonal or the full matrix
c     can be calculated; the full matrix needs nomega+1 gradient
c     evaluations while the diagonal needs just two evaluations
c
c
      subroutine hessrot (mode,hrot)
      use omega
      use math
      use zcoord
      implicit none
      integer i,j,line
      real*8 e,eps
      real*8, allocatable :: g(:)
      real*8, allocatable :: g0(:)
      real*8, allocatable :: old(:)
      real*8 hrot(nomega,*)
      character*4 mode
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (g(nomega))
      allocate (g0(nomega))
      allocate (old(nomega))
c
c     calculate base values for the torsional gradient
c
      eps = 0.0001d0
      call gradrot (e,g0)
c
c     compute one-sided numerical Hessian from gradient values;
c     set off-diagonal elements to the average symmetric value
c
      if (mode .eq. 'FULL') then
         do i = 1, nomega
            line = zline(i)
            old(i) = ztors(line)
            ztors(line) = ztors(line) + radian*eps
            call makexyz
            call gradrot (e,g)
            ztors(line) = old(i)
            do j = 1, nomega
               hrot(j,i) = (g(j)-g0(j)) / eps
            end do
            do j = 1, i-1
               hrot(j,i) = 0.5d0 * (hrot(j,i)+hrot(i,j))
               hrot(i,j) = hrot(j,i)
            end do
         end do
c
c     compute numerical Hessian diagonal from gradient values
c
      else if (mode .eq. 'DIAG') then
         do i = 1, nomega
            line = zline(i)
            old(i) = ztors(line)
            ztors(line) = ztors(line) + radian*eps
         end do
         call makexyz
         call gradrot (e,g)
         do i = 1, nomega
            hrot(i,i) = (g(i)-g0(i)) / eps
            line = zline(i)
            ztors(line) = old(i)
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (g)
      deallocate (g0)
      deallocate (old)
c
c     restore the Cartesian coordinates to original values
c
      call makexyz
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2010  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module hpmf  --  hydrophobic potential of mean force term  ##
c     ##                                                             ##
c     #################################################################
c
c
c     rcarbon      radius of a carbon atom for use with HPMF
c     rwater       radius of a water molecule for use with HPMF
c     acsurf       surface area of a hydrophobic carbon atom
c     safact       constant for calculation of atomic surface area
c     tgrad        tanh slope (set very steep, default=100)
c     toffset      shift the tanh plot along the x-axis (default=6)
c     hpmfcut      cutoff distance for pairwise HPMF interactions
c     hd1,hd2,hd3  hydrophobic PMF well depth parameter
c     hc1,hc2,hc3  hydrophobic PMF well center point
c     hw1,hw2,hw3  reciprocal of the hydrophobic PMF well width
c
c     npmf         number of hydrophobic carbon atoms in the system
c     ipmf         number of the atom for each HPMF carbon atom site
c     rpmf         radius of each atom for use with hydrophobic PMF
c     acsa         SASA value for each hydrophobic PMF carbon atom
c
c
      module hpmf
      implicit none
      real*8 rcarbon,rwater
      real*8 acsurf,safact
      real*8 tgrad,toffset
      real*8 hpmfcut
      real*8 hd1,hd2,hd3
      real*8 hc1,hc2,hc3
      real*8 hw1,hw2,hw3
      parameter (rcarbon=1.7d0)
      parameter (rwater=1.4d0)
      parameter (acsurf=120.7628d0)
      parameter (safact=0.3516d0)
      parameter (tgrad=100.0d0)
      parameter (toffset=6.0d0)
      parameter (hpmfcut=11.0d0)
      parameter (hd1=-0.7308004860404441194d0)
      parameter (hd2=0.2001645051578760659d0)
      parameter (hd3=-0.0905499953418473502d0)
      parameter (hc1=3.8167879266271396155d0)
      parameter (hc2=5.4669162286016419472d0)
      parameter (hc3=7.1167694861385353278d0)
      parameter (hw1=1.6858993102248638341d0)
      parameter (hw2=1.3906405621629980285d0)
      parameter (hw3=1.5741657341338335385d0)
      integer npmf
      integer, allocatable :: ipmf(:)
      real*8, allocatable :: rpmf(:)
      real*8, allocatable :: acsa(:)
      save
      end
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
      use iounit
      use mutant
      implicit none
c
c
c     set the potential energy parameters for hybrid atoms
c
      if (nmut .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
      use atomid
      use atoms
      use inform
      use iounit
      use katoms
      use mutant
      implicit none
      integer i,k,ntype
      integer it,it0,it1
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+nmut) 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, nmut
         k = imut(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)
         valnum(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 hybrid bond stretch parameters given
c     an initial state, final state and "lambda" value
c
c
      subroutine hbond
      use atomid
      use atoms
      use bndstr
      use iounit
      use inform
      use kbonds
      use mutant
      implicit none
      integer i,j,k
      integer ia,ib
      integer ita,itb
      integer size
      real*8 bk0,bk1
      real*8 bl0,bl1
      logical header
      character*4 pa,pb
      character*8 pt
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 (mut(ia) .or. mut(ib)) then
            ita = class(ia)
            itb = class(ib)
c
c     find the bond parameters for the initial state
c
            do j = 1, nmut
               k = imut(j)
               if (k .eq. ia)  ita = class0(j)
               if (k .eq. ib)  itb = class0(j)
            end do
            size = 4
            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 = bcon(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, nmut
               k = imut(j)
               if (k .eq. ia)  ita = class1(j)
               if (k .eq. ib)  itb = class1(j)
            end do
            size = 4
            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 = bcon(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 hybrid angle bending parameters given
c     an initial state, final state and "lambda" value
c
c
      subroutine hangle
      use angbnd
      use atomid
      use atoms
      use iounit
      use inform
      use kangs
      use mutant
      implicit none
      integer i,j,k,size
      integer ia,ib,ic
      integer ita,itb,itc
      real*8 ak0,ak1
      real*8 anat0,anat1
      logical header
      character*4 pa,pb,pc
      character*12 pt
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 (mut(ia) .or. mut(ib) .or. mut(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, nmut
               k = imut(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 = 4
            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
            ak0 = 0.0d0
            anat0 = 0.0d0
            do j = 1, maxna
               if (ka(j) .eq. pt) then
                  ak0 = acon(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, nmut
               k = imut(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 = 4
            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
            ak1 = 0.0d0
            anat1 = 0.0d0
            do j = 1, maxna
               if (ka(j) .eq. pt) then
                  ak1 = acon(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
            ak(i) = lambda*ak1 + (1.0d0-lambda)*ak0
            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,ak(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 hybrid stretch-bend parameters given
c     an initial state, final state and "lambda" value
c
c
      subroutine hstrbnd
      use angbnd
      use atmlst
      use atomid
      use atoms
      use couple
      use iounit
      use inform
      use katoms
      use kstbnd
      use mutant
      use strbnd
      implicit none
      integer i,j,k,size
      integer ia,ib,ic
      integer ita,itb,itc
      integer nba,nbc
      real*8 sbk0(2),sbk1(2)
      logical header,used
      character*4 pa,pb,pc
      character*12 pt
c
c
c     assign hybrid parameters for the stretch-bend sites
c
      header = .true.
      do i = 1, nangle
         used = .false.
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         if (mut(ia) .or. mut(ib) .or. mut(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, nmut
               k = imut(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 = 4
            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
            sbk0(1) = 0.0d0
            sbk0(2) = 0.0d0
            do j = 1, maxnsb
               if (ksb(j) .eq. pt) then
                  used = .true.
                  if (ita .le. itc) then
                     sbk0(1) = stbn(1,j)
                     sbk0(2) = stbn(2,j)
                  else
                     sbk0(1) = stbn(2,j)
                     sbk0(2) = stbn(1,j)
                  end if
                  goto 10
               end if
            end do
   10       continue
c
c     find the stretch-bend parameters for the final state
c
            do j = 1, nmut
               k = imut(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 = 4
            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
            sbk1(1) = 0.0d0
            sbk1(2) = 0.0d0
            do j = 1, maxnsb
               if (ksb(j) .eq. pt) then
                  used = .true.
                  if (ita .le. itc) then
                     sbk1(1) = stbn(1,j)
                     sbk1(2) = stbn(2,j)
                  else
                     sbk1(1) = stbn(2,j)
                     sbk1(2) = stbn(1,j)
                  end if
                  goto 20
               end if
            end do
   20       continue
c
c     form hybrid parameters for the current stretch-bend
c
            if (used) then
               nstrbnd = nstrbnd + 1
               k = nstrbnd
               isb(1,k) = i
               isb(2,k) = nba
               isb(3,k) = nbc
               sbk(1,k) = lambda*sbk1(1) + (1.0d0-lambda)*sbk0(1)
               sbk(2,k) = lambda*sbk1(2) + (1.0d0-lambda)*sbk0(2)
               if (verbose) then
                  if (header) then
                     header = .false.
                     write (iout,30)
   30                format (/,' Hybrid Stretch-Bend Parameters :',
     &                       //,6x,'Atom Numbers',8x,'KSB 1',
     &                          7x,'KSB 2',/)
                  end if
                  write (iout,40)  ia,ib,ic,sbk(1,i),sbk(2,i)
   40             format (3x,3i5,2f12.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 hybrid improper torsional parameters
c     given an initial state, final state and "lambda" value
c
c     note this version does not handle multiple parameters at
c     a single trigonal site
c
c
      subroutine himptor
      use atomid
      use atoms
      use couple
      use iounit
      use inform
      use imptor
      use kitors
      use math
      use mutant
      implicit none
      integer i,j,k
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer nti,size
      real*8 angle,symm
      real*8 v1_0,v2_0,v3_0
      real*8 s1_0,s2_0,s3_0
      real*8 v1_1,v2_1,v3_1
      real*8 s1_1,s2_1,s3_1
      logical header,used
      character*4 pa,pb,pc,pd
      character*4 zeros
      character*16 blank
      character*16 pt0,pt(6)
c
c
c     construct hybrid improper torsion parameters
c
      blank = '                '
      zeros = '0000'
      header = .true.
c
c     determine the total number of forcefield parameters
c
      nti = maxnti
      do i = maxnti, 1, -1
         if (kti(i) .eq. blank)  nti = i - 1
      end do
c
c     construct hybrid improper torsion parameters
c
      do i = 1, n
         if (n12(i) .eq. 3) then
            used = .false.
            ia = i12(1,i)
            ib = i12(2,i)
            ic = i
            id = i12(3,i)
            if (mut(ia) .or. mut(ib) .or. mut(ic) .or. mut(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, nmut
                  k = imut(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 = 4
               call numeral (ita,pa,size)
               call numeral (itb,pb,size)
               call numeral (itc,pc,size)
               call numeral (itd,pd,size)
               pt(1) = pa//pb//pc//pd
               pt(2) = pb//pa//pc//pd
               pt(3) = pa//pd//pc//pb
               pt(4) = pd//pa//pc//pb
               pt(5) = pb//pd//pc//pa
               pt(6) = pd//pb//pc//pa
               pt0 = zeros//zeros//pc//zeros
               symm = 1.0d0
               if (pa.eq.pb .or. pa.eq.pd .or. pb.eq.pd)  symm = 2.0d0
               if (pa.eq.pb .and. pa.eq.pd .and. pb.eq.pd)  symm = 6.0d0
               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, nti
                  if (kti(j)(9:12) .eq. pc) then
                     do k = 1, 6
                        if (kti(j) .eq. pt(k)) then
                           used = .true.
                           v1_0 = ti1(1,j) / symm
                           s1_0 = ti1(2,j)
                           v2_0 = ti2(1,j) / symm
                           s2_0 = ti2(2,j)
                           v3_0 = ti3(1,j) / symm
                           s3_0 = ti3(2,j)
                           goto 10
                        end if
                     end do
                  end if
               end do
               do j = 1, nti
                  if (kti(j) .eq. pt0) then
                     used = .true.
                     v1_0 = ti1(1,j) / symm
                     s1_0 = ti1(2,j)
                     v2_0 = ti2(1,j) / symm
                     s2_0 = ti2(2,j)
                     v3_0 = ti3(1,j) / symm
                     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, nmut
                  k = imut(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 = 4
               call numeral (ita,pa,size)
               call numeral (itb,pb,size)
               call numeral (itc,pc,size)
               call numeral (itd,pd,size)
               pt(1) = pa//pb//pc//pd
               pt(2) = pb//pa//pc//pd
               pt(3) = pa//pd//pc//pb
               pt(4) = pd//pa//pc//pb
               pt(5) = pb//pd//pc//pa
               pt(6) = pd//pb//pc//pa
               pt0 = zeros//zeros//pc//zeros
               symm = 1.0d0
               if (pa.eq.pb .or. pa.eq.pd .or. pb.eq.pd)  symm = 2.0d0
               if (pa.eq.pb .and. pa.eq.pd .and. pb.eq.pd)  symm = 6.0d0
               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, nti
                  if (kti(j)(9:12) .eq. pc) then
                     do k = 1, 6
                        if (kti(j) .eq. pt(k)) then
                           used = .true.
                           v1_1 = ti1(1,j) / symm
                           s1_1 = ti1(2,j)
                           v2_1 = ti2(1,j) / symm
                           s2_1 = ti2(2,j)
                           v3_1 = ti3(1,j) / symm
                           s3_1 = ti3(2,j)
                           goto 20
                        end if
                     end do
                  end if
               end do
               do j = 1, nti
                  if (kti(j) .eq. pt0) then
                     used = .true.
                     v1_1 = ti1(1,j) / symm
                     s1_1 = ti1(2,j)
                     v2_1 = ti2(1,j) / symm
                     s2_1 = ti2(2,j)
                     v3_1 = ti3(1,j) / symm
                     s3_1 = ti3(2,j)
                     goto 20
                  end if
               end do
   20          continue
c
c     form hybrid parameters for the current improper torsion
c
               if (used) then
                  do j = 1, nitors
                     if (iitors(3,j) .eq. ic) then
                        k = j
                        goto 30
                     end if
                  end do
                  nitors = nitors + 1
                  k = nitors
                  iitors(1,k) = ia
                  iitors(2,k) = ib
                  iitors(3,k) = ic
                  iitors(4,k) = id
   30             continue
                  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
                  angle = itors1(2,k) / radian
                  itors1(3,k) = cos(angle)
                  itors1(4,k) = sin(angle)
                  itors2(1,k) = lambda*v2_1 + (1.0d0-lambda)*v2_0
                  itors2(2,k) = lambda*s2_1 + (1.0d0-lambda)*s2_0
                  angle = itors2(2,k) / radian
                  itors2(3,k) = cos(angle)
                  itors2(4,k) = sin(angle)
                  itors3(1,k) = lambda*v3_1 + (1.0d0-lambda)*v3_0
                  itors3(2,k) = lambda*s3_1 + (1.0d0-lambda)*s3_0
                  angle = itors3(2,k) / radian
                  itors3(3,k) = cos(angle)
                  itors3(4,k) = sin(angle)
                  if (verbose) 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
                     ia = iitors(1,i)
                     ib = iitors(2,i)
                     ic = iitors(3,i)
                     id = iitors(4,i)
                     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.1))
                  end if
               end if
            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 hybrid torsional parameters for a given
c     initial state, final state and "lambda" value
c
c
      subroutine htors
      use atomid
      use atoms
      use inform
      use iounit
      use ktorsn
      use math
      use mutant
      use tors
      implicit none
      integer i,j,k,size
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      real*8 angle
      real*8 v1_0,v2_0,v3_0
      real*8 v4_0,v5_0,v6_0
      real*8 s1_0,s2_0,s3_0
      real*8 s4_0,s5_0,s6_0
      real*8 v1_1,v2_1,v3_1
      real*8 v4_1,v5_1,v6_1
      real*8 s1_1,s2_1,s3_1
      real*8 s4_1,s5_1,s6_1
      logical header
      character*4 pa,pb,pc,pd
      character*4 zeros
      character*16 pt,pt0
c
c
c     construct hybrid torsional parameters
c
      zeros = '0000'
      header = .true.
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         if (mut(ia) .or. mut(ib) .or. mut(ic) .or. mut(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, nmut
               k = imut(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 = 4
            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
            pt0 = zeros//pt(5:12)//zeros
            v1_0 = 0.0d0
            s1_0 = 0.0d0
            v2_0 = 0.0d0
            s2_0 = 0.0d0
            v3_0 = 0.0d0
            s3_0 = 0.0d0
            v4_0 = 0.0d0
            s4_0 = 0.0d0
            v5_0 = 0.0d0
            s5_0 = 0.0d0
            v6_0 = 0.0d0
            s6_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)
                  v4_0 = t4(1,j)
                  s4_0 = t4(2,j)
                  v5_0 = t5(1,j)
                  s5_0 = t5(2,j)
                  v6_0 = t6(1,j)
                  s6_0 = t6(2,j)
                  goto 10
               end if
            end do
            do j = 1, maxnt
               if (kt(j) .eq. pt0) 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)
                  v4_0 = t4(1,j)
                  s4_0 = t4(2,j)
                  v5_0 = t5(1,j)
                  s5_0 = t5(2,j)
                  v6_0 = t6(1,j)
                  s6_0 = t6(2,j)
                  goto 10
               end if
            end do
   10       continue
c
c     find the torsion parameters for the final state
c
            do j = 1, nmut
               k = imut(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 = 4
            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
            pt0 = zeros//pt(5:12)//zeros
            v1_1 = 0.0d0
            s1_1 = 0.0d0
            v2_1 = 0.0d0
            s2_1 = 0.0d0
            v3_1 = 0.0d0
            s3_1 = 0.0d0
            v4_1 = 0.0d0
            s4_1 = 0.0d0
            v5_1 = 0.0d0
            s5_1 = 0.0d0
            v6_1 = 0.0d0
            s6_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)
                  v4_1 = t4(1,j)
                  s4_1 = t4(2,j)
                  v5_1 = t5(1,j)
                  s5_1 = t5(2,j)
                  v6_1 = t6(1,j)
                  s6_1 = t6(2,j)
                  goto 20
               end if
            end do
            do j = 1, maxnt
               if (kt(j) .eq. pt0) 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)
                  v4_1 = t4(1,j)
                  s4_1 = t4(2,j)
                  v5_1 = t5(1,j)
                  s5_1 = t5(2,j)
                  v6_1 = t6(1,j)
                  s6_1 = t6(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 (s4_0 .eq. 0.0d0)  s4_0 = s4_1
            if (s5_0 .eq. 0.0d0)  s5_0 = s5_1
            if (s6_0 .eq. 0.0d0)  s6_0 = s6_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
            if (s4_1 .eq. 0.0d0)  s4_1 = s4_0
            if (s5_1 .eq. 0.0d0)  s5_1 = s5_0
            if (s6_1 .eq. 0.0d0)  s6_1 = s6_0
            tors1(1,i) = lambda*v1_1 + (1.0d0-lambda)*v1_0
            tors1(2,i) = lambda*s1_1 + (1.0d0-lambda)*s1_0
            angle = tors1(2,i) / radian
            tors1(3,i) = cos(angle)
            tors1(4,i) = sin(angle)
            tors2(1,i) = lambda*v2_1 + (1.0d0-lambda)*v2_0
            tors2(2,i) = lambda*s2_1 + (1.0d0-lambda)*s2_0
            angle = tors2(2,i) / radian
            tors2(3,i) = cos(angle)
            tors2(4,i) = sin(angle)
            tors3(1,i) = lambda*v3_1 + (1.0d0-lambda)*v3_0
            tors3(2,i) = lambda*s3_1 + (1.0d0-lambda)*s3_0
            angle = tors3(2,i) / radian
            tors3(3,i) = cos(angle)
            tors3(4,i) = sin(angle)
            tors4(1,i) = lambda*v4_1 + (1.0d0-lambda)*v4_0
            tors4(2,i) = lambda*s4_1 + (1.0d0-lambda)*s4_0
            angle = tors4(2,i) / radian
            tors4(3,i) = cos(angle)
            tors4(4,i) = sin(angle)
            tors5(1,i) = lambda*v5_1 + (1.0d0-lambda)*v5_0
            tors5(2,i) = lambda*s5_1 + (1.0d0-lambda)*s5_0
            angle = tors5(2,i) / radian
            tors5(3,i) = cos(angle)
            tors5(4,i) = sin(angle)
            tors6(1,i) = lambda*v6_1 + (1.0d0-lambda)*v6_0
            tors6(2,i) = lambda*s6_1 + (1.0d0-lambda)*s6_0
            angle = tors6(2,i) / radian
            tors6(3,i) = cos(angle)
            tors6(4,i) = sin(angle)
            if (verbose) then
               if (header) then
                  header = .false.
                  write (iout,30)
   30             format (/,' Hybrid Torsional Parameters :',
     &                    //,5x,'Atom Numbers',6x,'KT1',7x,'KT2',
     &                       7x,'KT3',7x,'KT4',7x,'KT5',7x,'KT6',/)
               end if
               write (iout,40)  ia,ib,ic,id,
     &                          tors1(1,i),nint(tors1(2,i)),
     &                          tors2(1,i),nint(tors2(2,i)),
     &                          tors3(1,i),nint(tors3(2,i)),
     &                          tors4(1,i),nint(tors4(2,i)),
     &                          tors5(1,i),nint(tors5(2,i)),
     &                          tors6(1,i),nint(tors6(2,i))
   40          format (1x,4i4,1x,6(f6.2,i4))
            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 hybrid stretch-torsion parameters
c     given an initial state, final state and "lambda" value
c
c
      subroutine hstrtor
      use atmlst
      use atomid
      use atoms
      use couple
      use inform
      use iounit
      use ksttor
      use mutant
      use strtor
      use tors
      implicit none
      integer i,j,k,size
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      real*8 kst0(3),kst1(3)
      logical header
      character*4 pa,pb,pc,pd
      character*4 zeros
      character*16 pt,pt0
c
c
c     assign hybrid parameters for the stretch-torsion sites
c
      zeros = '0000'
      header = .true.
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         if (mut(ia) .or. mut(ib) .or. mut(ic) .or. mut(id)) then
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            itd = class(id)
c
c     find the stretch-torsion parameters for the initial state
c
            do j = 1, nmut
               k = imut(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 = 4
            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
            pt0 = zeros//pt(5:12)//zeros
            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
            do j = 1, maxnbt
               if (kbt(j) .eq. pt0) 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, nmut
               k = imut(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 = 4
            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
            pt0 = zeros//pt(5:12)//zeros
            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
            do j = 1, maxnbt
               if (kbt(j) .eq. pt0) 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 hybrid van der Waals  parameters given
c     an initial state, final state and "lambda" value
c
c
      subroutine hvdw
      use atomid
      use atoms
      use inform
      use iounit
      use kvdws
      use math
      use mutant
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer it,kt
      integer itm,ktm
      integer it0,it1
      integer nlist
      integer, allocatable :: list(:)
      real*8 radius,rd,ep
      real*8, allocatable :: srad(:)
      real*8, allocatable :: seps(:)
      logical header
c
c
c     assign the hybrid van der Waals parameters
c
      do j = 1, nmut
         i = imut(j)
         if (vdwindex .eq. 'TYPE') then
            it = type(i)
            it0 = type0(j)
            it1 = type1(j)
         else
            it = class(i)
            it0 = class0(j)
            it1 = class1(j)
         end if
         rad(it) = lambda*rad(it1) + (1.0d0-lambda)*rad(it0)
         eps(it) = lambda*eps(it1) + (1.0d0-lambda)*eps(it0)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (srad(maxtyp))
      allocate (seps(maxtyp))
      allocate (list(n))
c
c     get the square roots of the vdw radii and well depths
c
      do i = 1, maxclass
         srad(i) = sqrt(rad(i))
         seps(i) = sqrt(eps(i))
      end do
c
c     set type or class index into condensed pair matrices
c
      nlist = n
      do i = 1, n
         list(i) = 0
         if (vdwindex .eq. 'TYPE') then
            list(i) = type(i)
         else
            list(i) = class(i)
         end if
      end do
      call sort8 (nlist,list)
c
c     use combination rules to set pairwise vdw radii sums
c
      do j = 1, nmut
         i = imut(j)
         if (vdwindex .eq. 'TYPE') then
            it = type(i)
         else
            it = class(i)
         end if
         itm = mvdw(it)
         do k = 1, nlist
            kt = list(k)
            ktm = mvdw(kt)
            if (kt .ne. 0) then
               if (rad(it).eq.0.0d0 .and. rad(kt).eq.0.0d0) then
                  rd = 0.0d0
               else if (radrule(1:10) .eq. 'ARITHMETIC') then
                  rd = rad(it) + rad(kt)
               else if (radrule(1:9) .eq. 'GEOMETRIC') then
                  rd = 2.0d0*(srad(it)*srad(kt))
               else if (radrule(1:10) .eq. 'CUBIC-MEAN') then
                  rd = 2.0d0*(rad(it)**3+rad(kt)**3)
     &                    / (rad(it)**2+rad(kt)**2)
               else
                  rd = rad(it) + rad(kt)
               end if
            end if
            radmin(itm,ktm) = rd
            radmin(ktm,itm) = rd
         end do
      end do
c
c     use combination rules to set pairwise well depths
c
      do j = 1, nmut
         i = imut(j)
         if (vdwindex .eq. 'TYPE') then
            it = type(i)
         else
            it = class(i)
         end if
         itm = mvdw(it)
         do k = 1, nlist
            kt = list(k)
            ktm = mvdw(kt)
            if (kt .ne. 0) then
               if (eps(it).eq.0.0d0 .and. eps(kt).eq.0.0d0) then
                  ep = 0.0d0
               else if (epsrule(1:10) .eq. 'ARITHMETIC') then
                  ep = 0.5d0 * (eps(it) + eps(kt))
               else if (epsrule(1:9) .eq. 'GEOMETRIC') then
                  ep = seps(it) * seps(kt)
               else if (epsrule(1:8) .eq. 'HARMONIC') then
                  ep = 2.0d0 * (eps(it)*eps(kt)) / (eps(it)+eps(kt))
               else if (epsrule(1:3) .eq. 'HHG') then
                  ep = 4.0d0 * (eps(it)*eps(kt))
     &                    / (seps(it)+seps(kt))**2
               else
                  ep = seps(it) * seps(kt)
               end if
            end if
            epsilon(itm,ktm) = ep
            epsilon(ktm,itm) = ep
         end do
      end do
c
c     print the van der Waals parameters for hybrid atoms
c
      header = .true.
      do j = 1, nmut
         i = imut(j)
         if (vdwindex .eq. 'TYPE') then
            it = type(i)
         else
            it = class(i)
         end if
         if (verbose) then
            if (header) then
               header = .false.
               write (iout,10)
   10          format (/,' Hybrid van der Waals Parameters :',
     &                 //,5x,'Atom Number',14x,'Size',8x,'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,i6,7x,2f15.4)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (srad)
      deallocate (seps)
      deallocate (list)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine hcharge  --  find hybrid charge parameters  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "hcharge" constructs hybrid charge interaction parameters
c     given an initial state, final state and "lambda" value
c
c
      subroutine hcharge
      use atoms
      use charge
      use inform
      use iounit
      use kchrge
      use mutant
      implicit none
      integer i,j,k,kk
      integer it,it0,it1
      real*8 chg0,chg1
      real*8 hybchg
      logical header,used
c
c
c     assign the hybrid parameters for atomic charges
c
      header = .true.
      do j = 1, nmut
         used = .false.
         i = imut(j)
         it = type(i)
         it0 = type0(j)
         it1 = type1(j)
         chg0 = chg(it0)
         chg1 = chg(it1)
         hybchg = lambda*chg1 + (1.0d0-lambda)*chg0
         do kk = 1, nion
            k = iion(kk)
            if (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(i) = i
            pchg(i) = 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 :',
     &                 //,5x,'Atom Number',12x,'Charge',/)
            end if
            write (iout,30)  i,hybchg
   30       format (6x,i6,7x,f15.4)
         end if
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine hdipole  --  find hybrid dipole parameters  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "hdipole" constructs hybrid dipole interaction parameters
c     given an initial state, final state and "lambda" value
c
c
      subroutine hdipole
      use atoms
      use bndstr
      use dipole
      use inform
      use iounit
      use kdipol
      use mutant
      implicit none
      integer i,j,k
      integer ia,ib
      integer ita,itb
      integer size
      real*8 dpl0,dpl1,hybdpl
      real*8 pos0,pos1,hybpos
      logical header,used
      character*4 pa,pb
      character*8 blank,pt
c
c
c     assign the hybrid parameters for bond dipoles
c
      blank = '      '
      header = .true.
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         if (mut(ia) .or. mut(ib)) then
            ita = type(ia)
            itb = type(ib)
c
c     find the dipole parameters for the initial state
c
            do j = 1, nmut
               k = imut(j)
               if (k .eq. ia)  ita = type0(j)
               if (k .eq. ib)  itb = type0(j)
            end do
            size = 4
            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, nmut
               k = imut(j)
               if (k .eq. ia)  ita = type1(j)
               if (k .eq. ib)  itb = type1(j)
            end do
            size = 4
            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
c
c
c     ###############################################################
c     ##  COPYRIGHT (C) 2014 by Alex Albaugh & Jay William Ponder  ##
c     ##                    All Rights Reserved                    ##
c     ###############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module ielscf  --  extended Lagrangian induced dipoles  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     nfree_aux    total degrees of freedom for auxiliary dipoles
c     tautemp_aux  time constant for auxiliary Berendsen thermostat
c     kelvin_aux   target system temperature for auxiliary dipoles
c     uaux         auxiliary induced dipole value at each site
c     upaux        auxiliary shadow induced dipoles at each site
c     vaux         auxiliary induced dipole velocity at each site
c     vpaux        auxiliary shadow dipole velocity at each site
c     aaux         auxiliary induced dipole acceleration at each site
c     apaux        auxiliary shadow dipole acceleration at each site
c     use_ielscf   flag to use inertial extended Lagrangian method
c
c
      module ielscf
      implicit none
      integer nfree_aux
      real*8 tautemp_aux
      real*8 kelvin_aux
      real*8, allocatable :: uaux(:,:)
      real*8, allocatable :: upaux(:,:)
      real*8, allocatable :: vaux(:,:)
      real*8, allocatable :: vpaux(:,:)
      real*8, allocatable :: aaux(:,:)
      real*8, allocatable :: apaux(:,:)
      logical use_ielscf
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine image  --  compute the minimum image distance  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "image" takes the components of pairwise distance between two
c     points in a periodic box and converts to the components of the
c     minimum image distance
c
c     literature reference:
c
c     U. K. Deiters, "Efficient Coding of the Minimum Image Convention",
c     Zeitschrift fur Physikalische Chemie, 227, 345-352 (2013)
c
c     note the "do while" clauses below can be written using the "nint"
c     intrinsic, and both forms give the same value; for example:
c
c     do while (abs(xr) .gt. xbox2)
c        xr = xr - sign(xbox,xr)    vs.  xr = xr - xbox*nint(xr/xbox)
c     end do
c
c     which form is faster depends upon specific machine and compiler
c     combinations, and other implementations are also possible
c
c
      subroutine image (xr,yr,zr)
      use boxes
      use cell
      use math
      implicit none
      real*8 xr,yr,zr
      real*8 corr
c
c
c     for orthogonal lattice, find the desired image directly
c
      if (orthogonal) then
         do while (abs(xr) .gt. xcell2)
            xr = xr - sign(xcell,xr)
         end do
         do while (abs(yr) .gt. ycell2)
            yr = yr - sign(ycell,yr)
         end do
         do while (abs(zr) .gt. zcell2)
            zr = zr - sign(zcell,zr)
         end do
c
c     for monoclinic lattice, convert x and z to fractional,
c     find desired image, then translate back to Cartesian
c
      else if (monoclinic) then
         zr = zr / beta_sin
         xr = xr - zr*beta_cos
         do while (abs(xr) .gt. xcell2)
            xr = xr - sign(xcell,xr)
         end do
         do while (abs(yr) .gt. ycell2)
            yr = yr - sign(ycell,yr)
         end do
         do while (abs(zr) .gt. zcell2)
            zr = zr - sign(zcell,zr)
         end do
         xr = xr + zr*beta_cos
         zr = zr * beta_sin
c
c     for triclinic lattice, convert to fractional coordinates,
c     find image, then translate fractional back to Cartesian
c
      else if (triclinic) then
         zr = zr / gamma_term
         yr = (yr - zr*beta_term) / gamma_sin
         xr = xr - yr*gamma_cos - zr*beta_cos
         do while (abs(xr) .gt. xcell2)
            xr = xr - sign(xcell,xr)
         end do
         do while (abs(yr) .gt. ycell2)
            yr = yr - sign(ycell,yr)
         end do
         do while (abs(zr) .gt. zcell2)
            zr = zr - sign(zcell,zr)
         end do
         xr = xr + yr*gamma_cos + zr*beta_cos
         yr = yr*gamma_sin + zr*beta_term
         zr = zr * gamma_term
c
c     for truncated octahedron, remove the corner pieces
c
      else if (octahedron) then
         do while (abs(xr) .gt. xbox2)
            xr = xr - sign(xbox,xr)
         end do
         do while (abs(yr) .gt. ybox2)
            yr = yr - sign(ybox,yr)
         end do
         do while (abs(zr) .gt. zbox2)
            zr = zr - sign(zbox,zr)
         end do
         if (abs(xr)+abs(yr)+abs(zr) .gt. box34) then
            xr = xr - sign(xbox2,xr)
            yr = yr - sign(ybox2,yr)
            zr = zr - sign(zbox2,zr)
         end if
c
c     for rhombic dodecahedron, align along the x- and y-axes
c
      else if (dodecadron) then
         do while (abs(xr) .gt. xbox2)
            xr = xr - sign(xbox,xr)
         end do
         do while (abs(yr) .gt. ybox2)
            yr = yr - sign(ybox,yr)
         end do
         zr = zr - root2*zbox*nint(zr/(zbox*root2))
         corr = xbox2 * int(abs(xr/xbox)+abs(yr/ybox)
     &                        +abs(root2*zr/zbox))
         xr = xr - sign(corr,xr)
         yr = yr - sign(corr,yr)
         zr = zr - sign(corr,zr)*root2
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine imager  --  replicate minimum image distance  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "imager" takes the components of pairwise distance between
c     two points in the same or neighboring periodic boxes and
c     converts to the components of the minimum image distance
c
c
      subroutine imager (xr,yr,zr,i)
      use boxes
      use cell
      use math
      implicit none
      integer i
      real*8 xr,yr,zr
      real*8 xmove,ymove,zmove
      real*8 corr
c
c
c     set the distance to translate along each cell axis
c
      xmove = icell(1,i) * xbox
      ymove = icell(2,i) * ybox
      zmove = icell(3,i) * zbox
c
c     for orthogonal lattice, find the desired image directly
c
      if (orthogonal) then
         xr = xr + xmove
         do while (abs(xr) .gt. xcell2)
            xr = xr - sign(xcell,xr)
         end do
         yr = yr + ymove
         do while (abs(yr) .gt. ycell2)
            yr = yr - sign(ycell,yr)
         end do
         zr = zr + zmove
         do while (abs(zr) .gt. zcell2)
            zr = zr - sign(zcell,zr)
         end do
c
c     for monoclinic lattice, convert x and z to fractional,
c     find desired image, then translate back to Cartesian
c
      else if (monoclinic) then
         zr = zr / beta_sin
         xr = xr - zr*beta_cos
         xr = xr + xmove
         do while (abs(xr) .gt. xcell2)
            xr = xr - sign(xcell,xr)
         end do
         yr = yr + ymove
         do while (abs(yr) .gt. ycell2)
            yr = yr - sign(ycell,yr)
         end do
         zr = zr + zmove
         do while (abs(zr) .gt. zcell2)
            zr = zr - sign(zcell,zr)
         end do
         xr = xr + zr*beta_cos
         zr = zr * beta_sin
c
c     for triclinic lattice, convert to fractional coordinates,
c     find image, then translate fractional back to Cartesian
c
      else if (triclinic) then
         zr = zr / gamma_term
         yr = (yr - zr*beta_term) / gamma_sin
         xr = xr - yr*gamma_cos - zr*beta_cos
         xr = xr + xmove
         do while (abs(xr) .gt. xcell2)
            xr = xr - sign(xcell,xr)
         end do
         yr = yr + ymove
         do while (abs(yr) .gt. ycell2)
            yr = yr - sign(ycell,yr)
         end do
         zr = zr + zmove
         do while (abs(zr) .gt. zcell2)
            zr = zr - sign(zcell,zr)
         end do
         xr = xr + yr*gamma_cos + zr*beta_cos
         yr = yr*gamma_sin + zr*beta_term
         zr = zr * gamma_term
c
c     for truncated octahedron, remove the corner pieces
c
      else if (octahedron) then
         do while (abs(xr) .gt. xbox2)
            xr = xr - sign(xbox,xr)
         end do
         do while (abs(yr) .gt. ybox2)
            yr = yr - sign(ybox,yr)
         end do
         do while (abs(zr) .gt. zbox2)
            zr = zr - sign(zbox,zr)
         end do
         if (abs(xr)+abs(yr)+abs(zr) .gt. box34) then
            xr = xr - sign(xbox2,xr)
            yr = yr - sign(ybox2,yr)
            zr = zr - sign(zbox2,zr)
         end if
c
c     for rhombic dodecahedron, align along the x- and y-axes
c
      else if (dodecadron) then
         do while (abs(xr) .gt. xbox2)
            xr = xr - sign(xbox,xr)
         end do
         do while (abs(yr) .gt. ybox2)
            yr = yr - sign(ybox,yr)
         end do
         zr = zr - root2*zbox*nint(zr/(zbox*root2))
         corr = xbox2 * int(abs(xr/xbox)+abs(yr/ybox)
     &                        +abs(root2*zr/zbox))
         xr = xr - sign(corr,xr)
         yr = yr - sign(corr,yr)
         zr = zr - sign(corr,zr)*root2
      end if
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine imagen  --  fast minimum image magnitude  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "imagen" takes the components of pairwise distance between
c     two points and converts to the components of the minimum
c     image distance
c
c     note this is a fast version for use in computing the 3D
c     distance during neighbor list construction
c
c
      subroutine imagen (xr,yr,zr)
      use boxes
      use math
      implicit none
      real*8 xr,yr,zr
      real*8 corr
c
c
c     for orthogonal lattice, find the desired image directly
c
      if (orthogonal) then
         xr = xr - xbox*nint(xr/xbox)
         yr = yr - ybox*nint(yr/ybox)
         zr = zr - zbox*nint(zr/zbox)
c
c     for monoclinic lattice, convert x and z to fractional,
c     find desired image, then translate back to Cartesian
c
      else if (monoclinic) then
         zr = zr / beta_sin
         xr = xr - zr*beta_cos
         xr = xr - xbox*nint(xr/xbox)
         yr = yr - ybox*nint(yr/ybox)
         zr = zr - zbox*nint(zr/zbox)
         xr = xr + zr*beta_cos
         zr = zr * beta_sin
c
c     for triclinic lattice, convert to fractional coordinates,
c     find image, then translate fractional back to Cartesian
c
      else if (triclinic) then
         zr = zr / gamma_term
         yr = (yr - zr*beta_term) / gamma_sin
         xr = xr - yr*gamma_cos - zr*beta_cos
         xr = xr - xbox*nint(xr/xbox)
         yr = yr - ybox*nint(yr/ybox)
         zr = zr - zbox*nint(zr/zbox)
         xr = xr + yr*gamma_cos + zr*beta_cos
         yr = yr*gamma_sin + zr*beta_term
         zr = zr * gamma_term
c
c     for truncated octahedron, remove the corner pieces
c
      else if (octahedron) then
         xr = xr - xbox*nint(xr/xbox)
         yr = yr - ybox*nint(yr/ybox)
         zr = zr - zbox*nint(zr/zbox)
         if (abs(xr)+abs(yr)+abs(zr) .gt. box34) then
            xr = xr - sign(xbox2,xr)
            yr = yr - sign(ybox2,yr)
            zr = zr - sign(zbox2,zr)
         end if
c
c     for rhombic dodecahedron, align along the x- and y-axes
c
      else if (dodecadron) then
         xr = xr - xbox*nint(xr/xbox)
         yr = yr - ybox*nint(yr/ybox)
         zr = zr - root2*zbox*nint(zr/(zbox*root2))
         corr = xbox2 * int(abs(xr/xbox)+abs(yr/ybox)
     &                        +abs(root2*zr/zbox))
         xr = xr - sign(corr,xr)
         yr = yr - sign(corr,yr)
         zr = zr - sign(corr,zr)*root2
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine impose  --  superimpose two coordinate sets  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "impose" performs the least squares best superposition
c     of two atomic coordinate sets via a quaternion method;
c     upon return, the first coordinate set is unchanged while
c     the second set is translated and rotated to give best fit;
c     the final root mean square fit is returned in "rmsvalue"
c
c
      subroutine impose (n1,x1,y1,z1,n2,x2,y2,z2,rmsvalue)
      use align
      use inform
      use iounit
      implicit none
      integer i,n1,n2,nmax
      real*8 xmid,ymid,zmid
      real*8 rmsvalue,rmsfit
      real*8 x1(*),x2(*)
      real*8 y1(*),y2(*)
      real*8 z1(*),z2(*)
c
c
c     perform dynamic allocation of some global arrays
c
      nmax = max(n1,n2)
      if (.not. allocated(ifit))  allocate (ifit(2,nmax))
      if (.not. allocated(wfit))  allocate (wfit(nmax))
c
c     superimpose the full structures if not specified
c
      if (nfit .eq. 0) then
         nfit = min(n1,n2)
         do i = 1, nfit
            ifit(1,i) = i
            ifit(2,i) = i
            wfit(i) = 1.0d0
         end do
      end if
c
c     if the weights are all zero, set them to unity
c
      do i = 1, nfit
         if (wfit(i) .ne. 0.0d0)  goto 10
      end do
      do i = 1, nfit
         wfit(i) = 1.0d0
      end do
   10 continue
c
c     find the rms fit of input coordinates
c
      if (verbose) then
         rmsvalue = rmsfit (x1,y1,z1,x2,y2,z2)
         write (iout,20)  rmsvalue
   20    format (/,' IMPOSE  --  Input Coordinates',12x,f12.6)
      end if
c
c     superimpose the centroids of active atom pairs
c
      call center (n1,x1,y1,z1,n2,x2,y2,z2,xmid,ymid,zmid)
      if (verbose) then
         rmsvalue = rmsfit (x1,y1,z1,x2,y2,z2)
         write (iout,30)  rmsvalue
   30    format (' IMPOSE  --  After Translation',12x,f12.6)
      end if
c
c     use a quaternion method to achieve the superposition
c
      call quatfit (n1,x1,y1,z1,n2,x2,y2,z2)
      rmsvalue = rmsfit (x1,y1,z1,x2,y2,z2)
      if (verbose) then
         write (iout,40)  rmsvalue
   40    format (' IMPOSE  --  After Rotation',15x,f12.6)
      end if
c
c     translate both coordinate sets so as to return
c     the first set to its original position
c
      do i = 1, n1
         x1(i) = x1(i) + xmid
         y1(i) = y1(i) + ymid
         z1(i) = z1(i) + zmid
      end do
      do i = 1, n2
         x2(i) = x2(i) + xmid
         y2(i) = y2(i) + ymid
         z2(i) = z2(i) + zmid
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module improp  --  improper dihedrals in current structure  ##
c     ##                                                              ##
c     ######################################################3###########
c
c
c     niprop   total number of improper dihedral angles in the system
c     iiprop   numbers of the atoms in each improper dihedral angle
c     kprop    force constant values for improper dihedral angles
c     vprop    ideal improper dihedral angle value in degrees
c
c
      module improp
      implicit none
      integer niprop
      integer, allocatable :: iiprop(:,:)
      real*8, allocatable :: kprop(:)
      real*8, allocatable :: vprop(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module imptor  --  improper torsions in current structure  ##
c     ##                                                             ##
c     #################################################################
c
c
c     nitors   total number of improper torsional angles in the system
c     iitors   numbers of the atoms in each improper torsional angle
c     itors1   1-fold amplitude and phase for each improper torsion
c     itors2   2-fold amplitude and phase for each improper torsion
c     itors3   3-fold amplitude and phase for each improper torsion
c
c
      module imptor
      implicit none
      integer nitors
      integer, allocatable :: iitors(:,:)
      real*8, allocatable :: itors1(:,:)
      real*8, allocatable :: itors2(:,:)
      real*8, allocatable :: itors3(:,:)
      save
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 1999 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine induce  --  evaluate induced dipole moments  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "induce" computes the induced dipole moments at polarizable
c     sites due to direct or mutual polarization
c
c     assumes multipole components have already been rotated into
c     the global coordinate frame; computes induced dipoles based
c     on full system, use of active or inactive atoms is ignored
c
c
      subroutine induce
      use inform
      use iounit
      use limits
      use mpole
      use polar
      use polpot
      use potent
      use solpot
      use units
      use uprior
      implicit none
      integer i,j,k,ii
      real*8 norm
      logical header
c
c
c     choose the method for computation of induced dipoles
c
      if (solvtyp(1:2) .eq. 'PB') then
         call induce0d
      else if (solvtyp(1:2) .eq. 'GK') then
         call induce0c
      else if (poltyp .eq. 'TCG') then
         call induce0b
      else
         call induce0a
      end if
c
c     update the lists of previous induced dipole values
c
      if (use_pred) then
         nualt = min(nualt+1,maxualt)
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               do k = nualt, 2, -1
                  udalt(k,j,i) = udalt(k-1,j,i)
                  upalt(k,j,i) = upalt(k-1,j,i)
               end do
               udalt(1,j,i) = uind(j,i)
               upalt(1,j,i) = uinp(j,i)
               if (use_solv) then
                  do k = nualt, 2, -1
                     usalt(k,j,i) = usalt(k-1,j,i)
                     upsalt(k,j,i) = upsalt(k-1,j,i)
                  end do
                  usalt(1,j,i) = uinds(j,i)
                  upsalt(1,j,i) = uinps(j,i)
               end if
            end do
         end do
      end if
c
c     print out a list of the final induced dipole moments
c
      if (use_polar .and. debug) then
         header = .true.
         do ii = 1, npole
            i = ipole(ii)
            if (polarity(i) .ne. 0.0d0) then
               if (header) then
                  header = .false.
                  if (solvtyp(1:2).eq.'GK' .or.
     &                solvtyp(1:2).eq.'PB') then
                     write (iout,10)
   10                format (/,' Vacuum Induced Dipole Moments',
     &                          ' (Debye) :')
                  else
                     write (iout,20)
   20                format (/,' Induced Dipole Moments (Debye) :')
                  end if
                  write (iout,30)
   30             format (/,4x,'Atom',15x,'X',12x,'Y',12x,'Z',
     &                       11x,'Total',/)
               end if
               norm = sqrt(uind(1,i)**2+uind(2,i)**2+uind(3,i)**2)
               write (iout,40)  i,(debye*uind(j,i),j=1,3),debye*norm
   40          format (i8,5x,3f13.4,1x,f13.4)
            end if
         end do
         header = .true.
         if (solvtyp(1:2).eq.'GK' .or. solvtyp(1:2).eq.'PB') then
            do ii = 1, npole
               i = ipole(ii)
               if (polarity(i) .ne. 0.0d0) then
                  if (header) then
                     header = .false.
                     write (iout,50)
   50                format (/,' SCRF Induced Dipole Moments',
     &                          ' (Debye) :')
                     write (iout,60)
   60                format (/,4x,'Atom',15x,'X',12x,'Y',12x,'Z',
     &                          11x,'Total',/)
                  end if
                  norm = sqrt(uinds(1,i)**2+uinds(2,i)**2
     &                           +uinds(3,i)**2)
                  write (iout,70)  i,(debye*uinds(j,i),j=1,3),
     &                             debye*norm
   70             format (i8,5x,3f13.4,1x,f13.4)
               end if
            end do
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine induce0a  --  conjugate gradient dipole solver  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "induce0a" computes the induced dipole moments at polarizable
c     sites using a preconditioned conjugate gradient solver
c
c
      subroutine induce0a
      use atoms
      use expol
      use extfld
      use ielscf
      use inform
      use iounit
      use limits
      use mpole
      use neigh
      use polar
      use polopt
      use polpcg
      use polpot
      use potent
      use units
      use uprior
      implicit none
      integer i,j,k
      integer ii,iter
      integer miniter
      integer maxiter
      real*8 polmin
      real*8 eps,epsold
      real*8 epsd,epsp
      real*8 udsum,upsum
      real*8 a,ap,b,bp
      real*8 sum,sump,term
      real*8, allocatable :: poli(:)
      real*8, allocatable :: field(:,:)
      real*8, allocatable :: fieldp(:,:)
      real*8, allocatable :: rsd(:,:)
      real*8, allocatable :: rsdp(:,:)
      real*8, allocatable :: zrsd(:,:)
      real*8, allocatable :: zrsdp(:,:)
      real*8, allocatable :: conj(:,:)
      real*8, allocatable :: conjp(:,:)
      real*8, allocatable :: vec(:,:)
      real*8, allocatable :: vecp(:,:)
      real*8, allocatable :: usum(:,:)
      real*8, allocatable :: usump(:,:)
      logical done
      character*6 mode
c
c
c     zero out the induced dipoles at each site
c
      do i = 1, n
         do j = 1, 3
            uind(j,i) = 0.0d0
            uinp(j,i) = 0.0d0
         end do
      end do
      if (.not. use_polar)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (field(3,n))
      allocate (fieldp(3,n))
c
c     compute induced dipoles based on direct and mutual fields
c
   10 continue
c
c     get the electrostatic field due to permanent multipoles
c
      if (use_ewald) then
         call dfield0c (field,fieldp)
      else if (use_mlist) then
         call dfield0b (field,fieldp)
      else
         call dfield0a (field,fieldp)
      end if
c
c     add external electric field to the direct field values
c
      if (use_exfld) then
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               field(j,i) = field(j,i) + exfld(j)
               fieldp(j,i) = fieldp(j,i) + exfld(j)
            end do
         end do
      end if
c
c     modify polarizability to account for exchange polarization
c
      if (use_expol)  call alterpol
c
c     set induced dipoles to polarizability times direct field
c
      do ii = 1, npole
         i = ipole(ii)
         if (douind(i) .and. .not.use_expol) then
            do j = 1, 3
               udir(j,i) = polarity(i) * field(j,i)
               udirp(j,i) = polarity(i) * fieldp(j,i)
               if (pcgguess) then
                  uind(j,i) = udir(j,i)
                  uinp(j,i) = udirp(j,i)
               end if
            end do
         else if (douind(i) .and. use_expol) then
            do j = 1, 3
               udir(j,i) = polarity(i) * field(j,i)
               udirp(j,i) = polarity(i) * fieldp(j,i)
               if (pcgguess) then
                  uind(j,i) = polarity(i)
     &                           * (polinv(j,1,i)*field(1,i)
     &                            + polinv(j,2,i)*field(2,i)
     &                            + polinv(j,3,i)*field(3,i))
                  uinp(j,i) = polarity(i)
     &                           * (polinv(j,1,i)*fieldp(1,i)
     &                            + polinv(j,2,i)*fieldp(2,i)
     &                            + polinv(j,3,i)*fieldp(3,i))
               end if
            end do
         end if
      end do

c     get induced dipoles via the OPT extrapolation method
c
      if (poltyp .eq. 'OPT') then
         do ii = 1, npole
            i = ipole(ii)
            if (douind(i)) then
               do j = 1, 3
                  uopt(0,j,i) = udir(j,i)
                  uoptp(0,j,i) = udirp(j,i)
               end do
            end if
         end do
         do k = 1, optorder
            optlevel = k - 1
            if (use_ewald) then
               call ufield0c (field,fieldp)
            else if (use_mlist) then
               call ufield0b (field,fieldp)
            else
               call ufield0a (field,fieldp)
            end if
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     uopt(k,j,i) = polarity(i) * field(j,i)
                     uoptp(k,j,i) = polarity(i) * fieldp(j,i)
                     uind(j,i) = uopt(k,j,i)
                     uinp(j,i) = uoptp(k,j,i)
                  end do
               end if
            end do
         end do
         allocate (usum(3,n))
         allocate (usump(3,n))
         do ii = 1, npole
            i = ipole(ii)
            if (douind(i)) then
               do j = 1, 3
                  uind(j,i) = 0.0d0
                  uinp(j,i) = 0.0d0
                  usum(j,i) = 0.0d0
                  usump(j,i) = 0.0d0
                  do k = 0, optorder
                     usum(j,i) = usum(j,i) + uopt(k,j,i)
                     usump(j,i) = usump(j,i) + uoptp(k,j,i)
                     uind(j,i) = uind(j,i) + copt(k)*usum(j,i)
                     uinp(j,i) = uinp(j,i) + copt(k)*usump(j,i)
                  end do
               end do
            end if
         end do
         deallocate (usum)
         deallocate (usump)
      end if
c
c     set tolerances for computation of mutual induced dipoles
c
      if (poltyp .eq. 'MUTUAL') then
         done = .false.
         miniter = min(3,n)
         maxiter = 100
         iter = 0
         polmin = 0.00000001d0
         eps = 100.0d0
c
c     estimate induced dipoles using a polynomial predictor
c
         if (use_pred .and. nualt.eq.maxualt) then
            call ulspred
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  udsum = 0.0d0
                  upsum = 0.0d0
                  do k = 1, nualt-1
                     udsum = udsum + bpred(k)*udalt(k,j,i)
                     upsum = upsum + bpredp(k)*upalt(k,j,i)
                  end do
                  uind(j,i) = udsum
                  uinp(j,i) = upsum
               end do
            end do
         end if
c
c     estimate induced dipoles via inertial extended Lagrangian
c
         if (use_ielscf) then
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  uind(j,i) = uaux(j,i)
                  uinp(j,i) = upaux(j,i)
               end do
            end do
         end if
c
c     perform dynamic allocation of some local arrays
c
         allocate (poli(n))
         allocate (rsd(3,n))
         allocate (rsdp(3,n))
         allocate (zrsd(3,n))
         allocate (zrsdp(3,n))
         allocate (conj(3,n))
         allocate (conjp(3,n))
         allocate (vec(3,n))
         allocate (vecp(3,n))
c
c     get the electrostatic field due to induced dipoles
c
         if (use_ewald) then
            call ufield0c (field,fieldp)
         else if (use_mlist) then
            call ufield0b (field,fieldp)
         else
            call ufield0a (field,fieldp)
         end if
c
c     set initial values for the residual vector components
c
         do ii = 1, npole
            i = ipole(ii)
            if (douind(i)) then
               poli(i) = max(polmin,polarity(i))
               do j = 1, 3
                  if (pcgguess) then
                     if (use_expol) then
                        rsd(j,i) = (udir(j,i)
     &                                - uind(1,i)*polscale(j,1,i)
     &                                - uind(2,i)*polscale(j,2,i)
     &                                - uind(3,i)*polscale(j,3,i))
     &                                     /poli(i) + field(j,i)
                        rsdp(j,i) = (udirp(j,i)
     &                                 - uinp(1,i)*polscale(j,1,i)
     &                                 - uinp(2,i)*polscale(j,2,i)
     &                                 - uinp(3,i)*polscale(j,3,i))
     &                                      /poli(i) + fieldp(j,i)
                     else
                        rsd(j,i) = (udir(j,i)-uind(j,i))/poli(i)
     &                                 + field(j,i)
                        rsdp(j,i) = (udirp(j,i)-uinp(j,i))/poli(i)
     &                                 + fieldp(j,i)
                     end if
                  else
                     rsd(j,i) = udir(j,i) / poli(i)
                     rsdp(j,i) = udirp(j,i) / poli(i)
                  end if
                  zrsd(j,i) = rsd(j,i)
                  zrsdp(j,i) = rsdp(j,i)
               end do
            else
               do j = 1, 3
                  rsd(j,i) = 0.0d0
                  rsdp(j,i) = 0.0d0
                  zrsd(j,i) = 0.0d0
                  zrsdp(j,i) = 0.0d0
               end do
            end if
         end do
c
c     perform dynamic allocation of some global arrays
c
         if (pcgprec) then
            if (.not. allocated(mindex))  allocate (mindex(n))
            if (.not. allocated(minv))  allocate (minv(3*maxulst*n))
c
c     apply a sparse matrix conjugate gradient preconditioner
c
            mode = 'BUILD'
            if (use_ulist) then
               call uscale0b (mode,rsd,rsdp,zrsd,zrsdp)
               mode = 'APPLY'
               call uscale0b (mode,rsd,rsdp,zrsd,zrsdp)
            else
               call uscale0a (mode,rsd,rsdp,zrsd,zrsdp)
               mode = 'APPLY'
               call uscale0a (mode,rsd,rsdp,zrsd,zrsdp)
            end if
         end if
c
c     set the initial conjugate vector to be the residuals
c
         do ii = 1, npole
            i = ipole(ii)
            if (douind(i)) then
               do j = 1, 3
                  conj(j,i) = zrsd(j,i)
                  conjp(j,i) = zrsdp(j,i)
               end do
            end if
         end do
c
c     conjugate gradient iteration of the mutual induced dipoles
c
         do while (.not. done)
            iter = iter + 1
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     vec(j,i) = uind(j,i)
                     vecp(j,i) = uinp(j,i)
                     uind(j,i) = conj(j,i)
                     uinp(j,i) = conjp(j,i)
                  end do
               end if
            end do
            if (use_ewald) then
               call ufield0c (field,fieldp)
            else if (use_mlist) then
               call ufield0b (field,fieldp)
            else
               call ufield0a (field,fieldp)
            end if
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     uind(j,i) = vec(j,i)
                     uinp(j,i) = vecp(j,i)
                     if (use_expol) then
                        vec(j,i) = (conj(1,i)*polscale(j,1,i)
     &                                + conj(2,i)*polscale(j,2,i)
     &                                + conj(3,i)*polscale(j,3,i))
     7                                   /poli(i) - field(j,i)
                        vecp(j,i) = (conjp(1,i)*polscale(j,1,i)
     &                                 + conjp(2,i)*polscale(j,2,i)
     &                                 + conjp(3,i)*polscale(j,3,i))
     &                                    /poli(i) - field(j,i)
                     else
                        vec(j,i) = conj(j,i)/poli(i) - field(j,i)
                        vecp(j,i) = conjp(j,i)/poli(i) - fieldp(j,i)
                     end if
                  end do
               end if
            end do
            a = 0.0d0
            ap = 0.0d0
            sum = 0.0d0
            sump = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     a = a + conj(j,i)*vec(j,i)
                     ap = ap + conjp(j,i)*vecp(j,i)
                     sum = sum + rsd(j,i)*zrsd(j,i)
                     sump = sump + rsdp(j,i)*zrsdp(j,i)
                  end do
               end if
            end do
            if (a .ne. 0.0d0)  a = sum / a
            if (ap .ne. 0.0d0)  ap = sump / ap
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     uind(j,i) = uind(j,i) + a*conj(j,i)
                     uinp(j,i) = uinp(j,i) + ap*conjp(j,i)
                     rsd(j,i) = rsd(j,i) - a*vec(j,i)
                     rsdp(j,i) = rsdp(j,i) - ap*vecp(j,i)
                     zrsd(j,i) = rsd(j,i)
                     zrsdp(j,i) = rsdp(j,i)
                  end do
               end if
            end do
            if (pcgprec) then
               if (use_ulist) then
                  call uscale0b (mode,rsd,rsdp,zrsd,zrsdp)
               else
                  call uscale0a (mode,rsd,rsdp,zrsd,zrsdp)
               end if
            end if
            b = 0.0d0
            bp = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     b = b + rsd(j,i)*zrsd(j,i)
                     bp = bp + rsdp(j,i)*zrsdp(j,i)
                  end do
               end if
            end do
            if (sum .ne. 0.0d0)  b = b / sum
            if (sump .ne. 0.0d0)  bp = bp / sump
            epsd = 0.0d0
            epsp = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     conj(j,i) = zrsd(j,i) + b*conj(j,i)
                     conjp(j,i) = zrsdp(j,i) + bp*conjp(j,i)
                     epsd = epsd + rsd(j,i)*rsd(j,i)
                     epsp = epsp + rsdp(j,i)*rsdp(j,i)
                  end do
               end if
            end do
c
c     check the convergence of the mutual induced dipoles
c
            epsold = eps
            eps = max(epsd,epsp)
            eps = debye * sqrt(eps/dble(npolar))
            if (debug) then
               if (iter .eq. 1) then
                  write (iout,20)
   20             format (/,' Determination of SCF Induced Dipole',
     &                       ' Moments :',
     &                    //,4x,'Iter',7x,'RMS Residual (Debye)',/)
               end if
               write (iout,30)  iter,eps
   30          format (i8,7x,f16.10)
            end if
            if (eps .lt. poleps)  done = .true.
c           if (eps .gt. epsold)  done = .true.
            if (iter .lt. miniter)  done = .false.
            if (iter .ge. politer)  done = .true.
c
c     apply a "peek" iteration to the mutual induced dipoles
c
            if (done) then
               do ii = 1, npole
                  i = ipole(ii)
                  if (douind(i)) then
                     term = pcgpeek * poli(i)
                     do j = 1, 3
                        uind(j,i) = uind(j,i) + term*rsd(j,i)
                        uinp(j,i) = uinp(j,i) + term*rsdp(j,i)
                     end do
                  end if
               end do
            end if
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (poli)
         deallocate (rsd)
         deallocate (rsdp)
         deallocate (zrsd)
         deallocate (zrsdp)
         deallocate (conj)
         deallocate (conjp)
         deallocate (vec)
         deallocate (vecp)
c
c     print the results from the conjugate gradient iteration
c
         if (polprt .or. debug) then
            write (iout,40)  iter,eps
   40       format (/,' Induced Dipoles :',4x,'Iterations',i5,
     &                 7x,'RMS Residual',f15.10)
         end if
c
c     terminate the calculation if dipoles fail to converge
c
         if (iter.ge.maxiter .or. eps.gt.epsold) then
            if (use_ulist) then
               use_ulist = .false.
               usolvcut = 0.0d0
               if (verbose) then
                  write (iout,50)
   50             format (/,' INDUCE  --  Switching to Diagonal',
     &                       ' PCG Preconditioner')
               end if
               goto 10
            else
               write (iout,60)
   60          format (/,' INDUCE  --  Warning, Induced Dipoles',
     &                    ' are not Converged')
               call prterr
               call fatal
            end if
         end if
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (field)
      deallocate (fieldp)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine dfield0a  --  direct induction via double loop  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "dfield0a" computes the direct electrostatic field due to
c     permanent multipole moments via a double loop
c
c
      subroutine dfield0a (field,fieldp)
      use atoms
      use bound
      use cell
      use chgpen
      use couple
      use mplpot
      use mpole
      use polar
      use polgrp
      use polpot
      use shunt
      implicit none
      integer i,j,k,m
      integer ii,kk
      real*8 xr,yr,zr
      real*8 r,r2,rr3
      real*8 rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 fid(3),fkd(3)
      real*8 fip(3),fkp(3)
      real*8 dmpi(7),dmpk(7)
      real*8 dmpik(7)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: pscale(:)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      character*6 mode
c
c
c     zero out the value of the field at each site
c
      do i = 1, n
         do j = 1, 3
            field(j,i) = 0.0d0
            fieldp(j,i) = 0.0d0
         end do
      end do
c
c     set the switching function coefficients
c
      mode = 'MPOLE'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (dscale(n))
      allocate (pscale(n))
c
c     set array needed to scale atom and group interactions
c
      do i = 1, n
         dscale(i) = 1.0d0
         pscale(i) = 1.0d0
      end do
c
c     find the electrostatic field due to permanent multipoles
c
      do ii = 1, npole-1
         i = ipole(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - x(i)
            yr = y(k) - y(i)
            zr = z(k) - z(i)
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
c
c     find the field components for Thole polarization damping
c
               if (use_thole) then
                  call damptholed (i,k,7,r,dmpik)
                  rr3 = dmpik(3) / (r*r2)
                  rr5 = 3.0d0 * dmpik(5) / (r*r2*r2)
                  rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2)
                  fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                        - rr3*dkx + 2.0d0*rr5*qkx
                  fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                        - rr3*dky + 2.0d0*rr5*qky
                  fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                        - rr3*dkz + 2.0d0*rr5*qkz
                  fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir)
     &                        - rr3*dix - 2.0d0*rr5*qix
                  fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir)
     &                        - rr3*diy - 2.0d0*rr5*qiy
                  fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir)
     &                        - rr3*diz - 2.0d0*rr5*qiz
c
c     find the field components for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampdir (r,alphai,alphak,dmpi,dmpk)
                  rr3 = 1.0d0 / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpi(3) * rr3
                  rr5i = dmpi(5) * rr5
                  rr7i = dmpi(7) * rr7
                  rr3k = dmpk(3) * rr3
                  rr5k = dmpk(5) * rr5
                  rr7k = dmpk(7) * rr7
                  fid(1) = -xr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dkx + 2.0d0*rr5k*qkx        
                  fid(2) = -yr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dky + 2.0d0*rr5k*qky
                  fid(3) = -zr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dkz + 2.0d0*rr5k*qkz
                  fkd(1) = xr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*dix - 2.0d0*rr5i*qix
                  fkd(2) = yr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*diy - 2.0d0*rr5i*qiy
                  fkd(3) = zr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*diz - 2.0d0*rr5i*qiz
               end if
c
c     increment the direct electrostatic field components
c
               do j = 1, 3
                  field(j,i) = field(j,i) + fid(j)*dscale(k)
                  field(j,k) = field(j,k) + fkd(j)*dscale(k)
                  fieldp(j,i) = fieldp(j,i) + fid(j)*pscale(k)
                  fieldp(j,k) = fieldp(j,k) + fkd(j)*pscale(k)
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
c
c     periodic boundary for large cutoffs via replicates method
c
      if (use_replica) then
         do ii = 1, npole
            i = ipole(ii)
            ci = rpole(1,i)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            qixx = rpole(5,i)
            qixy = rpole(6,i)
            qixz = rpole(7,i)
            qiyy = rpole(9,i)
            qiyz = rpole(10,i)
            qizz = rpole(13,i)
            if (use_chgpen) then
               corei = pcore(i)
               vali = pval(i)
               alphai = palpha(i)
            end if
c
c     set exclusion coefficients for connected atoms
c
            if (dpequal) then
               do j = 1, n12(i)
                  pscale(i12(j,i)) = p2scale
                  do k = 1, np11(i)
                     if (i12(j,i) .eq. ip11(k,i))
     &                  pscale(i12(j,i)) = p2iscale
                  end do
                  dscale(i12(j,i)) = pscale(i12(j,i))
               end do
               do j = 1, n13(i)
                  pscale(i13(j,i)) = p3scale
                  do k = 1, np11(i)
                     if (i13(j,i) .eq. ip11(k,i))
     &                  pscale(i13(j,i)) = p3iscale
                  end do
                  dscale(i13(j,i)) = pscale(i13(j,i))
               end do
               do j = 1, n14(i)
                  pscale(i14(j,i)) = p4scale
                  do k = 1, np11(i)
                     if (i14(j,i) .eq. ip11(k,i))
     &                  pscale(i14(j,i)) = p4iscale
                  end do
                  dscale(i14(j,i)) = pscale(i14(j,i))
               end do
               do j = 1, n15(i)
                  pscale(i15(j,i)) = p5scale
                  do k = 1, np11(i)
                     if (i15(j,i) .eq. ip11(k,i))
     &                  pscale(i15(j,i)) = p5iscale
                  end do
                  dscale(i15(j,i)) = pscale(i15(j,i))
               end do
            else
               do j = 1, n12(i)
                  pscale(i12(j,i)) = p2scale
                  do k = 1, np11(i)
                     if (i12(j,i) .eq. ip11(k,i))
     &                  pscale(i12(j,i)) = p2iscale
                  end do
               end do
               do j = 1, n13(i)
                  pscale(i13(j,i)) = p3scale
                  do k = 1, np11(i)
                     if (i13(j,i) .eq. ip11(k,i))
     &                  pscale(i13(j,i)) = p3iscale
                  end do
               end do
               do j = 1, n14(i)
                  pscale(i14(j,i)) = p4scale
                  do k = 1, np11(i)
                     if (i14(j,i) .eq. ip11(k,i))
     &                  pscale(i14(j,i)) = p4iscale
                  end do
               end do
               do j = 1, n15(i)
                  pscale(i15(j,i)) = p5scale
                  do k = 1, np11(i)
                     if (i15(j,i) .eq. ip11(k,i))
     &                  pscale(i15(j,i)) = p5iscale
                  end do
               end do
               do j = 1, np11(i)
                  dscale(ip11(j,i)) = d1scale
               end do
               do j = 1, np12(i)
                  dscale(ip12(j,i)) = d2scale
               end do
               do j = 1, np13(i)
                  dscale(ip13(j,i)) = d3scale
               end do
               do j = 1, np14(i)
                  dscale(ip14(j,i)) = d4scale
               end do
            end if
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               do m = 2, ncell
                  xr = x(k) - x(i)
                  yr = y(k) - y(i)
                  zr = z(k) - z(i)
                  call imager (xr,yr,zr,m)
                  r2 = xr*xr + yr* yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
c
c     intermediates involving moments and separation distance
c
                     dir = dix*xr + diy*yr + diz*zr
                     qix = qixx*xr + qixy*yr + qixz*zr
                     qiy = qixy*xr + qiyy*yr + qiyz*zr
                     qiz = qixz*xr + qiyz*yr + qizz*zr
                     qir = qix*xr + qiy*yr + qiz*zr
                     dkr = dkx*xr + dky*yr + dkz*zr
                     qkx = qkxx*xr + qkxy*yr + qkxz*zr
                     qky = qkxy*xr + qkyy*yr + qkyz*zr
                     qkz = qkxz*xr + qkyz*yr + qkzz*zr
                     qkr = qkx*xr + qky*yr + qkz*zr
c
c     find the field components for Thole polarization damping
c
                     if (use_thole) then
                        call damptholed (i,k,7,r,dmpik)
                        rr3 = dmpik(3) / (r*r2)
                        rr5 = 3.0d0 * dmpik(5) / (r*r2*r2)
                        rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2)
                        fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                              - rr3*dkx + 2.0d0*rr5*qkx
                        fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                              - rr3*dky + 2.0d0*rr5*qky
                        fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                              - rr3*dkz + 2.0d0*rr5*qkz
                        fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir)
     &                              - rr3*dix - 2.0d0*rr5*qix
                        fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir)
     &                              - rr3*diy - 2.0d0*rr5*qiy
                        fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir)
     &                              - rr3*diz - 2.0d0*rr5*qiz
c
c     find the field components for charge penetration damping
c
                     else if (use_chgpen) then
                        corek = pcore(k)
                        valk = pval(k)
                        alphak = palpha(k)
                        call dampdir (r,alphai,alphak,dmpi,dmpk)
                        rr3 = 1.0d0 / (r*r2)
                        rr5 = 3.0d0 * rr3 / r2
                        rr7 = 5.0d0 * rr5 / r2
                        rr3i = dmpi(3) * rr3
                        rr5i = dmpi(5) * rr5
                        rr7i = dmpi(7) * rr7
                        rr3k = dmpk(3) * rr3
                        rr5k = dmpk(5) * rr5
                        rr7k = dmpk(7) * rr7
                        fid(1) = -xr*(rr3*corek + rr3k*valk
     &                              - rr5k*dkr + rr7k*qkr)
     &                              - rr3k*dkx + 2.0d0*rr5k*qkx        
                        fid(2) = -yr*(rr3*corek + rr3k*valk
     &                              - rr5k*dkr+rr7k*qkr)
     &                              - rr3k*dky + 2.0d0*rr5k*qky
                        fid(3) = -zr*(rr3*corek + rr3k*valk
     &                              - rr5k*dkr+rr7k*qkr)
     &                              - rr3k*dkz + 2.0d0*rr5k*qkz
                        fkd(1) = xr*(rr3*corei + rr3i*vali
     &                              + rr5i*dir + rr7i*qir)
     &                              - rr3i*dix - 2.0d0*rr5i*qix
                        fkd(2) = yr*(rr3*corei + rr3i*vali
     &                              + rr5i*dir + rr7i*qir)
     &                              - rr3i*diy - 2.0d0*rr5i*qiy
                        fkd(3) = zr*(rr3*corei + rr3i*vali
     &                              + rr5i*dir + rr7i*qir)
     &                              - rr3i*diz - 2.0d0*rr5i*qiz
                     end if
c
c     increment the direct electrostatic field components
c
                     do j = 1, 3
                        fip(j) = fid(j)
                        fkp(j) = fkd(j)
                     end do
                     if (use_polymer .and. r2.le.polycut2) then
                        do j = 1, 3
                           fid(j) = fid(j) * dscale(k)
                           fip(j) = fip(j) * pscale(k)
                           fkd(j) = fkd(j) * dscale(k)
                           fkp(j) = fkp(j) * pscale(k)
                        end do
                     end if
                     do j = 1, 3
                        field(j,i) = field(j,i) + fid(j)
                        fieldp(j,i) = fieldp(j,i) + fip(j)
                        if (i .ne. k) then
                           field(j,k) = field(j,k) + fkd(j)
                           fieldp(j,k) = fieldp(j,k) + fkp(j)
                        end if
                     end do
                  end if
               end do
            end do
c
c     reset exclusion coefficients for connected atoms
c
            if (dpequal) then
               do j = 1, n12(i)
                  pscale(i12(j,i)) = 1.0d0
                  dscale(i12(j,i)) = 1.0d0
               end do
               do j = 1, n13(i)
                  pscale(i13(j,i)) = 1.0d0
                  dscale(i13(j,i)) = 1.0d0
               end do
               do j = 1, n14(i)
                  pscale(i14(j,i)) = 1.0d0
                  dscale(i14(j,i)) = 1.0d0
               end do
               do j = 1, n15(i)
                  pscale(i15(j,i)) = 1.0d0
                  dscale(i15(j,i)) = 1.0d0
               end do
            else
               do j = 1, n12(i)
                  pscale(i12(j,i)) = 1.0d0
               end do
               do j = 1, n13(i)
                  pscale(i13(j,i)) = 1.0d0
               end do
               do j = 1, n14(i)
                  pscale(i14(j,i)) = 1.0d0
               end do
               do j = 1, n15(i)
                  pscale(i15(j,i)) = 1.0d0
               end do
               do j = 1, np11(i)
                  dscale(ip11(j,i)) = 1.0d0
               end do
               do j = 1, np12(i)
                  dscale(ip12(j,i)) = 1.0d0
               end do
               do j = 1, np13(i)
                  dscale(ip13(j,i)) = 1.0d0
               end do
               do j = 1, np14(i)
                  dscale(ip14(j,i)) = 1.0d0
               end do
            end if
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (dscale)
      deallocate (pscale)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ufield0a  --  mutual induction via double loop  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ufield0a" computes the mutual electrostatic field due to
c     induced dipole moments via a double loop
c
c
      subroutine ufield0a (field,fieldp)
      use atoms
      use bound
      use cell
      use chgpen
      use couple
      use mplpot
      use mpole
      use polar
      use polgrp
      use polpot
      use shunt
      implicit none
      integer i,j,k,m
      integer ii,kk
      real*8 xr,yr,zr
      real*8 r,r2,rr3,rr5
      real*8 dix,diy,diz
      real*8 pix,piy,piz
      real*8 dkx,dky,dkz
      real*8 pkx,pky,pkz
      real*8 dir,pir
      real*8 dkr,pkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 fid(3),fkd(3)
      real*8 fip(3),fkp(3)
      real*8 dmpik(5)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: wscale(:)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      character*6 mode
c
c
c     zero out the value of the field at each site
c
      do i = 1, n
         do j = 1, 3
            field(j,i) = 0.0d0
            fieldp(j,i) = 0.0d0
         end do
      end do
c
c     set the switching function coefficients
c
      mode = 'MPOLE'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (uscale(n))
      allocate (wscale(n))
c
c     set array needed to scale atom and group interactions
c
      do i = 1, n
         uscale(i) = 1.0d0
         wscale(i) = 1.0d0
      end do
c
c     find the electrostatic field due to mutual induced dipoles
c
      do ii = 1, npole-1
         i = ipole(ii)
         dix = uind(1,i)
         diy = uind(2,i)
         diz = uind(3,i)
         pix = uinp(1,i)
         piy = uinp(2,i)
         piz = uinp(3,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, np11(i)
            uscale(ip11(j,i)) = u1scale
         end do
         do j = 1, np12(i)
            uscale(ip12(j,i)) = u2scale
         end do
         do j = 1, np13(i)
            uscale(ip13(j,i)) = u3scale
         end do
         do j = 1, np14(i)
            uscale(ip14(j,i)) = u4scale
         end do
         do j = 1, n12(i)
            wscale(i12(j,i)) = w2scale
         end do
         do j = 1, n13(i)
            wscale(i13(j,i)) = w3scale
         end do
         do j = 1, n14(i)
            wscale(i14(j,i)) = w4scale
         end do
         do j = 1, n15(i)
            wscale(i15(j,i)) = w5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - x(i)
            yr = y(k) - y(i)
            zr = z(k) - z(i)
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               dkx = uind(1,k)
               dky = uind(2,k)
               dkz = uind(3,k)
               pkx = uinp(1,k)
               pky = uinp(2,k)
               pkz = uinp(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               pir = pix*xr + piy*yr + piz*zr
               pkr = pkx*xr + pky*yr + pkz*zr
c
c     find the scale factors for Thole polarization damping
c
               if (use_thole) then
                  call dampthole (i,k,5,r,dmpik)
                  dmpik(3) = uscale(k) * dmpik(3)
                  dmpik(5) = uscale(k) * dmpik(5)
c
c     find the scale factors for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampmut (r,alphai,alphak,dmpik)
                  dmpik(3) = wscale(k) * dmpik(3)
                  dmpik(5) = wscale(k) * dmpik(5)
               end if
c
c     increment the mutual electrostatic field components
c
               rr3 = -dmpik(3) / (r*r2)
               rr5 = 3.0d0 * dmpik(5) / (r*r2*r2)
               fid(1) = rr3*dkx + rr5*dkr*xr
               fid(2) = rr3*dky + rr5*dkr*yr
               fid(3) = rr3*dkz + rr5*dkr*zr
               fkd(1) = rr3*dix + rr5*dir*xr
               fkd(2) = rr3*diy + rr5*dir*yr
               fkd(3) = rr3*diz + rr5*dir*zr
               fip(1) = rr3*pkx + rr5*pkr*xr
               fip(2) = rr3*pky + rr5*pkr*yr
               fip(3) = rr3*pkz + rr5*pkr*zr
               fkp(1) = rr3*pix + rr5*pir*xr
               fkp(2) = rr3*piy + rr5*pir*yr
               fkp(3) = rr3*piz + rr5*pir*zr
               do j = 1, 3
                  field(j,i) = field(j,i) + fid(j)
                  field(j,k) = field(j,k) + fkd(j)
                  fieldp(j,i) = fieldp(j,i) + fip(j)
                  fieldp(j,k) = fieldp(j,k) + fkp(j)
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, np11(i)
            uscale(ip11(j,i)) = 1.0d0
         end do
         do j = 1, np12(i)
            uscale(ip12(j,i)) = 1.0d0
         end do
         do j = 1, np13(i)
            uscale(ip13(j,i)) = 1.0d0
         end do
         do j = 1, np14(i)
            uscale(ip14(j,i)) = 1.0d0
         end do
         do j = 1, n12(i)
            wscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            wscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            wscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            wscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     periodic boundary for large cutoffs via replicates method
c
      if (use_replica) then
         do ii = 1, npole
            i = ipole(ii)
            dix = uind(1,i)
            diy = uind(2,i)
            diz = uind(3,i)
            pix = uinp(1,i)
            piy = uinp(2,i)
            piz = uinp(3,i)
            if (use_chgpen) then
               corei = pcore(i)
               vali = pval(i)
               alphai = palpha(i)
            end if
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
            do j = 1, n12(i)
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               wscale(i15(j,i)) = w5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               dkx = uind(1,k)
               dky = uind(2,k)
               dkz = uind(3,k)
               pkx = uinp(1,k)
               pky = uinp(2,k)
               pkz = uinp(3,k)
               do m = 2, ncell
                  xr = x(k) - x(i)
                  yr = y(k) - y(i)
                  zr = z(k) - z(i)
                  call imager (xr,yr,zr,m)
                  r2 = xr*xr + yr* yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
c
c     intermediates involving moments and separation distance
c
                     dir = dix*xr + diy*yr + diz*zr
                     dkr = dkx*xr + dky*yr + dkz*zr
                     pir = pix*xr + piy*yr + piz*zr
                     pkr = pkx*xr + pky*yr + pkz*zr
c
c     find the scale factors for Thole polarization damping
c
                     if (use_thole) then
                        call dampthole (i,k,5,r,dmpik)
                        dmpik(3) = uscale(k) * dmpik(3)
                        dmpik(5) = uscale(k) * dmpik(5)
c
c     find the scale factors for charge penetration damping
c
                     else if (use_chgpen) then
                        corek = pcore(k)
                        valk = pval(k)
                        alphak = palpha(k)
                        call dampmut (r,alphai,alphak,dmpik)
                        dmpik(3) = wscale(k) * dmpik(3)
                        dmpik(5) = wscale(k) * dmpik(5)
                     end if
c
c     increment the mutual electrostatic field components
c
                     rr3 = -dmpik(3) / (r*r2)
                     rr5 = 3.0d0 * dmpik(5) / (r*r2*r2)
                     fid(1) = rr3*dkx + rr5*dkr*xr
                     fid(2) = rr3*dky + rr5*dkr*yr
                     fid(3) = rr3*dkz + rr5*dkr*zr
                     fkd(1) = rr3*dix + rr5*dir*xr
                     fkd(2) = rr3*diy + rr5*dir*yr
                     fkd(3) = rr3*diz + rr5*dir*zr
                     fip(1) = rr3*pkx + rr5*pkr*xr
                     fip(2) = rr3*pky + rr5*pkr*yr
                     fip(3) = rr3*pkz + rr5*pkr*zr
                     fkp(1) = rr3*pix + rr5*pir*xr
                     fkp(2) = rr3*piy + rr5*pir*yr
                     fkp(3) = rr3*piz + rr5*pir*zr
                     if (use_polymer) then
                        if (r2 .le. polycut2) then
                           do j = 1, 3
                              fid(j) = fid(j) * uscale(k)
                              fkd(j) = fkd(j) * uscale(k)
                              fip(j) = fip(j) * uscale(k)
                              fkp(j) = fkp(j) * uscale(k)
                           end do
                        end if
                     end if
                     do j = 1, 3
                        field(j,i) = field(j,i) + fid(j)
                        fieldp(j,i) = fieldp(j,i) + fip(j)
                        if (i .ne. k) then
                           field(j,k) = field(j,k) + fkd(j)
                           fieldp(j,k) = fieldp(j,k) + fkp(j)
                        end if
                     end do
                  end if
               end do
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
            do j = 1, n12(i)
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               wscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (uscale)
      deallocate (wscale)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine dfield0b  --  direct induction via pair list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "dfield0b" computes the direct electrostatic field due to
c     permanent multipole moments via a pair list
c
c
      subroutine dfield0b (field,fieldp)
      use atoms
      use bound
      use chgpen
      use couple
      use mplpot
      use mpole
      use neigh
      use polar
      use polgrp
      use polpot
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xr,yr,zr
      real*8 r,r2,rr3
      real*8 rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 fid(3),fkd(3)
      real*8 dmpi(7),dmpk(7)
      real*8 dmpik(7)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: pscale(:)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      real*8, allocatable :: fieldt(:,:)
      real*8, allocatable :: fieldtp(:,:)
      character*6 mode
c
c
c     set the switching function coefficients
c
      mode = 'MPOLE'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (dscale(n))
      allocate (pscale(n))
      allocate (fieldt(3,n))
      allocate (fieldtp(3,n))
c
c     set array needed to scale connected atom interactions
c
      do i = 1, n
         dscale(i) = 1.0d0
         pscale(i) = 1.0d0
      end do
c
c     initialize local variables for OpenMP calculation
c
      do i = 1, n
         do j = 1, 3
            fieldt(j,i) = 0.0d0
            fieldtp(j,i) = 0.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,rpole,x,y,z,pcore,pval,palpha,n12,i12,
!$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14,
!$OMP& p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale,
!$OMP& p5iscale,d1scale,d2scale,d3scale,d4scale,nelst,elst,dpequal,
!$OMP& use_thole,use_chgpen,use_bounds,off2,field,fieldp)
!$OMP& firstprivate(dscale,pscale) shared (fieldt,fieldtp)
!$OMP DO reduction(+:fieldt,fieldtp)
c
c     find the electrostatic field due to permanent multipoles
c
      do ii = 1, npole
         i = ipole(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            xr = x(k) - x(i)
            yr = y(k) - y(i)
            zr = z(k) - z(i)
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
c
c     find the field components for Thole polarization damping
c
               if (use_thole) then
                  call damptholed (i,k,7,r,dmpik)
                  rr3 = dmpik(3) / (r*r2)
                  rr5 = 3.0d0 * dmpik(5) / (r*r2*r2)
                  rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2)
                  fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                        - rr3*dkx + 2.0d0*rr5*qkx
                  fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                        - rr3*dky + 2.0d0*rr5*qky
                  fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                        - rr3*dkz + 2.0d0*rr5*qkz
                  fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir)
     &                        - rr3*dix - 2.0d0*rr5*qix
                  fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir)
     &                        - rr3*diy - 2.0d0*rr5*qiy
                  fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir)
     &                        - rr3*diz - 2.0d0*rr5*qiz
c
c     find the field components for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampdir (r,alphai,alphak,dmpi,dmpk)
                  rr3 = 1.0d0 / (r*r2)
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr3i = dmpi(3) * rr3
                  rr5i = dmpi(5) * rr5
                  rr7i = dmpi(7) * rr7
                  rr3k = dmpk(3) * rr3
                  rr5k = dmpk(5) * rr5
                  rr7k = dmpk(7) * rr7
                  fid(1) = -xr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dkx + 2.0d0*rr5k*qkx        
                  fid(2) = -yr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dky + 2.0d0*rr5k*qky
                  fid(3) = -zr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dkz + 2.0d0*rr5k*qkz
                  fkd(1) = xr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*dix - 2.0d0*rr5i*qix
                  fkd(2) = yr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*diy - 2.0d0*rr5i*qiy
                  fkd(3) = zr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*diz - 2.0d0*rr5i*qiz
               end if
c
c     increment the direct electrostatic field components
c
               do j = 1, 3
                  fieldt(j,i) = fieldt(j,i) + fid(j)*dscale(k)
                  fieldt(j,k) = fieldt(j,k) + fkd(j)*dscale(k)
                  fieldtp(j,i) = fieldtp(j,i) + fid(j)*pscale(k)
                  fieldtp(j,k) = fieldtp(j,k) + fkd(j)*pscale(k)
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
!$OMP END DO
c
c     add local to global variables for OpenMP calculation
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            field(j,i) = fieldt(j,i)
            fieldp(j,i) = fieldtp(j,i)
         end do
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (dscale)
      deallocate (pscale)
      deallocate (fieldt)
      deallocate (fieldtp)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ufield0b  --  mutual induction via pair list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ufield0b" computes the mutual electrostatic field due to
c     induced dipole moments via a pair list
c
c
      subroutine ufield0b (field,fieldp)
      use atoms
      use bound
      use chgpen
      use couple
      use mplpot
      use mpole
      use neigh
      use polar
      use polgrp
      use polpot
      use shunt
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xr,yr,zr
      real*8 r,r2,rr3,rr5
      real*8 dix,diy,diz
      real*8 pix,piy,piz
      real*8 dkx,dky,dkz
      real*8 pkx,pky,pkz
      real*8 dir,pir
      real*8 dkr,pkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 fid(3),fkd(3)
      real*8 fip(3),fkp(3)
      real*8 dmpik(5)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: wscale(:)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      real*8, allocatable :: fieldt(:,:)
      real*8, allocatable :: fieldtp(:,:)
      character*6 mode
c
c
c     set the switching function coefficients
c
      mode = 'MPOLE'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (uscale(n))
      allocate (wscale(n))
      allocate (fieldt(3,n))
      allocate (fieldtp(3,n))
c
c     set array needed to scale connected atom interactions
c
      do i = 1, n
         uscale(i) = 1.0d0
         wscale(i) = 1.0d0
      end do
c
c     initialize local variables for OpenMP calculation
c
      do i = 1, n
         do j = 1, 3
            fieldt(j,i) = 0.0d0
            fieldtp(j,i) = 0.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(npole,ipole,uind,uinp,x,y,z,pcore,pval,palpha,n12,i12,
!$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14,
!$OMP& u1scale,u2scale,u3scale,u4scale,w2scale,w3scale,w4scale,w5scale,
!$OMP& nelst,elst,use_thole,use_chgpen,use_bounds,off2,field,fieldp)
!$OMP& firstprivate(uscale,wscale) shared (fieldt,fieldtp)
!$OMP DO reduction(+:fieldt,fieldtp)
c
c     find the electrostatic field due to mutual induced dipoles
c
      do ii = 1, npole
         i = ipole(ii)
         dix = uind(1,i)
         diy = uind(2,i)
         diz = uind(3,i)
         pix = uinp(1,i)
         piy = uinp(2,i)
         piz = uinp(3,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, np11(i)
            uscale(ip11(j,i)) = u1scale
         end do
         do j = 1, np12(i)
            uscale(ip12(j,i)) = u2scale
         end do
         do j = 1, np13(i)
            uscale(ip13(j,i)) = u3scale
         end do
         do j = 1, np14(i)
            uscale(ip14(j,i)) = u4scale
         end do
         do j = 1, n12(i)
            wscale(i12(j,i)) = w2scale
         end do
         do j = 1, n13(i)
            wscale(i13(j,i)) = w3scale
         end do
         do j = 1, n14(i)
            wscale(i14(j,i)) = w4scale
         end do
         do j = 1, n15(i)
            wscale(i15(j,i)) = w5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            xr = x(k) - x(i)
            yr = y(k) - y(i)
            zr = z(k) - z(i)
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               dkx = uind(1,k)
               dky = uind(2,k)
               dkz = uind(3,k)
               pkx = uinp(1,k)
               pky = uinp(2,k)
               pkz = uinp(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               pir = pix*xr + piy*yr + piz*zr
               pkr = pkx*xr + pky*yr + pkz*zr
c
c     find the scale factors for Thole polarization damping
c
               if (use_thole) then
                  call dampthole (i,k,5,r,dmpik)
                  dmpik(3) = uscale(k) * dmpik(3)
                  dmpik(5) = uscale(k) * dmpik(5)
c
c     find the scale factors for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampmut (r,alphai,alphak,dmpik)
                  dmpik(3) = wscale(k) * dmpik(3)
                  dmpik(5) = wscale(k) * dmpik(5)
               end if
c
c     increment the mutual electrostatic field components
c
               rr3 = -dmpik(3) / (r*r2)
               rr5 = 3.0d0 * dmpik(5) / (r*r2*r2)
               fid(1) = rr3*dkx + rr5*dkr*xr
               fid(2) = rr3*dky + rr5*dkr*yr
               fid(3) = rr3*dkz + rr5*dkr*zr
               fkd(1) = rr3*dix + rr5*dir*xr
               fkd(2) = rr3*diy + rr5*dir*yr
               fkd(3) = rr3*diz + rr5*dir*zr
               fip(1) = rr3*pkx + rr5*pkr*xr
               fip(2) = rr3*pky + rr5*pkr*yr
               fip(3) = rr3*pkz + rr5*pkr*zr
               fkp(1) = rr3*pix + rr5*pir*xr
               fkp(2) = rr3*piy + rr5*pir*yr
               fkp(3) = rr3*piz + rr5*pir*zr
               do j = 1, 3
                  fieldt(j,i) = fieldt(j,i) + fid(j)
                  fieldt(j,k) = fieldt(j,k) + fkd(j)
                  fieldtp(j,i) = fieldtp(j,i) + fip(j)
                  fieldtp(j,k) = fieldtp(j,k) + fkp(j)
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, np11(i)
            uscale(ip11(j,i)) = 1.0d0
         end do
         do j = 1, np12(i)
            uscale(ip12(j,i)) = 1.0d0
         end do
         do j = 1, np13(i)
            uscale(ip13(j,i)) = 1.0d0
         end do
         do j = 1, np14(i)
            uscale(ip14(j,i)) = 1.0d0
         end do
         do j = 1, n12(i)
            wscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            wscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            wscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            wscale(i15(j,i)) = 1.0d0
         end do
      end do
!$OMP END DO
c
c     add local to global variables for OpenMP calculation
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            field(j,i) = fieldt(j,i)
            fieldp(j,i) = fieldtp(j,i)
         end do
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (uscale)
      deallocate (wscale)
      deallocate (fieldt)
      deallocate (fieldtp)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine dfield0c  --  direct induction via Ewald sum  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "dfield0c" computes the mutual electrostatic field due to
c     permanent multipole moments via Ewald summation
c
c
      subroutine dfield0c (field,fieldp)
      use atoms
      use boxes
      use ewald
      use limits
      use math
      use mpole
      use pme
      use polar
      implicit none
      integer i,j,ii
      real*8 term
      real*8 ucell(3)
      real*8 field(3,*)
      real*8 fieldp(3,*)
c
c
c     zero out the value of the field at each site
c
      do i = 1, n
         do j = 1, 3
            field(j,i) = 0.0d0
            fieldp(j,i) = 0.0d0
         end do
      end do
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bsporder
      aewald = apewald
c
c     get the reciprocal space part of the permanent field
c
      call udirect1 (field)
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            fieldp(j,i) = field(j,i)
         end do
      end do
c
c     get the real space portion of the permanent field
c
      if (use_mlist) then
         call udirect2b (field,fieldp)
      else
         call udirect2a (field,fieldp)
      end if
c
c     get the self-energy portion of the permanent field
c
      term = (4.0d0/3.0d0) * aewald**3 / rootpi
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            field(j,i) = field(j,i) + term*rpole(j+1,i)
            fieldp(j,i) = fieldp(j,i) + term*rpole(j+1,i)
         end do
      end do
c
c     compute the cell dipole boundary correction to field
c
      if (boundary .eq. 'VACUUM') then
         do i = 1, 3
            ucell(i) = 0.0d0
         end do
         do ii = 1, npole
            i = ipole(ii)
            ucell(1) = ucell(1) + rpole(2,i) + rpole(1,i)*x(i)
            ucell(2) = ucell(2) + rpole(3,i) + rpole(1,i)*y(i)
            ucell(3) = ucell(3) + rpole(4,i) + rpole(1,i)*z(i)
         end do
         term = (4.0d0/3.0d0) * pi/volbox
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               field(j,i) = field(j,i) - term*ucell(j)
               fieldp(j,i) = fieldp(j,i) - term*ucell(j)
            end do
         end do
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine udirect1  --  Ewald recip direct induced field  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "udirect1" computes the reciprocal space contribution of the
c     permanent atomic multipole moments to the field
c
c     note that cmp, fmp, cphi and fphi should not be made global
c     since corresponding values in empole and epolar are different
c
c
      subroutine udirect1 (field)
      use atoms
      use bound
      use boxes
      use ewald
      use math
      use mpole
      use pme
      use polpot
      implicit none
      integer i,j,ii
      integer k1,k2,k3
      integer m1,m2,m3
      integer ntot,nff
      integer nf1,nf2,nf3
      real*8 r1,r2,r3
      real*8 h1,h2,h3
      real*8 volterm,denom
      real*8 hsq,expterm
      real*8 term,pterm
      real*8 field(3,*)
      real*8, allocatable :: cmp(:,:)
      real*8, allocatable :: fmp(:,:)
      real*8, allocatable :: cphi(:,:)
      real*8, allocatable :: fphi(:,:)
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (cmp(10,n))
      allocate (fmp(10,n))
      allocate (cphi(10,n))
      allocate (fphi(20,n))
c
c     perform dynamic allocation of some global arrays
c
      ntot = nfft1 * nfft2 * nfft3
      if (allocated(qgrid)) then
         if (size(qgrid) .ne. 2*ntot)  call fftclose
      end if
      if (.not. allocated(qgrid))  call fftsetup
      if (allocated(qfac)) then
         if (size(qfac) .ne. ntot)  deallocate (qfac)
      end if
      if (.not. allocated(qfac))  allocate (qfac(nfft1,nfft2,nfft3))
c
c     setup spatial decomposition and B-spline coefficients
c
      call getchunk
      call moduli
      call bspline_fill
      call table_fill
c
c     copy the multipole moments into local storage areas
c
      do ii = 1, npole
         i = ipole(ii)
         cmp(1,i) = rpole(1,i)
         cmp(2,i) = rpole(2,i)
         cmp(3,i) = rpole(3,i)
         cmp(4,i) = rpole(4,i)
         cmp(5,i) = rpole(5,i)
         cmp(6,i) = rpole(9,i)
         cmp(7,i) = rpole(13,i)
         cmp(8,i) = 2.0d0 * rpole(6,i)
         cmp(9,i) = 2.0d0 * rpole(7,i)
         cmp(10,i) = 2.0d0 * rpole(10,i)
      end do
c
c     convert Cartesian multipoles to fractional coordinates
c
      call cmp_to_fmp (cmp,fmp)
c
c     assign PME grid and perform 3-D FFT forward transform
c
      call grid_mpole (fmp)
      call fftfront
c
c     make the scalar summation over reciprocal lattice
c
      pterm = (pi/aewald)**2
      volterm = pi * volbox
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      nff = nfft1 * nfft2
      ntot = nff * nfft3
      do i = 1, ntot-1
         k3 = i/nff + 1
         j = i - (k3-1)*nff
         k2 = j/nfft1 + 1
         k1 = j - (k2-1)*nfft1 + 1
         m1 = k1 - 1
         m2 = k2 - 1
         m3 = k3 - 1
         if (k1 .gt. nf1)  m1 = m1 - nfft1
         if (k2 .gt. nf2)  m2 = m2 - nfft2
         if (k3 .gt. nf3)  m3 = m3 - nfft3
         r1 = dble(m1)
         r2 = dble(m2)
         r3 = dble(m3)
         h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3
         h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3
         h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3
         hsq = h1*h1 + h2*h2 + h3*h3
         term = -pterm * hsq
         expterm = 0.0d0
         if (term .gt. -50.0d0) then
            denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3)
            expterm = exp(term) / denom
            if (.not. use_bounds) then
               expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq)))
            else if (nonprism) then
               if (mod(m1+m2+m3,2) .ne. 0)  expterm = 0.0d0
            end if
         end if
         qfac(k1,k2,k3) = expterm
         qgrid(1,k1,k2,k3) = expterm * qgrid(1,k1,k2,k3)
         qgrid(2,k1,k2,k3) = expterm * qgrid(2,k1,k2,k3)
      end do
c
c     account for zeroth grid point for nonperiodic system
c
      qfac(1,1,1) = 0.0d0
      qgrid(1,1,1,1) = 0.0d0
      qgrid(2,1,1,1) = 0.0d0
      if (.not. use_bounds) then
         expterm = 0.5d0 * pi / xbox
         qfac(1,1,1) = expterm
         qgrid(1,1,1,1) = expterm * qgrid(1,1,1,1)
         qgrid(2,1,1,1) = expterm * qgrid(2,1,1,1)
      end if
c
c     perform 3-D FFT backward transform and get field
c
      call fftback
      call fphi_mpole (fphi)
c
c     convert the field from fractional to Cartesian
c
      call fphi_to_cphi (fphi,cphi)
c
c     increment the field at each multipole site
c
      do ii = 1, npole
         i = ipole(ii)
         field(1,i) = field(1,i) - cphi(2,i)
         field(2,i) = field(2,i) - cphi(3,i)
         field(3,i) = field(3,i) - cphi(4,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (cmp)
      deallocate (fmp)
      deallocate (cphi)
      deallocate (fphi)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine udirect2a  --  Ewald real direct field via loop  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "udirect2a" computes the real space contribution of the permanent
c     atomic multipole moments to the field via a double loop
c
c
      subroutine udirect2a (field,fieldp)
      use atoms
      use boxes
      use bound
      use cell
      use chgpen
      use couple
      use math
      use mplpot
      use mpole
      use polar
      use polgrp
      use polpot
      use shunt
      use units
      implicit none
      integer i,j,k,m
      integer ii,kk
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr2
      real*8 rr3,rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 ci,dix,diy,diz
      real*8 qixx,qiyy,qizz
      real*8 qixy,qixz,qiyz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkyy,qkzz
      real*8 qkxy,qkxz,qkyz
      real*8 dir,dkr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 scalek
      real*8 dmp3,dmp5,dmp7
      real*8 dsc3,dsc5,dsc7
      real*8 psc3,psc5,psc7
      real*8 fid(3),fkd(3)
      real*8 fip(3),fkp(3)
      real*8 dmpi(7),dmpk(7)
      real*8 dmpik(7),dmpe(7)
      real*8, allocatable :: pscale(:)
      real*8, allocatable :: dscale(:)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      character*6 mode
c
c
c     check for multipoles and set cutoff coefficients
c
      if (npole .eq. 0)  return
      mode = 'EWALD'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
      allocate (dscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         pscale(i) = 1.0d0
         dscale(i) = 1.0d0
      end do
c
c     compute real space Ewald field due to permanent multipoles
c
      do ii = 1, npole-1
         i = ipole(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - x(i)
            yr = y(k) - y(i)
            zr = z(k) - z(i)
            call image (xr,yr,zr)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               rr1 = 1.0d0 / r
               rr2 = rr1 * rr1
               rr3 = rr2 * rr1
               rr5 = 3.0d0 * rr2 * rr3
               rr7 = 5.0d0 * rr2 * rr5
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
c
c     calculate real space Ewald error function damping
c
               call dampewald (7,r,r2,1.0d0,dmpe)
c
c     find the field components for Thole polarization damping
c
               if (use_thole) then
                  call damptholed (i,k,7,r,dmpik)
                  scalek = dscale(k)
                  dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                  dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                  dmp7 = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                  fid(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                        - dmp3*dkx + 2.0d0*dmp5*qkx
                  fid(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                        - dmp3*dky + 2.0d0*dmp5*qky
                  fid(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                        - dmp3*dkz + 2.0d0*dmp5*qkz
                  fkd(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                        - dmp3*dix - 2.0d0*dmp5*qix
                  fkd(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                        - dmp3*diy - 2.0d0*dmp5*qiy
                  fkd(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                        - dmp3*diz - 2.0d0*dmp5*qiz
                  scalek = pscale(k)
                  dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                  dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                  dmp7 = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                  fip(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                        - dmp3*dkx + 2.0d0*dmp5*qkx
                  fip(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                        - dmp3*dky + 2.0d0*dmp5*qky
                  fip(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                        - dmp3*dkz + 2.0d0*dmp5*qkz
                  fkp(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                        - dmp3*dix - 2.0d0*dmp5*qix
                  fkp(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                        - dmp3*diy - 2.0d0*dmp5*qiy
                  fkp(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                        - dmp3*diz - 2.0d0*dmp5*qiz
c
c     find the field components for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampdir (r,alphai,alphak,dmpi,dmpk)
                  scalek = dscale(k)
                  rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                  rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7
                  rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                  rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7
                  rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                  fid(1) = -xr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dkx + 2.0d0*rr5k*qkx
                  fid(2) = -yr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dky + 2.0d0*rr5k*qky
                  fid(3) = -zr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dkz + 2.0d0*rr5k*qkz
                  fkd(1) = xr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*dix - 2.0d0*rr5i*qix
                  fkd(2) = yr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*diy - 2.0d0*rr5i*qiy
                  fkd(3) = zr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*diz - 2.0d0*rr5i*qiz
                  scalek = pscale(k)
                  rr3 = rr2 * rr1
                  rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                  rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7
                  rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                  rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7
                  rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                  fip(1) = -xr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dkx + 2.0d0*rr5k*qkx
                  fip(2) = -yr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dky + 2.0d0*rr5k*qky
                  fip(3) = -zr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dkz + 2.0d0*rr5k*qkz
                  fkp(1) = xr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*dix - 2.0d0*rr5i*qix
                  fkp(2) = yr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*diy - 2.0d0*rr5i*qiy
                  fkp(3) = zr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*diz - 2.0d0*rr5i*qiz
               end if
c
c     increment the field at each site due to this interaction
c
               do j = 1, 3
                  field(j,i) = field(j,i) + fid(j)
                  field(j,k) = field(j,k) + fkd(j)
                  fieldp(j,i) = fieldp(j,i) + fip(j)
                  fieldp(j,k) = fieldp(j,k) + fkp(j)
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
c
c     periodic boundary for large cutoffs via replicates method
c
      if (use_replica) then
         do ii = 1, npole
            i = ipole(ii)
            ci = rpole(1,i)
            dix = rpole(2,i)
            diy = rpole(3,i)
            diz = rpole(4,i)
            qixx = rpole(5,i)
            qixy = rpole(6,i)
            qixz = rpole(7,i)
            qiyy = rpole(9,i)
            qiyz = rpole(10,i)
            qizz = rpole(13,i)
            if (use_chgpen) then
               corei = pcore(i)
               vali = pval(i)
               alphai = palpha(i)
            end if
c
c     set exclusion coefficients for connected atoms
c
            if (dpequal) then
               do j = 1, n12(i)
                  pscale(i12(j,i)) = p2scale
                  do k = 1, np11(i)
                     if (i12(j,i) .eq. ip11(k,i))
     &                  pscale(i12(j,i)) = p2iscale
                  end do
                  dscale(i12(j,i)) = pscale(i12(j,i))
               end do
               do j = 1, n13(i)
                  pscale(i13(j,i)) = p3scale
                  do k = 1, np11(i)
                     if (i13(j,i) .eq. ip11(k,i))
     &                  pscale(i13(j,i)) = p3iscale
                  end do
                  dscale(i13(j,i)) = pscale(i13(j,i))
               end do
               do j = 1, n14(i)
                  pscale(i14(j,i)) = p4scale
                  do k = 1, np11(i)
                     if (i14(j,i) .eq. ip11(k,i))
     &                  pscale(i14(j,i)) = p4iscale
                  end do
                  dscale(i14(j,i)) = pscale(i14(j,i))
               end do
               do j = 1, n15(i)
                  pscale(i15(j,i)) = p5scale
                  do k = 1, np11(i)
                     if (i15(j,i) .eq. ip11(k,i))
     &                  pscale(i15(j,i)) = p5iscale
                  end do
                  dscale(i15(j,i)) = pscale(i15(j,i))
               end do
            else
               do j = 1, n12(i)
                  pscale(i12(j,i)) = p2scale
                  do k = 1, np11(i)
                     if (i12(j,i) .eq. ip11(k,i))
     &                  pscale(i12(j,i)) = p2iscale
                  end do
               end do
               do j = 1, n13(i)
                  pscale(i13(j,i)) = p3scale
                  do k = 1, np11(i)
                     if (i13(j,i) .eq. ip11(k,i))
     &                  pscale(i13(j,i)) = p3iscale
                  end do
               end do
               do j = 1, n14(i)
                  pscale(i14(j,i)) = p4scale
                  do k = 1, np11(i)
                     if (i14(j,i) .eq. ip11(k,i))
     &                  pscale(i14(j,i)) = p4iscale
                  end do
               end do
               do j = 1, n15(i)
                  pscale(i15(j,i)) = p5scale
                  do k = 1, np11(i)
                     if (i15(j,i) .eq. ip11(k,i))
     &                  pscale(i15(j,i)) = p5iscale
                  end do
               end do
               do j = 1, np11(i)
                  dscale(ip11(j,i)) = d1scale
               end do
               do j = 1, np12(i)
                  dscale(ip12(j,i)) = d2scale
               end do
               do j = 1, np13(i)
                  dscale(ip13(j,i)) = d3scale
               end do
               do j = 1, np14(i)
                  dscale(ip14(j,i)) = d4scale
               end do
            end if
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
               do m = 2, ncell
                  xr = x(k) - x(i)
                  yr = y(k) - y(i)
                  zr = z(k) - z(i)
                  call imager (xr,yr,zr,m)
                  r2 = xr*xr + yr* yr + zr*zr
c
c     calculate the error function damping factors
c
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     rr1 = 1.0d0 / r
                     rr2 = rr1 * rr1
                     rr3 = rr2 * rr1
                     rr5 = 3.0d0 * rr2 * rr3
                     rr7 = 5.0d0 * rr2 * rr5
c
c     intermediates involving moments and separation distance
c
                     dir = dix*xr + diy*yr + diz*zr
                     qix = qixx*xr + qixy*yr + qixz*zr
                     qiy = qixy*xr + qiyy*yr + qiyz*zr
                     qiz = qixz*xr + qiyz*yr + qizz*zr
                     qir = qix*xr + qiy*yr + qiz*zr
                     dkr = dkx*xr + dky*yr + dkz*zr
                     qkx = qkxx*xr + qkxy*yr + qkxz*zr
                     qky = qkxy*xr + qkyy*yr + qkyz*zr
                     qkz = qkxz*xr + qkyz*yr + qkzz*zr
                     qkr = qkx*xr + qky*yr + qkz*zr
c
c     calculate real space Ewald error function damping
c
                     call dampewald (7,r,r2,1.0d0,dmpe)
c
c     find the field components for Thole polarization damping
c
                     if (use_thole) then
                        call damptholed (i,k,7,r,dmpik)
                        dsc3 = dmpik(3)
                        dsc5 = dmpik(5)
                        dsc7 = dmpik(7)
                        psc3 = dmpik(3)
                        psc5 = dmpik(5)
                        psc7 = dmpik(7)
                        if (use_polymer) then
                           if (r2 .le. polycut2) then
                              dsc3 = dmpik(3) * dscale(k)
                              dsc5 = dmpik(5) * dscale(k)
                              dsc7 = dmpik(7) * dscale(k)
                              psc3 = dmpik(3) * pscale(k)
                              psc5 = dmpik(5) * pscale(k)
                              psc7 = dmpik(7) * pscale(k)
                           end if
                        end if
                        dmp3 = dmpe(3) - (1.0d0-dsc3)*rr3
                        dmp5 = dmpe(5) - (1.0d0-dsc5)*rr5
                        dmp7 = dmpe(7) - (1.0d0-dsc7)*rr7
                        fid(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                              - dmp3*dkx + 2.0d0*dmp5*qkx
                        fid(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                              - dmp3*dky + 2.0d0*dmp5*qky
                        fid(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                              - dmp3*dkz + 2.0d0*dmp5*qkz
                        fkd(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                              - dmp3*dix - 2.0d0*dmp5*qix
                        fkd(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                              - dmp3*diy - 2.0d0*dmp5*qiy
                        fkd(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                              - dmp3*diz - 2.0d0*dmp5*qiz
                        dmp3 = dmpe(3) - (1.0d0-psc3)*rr3
                        dmp5 = dmpe(5) - (1.0d0-psc5)*rr5
                        dmp7 = dmpe(7) - (1.0d0-psc7)*rr7
                        fip(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                              - dmp3*dkx + 2.0d0*dmp5*qkx
                        fip(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                              - dmp3*dky + 2.0d0*dmp5*qky
                        fip(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                              - dmp3*dkz + 2.0d0*dmp5*qkz
                        fkp(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                              - dmp3*dix - 2.0d0*dmp5*qix
                        fkp(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                              - dmp3*diy - 2.0d0*dmp5*qiy
                        fkp(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                              - dmp3*diz - 2.0d0*dmp5*qiz
c
c     find the field components for charge penetration damping
c
                     else if (use_chgpen) then
                        corek = pcore(k)
                        valk = pval(k)
                        alphak = palpha(k)
                        call dampdir (r,alphai,alphak,dmpi,dmpk)
                        scalek = 1.0d0
                        if (use_polymer) then
                           if (r2 .le. polycut2) then
                              scalek = dscale(k)
                           end if
                        end if
                        rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                        rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                        rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7
                        rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                        rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                        rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7
                        rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                        fid(1) = -xr*(rr3*corek + rr3k*valk
     &                              - rr5k*dkr + rr7k*qkr)
     &                              - rr3k*dkx + 2.0d0*rr5k*qkx
                        fid(2) = -yr*(rr3*corek + rr3k*valk
     &                              - rr5k*dkr + rr7k*qkr)
     &                              - rr3k*dky + 2.0d0*rr5k*qky
                        fid(3) = -zr*(rr3*corek + rr3k*valk
     &                              - rr5k*dkr + rr7k*qkr)
     &                              - rr3k*dkz + 2.0d0*rr5k*qkz
                        fkd(1) = xr*(rr3*corei + rr3i*vali
     &                              + rr5i*dir + rr7i*qir)
     &                              - rr3i*dix - 2.0d0*rr5i*qix
                        fkd(2) = yr*(rr3*corei + rr3i*vali
     &                              + rr5i*dir + rr7i*qir)
     &                              - rr3i*diy - 2.0d0*rr5i*qiy
                        fkd(3) = zr*(rr3*corei + rr3i*vali
     &                              + rr5i*dir + rr7i*qir)
     &                              - rr3i*diz - 2.0d0*rr5i*qiz
                        scalek = 1.0d0
                        if (use_polymer) then
                           if (r2 .le. polycut2) then
                              scalek = pscale(k)
                           end if
                        end if
                        rr3 = rr2 * rr1
                        rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                        rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                        rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7
                        rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                        rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                        rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7
                        rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                        fip(1) = -xr*(rr3*corek + rr3k*valk
     &                              - rr5k*dkr + rr7k*qkr)
     &                              - rr3k*dkx + 2.0d0*rr5k*qkx
                        fip(2) = -yr*(rr3*corek + rr3k*valk
     &                              - rr5k*dkr + rr7k*qkr)
     &                              - rr3k*dky + 2.0d0*rr5k*qky
                        fip(3) = -zr*(rr3*corek + rr3k*valk
     &                              - rr5k*dkr + rr7k*qkr)
     &                              - rr3k*dkz + 2.0d0*rr5k*qkz
                        fkp(1) = xr*(rr3*corei + rr3i*vali
     &                              + rr5i*dir + rr7i*qir)
     &                              - rr3i*dix - 2.0d0*rr5i*qix
                        fkp(2) = yr*(rr3*corei + rr3i*vali
     &                              + rr5i*dir + rr7i*qir)
     &                              - rr3i*diy - 2.0d0*rr5i*qiy
                        fkp(3) = zr*(rr3*corei + rr3i*vali
     &                              + rr5i*dir + rr7i*qir)
     &                              - rr3i*diz - 2.0d0*rr5i*qiz
                     end if
c
c     increment the field at each site due to this interaction
c
                     do j = 1, 3
                        field(j,i) = field(j,i) + fid(j)
                        fieldp(j,i) = fieldp(j,i) + fid(j)
                        if (i .ne. k) then
                           field(j,k) = field(j,k) + fkp(j)
                           fieldp(j,k) = fieldp(j,k) + fkp(j)
                        end if
                     end do
                  end if
               end do
            end do
c
c     reset exclusion coefficients for connected atoms
c
            if (dpequal) then
               do j = 1, n12(i)
                  pscale(i12(j,i)) = 1.0d0
                  dscale(i12(j,i)) = 1.0d0
               end do
               do j = 1, n13(i)
                  pscale(i13(j,i)) = 1.0d0
                  dscale(i13(j,i)) = 1.0d0
               end do
               do j = 1, n14(i)
                  pscale(i14(j,i)) = 1.0d0
                  dscale(i14(j,i)) = 1.0d0
               end do
               do j = 1, n15(i)
                  pscale(i15(j,i)) = 1.0d0
                  dscale(i15(j,i)) = 1.0d0
               end do
            else
               do j = 1, n12(i)
                  pscale(i12(j,i)) = 1.0d0
               end do
               do j = 1, n13(i)
                  pscale(i13(j,i)) = 1.0d0
               end do
               do j = 1, n14(i)
                  pscale(i14(j,i)) = 1.0d0
               end do
               do j = 1, n15(i)
                  pscale(i15(j,i)) = 1.0d0
               end do
               do j = 1, np11(i)
                  dscale(ip11(j,i)) = 1.0d0
               end do
               do j = 1, np12(i)
                  dscale(ip12(j,i)) = 1.0d0
               end do
               do j = 1, np13(i)
                  dscale(ip13(j,i)) = 1.0d0
               end do
               do j = 1, np14(i)
                  dscale(ip14(j,i)) = 1.0d0
               end do
            end if
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (dscale)
      deallocate (pscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine udirect2b  --  Ewald real direct field via list  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "udirect2b" computes the real space contribution of the permanent
c     atomic multipole moments to the field via a neighbor list
c
c
      subroutine udirect2b (field,fieldp)
      use atoms
      use boxes
      use bound
      use chgpen
      use couple
      use math
      use mplpot
      use mpole
      use neigh
      use openmp
      use polar
      use polgrp
      use polpot
      use shunt
      use tarray
      use units
      implicit none
      integer i,j,k,m
      integer ii,kk
      integer nlocal,nslice
      integer tid,maxlocal
!$    integer omp_get_thread_num
      integer, allocatable :: toffset(:)
      integer, allocatable :: ilocal(:,:)
      real*8 xr,yr,zr
      real*8 r,r2,rr1,rr2
      real*8 rr3,rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 rr3ik,rr5ik
      real*8 ci,dix,diy,diz
      real*8 qixx,qiyy,qizz
      real*8 qixy,qixz,qiyz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkyy,qkzz
      real*8 qkxy,qkxz,qkyz
      real*8 dir,dkr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 scalek
      real*8 dmp3,dmp5,dmp7
      real*8 fid(3),fkd(3)
      real*8 fip(3),fkp(3)
      real*8 dmpi(7),dmpk(7)
      real*8 dmpik(7),dmpe(7)
      real*8, allocatable :: pscale(:)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: wscale(:)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      real*8, allocatable :: fieldt(:,:)
      real*8, allocatable :: fieldtp(:,:)
      real*8, allocatable :: dlocal(:,:)
      character*6 mode
c
c
c     check for multipoles and set cutoff coefficients
c
      if (npole .eq. 0)  return
      mode = 'EWALD'
      call switch (mode)
c
c     values for storage of mutual polarization intermediates
c
      nslice = int(0.5d0*dble(n)/dble(nthread)) + 1
      maxlocal = int(dble(n)*dble(maxelst)/dble(nthread))
      nlocal = 0
      ntpair = 0
c
c     perform dynamic allocation of some local arrays
c
      allocate (pscale(n))
      allocate (dscale(n))
      allocate (uscale(n))
      allocate (wscale(n))
      allocate (fieldt(3,n))
      allocate (fieldtp(3,n))
      allocate (toffset(0:nthread-1))
      if (poltyp .ne. 'DIRECT') then
         allocate (ilocal(2,maxlocal))
         allocate (dlocal(6,maxlocal))
      end if
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         pscale(i) = 1.0d0
         wscale(i) = 1.0d0
         dscale(i) = 1.0d0
         uscale(i) = 1.0d0
      end do
c
c     initialize local variables for OpenMP calculation
c
      do i = 1, n
         do j = 1, 3
            fieldt(j,i) = 0.0d0
            fieldtp(j,i) = 0.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,rpole,x,y,z,pcore,
!$OMP& pval,palpha,p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,
!$OMP& p4iscale,p5iscale,w2scale,w3scale,w4scale,w5scale,d1scale,
!$OMP& d2scale,d3scale,d4scale,u1scale,u2scale,u3scale,u4scale,n12,i12,
!$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14,
!$OMP& nelst,elst,dpequal,use_thole,use_chgpen,use_bounds,off2,poltyp,
!$OMP& nslice,ntpair,tindex,tdipdip,toffset,field,fieldp,fieldt,fieldtp)
!$OMP& firstprivate(pscale,dscale,uscale,wscale,nlocal)
!$OMP DO reduction(+:fieldt,fieldtp) schedule(static,nslice)
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, npole
         i = ipole(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                   if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               wscale(i15(j,i)) = w5scale
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
               uscale(ip14(j,i)) = u4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = 1, nelst(i)
            k = elst(kk,i)
            xr = x(k) - x(i)
            yr = y(k) - y(i)
            zr = z(k) - z(i)
            if (use_bounds)  call image (xr,yr,zr)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               rr1 = 1.0d0 / r
               rr2 = rr1 * rr1
               rr3 = rr2 * rr1
               rr5 = 3.0d0 * rr2 * rr3
               rr7 = 5.0d0 * rr2 * rr5
               ck = rpole(1,k)
               dkx = rpole(2,k)
               dky = rpole(3,k)
               dkz = rpole(4,k)
               qkxx = rpole(5,k)
               qkxy = rpole(6,k)
               qkxz = rpole(7,k)
               qkyy = rpole(9,k)
               qkyz = rpole(10,k)
               qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               qix = qixx*xr + qixy*yr + qixz*zr
               qiy = qixy*xr + qiyy*yr + qiyz*zr
               qiz = qixz*xr + qiyz*yr + qizz*zr
               qir = qix*xr + qiy*yr + qiz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               qkx = qkxx*xr + qkxy*yr + qkxz*zr
               qky = qkxy*xr + qkyy*yr + qkyz*zr
               qkz = qkxz*xr + qkyz*yr + qkzz*zr
               qkr = qkx*xr + qky*yr + qkz*zr
c
c     calculate real space Ewald error function damping
c
               call dampewald (7,r,r2,1.0d0,dmpe)
c
c     find the field components for Thole polarization damping
c
               if (use_thole) then
                  call damptholed (i,k,7,r,dmpik)
                  scalek = dscale(k)
                  dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                  dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                  dmp7 = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                  fid(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                        - dmp3*dkx + 2.0d0*dmp5*qkx
                  fid(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                        - dmp3*dky + 2.0d0*dmp5*qky
                  fid(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                        - dmp3*dkz + 2.0d0*dmp5*qkz
                  fkd(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                        - dmp3*dix - 2.0d0*dmp5*qix
                  fkd(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                        - dmp3*diy - 2.0d0*dmp5*qiy
                  fkd(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                        - dmp3*diz - 2.0d0*dmp5*qiz
                  scalek = pscale(k)
                  dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                  dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                  dmp7 = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7
                  fip(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                        - dmp3*dkx + 2.0d0*dmp5*qkx
                  fip(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                        - dmp3*dky + 2.0d0*dmp5*qky
                  fip(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr)
     &                        - dmp3*dkz + 2.0d0*dmp5*qkz
                  fkp(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                        - dmp3*dix - 2.0d0*dmp5*qix
                  fkp(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                        - dmp3*diy - 2.0d0*dmp5*qiy
                  fkp(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir)
     &                        - dmp3*diz - 2.0d0*dmp5*qiz
c
c     find terms needed later to compute mutual polarization
c
                  if (poltyp .ne. 'DIRECT') then
                     call dampthole (i,k,5,r,dmpik)
                     scalek = uscale(k)
                     dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                     dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                     nlocal = nlocal + 1
                     ilocal(1,nlocal) = i
                     ilocal(2,nlocal) = k
                     dlocal(1,nlocal) = -dmp3 + dmp5*xr*xr
                     dlocal(2,nlocal) = dmp5*xr*yr
                     dlocal(3,nlocal) = dmp5*xr*zr
                     dlocal(4,nlocal) = -dmp3 + dmp5*yr*yr
                     dlocal(5,nlocal) = dmp5*yr*zr
                     dlocal(6,nlocal) = -dmp3 + dmp5*zr*zr
                  end if
c
c     find the field components for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampdir (r,alphai,alphak,dmpi,dmpk)
                  scalek = dscale(k)
                  rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                  rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7
                  rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                  rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7
                  rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                  fid(1) = -xr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dkx + 2.0d0*rr5k*qkx
                  fid(2) = -yr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dky + 2.0d0*rr5k*qky
                  fid(3) = -zr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dkz + 2.0d0*rr5k*qkz
                  fkd(1) = xr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*dix - 2.0d0*rr5i*qix
                  fkd(2) = yr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*diy - 2.0d0*rr5i*qiy
                  fkd(3) = zr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*diz - 2.0d0*rr5i*qiz
                  scalek = pscale(k)
                  rr3 = rr2 * rr1
                  rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3
                  rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5
                  rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7
                  rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3
                  rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5
                  rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7
                  rr3 = dmpe(3) - (1.0d0-scalek)*rr3
                  fip(1) = -xr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dkx + 2.0d0*rr5k*qkx
                  fip(2) = -yr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dky + 2.0d0*rr5k*qky
                  fip(3) = -zr*(rr3*corek + rr3k*valk
     &                        - rr5k*dkr + rr7k*qkr)
     &                        - rr3k*dkz + 2.0d0*rr5k*qkz
                  fkp(1) = xr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*dix - 2.0d0*rr5i*qix
                  fkp(2) = yr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*diy - 2.0d0*rr5i*qiy
                  fkp(3) = zr*(rr3*corei + rr3i*vali
     &                        + rr5i*dir + rr7i*qir)
     &                        - rr3i*diz - 2.0d0*rr5i*qiz
c
c     find terms needed later to compute mutual polarization
c
                  if (poltyp .ne. 'DIRECT') then
                     call dampmut (r,alphai,alphak,dmpik)
                     scalek = wscale(k)
                     rr3 = rr2 * rr1
                     rr3ik = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3
                     rr5ik = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5
                     nlocal = nlocal + 1
                     ilocal(1,nlocal) = i
                     ilocal(2,nlocal) = k
                     dlocal(1,nlocal) = -rr3ik + rr5ik*xr*xr
                     dlocal(2,nlocal) = rr5ik*xr*yr
                     dlocal(3,nlocal) = rr5ik*xr*zr
                     dlocal(4,nlocal) = -rr3ik + rr5ik*yr*yr
                     dlocal(5,nlocal) = rr5ik*yr*zr
                     dlocal(6,nlocal) = -rr3ik + rr5ik*zr*zr
                  end if
               end if
c
c     increment the field at each site due to this interaction
c
               do j = 1, 3
                  fieldt(j,i) = fieldt(j,i) + fid(j)
                  fieldt(j,k) = fieldt(j,k) + fkd(j)
                  fieldtp(j,i) = fieldtp(j,i) + fip(j)
                  fieldtp(j,k) = fieldtp(j,k) + fkp(j)
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               wscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
               uscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
!$OMP END DO
c
c     find offset into global arrays for the current thread
c
!$OMP CRITICAL
      tid = 0
!$    tid = omp_get_thread_num ()
      toffset(tid) = ntpair
      ntpair = ntpair + nlocal
c
c     store terms used later to compute mutual polarization
c
      if (poltyp .ne. 'DIRECT') then
         k = toffset(tid)
         do i = 1, nlocal
            m = k + i
            tindex(1,m) = ilocal(1,i)
            tindex(2,m) = ilocal(2,i)
            do j = 1, 6
               tdipdip(j,m) = dlocal(j,i)
            end do
         end do
      end if
!$OMP END CRITICAL
c
c     add local to global variables for OpenMP calculation
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            field(j,i) = field(j,i) + fieldt(j,i)
            fieldp(j,i) = fieldp(j,i) + fieldtp(j,i)
         end do
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (pscale)
      deallocate (wscale)
      deallocate (dscale)
      deallocate (uscale)
      deallocate (fieldt)
      deallocate (fieldtp)
      deallocate (toffset)
      if (allocated(ilocal))  deallocate (ilocal)
      if (allocated(dlocal))  deallocate (dlocal)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ufield0c  --  mutual induction via Ewald sum  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ufield0c" computes the mutual electrostatic field due to
c     induced dipole moments via Ewald summation
c
c
      subroutine ufield0c (field,fieldp)
      use atoms
      use boxes
      use ewald
      use limits
      use math
      use mpole
      use pme
      use polar
      implicit none
      integer i,j,ii
      real*8 term
      real*8 ucell(3)
      real*8 ucellp(3)
      real*8 field(3,*)
      real*8 fieldp(3,*)
c
c
c     zero out the electrostatic field at each site
c
      do i = 1, n
         do j = 1, 3
            field(j,i) = 0.0d0
            fieldp(j,i) = 0.0d0
         end do
      end do
c
c     set grid size, spline order and Ewald coefficient
c
      nfft1 = nefft1
      nfft2 = nefft2
      nfft3 = nefft3
      bsorder = bsporder
      aewald = apewald
c
c     get the reciprocal space part of the mutual field
c
      call umutual1 (field,fieldp)
c
c     get the real space portion of the mutual field
c
      if (use_mlist) then
         call umutual2b (field,fieldp)
      else
         call umutual2a (field,fieldp)
      end if
c
c     get the self-energy portion of the mutual field
c
      term = (4.0d0/3.0d0) * aewald**3 / rootpi
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            field(j,i) = field(j,i) + term*uind(j,i)
            fieldp(j,i) = fieldp(j,i) + term*uinp(j,i)
         end do
      end do
c
c     compute the cell dipole boundary correction to the field
c
      if (boundary .eq. 'VACUUM') then
         do j = 1, 3
            ucell(j) = 0.0d0
            ucellp(j) = 0.0d0
         end do
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               ucell(j) = ucell(j) + uind(j,i)
               ucellp(j) = ucellp(j) + uinp(j,i)
            end do
         end do
         term = (4.0d0/3.0d0) * pi/volbox
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               field(j,i) = field(j,i) - term*ucell(j)
               fieldp(j,i) = fieldp(j,i) - term*ucellp(j)
            end do
         end do
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine umutual1  --  Ewald recip mutual induced field  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "umutual1" computes the reciprocal space contribution of the
c     induced atomic dipole moments to the field
c
c
      subroutine umutual1 (field,fieldp)
      use atoms
      use boxes
      use ewald
      use math
      use mpole
      use pme
      use polar
      use polopt
      use polpot
      implicit none
      integer i,j,k,ii
      real*8 term
      real*8 a(3,3)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      real*8, allocatable :: fuind(:,:)
      real*8, allocatable :: fuinp(:,:)
      real*8, allocatable :: fdip_phi1(:,:)
      real*8, allocatable :: fdip_phi2(:,:)
      real*8, allocatable :: fdip_sum_phi(:,:)
      real*8, allocatable :: dipfield1(:,:)
      real*8, allocatable :: dipfield2(:,:)
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (fuind(3,n))
      allocate (fuinp(3,n))
      allocate (fdip_phi1(10,n))
      allocate (fdip_phi2(10,n))
      allocate (fdip_sum_phi(20,n))
      allocate (dipfield1(3,n))
      allocate (dipfield2(3,n))
c
c     convert Cartesian dipoles to fractional coordinates
c
      do i = 1, 3
         a(1,i) = dble(nfft1) * recip(i,1)
         a(2,i) = dble(nfft2) * recip(i,2)
         a(3,i) = dble(nfft3) * recip(i,3)
      end do
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            fuind(j,i) = a(j,1)*uind(1,i) + a(j,2)*uind(2,i)
     &                      + a(j,3)*uind(3,i)
            fuinp(j,i) = a(j,1)*uinp(1,i) + a(j,2)*uinp(2,i)
     &                      + a(j,3)*uinp(3,i)
         end do
      end do
c
c     assign PME grid and perform 3-D FFT forward transform
c
      call grid_uind (fuind,fuinp)
      call fftfront
c
c     complete the transformation of the PME grid
c
      do k = 1, nfft3
         do j = 1, nfft2
            do i = 1, nfft1
               term = qfac(i,j,k)
               qgrid(1,i,j,k) = term * qgrid(1,i,j,k)
               qgrid(2,i,j,k) = term * qgrid(2,i,j,k)
            end do
         end do
      end do
c
c     perform 3-D FFT backward transform and get field
c
      call fftback
      call fphi_uind (fdip_phi1,fdip_phi2,fdip_sum_phi)
c
c     store fractional reciprocal potentials for OPT method
c
      if (poltyp .eq. 'OPT') then
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 10
               fopt(optlevel,j,i) = fdip_phi1(j,i)
               foptp(optlevel,j,i) = fdip_phi2(j,i)
            end do
         end do
      end if
c
c     convert the dipole fields from fractional to Cartesian
c
      do i = 1, 3
         a(i,1) = dble(nfft1) * recip(i,1)
         a(i,2) = dble(nfft2) * recip(i,2)
         a(i,3) = dble(nfft3) * recip(i,3)
      end do
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            dipfield1(j,i) = a(j,1)*fdip_phi1(2,i)
     &                          + a(j,2)*fdip_phi1(3,i)
     &                          + a(j,3)*fdip_phi1(4,i)
            dipfield2(j,i) = a(j,1)*fdip_phi2(2,i)
     &                          + a(j,2)*fdip_phi2(3,i)
     &                          + a(j,3)*fdip_phi2(4,i)
         end do
      end do
c
c     increment the field at each multipole site
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            field(j,i) = field(j,i) - dipfield1(j,i)
            fieldp(j,i) = fieldp(j,i) - dipfield2(j,i)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (fuind)
      deallocate (fuinp)
      deallocate (fdip_phi1)
      deallocate (fdip_phi2)
      deallocate (fdip_sum_phi)
      deallocate (dipfield1)
      deallocate (dipfield2)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine umutual2a  --  Ewald real mutual field via loop  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "umutual2a" computes the real space contribution of the induced
c     atomic dipole moments to the field via a double loop
c
c
      subroutine umutual2a (field,fieldp)
      use atoms
      use boxes
      use bound
      use cell
      use chgpen
      use couple
      use math
      use mplpot
      use mpole
      use polar
      use polgrp
      use polpot
      use shunt
      use units
      implicit none
      integer i,j,k,m
      integer ii,kk
      real*8 xr,yr,zr
      real*8 r,r2,rr1
      real*8 rr2,rr3,rr5
      real*8 dix,diy,diz
      real*8 pix,piy,piz
      real*8 dkx,dky,dkz
      real*8 pkx,pky,pkz
      real*8 dir,dkr
      real*8 pir,pkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 fid(3),fkd(3)
      real*8 fip(3),fkp(3)
      real*8 dmpik(5),dmpe(5)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: wscale(:)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      character*6 mode
c
c
c     check for multipoles and set cutoff coefficients
c
      if (npole .eq. 0)  return
      mode = 'EWALD'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (uscale(n))
      allocate (wscale(n))
c
c     set array needed to scale connected atom interactions
c
      do i = 1, n
         uscale(i) = 1.0d0
         wscale(i) = 1.0d0
      end do
c
c     compute the real space portion of the Ewald summation
c
      do ii = 1, npole-1
         i = ipole(ii)
         dix = uind(1,i)
         diy = uind(2,i)
         diz = uind(3,i)
         pix = uinp(1,i)
         piy = uinp(2,i)
         piz = uinp(3,i)
         if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, np11(i)
            uscale(ip11(j,i)) = u1scale
         end do
         do j = 1, np12(i)
            uscale(ip12(j,i)) = u2scale
         end do
         do j = 1, np13(i)
            uscale(ip13(j,i)) = u3scale
         end do
         do j = 1, np14(i)
            uscale(ip14(j,i)) = u4scale
         end do
         do j = 1, n12(i)
            wscale(i12(j,i)) = w2scale
         end do
         do j = 1, n13(i)
            wscale(i13(j,i)) = w3scale
         end do
         do j = 1, n14(i)
            wscale(i14(j,i)) = w4scale
         end do
         do j = 1, n15(i)
            wscale(i15(j,i)) = w5scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - x(i)
            yr = y(k) - y(i)
            zr = z(k) - z(i)
            call image (xr,yr,zr)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               rr1 = 1.0d0 / r
               rr2 = rr1 * rr1
               rr3 = rr2 * rr1
               rr5 = rr2 * rr3
               dkx = uind(1,k)
               dky = uind(2,k)
               dkz = uind(3,k)
               pkx = uinp(1,k)
               pky = uinp(2,k)
               pkz = uinp(3,k)
c
c     intermediates involving moments and separation distance
c
               dir = dix*xr + diy*yr + diz*zr
               dkr = dkx*xr + dky*yr + dkz*zr
               pir = pix*xr + piy*yr + piz*zr
               pkr = pkx*xr + pky*yr + pkz*zr
c
c     calculate real space Ewald error function damping
c
               call dampewald (5,r,r2,1.0d0,dmpe)
c
c     find the field components for Thole polarization damping
c
               if (use_thole) then
                  call dampthole (i,k,5,r,dmpik)
                  dmpik(3) = uscale(k) * dmpik(3)
                  dmpik(5) = uscale(k) * dmpik(5)
c
c     find the field components for charge penetration damping
c
               else if (use_chgpen) then
                  corek = pcore(k)
                  valk = pval(k)
                  alphak = palpha(k)
                  call dampmut (r,alphai,alphak,dmpik)
                  dmpik(3) = wscale(k) * dmpik(3)
                  dmpik(5) = wscale(k) * dmpik(5)
               end if
c
c     find the field terms for the current interaction
c
               rr3 = -dmpe(3) + (1.0d0-dmpik(3))*rr3
               rr5 = dmpe(5) - 3.0d0*(1.0d0-dmpik(5))*rr5
               fid(1) = rr3*dkx + rr5*dkr*xr
               fid(2) = rr3*dky + rr5*dkr*yr
               fid(3) = rr3*dkz + rr5*dkr*zr
               fkd(1) = rr3*dix + rr5*dir*xr
               fkd(2) = rr3*diy + rr5*dir*yr
               fkd(3) = rr3*diz + rr5*dir*zr
               fip(1) = rr3*pkx + rr5*pkr*xr
               fip(2) = rr3*pky + rr5*pkr*yr
               fip(3) = rr3*pkz + rr5*pkr*zr
               fkp(1) = rr3*pix + rr5*pir*xr
               fkp(2) = rr3*piy + rr5*pir*yr
               fkp(3) = rr3*piz + rr5*pir*zr
c
c     increment the field at each site due to this interaction
c
               do j = 1, 3
                  field(j,i) = field(j,i) + fid(j)
                  field(j,k) = field(j,k) + fkd(j)
                  fieldp(j,i) = fieldp(j,i) + fip(j)
                  fieldp(j,k) = fieldp(j,k) + fkp(j)
               end do
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, np11(i)
            uscale(ip11(j,i)) = 1.0d0
         end do
         do j = 1, np12(i)
            uscale(ip12(j,i)) = 1.0d0
         end do
         do j = 1, np13(i)
            uscale(ip13(j,i)) = 1.0d0
         end do
         do j = 1, np14(i)
            uscale(ip14(j,i)) = 1.0d0
         end do
         do j = 1, n12(i)
            wscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            wscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            wscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            wscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     periodic boundary for large cutoffs via replicates method
c
      if (use_replica) then
         do ii = 1, npole
            i = ipole(ii)
            dix = uind(1,i)
            diy = uind(2,i)
            diz = uind(3,i)
            pix = uinp(1,i)
            piy = uinp(2,i)
            piz = uinp(3,i)
            if (use_chgpen) then
               corei = pcore(i)
               vali = pval(i)
               alphai = palpha(i)
            end if
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
            do j = 1, n12(i)
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               wscale(i15(j,i)) = w5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii, npole
               k = ipole(kk)
               dkx = uind(1,k)
               dky = uind(2,k)
               dkz = uind(3,k)
               pkx = uinp(1,k)
               pky = uinp(2,k)
               pkz = uinp(3,k)
               do m = 2, ncell
                  xr = x(k) - x(i)
                  yr = y(k) - y(i)
                  zr = z(k) - z(i)
                  call imager (xr,yr,zr,m)
                  r2 = xr*xr + yr* yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     rr1 = 1.0d0 / r
                     rr2 = rr1 * rr1
                     rr3 = rr2 * rr1
                     rr5 = rr2 * rr3
c
c     intermediates involving moments and separation distance
c
                     dir = dix*xr + diy*yr + diz*zr
                     dkr = dkx*xr + dky*yr + dkz*zr
                     pir = pix*xr + piy*yr + piz*zr
                     pkr = pkx*xr + pky*yr + pkz*zr
c
c     calculate real space Ewald error function damping
c
                     call dampewald (5,r,r2,1.0d0,dmpe)
c
c     find the field components for Thole polarization damping
c
                     if (use_thole) then
                        call dampthole (i,k,5,r,dmpik)
                        dmpik(3) = uscale(k) * dmpik(3)
                        dmpik(5) = uscale(k) * dmpik(5)
c
c     find the field components for charge penetration damping
c
                     else if (use_chgpen) then
                        corek = pcore(k)
                        valk = pval(k)
                        alphak = palpha(k)
                        call dampmut (r,alphai,alphak,dmpik)
                        dmpik(3) = wscale(k) * dmpik(3)
                        dmpik(5) = wscale(k) * dmpik(5)
                     end if
c
c     find the field terms for the current interaction
c
                     rr3 = -dmpe(3) + (1.0d0-dmpik(3))*rr3
                     rr5 = dmpe(5) - 3.0d0*(1.0d0-dmpik(5))*rr5
                     fid(1) = rr3*dkx + rr5*dkr*xr
                     fid(2) = rr3*dky + rr5*dkr*yr
                     fid(3) = rr3*dkz + rr5*dkr*zr
                     fkd(1) = rr3*dix + rr5*dir*xr
                     fkd(2) = rr3*diy + rr5*dir*yr
                     fkd(3) = rr3*diz + rr5*dir*zr
                     fip(1) = rr3*pkx + rr5*pkr*xr
                     fip(2) = rr3*pky + rr5*pkr*yr
                     fip(3) = rr3*pkz + rr5*pkr*zr
                     fkp(1) = rr3*pix + rr5*pir*xr
                     fkp(2) = rr3*piy + rr5*pir*yr
                     fkp(3) = rr3*piz + rr5*pir*zr
c
c     increment the field at each site due to this interaction
c
                     do j = 1, 3
                        field(j,i) = field(j,i) + fid(j)
                        fieldp(j,i) = fieldp(j,i) + fip(j)
                        if (i .ne. k) then
                           field(j,k) = field(j,k) + fkd(j)
                           fieldp(j,k) = fieldp(j,k) + fkp(j)
                        end if
                     end do
                  end if
               end do
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
            do j = 1, n12(i)
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               wscale(i15(j,i)) = 1.0d0
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (uscale)
      deallocate (wscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine umutual2b  --  Ewald real mutual field via list  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "umutual2b" computes the real space contribution of the induced
c     atomic dipole moments to the field via a neighbor list
c
c
      subroutine umutual2b (field,fieldp)
      use atoms
      use mpole
      use polar
      use tarray
      implicit none
      integer i,j,k,m,ii
      real*8 fid(3),fkd(3)
      real*8 fip(3),fkp(3)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      real*8, allocatable :: fieldt(:,:)
      real*8, allocatable :: fieldtp(:,:)
c
c
c     check for multipoles and set cutoff coefficients
c
      if (npole .eq. 0)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (fieldt(3,n))
      allocate (fieldtp(3,n))
c
c     initialize local variables for OpenMP calculation
c
      do i = 1, n
         do j = 1, 3
            fieldt(j,i) = 0.0d0
            fieldtp(j,i) = 0.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,uind,uinp,
!$OMP& ntpair,tindex,tdipdip,field,fieldp,fieldt,fieldtp)
!$OMP DO reduction(+:fieldt,fieldtp)
c
c     find the field terms for each pairwise interaction
c
      do m = 1, ntpair
         i = tindex(1,m)
         k = tindex(2,m)
         fid(1) = tdipdip(1,m)*uind(1,k) + tdipdip(2,m)*uind(2,k)
     &               + tdipdip(3,m)*uind(3,k)
         fid(2) = tdipdip(2,m)*uind(1,k) + tdipdip(4,m)*uind(2,k)
     &               + tdipdip(5,m)*uind(3,k)
         fid(3) = tdipdip(3,m)*uind(1,k) + tdipdip(5,m)*uind(2,k)
     &               + tdipdip(6,m)*uind(3,k)
         fkd(1) = tdipdip(1,m)*uind(1,i) + tdipdip(2,m)*uind(2,i)
     &               + tdipdip(3,m)*uind(3,i)
         fkd(2) = tdipdip(2,m)*uind(1,i) + tdipdip(4,m)*uind(2,i)
     &               + tdipdip(5,m)*uind(3,i)
         fkd(3) = tdipdip(3,m)*uind(1,i) + tdipdip(5,m)*uind(2,i)
     &               + tdipdip(6,m)*uind(3,i)
         fip(1) = tdipdip(1,m)*uinp(1,k) + tdipdip(2,m)*uinp(2,k)
     &               + tdipdip(3,m)*uinp(3,k)
         fip(2) = tdipdip(2,m)*uinp(1,k) + tdipdip(4,m)*uinp(2,k)
     &               + tdipdip(5,m)*uinp(3,k)
         fip(3) = tdipdip(3,m)*uinp(1,k) + tdipdip(5,m)*uinp(2,k)
     &               + tdipdip(6,m)*uinp(3,k)
         fkp(1) = tdipdip(1,m)*uinp(1,i) + tdipdip(2,m)*uinp(2,i)
     &               + tdipdip(3,m)*uinp(3,i)
         fkp(2) = tdipdip(2,m)*uinp(1,i) + tdipdip(4,m)*uinp(2,i)
     &               + tdipdip(5,m)*uinp(3,i)
         fkp(3) = tdipdip(3,m)*uinp(1,i) + tdipdip(5,m)*uinp(2,i)
     &               + tdipdip(6,m)*uinp(3,i)
c
c     increment the field at each site due to this interaction
c
         do j = 1, 3
            fieldt(j,i) = fieldt(j,i) + fid(j)
            fieldt(j,k) = fieldt(j,k) + fkd(j)
            fieldtp(j,i) = fieldtp(j,i) + fip(j)
            fieldtp(j,k) = fieldtp(j,k) + fkp(j)
         end do
      end do
!$OMP END DO
c
c     add local to global variables for OpenMP calculation
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            field(j,i) = field(j,i) + fieldt(j,i)
            fieldp(j,i) = fieldp(j,i) + fieldtp(j,i)
         end do
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (fieldt)
      deallocate (fieldtp)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine induce0c  --  Kirkwood SCRF induced dipoles  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "induce0c" computes the induced dipole moments at polarizable
c     sites for generalized Kirkwood SCRF and vacuum environments
c
c
      subroutine induce0c
      use atoms
      use extfld
      use inform
      use iounit
      use limits
      use mpole
      use polar
      use polopt
      use polpot
      use potent
      use units
      use uprior
      implicit none
      integer i,j,k
      integer ii,iter
      integer miniter
      integer maxiter
      real*8 polmin
      real*8 eps,epsold
      real*8 epsd,epsp
      real*8 epsds,epsps
      real*8 udsum,upsum
      real*8 ussum,upssum
      real*8 a,ap,as,aps
      real*8 b,bp,bs,bps
      real*8 sum,sump
      real*8 sums,sumps
      real*8, allocatable :: poli(:)
      real*8, allocatable :: field(:,:)
      real*8, allocatable :: fieldp(:,:)
      real*8, allocatable :: fields(:,:)
      real*8, allocatable :: fieldps(:,:)
      real*8, allocatable :: rsd(:,:)
      real*8, allocatable :: rsdp(:,:)
      real*8, allocatable :: rsds(:,:)
      real*8, allocatable :: rsdps(:,:)
      real*8, allocatable :: zrsd(:,:)
      real*8, allocatable :: zrsdp(:,:)
      real*8, allocatable :: zrsds(:,:)
      real*8, allocatable :: zrsdps(:,:)
      real*8, allocatable :: conj(:,:)
      real*8, allocatable :: conjp(:,:)
      real*8, allocatable :: conjs(:,:)
      real*8, allocatable :: conjps(:,:)
      real*8, allocatable :: vec(:,:)
      real*8, allocatable :: vecp(:,:)
      real*8, allocatable :: vecs(:,:)
      real*8, allocatable :: vecps(:,:)
      real*8, allocatable :: usum(:,:)
      real*8, allocatable :: usump(:,:)
      real*8, allocatable :: usums(:,:)
      real*8, allocatable :: usumps(:,:)
      logical done
      character*6 mode
c
c
c     zero out the induced dipoles at each site; uind and uinp are
c     vacuum dipoles, uinds and uinps are SCRF dipoles
c
      do i = 1, n
         do j = 1, 3
            uind(j,i) = 0.0d0
            uinp(j,i) = 0.0d0
            uinds(j,i) = 0.0d0
            uinps(j,i) = 0.0d0
         end do
      end do
      if (.not.use_polar .and. .not.use_solv)  return
c
c     set the switching function coefficients
c
      mode = 'MPOLE'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (field(3,n))
      allocate (fieldp(3,n))
      allocate (fields(3,n))
      allocate (fieldps(3,n))
c
c     compute induced dipoles based on direct and mutual fields
c
   10 continue
c
c     compute the direct induced dipole moment at each atom, and
c     another set that also includes RF due to permanent multipoles
c
      call dfield0d (field,fieldp,fields,fieldps)
c
c     add external electric field to the direct field values
c
      if (use_exfld) then
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               field(j,i) = field(j,i) + exfld(j)
               fieldp(j,i) = fieldp(j,i) + exfld(j)
               fields(j,i) = fields(j,i) + exfld(j)
               fieldps(j,i) = fieldps(j,i) + exfld(j)
            end do
         end do
      end if
c
c     set vacuum induced dipoles to polarizability times direct field;
c     set SCRF induced dipoles to polarizability times direct field
c     plus the GK reaction field due to permanent multipoles
c
      do ii = 1, npole
         i = ipole(ii)
         if (douind(i)) then
            do j = 1, 3
               udir(j,i) = polarity(i) * field(j,i)
               udirp(j,i) = polarity(i) * fieldp(j,i)
               udirs(j,i) = polarity(i) * fields(j,i)
               udirps(j,i) = polarity(i) * fieldps(j,i)
               uind(j,i) = udir(j,i)
               uinp(j,i) = udirp(j,i)
               uinds(j,i) = udirs(j,i)
               uinps(j,i) = udirps(j,i)
            end do
         end if
      end do
c
c     get induced dipoles via the OPT extrapolation method
c
      if (poltyp .eq. 'OPT') then
         do ii = 1, npole
            i = ipole(ii)
            if (douind(i)) then
               do j = 1, 3
                  uopt(0,j,i) = udir(j,i)
                  uoptp(0,j,i) = udirp(j,i)
                  uopts(0,j,i) = udirs(j,i)
                  uoptps(0,j,i) = udirps(j,i)
               end do
            end if
         end do
         do k = 1, optorder
            call ufield0d (field,fieldp,fields,fieldps)
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     uopt(k,j,i) = polarity(i) * field(j,i)
                     uoptp(k,j,i) = polarity(i) * fieldp(j,i)
                     uopts(k,j,i) = polarity(i) * fields(j,i)
                     uoptps(k,j,i) = polarity(i) * fieldps(j,i)
                     uind(j,i) = uopt(k,j,i)
                     uinp(j,i) = uoptp(k,j,i)
                     uinds(j,i) = uopts(k,j,i)
                     uinps(j,i) = uoptps(k,j,i)
                  end do
               end if
            end do
         end do
         allocate (usum(3,n))
         allocate (usump(3,n))
         allocate (usums(3,n))
         allocate (usumps(3,n))
         do ii = 1, npole
            i = ipole(ii)
            if (douind(i)) then
               do j = 1, 3
                  uind(j,i) = 0.0d0
                  uinp(j,i) = 0.0d0
                  uinds(j,i) = 0.0d0
                  uinps(j,i) = 0.0d0
                  usum(j,i) = 0.0d0
                  usump(j,i) = 0.0d0
                  usums(j,i) = 0.0d0
                  usumps(j,i) = 0.0d0
                  do k = 0, optorder
                     usum(j,i) = usum(j,i) + uopt(k,j,i)
                     usump(j,i) = usump(j,i) + uoptp(k,j,i)
                     usums(j,i) = usums(j,i) + uopts(k,j,i)
                     usumps(j,i) = usumps(j,i) + uoptps(k,j,i)
                     uind(j,i) = uind(j,i) + copt(k)*usum(j,i)
                     uinp(j,i) = uinp(j,i) + copt(k)*usump(j,i)
                     uinds(j,i) = uinds(j,i) + copt(k)*usums(j,i)
                     uinps(j,i) = uinps(j,i) + copt(k)*usumps(j,i)
                  end do
               end do
            end if
         end do
         deallocate (usum)
         deallocate (usump)
         deallocate (usums)
         deallocate (usumps)
      end if
c
c     set tolerances for computation of mutual induced dipoles
c
      if (poltyp .eq. 'MUTUAL') then
         done = .false.
         miniter = min(3,npole)
         maxiter = 100
         iter = 0
         polmin = 0.00000001d0
         eps = 100.0d0
c
c     estimated induced dipoles from polynomial predictor
c
         if (use_pred .and. nualt.eq.maxualt) then
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  udsum = 0.0d0
                  upsum = 0.0d0
                  ussum = 0.0d0
                  upssum = 0.0d0
                  do k = 1, nualt-1
                     udsum = udsum + bpred(k)*udalt(k,j,i)
                     upsum = upsum + bpredp(k)*upalt(k,j,i)
                     ussum = ussum + bpreds(k)*usalt(k,j,i)
                     upssum = upssum + bpredps(k)*upsalt(k,j,i)
                  end do
                  uind(j,i) = udsum
                  uinp(j,i) = upsum
                  uinds(j,i) = ussum
                  uinps(j,i) = upssum
               end do
            end do
         end if
c
c     perform dynamic allocation of some local arrays
c
         allocate (poli(n))
         allocate (rsd(3,n))
         allocate (rsdp(3,n))
         allocate (rsds(3,n))
         allocate (rsdps(3,n))
         allocate (zrsd(3,n))
         allocate (zrsdp(3,n))
         allocate (zrsds(3,n))
         allocate (zrsdps(3,n))
         allocate (conj(3,n))
         allocate (conjp(3,n))
         allocate (conjs(3,n))
         allocate (conjps(3,n))
         allocate (vec(3,n))
         allocate (vecp(3,n))
         allocate (vecs(3,n))
         allocate (vecps(3,n))
c
c     set initial conjugate gradient residual and conjugate vector
c
         call ufield0d (field,fieldp,fields,fieldps)
         do ii = 1, npole
            i = ipole(ii)
            if (douind(i)) then
               poli(i) = max(polmin,polarity(i))
               do j = 1, 3
                  rsd(j,i) = (udir(j,i)-uind(j,i))/poli(i)
     &                          + field(j,i)
                  rsdp(j,i) = (udirp(j,i)-uinp(j,i))/poli(i)
     &                           + fieldp(j,i)
                  rsds(j,i) = (udirs(j,i)-uinds(j,i))/poli(i)
     &                           + fields(j,i)
                  rsdps(j,i) = (udirps(j,i)-uinps(j,i))/poli(i)
     &                            + fieldps(j,i)
                  zrsd(j,i) = rsd(j,i) * poli(i)
                  zrsdp(j,i) = rsdp(j,i) * poli(i)
                  zrsds(j,i) = rsds(j,i) * poli(i)
                  zrsdps(j,i) = rsdps(j,i) * poli(i)
                  conj(j,i) = zrsd(j,i)
                  conjp(j,i) = zrsdp(j,i)
                  conjs(j,i) = zrsds(j,i)
                  conjps(j,i) = zrsdps(j,i)
               end do
            end if
         end do
c
c     conjugate gradient iteration of the mutual induced dipoles
c
         do while (.not. done)
            iter = iter + 1
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     vec(j,i) = uind(j,i)
                     vecp(j,i) = uinp(j,i)
                     vecs(j,i) = uinds(j,i)
                     vecps(j,i) = uinps(j,i)
                     uind(j,i) = conj(j,i)
                     uinp(j,i) = conjp(j,i)
                     uinds(j,i) = conjs(j,i)
                     uinps(j,i) = conjps(j,i)
                  end do
               end if
            end do
            call ufield0d (field,fieldp,fields,fieldps)
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     uind(j,i) = vec(j,i)
                     uinp(j,i) = vecp(j,i)
                     uinds(j,i) = vecs(j,i)
                     uinps(j,i) = vecps(j,i)
                     vec(j,i) = conj(j,i)/poli(i) - field(j,i)
                     vecp(j,i) = conjp(j,i)/poli(i) - fieldp(j,i)
                     vecs(j,i) = conjs(j,i)/poli(i) - fields(j,i)
                     vecps(j,i) = conjps(j,i)/poli(i) - fieldps(j,i)
                  end do
               end if
            end do
            a = 0.0d0
            ap = 0.0d0
            as = 0.0d0
            aps = 0.0d0
            sum = 0.0d0
            sump = 0.0d0
            sums = 0.0d0
            sumps = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     a = a + conj(j,i)*vec(j,i)
                     ap = ap + conjp(j,i)*vecp(j,i)
                     as = as + conjs(j,i)*vecs(j,i)
                     aps = aps + conjps(j,i)*vecps(j,i)
                     sum = sum + rsd(j,i)*zrsd(j,i)
                     sump = sump + rsdp(j,i)*zrsdp(j,i)
                     sums = sums + rsds(j,i)*zrsds(j,i)
                     sumps = sumps + rsdps(j,i)*zrsdps(j,i)
                  end do
               end if
            end do
            if (a .ne. 0.0d0)  a = sum / a
            if (ap .ne. 0.0d0)  ap = sump / ap
            if (as .ne. 0.0d0)  as = sums / as
            if (aps .ne. 0.0d0)  aps = sumps / aps
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     uind(j,i) = uind(j,i) + a*conj(j,i)
                     uinp(j,i) = uinp(j,i) + ap*conjp(j,i)
                     uinds(j,i) = uinds(j,i) + as*conjs(j,i)
                     uinps(j,i) = uinps(j,i) + aps*conjps(j,i)
                     rsd(j,i) = rsd(j,i) - a*vec(j,i)
                     rsdp(j,i) = rsdp(j,i) - ap*vecp(j,i)
                     rsds(j,i) = rsds(j,i) - as*vecs(j,i)
                     rsdps(j,i) = rsdps(j,i) - aps*vecps(j,i)
                  end do
               end if
            end do
            b = 0.0d0
            bp = 0.0d0
            bs = 0.0d0
            bps = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     zrsd(j,i) = rsd(j,i) * poli(i)
                     zrsdp(j,i) = rsdp(j,i) * poli(i)
                     zrsds(j,i) = rsds(j,i) * poli(i)
                     zrsdps(j,i) = rsdps(j,i) * poli(i)
                     b = b + rsd(j,i)*zrsd(j,i)
                     bp = bp + rsdp(j,i)*zrsdp(j,i)
                     bs = bs + rsds(j,i)*zrsds(j,i)
                     bps = bps + rsdps(j,i)*zrsdps(j,i)
                  end do
               end if
            end do
            if (sum .ne. 0.0d0)  b = b / sum
            if (sump .ne. 0.0d0)  bp = bp / sump
            if (sums .ne. 0.0d0)  bs = bs / sums
            if (sumps .ne. 0.0d0)  bps = bps / sumps
            epsd = 0.0d0
            epsp = 0.0d0
            epsds = 0.0d0
            epsps = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     conj(j,i) = zrsd(j,i) + b*conj(j,i)
                     conjp(j,i) = zrsdp(j,i) + bp*conjp(j,i)
                     conjs(j,i) = zrsds(j,i) + bs*conjs(j,i)
                     conjps(j,i) = zrsdps(j,i) + bps*conjps(j,i)
                     epsd = epsd + rsd(j,i)*rsd(j,i)
                     epsp = epsp + rsdp(j,i)*rsdp(j,i)
                     epsds = epsds + rsds(j,i)*rsds(j,i)
                     epsps = epsps + rsdps(j,i)*rsdps(j,i)
                  end do
               end if
            end do
c
c     check the convergence of the mutual induced dipoles
c
            epsold = eps
            eps = max(epsd,epsp,epsds,epsps)
            eps = debye * sqrt(eps/dble(npolar))
            if (debug) then
               if (iter .eq. 1) then
                  write (iout,20)
   20             format (/,' Determination of Induced Dipole',
     &                       ' Moments :',
     &                    //,4x,'Iter',8x,'RMS Change (Debye)',/)
               end if
               write (iout,30)  iter,eps
   30          format (i8,7x,f16.10)
            end if
            if (eps .lt. poleps)  done = .true.
            if (eps .gt. epsold)  done = .true.
            if (iter .lt. miniter)  done = .false.
            if (iter .ge. politer)  done = .true.
c
c     apply a "peek" iteration to the mutual induced dipoles
c
            if (done) then
               do ii = 1, npole
                  i = ipole(ii)
                  if (douind(i)) then
                     do j = 1, 3
                        uind(j,i) = uind(j,i) + poli(i)*rsd(j,i)
                        uinp(j,i) = uinp(j,i) + poli(i)*rsdp(j,i)
                        uinds(j,i) = uinds(j,i) + poli(i)*rsds(j,i)
                        uinps(j,i) = uinps(j,i) + poli(i)*rsdps(j,i)
                     end do
                  end if
               end do
            end if
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (poli)
         deallocate (rsd)
         deallocate (rsdp)
         deallocate (rsds)
         deallocate (rsdps)
         deallocate (zrsd)
         deallocate (zrsdp)
         deallocate (zrsds)
         deallocate (zrsdps)
         deallocate (conj)
         deallocate (conjp)
         deallocate (conjs)
         deallocate (conjps)
         deallocate (vec)
         deallocate (vecp)
         deallocate (vecs)
         deallocate (vecps)
c
c     print the results from the conjugate gradient iteration
c
         if (debug) then
            write (iout,40)  iter,eps
   40       format (/,' Induced Dipoles :',6x,'Iterations',i5,
     &                 6x,'RMS Change',f15.10)
         end if
c
c     terminate the calculation if dipoles failed to converge
c
         if (iter.ge.maxiter .or. eps.gt.epsold) then
            if (use_ulist) then
               use_ulist = .false.
               usolvcut = 0.0d0
               if (verbose) then
                  write (iout,50)
   50             format (/,' INDUCE  --  Switching to Diagonal',
     &                       ' PCG Preconditioner')
               end if
               goto 10
            else
               write (iout,60)
   60          format (/,' INDUCE  --  Warning, Induced Dipoles',
     &                    ' are not Converged')
               call prterr
               call fatal
            end if
         end if
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (field)
      deallocate (fieldp)
      deallocate (fields)
      deallocate (fieldps)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine dfield0d  --  generalized Kirkwood direct field  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "dfield0d" computes the direct electrostatic field due to
c     permanent multipole moments for use with with generalized
c     Kirkwood implicit solvation
c
c
      subroutine dfield0d (field,fieldp,fields,fieldps)
      use atoms
      use couple
      use gkstuf
      use group
      use mpole
      use polar
      use polgrp
      use polpot
      use shunt
      use solute
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xr,yr,zr
      real*8 xr2,yr2,zr2
      real*8 fgrp,r,r2
      real*8 rr3,rr5,rr7
      real*8 ci,uxi,uyi,uzi
      real*8 qxxi,qxyi,qxzi
      real*8 qyyi,qyzi,qzzi
      real*8 ck,uxk,uyk,uzk
      real*8 qxxk,qxyk,qxzk
      real*8 qyyk,qyzk,qzzk
      real*8 dir,dkr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 rb2,rbi,rbk
      real*8 dwater,fc,fd,fq
      real*8 gf,gf2,gf3,gf5,gf7
      real*8 expterm,expc,expc1
      real*8 dexpc,expcdexpc
      real*8 a(0:3,0:2)
      real*8 gc(4),gux(10)
      real*8 guy(10),guz(10)
      real*8 gqxx(4),gqxy(4)
      real*8 gqxz(4),gqyy(4)
      real*8 gqyz(4),gqzz(4)
      real*8 fid(3),fkd(3)
      real*8 dmpik(7)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: pscale(:)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      real*8 fields(3,*)
      real*8 fieldps(3,*)
      real*8, allocatable :: fieldt(:,:)
      real*8, allocatable :: fieldtp(:,:)
      real*8, allocatable :: fieldts(:,:)
      real*8, allocatable :: fieldtps(:,:)
      logical proceed
c
c
c     zero out the value of the field at each site
c
      do i = 1, n
         do j = 1, 3
            field(j,i) = 0.0d0
            fieldp(j,i) = 0.0d0
            fields(j,i) = 0.0d0
            fieldps(j,i) = 0.0d0
         end do
      end do
c
c     set dielectric constant and scaling factors for water
c
      dwater = 78.3d0
      fc = 1.0d0 * (1.0d0-dwater) / (1.0d0*dwater)
      fd = 2.0d0 * (1.0d0-dwater) / (1.0d0+2.0d0*dwater)
      fq = 3.0d0 * (1.0d0-dwater) / (2.0d0+3.0d0*dwater)
c
c     perform dynamic allocation of some local arrays
c
      allocate (dscale(n))
      allocate (pscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         dscale(i) = 1.0d0
         pscale(i) = 1.0d0
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (fieldt(3,n))
      allocate (fieldtp(3,n))
      allocate (fieldts(3,n))
      allocate (fieldtps(3,n))
c
c     initialize local variables for OpenMP calculation
c
      do i = 1, n
         do j = 1, 3
            fieldt(j,i) = 0.0d0
            fieldtp(j,i) = 0.0d0
            fieldts(j,i) = 0.0d0
            fieldtps(j,i) = 0.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,rpole,rborn,n12,n13,
!$OMP& n14,n15,np11,np12,np13,np14,i12,i13,i14,i15,ip11,ip12,ip13,ip14,
!$OMP& p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale,
!$OMP& p5iscale,d1scale,d2scale,d3scale,d4scale,dpequal,use_intra,
!$OMP& x,y,z,off2,fc,fd,fq,gkc,field,fieldp,fields,fieldps)
!$OMP& firstprivate(dscale,pscale)
!$OMP& shared(fieldt,fieldtp,fieldts,fieldtps)
!$OMP DO reduction(+:fieldt,fieldtp,fieldts,fieldtps)
c
c     find the field terms for each pairwise interaction
c
      do ii = 1, npole
         i = ipole(ii)
         ci = rpole(1,i)
         uxi = rpole(2,i)
         uyi = rpole(3,i)
         uzi = rpole(4,i)
         qxxi = rpole(5,i)
         qxyi = rpole(6,i)
         qxzi = rpole(7,i)
         qyyi = rpole(9,i)
         qyzi = rpole(10,i)
         qzzi = rpole(13,i)
         rbi = rborn(i)
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii, npole
            k = ipole(kk)
            proceed = .true.
            if (use_intra)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed) then
               xr = x(k) - x(i)
               yr = y(k) - y(i)
               zr = z(k) - z(i)
               xr2 = xr * xr
               yr2 = yr * yr
               zr2 = zr * zr
               r2 = xr2 + yr2 + zr2
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  ck = rpole(1,k)
                  uxk = rpole(2,k)
                  uyk = rpole(3,k)
                  uzk = rpole(4,k)
                  qxxk = rpole(5,k)
                  qxyk = rpole(6,k)
                  qxzk = rpole(7,k)
                  qyyk = rpole(9,k)
                  qyzk = rpole(10,k)
                  qzzk = rpole(13,k)
                  rbk = rborn(k)
c
c     self-interactions for the solute field are skipped
c
                  if (i .ne. k) then
                     call damptholed (i,k,7,r,dmpik)
                     rr3 = dmpik(3) / (r*r2)
                     rr5 = 3.0d0 * dmpik(5) / (r*r2*r2)
                     rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2)
                     dir = uxi*xr + uyi*yr + uzi*zr
                     qix = qxxi*xr + qxyi*yr + qxzi*zr
                     qiy = qxyi*xr + qyyi*yr + qyzi*zr
                     qiz = qxzi*xr + qyzi*yr + qzzi*zr
                     qir = qix*xr + qiy*yr + qiz*zr
                     dkr = uxk*xr + uyk*yr + uzk*zr
                     qkx = qxxk*xr + qxyk*yr + qxzk*zr
                     qky = qxyk*xr + qyyk*yr + qyzk*zr
                     qkz = qxzk*xr + qyzk*yr + qzzk*zr
                     qkr = qkx*xr + qky*yr + qkz*zr
                     fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                           - rr3*uxk + 2.0d0*rr5*qkx
                     fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                           - rr3*uyk + 2.0d0*rr5*qky
                     fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                           - rr3*uzk + 2.0d0*rr5*qkz
                     fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir)
     &                           - rr3*uxi - 2.0d0*rr5*qix
                     fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir)
     &                           - rr3*uyi - 2.0d0*rr5*qiy
                     fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir)
     &                           - rr3*uzi - 2.0d0*rr5*qiz
                     do j = 1, 3
                        fieldt(j,i) = fieldt(j,i) + fid(j)*dscale(k)
                        fieldt(j,k) = fieldt(j,k) + fkd(j)*dscale(k)
                        fieldtp(j,i) = fieldtp(j,i) + fid(j)*pscale(k)
                        fieldtp(j,k) = fieldtp(j,k) + fkd(j)*pscale(k)
                     end do
                  end if
c
c     set the reaction potential auxiliary terms
c
                  rb2 = rbi * rbk
                  expterm = exp(-r2/(gkc*rb2))
                  expc = expterm / gkc
                  dexpc = -2.0d0 / (gkc*rb2)
                  gf2 = 1.0d0 / (r2+rb2*expterm)
                  gf = sqrt(gf2)
                  gf3 = gf2 * gf
                  gf5 = gf3 * gf2
                  gf7 = gf5 * gf2
                  a(0,0) = gf
                  a(1,0) = -gf3
                  a(2,0) = 3.0d0 * gf5
                  a(3,0) = -15.0d0 * gf7
c
c     set the reaction potential gradient auxiliary terms
c
                  expc1 = 1.0d0 - expc
                  a(0,1) = expc1 * a(1,0)
                  a(1,1) = expc1 * a(2,0)
                  a(2,1) = expc1 * a(3,0)
c
c     dipole second reaction potential gradient auxiliary term
c
                  expcdexpc = -expc * dexpc
                  a(1,2) = expc1*a(2,1) + expcdexpc*a(2,0)
c
c     multiply the auxiliary terms by dielectric functions
c
                  a(0,1) = fc * a(0,1)
                  a(1,0) = fd * a(1,0)
                  a(1,1) = fd * a(1,1)
                  a(1,2) = fd * a(1,2)
                  a(2,0) = fq * a(2,0)
                  a(2,1) = fq * a(2,1)
c
c     unweighted dipole reaction potential tensor
c
                  gux(1) = xr * a(1,0)
                  guy(1) = yr * a(1,0)
                  guz(1) = zr * a(1,0)
c
c     unweighted reaction potential gradient tensor
c
                  gc(2) = xr * a(0,1)
                  gc(3) = yr * a(0,1)
                  gc(4) = zr * a(0,1)
                  gux(2) = a(1,0) + xr2*a(1,1)
                  gux(3) = xr * yr * a(1,1)
                  gux(4) = xr * zr * a(1,1)
                  guy(2) = gux(3)
                  guy(3) = a(1,0) + yr2*a(1,1)
                  guy(4) = yr * zr * a(1,1)
                  guz(2) = gux(4)
                  guz(3) = guy(4)
                  guz(4) = a(1,0) + zr2*a(1,1)
                  gqxx(2) = xr * (2.0d0*a(2,0)+xr2*a(2,1))
                  gqxx(3) = yr * xr2*a(2,1)
                  gqxx(4) = zr * xr2*a(2,1)
                  gqyy(2) = xr * yr2*a(2,1)
                  gqyy(3) = yr * (2.0d0*a(2,0)+yr2*a(2,1))
                  gqyy(4) = zr * yr2 * a(2,1)
                  gqzz(2) = xr * zr2 * a(2,1)
                  gqzz(3) = yr * zr2 * a(2,1)
                  gqzz(4) = zr * (2.0d0*a(2,0)+zr2*a(2,1))
                  gqxy(2) = yr * (a(2,0)+xr2*a(2,1))
                  gqxy(3) = xr * (a(2,0)+yr2*a(2,1))
                  gqxy(4) = zr * xr * yr * a(2,1)
                  gqxz(2) = zr * (a(2,0)+xr2*a(2,1))
                  gqxz(3) = gqxy(4)
                  gqxz(4) = xr * (a(2,0)+zr2*a(2,1))
                  gqyz(2) = gqxy(4)
                  gqyz(3) = zr * (a(2,0)+yr2*a(2,1))
                  gqyz(4) = yr * (a(2,0)+zr2*a(2,1))
c
c     unweighted dipole second reaction potential gradient tensor
c
                  gux(5) = xr * (3.0d0*a(1,1)+xr2*a(1,2))
                  gux(6) = yr * (a(1,1)+xr2*a(1,2))
                  gux(7) = zr * (a(1,1)+xr2*a(1,2))
                  gux(8) = xr * (a(1,1)+yr2*a(1,2))
                  gux(9) = zr * xr * yr * a(1,2)
                  gux(10) = xr * (a(1,1)+zr2*a(1,2))
                  guy(5) = yr * (a(1,1)+xr2*a(1,2))
                  guy(6) = xr * (a(1,1)+yr2*a(1,2))
                  guy(7) = gux(9)
                  guy(8) = yr * (3.0d0*a(1,1)+yr2*a(1,2))
                  guy(9) = zr * (a(1,1)+yr2*a(1,2))
                  guy(10) = yr * (a(1,1)+zr2*a(1,2))
                  guz(5) = zr * (a(1,1)+xr2*a(1,2))
                  guz(6) = gux(9)
                  guz(7) = xr * (a(1,1)+zr2*a(1,2))
                  guz(8) = zr * (a(1,1)+yr2*a(1,2))
                  guz(9) = yr * (a(1,1)+zr2*a(1,2))
                  guz(10) = zr * (3.0d0*a(1,1)+zr2*a(1,2))
c
c     generalized Kirkwood permanent reaction field
c
                  fid(1) = uxk*gux(2) + uyk*gux(3) + uzk*gux(4)
     &                        + 0.5d0 * (ck*gux(1) + qxxk*gux(5)
     &                            + qyyk*gux(8) + qzzk*gux(10)
     &                            + 2.0d0*(qxyk*gux(6)+qxzk*gux(7)
     &                                         +qyzk*gux(9)))
     &                        + 0.5d0 * (ck*gc(2) + qxxk*gqxx(2)
     &                            + qyyk*gqyy(2) + qzzk*gqzz(2)
     &                            + 2.0d0*(qxyk*gqxy(2)+qxzk*gqxz(2)
     &                                         +qyzk*gqyz(2)))
                  fid(2) = uxk*guy(2) + uyk*guy(3) + uzk*guy(4)
     &                        + 0.5d0 * (ck*guy(1) + qxxk*guy(5)
     &                            + qyyk*guy(8) + qzzk*guy(10)
     &                            + 2.0d0*(qxyk*guy(6)+qxzk*guy(7)
     &                                         +qyzk*guy(9)))
     &                        + 0.5d0 * (ck*gc(3) + qxxk*gqxx(3)
     &                            + qyyk*gqyy(3) + qzzk*gqzz(3)
     &                            + 2.0d0*(qxyk*gqxy(3)+qxzk*gqxz(3)
     &                                         +qyzk*gqyz(3)))
                  fid(3) = uxk*guz(2) + uyk*guz(3) + uzk*guz(4)
     &                        + 0.5d0 * (ck*guz(1) + qxxk*guz(5)
     &                            + qyyk*guz(8) + qzzk*guz(10)
     &                            + 2.0d0*(qxyk*guz(6)+qxzk*guz(7)
     &                                         +qyzk*guz(9)))
     &                        + 0.5d0 * (ck*gc(4) + qxxk*gqxx(4)
     &                            + qyyk*gqyy(4) + qzzk*gqzz(4)
     &                            + 2.0d0*(qxyk*gqxy(4)+qxzk*gqxz(4)
     &                                         +qyzk*gqyz(4)))
                  fkd(1) = uxi*gux(2) + uyi*gux(3) + uzi*gux(4)
     &                        - 0.5d0 * (ci*gux(1) + qxxi*gux(5)
     &                            + qyyi*gux(8) + qzzi*gux(10)
     &                            + 2.0d0*(qxyi*gux(6)+qxzi*gux(7)
     &                                         +qyzi*gux(9)))
     &                        - 0.5d0 * (ci*gc(2) + qxxi*gqxx(2)
     &                            + qyyi*gqyy(2) + qzzi*gqzz(2)
     &                            + 2.0d0*(qxyi*gqxy(2)+qxzi*gqxz(2)
     &                                         +qyzi*gqyz(2)))
                  fkd(2) = uxi*guy(2) + uyi*guy(3) + uzi*guy(4)
     &                        - 0.5d0 * (ci*guy(1) + qxxi*guy(5)
     &                            + qyyi*guy(8) + qzzi*guy(10)
     &                            + 2.0d0*(qxyi*guy(6)+qxzi*guy(7)
     &                                         +qyzi*guy(9)))
     &                        - 0.5d0 * (ci*gc(3) + qxxi*gqxx(3)
     &                            + qyyi*gqyy(3) + qzzi*gqzz(3)
     &                            + 2.0d0*(qxyi*gqxy(3)+qxzi*gqxz(3)
     &                                         +qyzi*gqyz(3)))
                  fkd(3) = uxi*guz(2) + uyi*guz(3) + uzi*guz(4)
     &                        - 0.5d0 * (ci*guz(1) + qxxi*guz(5)
     &                            + qyyi*guz(8) + qzzi*guz(10)
     &                            + 2.0d0*(qxyi*guz(6)+qxzi*guz(7)
     &                                         +qyzi*guz(9)))
     &                        - 0.5d0 * (ci*gc(4) + qxxi*gqxx(4)
     &                            + qyyi*gqyy(4) + qzzi*gqzz(4)
     &                            + 2.0d0*(qxyi*gqxy(4)+qxzi*gqxz(4)
     &                                         +qyzi*gqyz(4)))
c
c     scale the self-field by half, such that it sums to one below
c
                  if (i .eq. k) then
                     do j = 1, 3
                        fid(j) = 0.5d0 * fid(j)
                        fkd(j) = 0.5d0 * fkd(j)
                     end do
                  end if
                  do j = 1, 3
                     fieldts(j,i) = fieldts(j,i) + fid(j)
                     fieldts(j,k) = fieldts(j,k) + fkd(j)
                     fieldtps(j,i) = fieldtps(j,i) + fid(j)
                     fieldtps(j,k) = fieldtps(j,k) + fkd(j)
                  end do
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
!$OMP END DO
c
c     add local to global variables for OpenMP calculation
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            field(j,i) = field(j,i) + fieldt(j,i)
            fieldp(j,i) = fieldp(j,i) + fieldtp(j,i)
            fields(j,i) = fields(j,i) + fieldts(j,i)
            fieldps(j,i) = fieldps(j,i) + fieldtps(j,i)
         end do
      end do
!$OMP END DO
c
c     combine permanent multipole field and GK reaction field
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            fields(j,i) = field(j,i) + fields(j,i)
            fieldps(j,i) = fieldp(j,i) + fieldps(j,i)
         end do
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (dscale)
      deallocate (pscale)
      deallocate (fieldt)
      deallocate (fieldtp)
      deallocate (fieldts)
      deallocate (fieldtps)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ufield0d  --  generalized Kirkwood mutual field  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ufield0d" computes the mutual electrostatic field due to
c     induced dipole moments for use with with generalized Kirkwood
c     implicit solvation
c
c
      subroutine ufield0d (field,fieldp,fields,fieldps)
      use atoms
      use gkstuf
      use group
      use mpole
      use polar
      use polgrp
      use polpot
      use shunt
      use solute
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xr,yr,zr
      real*8 xr2,yr2,zr2
      real*8 fgrp,r,r2
      real*8 rr3,rr5
      real*8 duix,duiy,duiz
      real*8 puix,puiy,puiz
      real*8 dukx,duky,dukz
      real*8 pukx,puky,pukz
      real*8 duir,dukr
      real*8 puir,pukr
      real*8 duixs,duiys,duizs
      real*8 puixs,puiys,puizs
      real*8 dukxs,dukys,dukzs
      real*8 pukxs,pukys,pukzs
      real*8 duirs,puirs
      real*8 dukrs,pukrs
      real*8 rb2,rbi,rbk
      real*8 dwater,fd
      real*8 gf,gf2,gf3,gf5
      real*8 expterm,expc
      real*8 expc1,dexpc
      real*8 a(0:3,0:2)
      real*8 gux(10),guy(10)
      real*8 guz(10)
      real*8 fid(3),fkd(3)
      real*8 fip(3),fkp(3)
      real*8 fids(3),fkds(3)
      real*8 fips(3),fkps(3)
      real*8 dmpik(5)
      real*8, allocatable :: uscale(:)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      real*8 fields(3,*)
      real*8 fieldps(3,*)
      real*8, allocatable :: fieldt(:,:)
      real*8, allocatable :: fieldtp(:,:)
      real*8, allocatable :: fieldts(:,:)
      real*8, allocatable :: fieldtps(:,:)
      logical proceed
c
c
c     zero out the value of the field at each site
c
      do i = 1, npole
         do j = 1, 3
            field(j,i) = 0.0d0
            fieldp(j,i) = 0.0d0
            fields(j,i) = 0.0d0
            fieldps(j,i) = 0.0d0
         end do
      end do
c
c     set dielectric constant and scaling factor for water
c
      dwater = 78.3d0
      fd = 2.0d0 * (1.0d0-dwater) / (1.0d0+2.0d0*dwater)
c
c     perform dynamic allocation of some local arrays
c
      allocate (uscale(n))
c
c     set array needed to scale connected atom interactions
c
      do i = 1, n
         uscale(i) = 1.0d0
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (fieldt(3,n))
      allocate (fieldtp(3,n))
      allocate (fieldts(3,n))
      allocate (fieldtps(3,n))
c
c     initialize local variables for OpenMP calculation
c
      do i = 1, n
         do j = 1, 3
            fieldt(j,i) = 0.0d0
            fieldtp(j,i) = 0.0d0
            fieldts(j,i) = 0.0d0
            fieldtps(j,i) = 0.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,rborn,uind,uinp,
!$OMP& uinds,uinps,np11,np12,np13,np14,ip11,ip12,ip13,ip14,u1scale,
!$OMP& u2scale,u3scale,u4scale,use_intra,x,y,z,off2,fd,gkc,field,
!$OMP& fieldp,fields,fieldps)
!$OMP& firstprivate(uscale) shared(fieldt,fieldtp,fieldts,fieldtps)
!$OMP DO reduction(+:fieldt,fieldtp,fieldts,fieldtps)
c
c     find the field terms for each pairwise interaction
c
      do ii = 1, npole
         i = ipole(ii)
         duix = uind(1,i)
         duiy = uind(2,i)
         duiz = uind(3,i)
         puix = uinp(1,i)
         puiy = uinp(2,i)
         puiz = uinp(3,i)
         duixs = uinds(1,i)
         duiys = uinds(2,i)
         duizs = uinds(3,i)
         puixs = uinps(1,i)
         puiys = uinps(2,i)
         puizs = uinps(3,i)
         rbi = rborn(i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, np11(i)
            uscale(ip11(j,i)) = u1scale
         end do
         do j = 1, np12(i)
            uscale(ip12(j,i)) = u2scale
         end do
         do j = 1, np13(i)
            uscale(ip13(j,i)) = u3scale
         end do
         do j = 1, np14(i)
            uscale(ip14(j,i)) = u4scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii, npole
            k = ipole(kk)
            proceed = .true.
            if (use_intra)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed) then
               xr = x(k) - x(i)
               yr = y(k) - y(i)
               zr = z(k) - z(i)
               xr2 = xr * xr
               yr2 = yr * yr
               zr2 = zr * zr
               r2 = xr2 + yr2 + zr2
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  dukx = uind(1,k)
                  duky = uind(2,k)
                  dukz = uind(3,k)
                  pukx = uinp(1,k)
                  puky = uinp(2,k)
                  pukz = uinp(3,k)
                  dukxs = uinds(1,k)
                  dukys = uinds(2,k)
                  dukzs = uinds(3,k)
                  pukxs = uinps(1,k)
                  pukys = uinps(2,k)
                  pukzs = uinps(3,k)
                  rbk = rborn(k)
                  if (i .ne. k) then
                     call dampthole (i,k,5,r,dmpik)
                     dmpik(3) = uscale(k) * dmpik(3)
                     dmpik(5) = uscale(k) * dmpik(5)
                     rr3 = -dmpik(3) / (r*r2)
                     rr5 = 3.0d0 * dmpik(5) / (r*r2*r2)
                     duir = xr*duix + yr*duiy + zr*duiz
                     dukr = xr*dukx + yr*duky + zr*dukz
                     puir = xr*puix + yr*puiy + zr*puiz
                     pukr = xr*pukx + yr*puky + zr*pukz
                     duirs = xr*duixs + yr*duiys + zr*duizs
                     dukrs = xr*dukxs + yr*dukys + zr*dukzs
                     puirs = xr*puixs + yr*puiys + zr*puizs
                     pukrs = xr*pukxs + yr*pukys + zr*pukzs
                     fid(1) = rr3*dukx + rr5*dukr*xr
                     fid(2) = rr3*duky + rr5*dukr*yr
                     fid(3) = rr3*dukz + rr5*dukr*zr
                     fkd(1) = rr3*duix + rr5*duir*xr
                     fkd(2) = rr3*duiy + rr5*duir*yr
                     fkd(3) = rr3*duiz + rr5*duir*zr
                     fip(1) = rr3*pukx + rr5*pukr*xr
                     fip(2) = rr3*puky + rr5*pukr*yr
                     fip(3) = rr3*pukz + rr5*pukr*zr
                     fkp(1) = rr3*puix + rr5*puir*xr
                     fkp(2) = rr3*puiy + rr5*puir*yr
                     fkp(3) = rr3*puiz + rr5*puir*zr
                     fids(1) = rr3*dukxs + rr5*dukrs*xr
                     fids(2) = rr3*dukys + rr5*dukrs*yr
                     fids(3) = rr3*dukzs + rr5*dukrs*zr
                     fkds(1) = rr3*duixs + rr5*duirs*xr
                     fkds(2) = rr3*duiys + rr5*duirs*yr
                     fkds(3) = rr3*duizs + rr5*duirs*zr
                     fips(1) = rr3*pukxs + rr5*pukrs*xr
                     fips(2) = rr3*pukys + rr5*pukrs*yr
                     fips(3) = rr3*pukzs + rr5*pukrs*zr
                     fkps(1) = rr3*puixs + rr5*puirs*xr
                     fkps(2) = rr3*puiys + rr5*puirs*yr
                     fkps(3) = rr3*puizs + rr5*puirs*zr
                     do j = 1, 3
                        fieldt(j,i) = fieldt(j,i) + fid(j)
                        fieldt(j,k) = fieldt(j,k) + fkd(j)
                        fieldtp(j,i) = fieldtp(j,i) + fip(j)
                        fieldtp(j,k) = fieldtp(j,k) + fkp(j)
                        fieldts(j,i) = fieldts(j,i) + fids(j)
                        fieldts(j,k) = fieldts(j,k) + fkds(j)
                        fieldtps(j,i) = fieldtps(j,i) + fips(j)
                        fieldtps(j,k) = fieldtps(j,k) + fkps(j)
                     end do
                  end if
c
c     unweighted dipole reaction potential gradient tensor
c
                  rb2 = rbi * rbk
                  expterm = exp(-r2/(gkc*rb2))
                  expc = expterm / gkc
                  dexpc = -2.0d0 / (gkc*rbi*rbk)
                  gf2 = 1.0d0 / (r2+rb2*expterm)
                  gf = sqrt(gf2)
                  gf3 = gf2 * gf
                  gf5 = gf3 * gf2
                  a(1,0) = -gf3
                  a(2,0) = 3.0d0 * gf5
                  expc1 = 1.0d0 - expc
                  a(1,1) = expc1 * a(2,0)
                  gux(2) = fd * (a(1,0) + xr2*a(1,1))
                  gux(3) = fd * xr*yr*a(1,1)
                  gux(4) = fd * xr*zr*a(1,1)
                  guy(2) = gux(3)
                  guy(3) = fd * (a(1,0) + yr2*a(1,1))
                  guy(4) = fd * yr*zr*a(1,1)
                  guz(2) = gux(4)
                  guz(3) = guy(4)
                  guz(4) = fd * (a(1,0) + zr2*a(1,1))
                  fids(1) = dukxs*gux(2) + dukys*guy(2) + dukzs*guz(2)
                  fids(2) = dukxs*gux(3) + dukys*guy(3) + dukzs*guz(3)
                  fids(3) = dukxs*gux(4) + dukys*guy(4) + dukzs*guz(4)
                  fkds(1) = duixs*gux(2) + duiys*guy(2) + duizs*guz(2)
                  fkds(2) = duixs*gux(3) + duiys*guy(3) + duizs*guz(3)
                  fkds(3) = duixs*gux(4) + duiys*guy(4) + duizs*guz(4)
                  fips(1) = pukxs*gux(2) + pukys*guy(2) + pukzs*guz(2)
                  fips(2) = pukxs*gux(3) + pukys*guy(3) + pukzs*guz(3)
                  fips(3) = pukxs*gux(4) + pukys*guy(4) + pukzs*guz(4)
                  fkps(1) = puixs*gux(2) + puiys*guy(2) + puizs*guz(2)
                  fkps(2) = puixs*gux(3) + puiys*guy(3) + puizs*guz(3)
                  fkps(3) = puixs*gux(4) + puiys*guy(4) + puizs*guz(4)
                  if (i .eq. k) then
                     do j = 1, 3
                        fids(j) = 0.5d0 * fids(j)
                        fkds(j) = 0.5d0 * fkds(j)
                        fips(j) = 0.5d0 * fips(j)
                        fkps(j) = 0.5d0 * fkps(j)
                     end do
                  end if
                  do j = 1, 3
                     fieldts(j,i) = fieldts(j,i) + fids(j)
                     fieldts(j,k) = fieldts(j,k) + fkds(j)
                     fieldtps(j,i) = fieldtps(j,i) + fips(j)
                     fieldtps(j,k) = fieldtps(j,k) + fkps(j)
                  end do
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, np11(i)
            uscale(ip11(j,i)) = 1.0d0
         end do
         do j = 1, np12(i)
            uscale(ip12(j,i)) = 1.0d0
         end do
         do j = 1, np13(i)
            uscale(ip13(j,i)) = 1.0d0
         end do
         do j = 1, np14(i)
            uscale(ip14(j,i)) = 1.0d0
         end do
      end do
!$OMP END DO
c
c     add local to global variables for OpenMP calculation
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            field(j,i) = field(j,i) + fieldt(j,i)
            fieldp(j,i) = fieldp(j,i) + fieldtp(j,i)
            fields(j,i) = fields(j,i) + fieldts(j,i)
            fieldps(j,i) = fieldps(j,i) + fieldtps(j,i)
         end do
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (uscale)
      deallocate (fieldt)
      deallocate (fieldtp)
      deallocate (fieldts)
      deallocate (fieldtps)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine induce0d  --  Poisson-Boltzmann induced dipoles  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "induce0d" computes the induced dipole moments at polarizable
c     sites for Poisson-Boltzmann SCRF and vacuum environments
c
c
      subroutine induce0d
      use atoms
      use extfld
      use inform
      use iounit
      use limits
      use mpole
      use polar
      use polopt
      use polpot
      use potent
      use units
      use uprior
      implicit none
      integer i,j,k
      integer ii,iter
      integer miniter
      integer maxiter
      real*8 polmin
      real*8 eps,epsold
      real*8 epsd,epsp
      real*8 epsds,epsps
      real*8 udsum,upsum
      real*8 ussum,upssum
      real*8 a,ap,as,aps
      real*8 b,bp,bs,bps
      real*8 sum,sump
      real*8 sums,sumps
      real*8, allocatable :: poli(:)
      real*8, allocatable :: field(:,:)
      real*8, allocatable :: fieldp(:,:)
      real*8, allocatable :: fields(:,:)
      real*8, allocatable :: fieldps(:,:)
      real*8, allocatable :: rsd(:,:)
      real*8, allocatable :: rsdp(:,:)
      real*8, allocatable :: rsds(:,:)
      real*8, allocatable :: rsdps(:,:)
      real*8, allocatable :: zrsd(:,:)
      real*8, allocatable :: zrsdp(:,:)
      real*8, allocatable :: zrsds(:,:)
      real*8, allocatable :: zrsdps(:,:)
      real*8, allocatable :: conj(:,:)
      real*8, allocatable :: conjp(:,:)
      real*8, allocatable :: conjs(:,:)
      real*8, allocatable :: conjps(:,:)
      real*8, allocatable :: vec(:,:)
      real*8, allocatable :: vecp(:,:)
      real*8, allocatable :: vecs(:,:)
      real*8, allocatable :: vecps(:,:)
      real*8, allocatable :: usum(:,:)
      real*8, allocatable :: usump(:,:)
      real*8, allocatable :: usums(:,:)
      real*8, allocatable :: usumps(:,:)
      logical done
      character*6 mode
c
c
c     zero out the induced dipoles; uind and uinp are vacuum dipoles,
c     uinds and uinps are Poisson-Boltzmann SCRF dipoles
c
      do i = 1, n
         do j = 1, 3
            uind(j,i) = 0.0d0
            uinp(j,i) = 0.0d0
            uinds(j,i) = 0.0d0
            uinps(j,i) = 0.0d0
         end do
      end do
      if (.not.use_polar .or. .not.use_solv)  return
c
c     set the switching function coefficients
c
      mode = 'MPOLE'
      call switch (mode)
c
c     perform dynamic allocation of some local arrays
c
      allocate (field(3,n))
      allocate (fieldp(3,n))
      allocate (fields(3,n))
      allocate (fieldps(3,n))
c
c     compute induced dipoles based on direct and mutual fields
c
   10 continue
c
c     compute the direct induced dipole moment at each atom, and
c     another set that also includes RF due to permanent multipoles
c
      call dfield0e (field,fieldp,fields,fieldps)
c
c     add external electric field to the direct field values
c
      if (use_exfld) then
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               field(j,i) = field(j,i) + exfld(j)
               fieldp(j,i) = fieldp(j,i) + exfld(j)
               fields(j,i) = fields(j,i) + exfld(j)
               fieldps(j,i) = fieldps(j,i) + exfld(j)
            end do
         end do
      end if
c
c     set vacuum induced dipoles to polarizability times direct field;
c     SCRF induced dipoles are polarizability times direct field
c     plus the reaction field due to permanent multipoles
c
      do ii = 1, npole
         i = ipole(ii)
         if (douind(i)) then
            do j = 1, 3
               udir(j,i) = polarity(i) * field(j,i)
               udirp(j,i) = polarity(i) * fieldp(j,i)
               udirs(j,i) = polarity(i) * fields(j,i)
               udirps(j,i) = polarity(i) * fieldps(j,i)
               uind(j,i) = udir(j,i)
               uinp(j,i) = udirp(j,i)
               uinds(j,i) = udirs(j,i)
               uinps(j,i) = udirps(j,i)
            end do
         end if
      end do
c
c     get induced dipoles via the OPT extrapolation method
c
      if (poltyp .eq. 'OPT') then
         do ii = 1, npole
            i = ipole(ii)
            if (douind(i)) then
               do j = 1, 3
                  uopt(0,j,i) = udir(j,i)
                  uoptp(0,j,i) = udirp(j,i)
                  uopts(0,j,i) = udirs(j,i)
                  uoptps(0,j,i) = udirps(j,i)
               end do
            end if
         end do
         do k = 1, optorder
            call ufield0e (field,fieldp,fields,fieldps)
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     uopt(k,j,i) = polarity(i) * field(j,i)
                     uoptp(k,j,i) = polarity(i) * fieldp(j,i)
                     uopts(k,j,i) = polarity(i) * fields(j,i)
                     uoptps(k,j,i) = polarity(i) * fieldps(j,i)
                     uind(j,i) = uopt(k,j,i)
                     uinp(j,i) = uoptp(k,j,i)
                     uinds(j,i) = uopts(k,j,i)
                     uinps(j,i) = uoptps(k,j,i)
                  end do
               end if
            end do
         end do
         allocate (usum(3,n))
         allocate (usump(3,n))
         allocate (usums(3,n))
         allocate (usumps(3,n))
         do ii = 1, npole
            i = ipole(ii)
            if (douind(i)) then
               do j = 1, 3
                  uind(j,i) = 0.0d0
                  uinp(j,i) = 0.0d0
                  uinds(j,i) = 0.0d0
                  uinps(j,i) = 0.0d0
                  usum(j,i) = 0.0d0
                  usump(j,i) = 0.0d0
                  usums(j,i) = 0.0d0
                  usumps(j,i) = 0.0d0
                  do k = 0, optorder
                     usum(j,i) = usum(j,i) + uopt(k,j,i)
                     usump(j,i) = usump(j,i) + uoptp(k,j,i)
                     usums(j,i) = usums(j,i) + uopts(k,j,i)
                     usumps(j,i) = usumps(j,i) + uoptps(k,j,i)
                     uind(j,i) = uind(j,i) + copt(k)*usum(j,i)
                     uinp(j,i) = uinp(j,i) + copt(k)*usump(j,i)
                     uinds(j,i) = uinds(j,i) + copt(k)*usums(j,i)
                     uinps(j,i) = uinps(j,i) + copt(k)*usumps(j,i)
                  end do
               end do
            end if
         end do
         deallocate (usum)
         deallocate (usump)
         deallocate (usums)
         deallocate (usumps)
      end if
c
c     set tolerances for computation of mutual induced dipoles
c
      if (poltyp .eq. 'MUTUAL') then
         done = .false.
         miniter = min(3,npole)
         maxiter = 100
         iter = 0
         polmin = 0.00000001d0
         eps = 100.0d0
c
c     estimated induced dipoles from polynomial predictor
c
         if (use_pred .and. nualt.eq.maxualt) then
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  udsum = 0.0d0
                  upsum = 0.0d0
                  ussum = 0.0d0
                  upssum = 0.0d0
                  do k = 1, nualt-1
                     udsum = udsum + bpred(k)*udalt(k,j,i)
                     upsum = upsum + bpredp(k)*upalt(k,j,i)
                     ussum = ussum + bpreds(k)*usalt(k,j,i)
                     upssum = upssum + bpredps(k)*upsalt(k,j,i)
                  end do
                  uind(j,i) = udsum
                  uinp(j,i) = upsum
                  uinds(j,i) = ussum
                  uinps(j,i) = upssum
               end do
            end do
         end if
c
c     perform dynamic allocation of some local arrays
c
         allocate (poli(n))
         allocate (rsd(3,n))
         allocate (rsdp(3,n))
         allocate (rsds(3,n))
         allocate (rsdps(3,n))
         allocate (zrsd(3,n))
         allocate (zrsdp(3,n))
         allocate (zrsds(3,n))
         allocate (zrsdps(3,n))
         allocate (conj(3,n))
         allocate (conjp(3,n))
         allocate (conjs(3,n))
         allocate (conjps(3,n))
         allocate (vec(3,n))
         allocate (vecp(3,n))
         allocate (vecs(3,n))
         allocate (vecps(3,n))
c
c     set initial conjugate gradient residual and conjugate vector
c
         call ufield0e (field,fieldp,fields,fieldps)
         do ii = 1, npole
            i = ipole(ii)
            if (douind(i)) then
               poli(i) = max(polmin,polarity(i))
               do j = 1, 3
                  rsd(j,i) = (udir(j,i)-uind(j,i))/poli(i)
     &                          + field(j,i)
                  rsdp(j,i) = (udirp(j,i)-uinp(j,i))/poli(i)
     &                           + fieldp(j,i)
                  rsds(j,i) = (udirs(j,i)-uinds(j,i))/poli(i)
     &                           + fields(j,i)
                  rsdps(j,i) = (udirps(j,i)-uinps(j,i))/poli(i)
     &                            + fieldps(j,i)
                  zrsd(j,i) = rsd(j,i) * poli(i)
                  zrsdp(j,i) = rsdp(j,i) * poli(i)
                  zrsds(j,i) = rsds(j,i) * poli(i)
                  zrsdps(j,i) = rsdps(j,i) * poli(i)
                  conj(j,i) = zrsd(j,i)
                  conjp(j,i) = zrsdp(j,i)
                  conjs(j,i) = zrsds(j,i)
                  conjps(j,i) = zrsdps(j,i)
               end do
            end if
         end do
c
c     conjugate gradient iteration of the mutual induced dipoles
c
         do while (.not. done)
            iter = iter + 1
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     vec(j,i) = uind(j,i)
                     vecp(j,i) = uinp(j,i)
                     vecs(j,i) = uinds(j,i)
                     vecps(j,i) = uinps(j,i)
                     uind(j,i) = conj(j,i)
                     uinp(j,i) = conjp(j,i)
                     uinds(j,i) = conjs(j,i)
                     uinps(j,i) = conjps(j,i)
                  end do
               end if
            end do
            call ufield0e (field,fieldp,fields,fieldps)
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     uind(j,i) = vec(j,i)
                     uinp(j,i) = vecp(j,i)
                     uinds(j,i) = vecs(j,i)
                     uinps(j,i) = vecps(j,i)
                     vec(j,i) = conj(j,i)/poli(i) - field(j,i)
                     vecp(j,i) = conjp(j,i)/poli(i) - fieldp(j,i)
                     vecs(j,i) = conjs(j,i)/poli(i) - fields(j,i)
                     vecps(j,i) = conjps(j,i)/poli(i) - fieldps(j,i)
                  end do
               end if
            end do
            a = 0.0d0
            ap = 0.0d0
            as = 0.0d0
            aps = 0.0d0
            sum = 0.0d0
            sump = 0.0d0
            sums = 0.0d0
            sumps = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     a = a + conj(j,i)*vec(j,i)
                     ap = ap + conjp(j,i)*vecp(j,i)
                     as = as + conjs(j,i)*vecs(j,i)
                     aps = aps + conjps(j,i)*vecps(j,i)
                     sum = sum + rsd(j,i)*zrsd(j,i)
                     sump = sump + rsdp(j,i)*zrsdp(j,i)
                     sums = sums + rsds(j,i)*zrsds(j,i)
                     sumps = sumps + rsdps(j,i)*zrsdps(j,i)
                  end do
               end if
            end do
            if (a .ne. 0.0d0)  a = sum / a
            if (ap .ne. 0.0d0)  ap = sump / ap
            if (as .ne. 0.0d0)  as = sums / as
            if (aps .ne. 0.0d0)  aps = sumps / aps
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     uind(j,i) = uind(j,i) + a*conj(j,i)
                     uinp(j,i) = uinp(j,i) + ap*conjp(j,i)
                     uinds(j,i) = uinds(j,i) + as*conjs(j,i)
                     uinps(j,i) = uinps(j,i) + aps*conjps(j,i)
                     rsd(j,i) = rsd(j,i) - a*vec(j,i)
                     rsdp(j,i) = rsdp(j,i) - ap*vecp(j,i)
                     rsds(j,i) = rsds(j,i) - as*vecs(j,i)
                     rsdps(j,i) = rsdps(j,i) - aps*vecps(j,i)
                  end do
               end if
            end do
            b = 0.0d0
            bp = 0.0d0
            bs = 0.0d0
            bps = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     zrsd(j,i) = rsd(j,i) * poli(i)
                     zrsdp(j,i) = rsdp(j,i) * poli(i)
                     zrsds(j,i) = rsds(j,i) * poli(i)
                     zrsdps(j,i) = rsdps(j,i) * poli(i)
                     b = b + rsd(j,i)*zrsd(j,i)
                     bp = bp + rsdp(j,i)*zrsdp(j,i)
                     bs = bs + rsds(j,i)*zrsds(j,i)
                     bps = bps + rsdps(j,i)*zrsdps(j,i)
                  end do
               end if
            end do
            if (sum .ne. 0.0d0)  b = b / sum
            if (sump .ne. 0.0d0)  bp = bp / sump
            if (sums .ne. 0.0d0)  bs = bs / sums
            if (sumps .ne. 0.0d0)  bps = bps / sumps
            epsd = 0.0d0
            epsp = 0.0d0
            epsds = 0.0d0
            epsps = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     conj(j,i) = zrsd(j,i) + b*conj(j,i)
                     conjp(j,i) = zrsdp(j,i) + bp*conjp(j,i)
                     conjs(j,i) = zrsds(j,i) + bs*conjs(j,i)
                     conjps(j,i) = zrsdps(j,i) + bps*conjps(j,i)
                     epsd = epsd + rsd(j,i)*rsd(j,i)
                     epsp = epsp + rsdp(j,i)*rsdp(j,i)
                     epsds = epsds + rsds(j,i)*rsds(j,i)
                     epsps = epsps + rsdps(j,i)*rsdps(j,i)
                  end do
               end if
            end do
c
c     check the convergence of the mutual induced dipoles
c
            epsold = eps
            eps = max(epsd,epsp,epsds,epsps)
            eps = debye * sqrt(eps/dble(npolar))
            if (debug) then
               if (iter .eq. 1) then
                  write (iout,20)
   20             format (/,' Determination of Induced Dipole',
     &                       ' Moments :',
     &                    //,4x,'Iter',8x,'RMS Change (Debye)',/)
               end if
               write (iout,30)  iter,eps
   30          format (i8,7x,f16.10)
            end if
            if (eps .lt. poleps)  done = .true.
            if (eps .gt. epsold)  done = .true.
            if (iter .lt. miniter)  done = .false.
            if (iter .ge. politer)  done = .true.
c
c     apply a "peek" iteration to the mutual induced dipoles
c
            if (done) then
               do ii = 1, npole
                  i = ipole(ii)
                  if (douind(i)) then
                     do j = 1, 3
                        uind(j,i) = uind(j,i) + poli(i)*rsd(j,i)
                        uinp(j,i) = uinp(j,i) + poli(i)*rsdp(j,i)
                        uinds(j,i) = uinds(j,i) + poli(i)*rsds(j,i)
                        uinps(j,i) = uinps(j,i) + poli(i)*rsdps(j,i)
                     end do
                  end if
               end do
            end if
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (poli)
         deallocate (rsd)
         deallocate (rsdp)
         deallocate (rsds)
         deallocate (rsdps)
         deallocate (zrsd)
         deallocate (zrsdp)
         deallocate (zrsds)
         deallocate (zrsdps)
         deallocate (conj)
         deallocate (conjp)
         deallocate (conjs)
         deallocate (conjps)
         deallocate (vec)
         deallocate (vecp)
         deallocate (vecs)
         deallocate (vecps)
c
c     print the results from the conjugate gradient iteration
c
         if (debug) then
            write (iout,40)  iter,eps
   40       format (/,' Induced Dipoles :',6x,'Iterations',i5,
     &                 6x,'RMS Change',f15.10)
         end if
c
c     terminate the calculation if dipoles failed to converge
c
         if (iter.ge.maxiter .or. eps.gt.epsold) then
            if (use_ulist) then
               use_ulist = .false.
               usolvcut = 0.0d0
               if (verbose) then
                  write (iout,50)
   50             format (/,' INDUCE  --  Switching to Diagonal',
     &                       ' PCG Preconditioner')
               end if
               goto 10
            else
               write (iout,60)
   60          format (/,' INDUCE  --  Warning, Induced Dipoles',
     &                    ' are not Converged')
               call prterr
               call fatal
            end if
         end if
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (field)
      deallocate (fieldp)
      deallocate (fields)
      deallocate (fieldps)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine dfield0e  --  Poisson-Boltzmann direct field  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "dfield0e" computes the direct electrostatic field due to
c     permanent multipole moments for use with in Poisson-Boltzmann
c
c
      subroutine dfield0e (field,fieldp,fields,fieldps)
      use atoms
      use couple
      use group
      use mpole
      use pbstuf
      use polar
      use polgrp
      use polpot
      use shunt
      use solpot
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xr,yr,zr
      real*8 xr2,yr2,zr2
      real*8 fgrp,r,r2
      real*8 rr3,rr5,rr7
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 fid(3),fkd(3)
      real*8 dmpik(7)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      real*8 fields(3,*)
      real*8 fieldps(3,*)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: pscale(:)
      logical proceed
c
c
c     zero out the value of the field at each site
c
      do i = 1, n
         do j = 1, 3
            field(j,i) = 0.0d0
            fieldp(j,i) = 0.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (dscale(n))
      allocate (pscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         pscale(i) = 1.0d0
         dscale(i) = 1.0d0
      end do
c
c     compute the direct electrostatic field at each atom, and
c     another field including RF due to permanent multipoles;
c     note self-interactions for the solute field are skipped
c
      do ii = 1, npole
         i = ipole(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
               dscale(i12(j,i)) = pscale(i12(j,i))
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
               dscale(i13(j,i)) = pscale(i13(j,i))
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
               dscale(i14(j,i)) = pscale(i14(j,i))
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
               dscale(i15(j,i)) = pscale(i15(j,i))
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               pscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               pscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               pscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               pscale(i15(j,i)) = p5iscale
               end do
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
            end do
         end if
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            proceed = .true.
            if (use_intra)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed) then
               xr = x(k) - x(i)
               yr = y(k) - y(i)
               zr = z(k) - z(i)
               xr2 = xr * xr
               yr2 = yr * yr
               zr2 = zr * zr
               r2 = xr2 + yr2 + zr2
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  ck = rpole(1,k)
                  dkx = rpole(2,k)
                  dky = rpole(3,k)
                  dkz = rpole(4,k)
                  qkxx = rpole(5,k)
                  qkxy = rpole(6,k)
                  qkxz = rpole(7,k)
                  qkyy = rpole(9,k)
                  qkyz = rpole(10,k)
                  qkzz = rpole(13,k)
                  call damptholed (i,k,7,r,dmpik)
                  rr3 = dmpik(3) / (r*r2)
                  rr5 = 3.0d0 * dmpik(5) / (r*r2*r2)
                  rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2)
                  dir = dix*xr + diy*yr + diz*zr
                  qix = qixx*xr + qixy*yr + qixz*zr
                  qiy = qixy*xr + qiyy*yr + qiyz*zr
                  qiz = qixz*xr + qiyz*yr + qizz*zr
                  qir = qix*xr + qiy*yr + qiz*zr
                  dkr = dkx*xr + dky*yr + dkz*zr
                  qkx = qkxx*xr + qkxy*yr + qkxz*zr
                  qky = qkxy*xr + qkyy*yr + qkyz*zr
                  qkz = qkxz*xr + qkyz*yr + qkzz*zr
                  qkr = qkx*xr + qky*yr + qkz*zr
                  fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                        - rr3*dkx + 2.0d0*rr5*qkx
                  fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                        - rr3*dky + 2.0d0*rr5*qky
                  fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                        - rr3*dkz + 2.0d0*rr5*qkz
                  fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir)
     &                        - rr3*dix - 2.0d0*rr5*qix
                  fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir)
     &                        - rr3*diy - 2.0d0*rr5*qiy
                  fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir)
     &                        - rr3*diz - 2.0d0*rr5*qiz
                  do j = 1, 3
                     field(j,i) = field(j,i) + fid(j)*dscale(k)
                     field(j,k) = field(j,k) + fkd(j)*dscale(k)
                     fieldp(j,i) = fieldp(j,i) + fid(j)*pscale(k)
                     fieldp(j,k) = fieldp(j,k) + fkd(j)*pscale(k)
                  end do
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
               dscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
               dscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
               dscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
               dscale(i15(j,i)) = 1.0d0
            end do
         else
            do j = 1, n12(i)
               pscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               pscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               pscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               pscale(i15(j,i)) = 1.0d0
            end do
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (dscale)
      deallocate (pscale)
c
c     find the Poisson-Boltzmann reaction field at each site
c
      call pbempole
c
c     combine permanent multipole field and PB reaction field
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            fields(j,i) = field(j,i) + pbep(j,i)
            fieldps(j,i) = fieldp(j,i) + pbep(j,i)
         end do
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ufield0e  --  Poisson-Boltzmann mutual field  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ufield0e" computes the mutual electrostatic field due to
c     induced dipole moments via a Poisson-Boltzmann solver
c
c
      subroutine ufield0e (field,fieldp,fields,fieldps)
      use atoms
      use group
      use mpole
      use pbstuf
      use polar
      use polgrp
      use polpot
      use shunt
      use solpot
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xr,yr,zr
      real*8 xr2,yr2,zr2
      real*8 fgrp,r,r2
      real*8 rr3,rr5
      real*8 duix,duiy,duiz
      real*8 puix,puiy,puiz
      real*8 dukx,duky,dukz
      real*8 pukx,puky,pukz
      real*8 duir,puir
      real*8 dukr,pukr
      real*8 duixs,duiys,duizs
      real*8 puixs,puiys,puizs
      real*8 dukxs,dukys,dukzs
      real*8 pukxs,pukys,pukzs
      real*8 duirs,puirs
      real*8 dukrs,pukrs
      real*8 fid(3),fkd(3)
      real*8 fip(3),fkp(3)
      real*8 fids(3),fkds(3)
      real*8 fips(3),fkps(3)
      real*8 dmpik(5)
      real*8 field(3,*)
      real*8 fieldp(3,*)
      real*8 fields(3,*)
      real*8 fieldps(3,*)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: indpole(:,:)
      real*8, allocatable :: inppole(:,:)
      logical proceed
c
c
c     zero out the value of the field at each site
c
      do i = 1, n
         do j = 1, 3
            field(j,i) = 0.0d0
            fieldp(j,i) = 0.0d0
            fields(j,i) = 0.0d0
            fieldps(j,i) = 0.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (uscale(n))
c
c     set array needed to scale connected atom interactions
c
      do i = 1, n
         uscale(i) = 1.0d0
      end do
c
c     compute the mutual electrostatic field at each atom,
c     and another field including RF due to induced dipoles
c
      do ii = 1, npole
         i = ipole(ii)
         duix = uind(1,i)
         duiy = uind(2,i)
         duiz = uind(3,i)
         puix = uinp(1,i)
         puiy = uinp(2,i)
         puiz = uinp(3,i)
         duixs = uinds(1,i)
         duiys = uinds(2,i)
         duizs = uinds(3,i)
         puixs = uinps(1,i)
         puiys = uinps(2,i)
         puizs = uinps(3,i)
c
c     set exclusion coefficients for connected atoms
c
         do j = 1, np11(i)
            uscale(ip11(j,i)) = u1scale
         end do
         do j = 1, np12(i)
            uscale(ip12(j,i)) = u2scale
         end do
         do j = 1, np13(i)
            uscale(ip13(j,i)) = u3scale
         end do
         do j = 1, np14(i)
            uscale(ip14(j,i)) = u4scale
         end do
c
c     evaluate all sites within the cutoff distance
c
         do kk = ii+1, npole
            k = ipole(kk)
            proceed = .true.
            if (use_intra)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed) then
               xr = x(k) - x(i)
               yr = y(k) - y(i)
               zr = z(k) - z(i)
               xr2 = xr * xr
               yr2 = yr * yr
               zr2 = zr * zr
               r2 = xr2 + yr2 + zr2
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  dukx = uind(1,k)
                  duky = uind(2,k)
                  dukz = uind(3,k)
                  pukx = uinp(1,k)
                  puky = uinp(2,k)
                  pukz = uinp(3,k)
                  dukxs = uinds(1,k)
                  dukys = uinds(2,k)
                  dukzs = uinds(3,k)
                  pukxs = uinps(1,k)
                  pukys = uinps(2,k)
                  pukzs = uinps(3,k)
                  call dampthole (i,k,5,r,dmpik)
                  dmpik(3) = uscale(k) * dmpik(3)
                  dmpik(5) = uscale(k) * dmpik(5)
                  rr3 = -dmpik(3) / (r*r2)
                  rr5 = 3.0d0 * dmpik(5) / (r*r2*r2)
                  duir = xr*duix + yr*duiy + zr*duiz
                  dukr = xr*dukx + yr*duky + zr*dukz
                  puir = xr*puix + yr*puiy + zr*puiz
                  pukr = xr*pukx + yr*puky + zr*pukz
                  duirs = xr*duixs + yr*duiys + zr*duizs
                  dukrs = xr*dukxs + yr*dukys + zr*dukzs
                  puirs = xr*puixs + yr*puiys + zr*puizs
                  pukrs = xr*pukxs + yr*pukys + zr*pukzs
                  fid(1) = rr3*dukx + rr5*dukr*xr
                  fid(2) = rr3*duky + rr5*dukr*yr
                  fid(3) = rr3*dukz + rr5*dukr*zr
                  fkd(1) = rr3*duix + rr5*duir*xr
                  fkd(2) = rr3*duiy + rr5*duir*yr
                  fkd(3) = rr3*duiz + rr5*duir*zr
                  fip(1) = rr3*pukx + rr5*pukr*xr
                  fip(2) = rr3*puky + rr5*pukr*yr
                  fip(3) = rr3*pukz + rr5*pukr*zr
                  fkp(1) = rr3*puix + rr5*puir*xr
                  fkp(2) = rr3*puiy + rr5*puir*yr
                  fkp(3) = rr3*puiz + rr5*puir*zr
                  fids(1) = rr3*dukxs + rr5*dukrs*xr
                  fids(2) = rr3*dukys + rr5*dukrs*yr
                  fids(3) = rr3*dukzs + rr5*dukrs*zr
                  fkds(1) = rr3*duixs + rr5*duirs*xr
                  fkds(2) = rr3*duiys + rr5*duirs*yr
                  fkds(3) = rr3*duizs + rr5*duirs*zr
                  fips(1) = rr3*pukxs + rr5*pukrs*xr
                  fips(2) = rr3*pukys + rr5*pukrs*yr
                  fips(3) = rr3*pukzs + rr5*pukrs*zr
                  fkps(1) = rr3*puixs + rr5*puirs*xr
                  fkps(2) = rr3*puiys + rr5*puirs*yr
                  fkps(3) = rr3*puizs + rr5*puirs*zr
                  do j = 1, 3
                     field(j,i) = field(j,i) + fid(j)
                     field(j,k) = field(j,k) + fkd(j)
                     fieldp(j,i) = fieldp(j,i) + fip(j)
                     fieldp(j,k) = fieldp(j,k) + fkp(j)
                     fields(j,i) = fields(j,i) + fids(j)
                     fields(j,k) = fields(j,k) + fkds(j)
                     fieldps(j,i) = fieldps(j,i) + fips(j)
                     fieldps(j,k) = fieldps(j,k) + fkps(j)
                  end do
               end if
            end if
         end do
c
c     reset exclusion coefficients for connected atoms
c
         do j = 1, np11(i)
            uscale(ip11(j,i)) = 1.0d0
         end do
         do j = 1, np12(i)
            uscale(ip12(j,i)) = 1.0d0
         end do
         do j = 1, np13(i)
            uscale(ip13(j,i)) = 1.0d0
         end do
         do j = 1, np14(i)
            uscale(ip14(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (uscale)
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(pbeuind))  allocate (pbeuind(3,n))
      if (.not. allocated(pbeuinp))  allocate (pbeuinp(3,n))
c
c     perform dynamic allocation of some local arrays
c
      allocate (indpole(3,n))
      allocate (inppole(3,n))
c
c     zero out the PB reaction field at each atomic site
c
      do i = 1, n
         do j = 1, 3
            indpole(j,i) = 0.0d0
            inppole(j,i) = 0.0d0
            pbeuind(j,i) = 0.0d0
            pbeuinp(j,i) = 0.0d0
         end do
      end do
c
c     find the Poisson-Boltzmann reaction field at each site
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            indpole(j,i) = uinds(j,i)
            inppole(j,i) = uinps(j,i)
         end do
      end do
      call apbsinduce (indpole,pbeuind)
      call apbsnlinduce (inppole,pbeuinp)
c
c     perform deallocation of some local arrays
c
      deallocate (indpole)
      deallocate (inppole)
c
c     combine mutual induced dipole field and PB reaction field
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            fields(j,i) = fields(j,i) + pbeuind(j,i)
            fieldps(j,i) = fieldps(j,i) + pbeuinp(j,i)
         end do
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ulspred  --  induced dipole prediction coeffs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ulspred" uses an ASPC or Gear extrapolation method, or a least
c     squares fit, to set coefficients of an induced dipole predictor
c     polynomial
c
c     literature references:
c
c     J. Kolafa, "Time-Reversible Always Stable Predictor-Corrector
c     Method for Molecular Dynamics of Polarizable Molecules", Journal
c     of Computational Chemistry, 25, 335-342 (2004)
c
c     D. Nocito and G. J. O. Beran, Reduced Computational Cost
c     of Polarizable Force Fields by a Modification of the Always
c     Stable Predictor-Corrector, Journal of Chemical Physics, 150,
c     151103 (2019)
c
c     W. Wang and R. D. Skeel, "Fast Evaluation of Polarizable Forces",
c     Journal of Chemical Physics, 123, 164107 (2005)
c
c
      subroutine ulspred
      use mpole
      use uprior
      implicit none
      integer i,j,k,m,ii
      real*8 coeff,udk,upk
      real*8 amax,apmax
      real*8 b(maxualt)
      real*8 bp(maxualt)
      real*8 a(maxualt*(maxualt+1)/2)
      real*8 ap(maxualt*(maxualt+1)/2)
      real*8 c(maxualt,maxualt)
      real*8 cp(maxualt,maxualt)
c
c
c     set always stable predictor-corrector (ASPC) coefficients
c
      if (polpred .eq. 'ASPC') then
         do i = 1, nualt
            coeff = aspc(i)
            bpred(i) = coeff
            bpredp(i) = coeff
            bpreds(i) = coeff
            bpredps(i) = coeff
         end do
c
c     set the Gear predictor binomial coefficients
c
      else if (polpred .eq. 'GEAR') then
         do i = 1, nualt
            coeff = gear(i)
            bpred(i) = coeff
            bpredp(i) = coeff
            bpreds(i) = coeff
            bpredps(i) = coeff
         end do
c
c     derive normal equations corresponding to least squares fit
c
      else if (polpred .eq. 'LSQR') then
         do k = 1, nualt
            b(k) = 0.0d0
            bp(k) = 0.0d0
            do m = k, nualt
               c(k,m) = 0.0d0
               cp(k,m) = 0.0d0
            end do
         end do
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               do k = 1, nualt
                  udk = udalt(k,j,i)
                  upk = upalt(k,j,i)
                  do m = k, nualt
                     c(k,m) = c(k,m) + udk*udalt(m,j,i)
                     cp(k,m) = cp(k,m) + upk*upalt(m,j,i)
                  end do
               end do
            end do
         end do
         i = 0
         do k = 2, nualt
            b(k-1) = c(1,k)
            bp(k-1) = cp(1,k)
            do m = k, nualt
               i = i + 1
               a(i) = c(k,m)
               ap(i) = cp(k,m)
            end do
         end do
c
c     check for nonzero coefficients of the normal equations
c
         k = nualt - 1
         amax = 0.0d0
         apmax = 0.0d0
         do i = 1, k*(k+1)/2
            amax = max(amax,a(i))
            apmax = max(apmax,ap(i))
         end do
c
c     solve the normal equations via LU matrix factorization
c
         if (amax .ne. 0.0d0)  call lusolve (k,a,b)
         if (apmax .ne. 0.0d0)  call lusolve (k,ap,bp)
c
c     transfer the final solution to the coefficient vector
c
         do k = 1, nualt-1
            bpred(k) = b(k)
            bpredp(k) = bp(k)
            bpreds(k) = b(k)
            bpredps(k) = bp(k)
         end do
         bpred(nualt) = 0.0d0
         bpredp(nualt) = 0.0d0
         bpreds(nualt) = 0.0d0
         bpredps(nualt) = 0.0d0
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine uscale0a  --  dipole preconditioner via loop  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "uscale0a" builds and applies a preconditioner for the conjugate
c     gradient induced dipole solver using a double loop
c
c
      subroutine uscale0a (mode,rsd,rsdp,zrsd,zrsdp)
      use atoms
      use chgpen
      use couple
      use limits
      use mplpot
      use mpole
      use polar
      use polgrp
      use polpcg
      use polpot
      implicit none
      integer i,j,k,m
      integer ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr3,rr5
      real*8 polmin
      real*8 poli,polik
      real*8 alphai,alphak
      real*8 off2
      real*8 m1,m2,m3
      real*8 m4,m5,m6
      real*8 dmpik(5)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: wscale(:)
      real*8 rsd(3,*)
      real*8 rsdp(3,*)
      real*8 zrsd(3,*)
      real*8 zrsdp(3,*)
      character*6 mode
c
c
c     apply the preconditioning matrix to the current residual
c
      if (mode .eq. 'APPLY') then
c
c     use diagonal preconditioner elements as first approximation
c
         polmin = 0.00000001d0
         do ii = 1, npole
            i = ipole(ii)
            poli = uaccel * max(polmin,polarity(i))
            do j = 1, 3
               zrsd(j,i) = poli * rsd(j,i)
               zrsdp(j,i) = poli * rsdp(j,i)
            end do
         end do
c
c     use the off-diagonal preconditioner elements in second phase
c
         off2 = usolvcut * usolvcut
         m = 0
         do ii = 1, npole-1
            i = ipole(ii)
            do kk = ii+1, npole
               k = ipole(kk)
               xr = x(k) - x(i)
               yr = y(k) - y(i)
               zr = z(k) - z(i)
               call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  m1 = minv(m+1)
                  m2 = minv(m+2)
                  m3 = minv(m+3)
                  m4 = minv(m+4)
                  m5 = minv(m+5)
                  m6 = minv(m+6)
                  m = m + 6
                  zrsd(1,i) = zrsd(1,i) + m1*rsd(1,k)
     &                           + m2*rsd(2,k) + m3*rsd(3,k)
                  zrsd(2,i) = zrsd(2,i) + m2*rsd(1,k)
     &                           + m4*rsd(2,k) + m5*rsd(3,k)
                  zrsd(3,i) = zrsd(3,i) + m3*rsd(1,k)
     &                           + m5*rsd(2,k) + m6*rsd(3,k)
                  zrsd(1,k) = zrsd(1,k) + m1*rsd(1,i)
     &                           + m2*rsd(2,i) + m3*rsd(3,i)
                  zrsd(2,k) = zrsd(2,k) + m2*rsd(1,i)
     &                           + m4*rsd(2,i) + m5*rsd(3,i)
                  zrsd(3,k) = zrsd(3,k) + m3*rsd(1,i)
     &                           + m5*rsd(2,i) + m6*rsd(3,i)
                  zrsdp(1,i) = zrsdp(1,i) + m1*rsdp(1,k)
     &                            + m2*rsdp(2,k) + m3*rsdp(3,k)
                  zrsdp(2,i) = zrsdp(2,i) + m2*rsdp(1,k)
     &                            + m4*rsdp(2,k) + m5*rsdp(3,k)
                  zrsdp(3,i) = zrsdp(3,i) + m3*rsdp(1,k)
     &                            + m5*rsdp(2,k) + m6*rsdp(3,k)
                  zrsdp(1,k) = zrsdp(1,k) + m1*rsdp(1,i)
     &                            + m2*rsdp(2,i) + m3*rsdp(3,i)
                  zrsdp(2,k) = zrsdp(2,k) + m2*rsdp(1,i)
     &                            + m4*rsdp(2,i) + m5*rsdp(3,i)
                  zrsdp(3,k) = zrsdp(3,k) + m3*rsdp(1,i)
     &                            + m5*rsdp(2,i) + m6*rsdp(3,i)
               end if
            end do
         end do
c
c     construct off-diagonal elements of preconditioning matrix
c
      else if (mode .eq. 'BUILD') then
c
c     perform dynamic allocation of some local arrays
c
         allocate (uscale(n))
         allocate (wscale(n))
c
c     set array needed to scale connected atom interactions
c
         do i = 1, n
            uscale(i) = 1.0d0
            wscale(i) = 1.0d0
         end do
c
c     determine the off-diagonal elements of the preconditioner
c
         off2 = usolvcut * usolvcut
         m = 0
         do ii = 1, npole-1
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            poli = polarity(i)
            if (use_chgpen)  alphai = palpha(i)
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
            do j = 1, n12(i)
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               wscale(i15(j,i)) = w5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            do kk = ii+1, npole
               k = ipole(kk)
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  if (use_thole) then
                     call dampthole (i,k,5,r,dmpik)
                     dmpik(3) = uscale(k) * dmpik(3)
                     dmpik(5) = uscale(k) * dmpik(5)
                  else if (use_chgpen) then
                     alphak = palpha(k)
                     call dampmut (r,alphai,alphak,dmpik)
                     dmpik(3) = wscale(k) * dmpik(3)
                     dmpik(5) = wscale(k) * dmpik(5)
                  end if
                  polik = poli * polarity(k)
                  rr3 = dmpik(3) * polik / (r*r2)
                  rr5 = 3.0d0 * dmpik(5) * polik / (r*r2*r2)
                  minv(m+1) = rr5*xr*xr - rr3
                  minv(m+2) = rr5*xr*yr
                  minv(m+3) = rr5*xr*zr
                  minv(m+4) = rr5*yr*yr - rr3
                  minv(m+5) = rr5*yr*zr
                  minv(m+6) = rr5*zr*zr - rr3
                  m = m + 6
               end if
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
            do j = 1, n12(i)
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               wscale(i15(j,i)) = 1.0d0
            end do
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (uscale)
         deallocate (wscale)
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine uscale0b  --  dipole preconditioner via list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "uscale0b" builds and applies a preconditioner for the conjugate
c     gradient induced dipole solver using a neighbor pair list
c
c
      subroutine uscale0b (mode,rsd,rsdp,zrsd,zrsdp)
      use atoms
      use chgpen
      use couple
      use limits
      use mplpot
      use mpole
      use neigh
      use polar
      use polgrp
      use polpcg
      use polpot
      implicit none
      integer i,j,k,m
      integer ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r,r2,rr3,rr5
      real*8 polmin
      real*8 poli,polik
      real*8 alphai,alphak
      real*8 m1,m2,m3
      real*8 m4,m5,m6
      real*8 dmpik(5)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: wscale(:)
      real*8 rsd(3,*)
      real*8 rsdp(3,*)
      real*8 zrsd(3,*)
      real*8 zrsdp(3,*)
      real*8, allocatable :: zrsdt(:,:)
      real*8, allocatable :: zrsdtp(:,:)
      character*6 mode
c
c
c     apply the preconditioning matrix to the current residual
c
      if (mode .eq. 'APPLY') then
c
c     perform dynamic allocation of some local arrays
c
         allocate (zrsdt(3,n))
         allocate (zrsdtp(3,n))
c
c     use diagonal preconditioner elements as first approximation
c
         polmin = 0.00000001d0
         do ii = 1, npole
            i = ipole(ii)
            poli = uaccel * max(polmin,polarity(i))
            do j = 1, 3
               zrsd(j,i) = poli * rsd(j,i)
               zrsdp(j,i) = poli * rsdp(j,i)
               zrsdt(j,i) = 0.0d0
               zrsdtp(j,i) = 0.0d0
            end do
         end do
c
c     use the off-diagonal preconditioner elements in second phase
c
         if (use_ulist) then
!$OMP PARALLEL default(private) shared(npole,ipole,mindex,
!$OMP& minv,nulst,ulst,rsd,rsdp,zrsd,zrsdp,zrsdt,zrsdtp)
!$OMP DO reduction(+:zrsdt,zrsdtp)
            do ii = 1, npole
               i = ipole(ii)
               m = mindex(i)
               do kk = 1, nulst(i)
                  k = ulst(kk,i)
                  m1 = minv(m+1)
                  m2 = minv(m+2)
                  m3 = minv(m+3)
                  m4 = minv(m+4)
                  m5 = minv(m+5)
                  m6 = minv(m+6)
                  m = m + 6
                  zrsdt(1,i) = zrsdt(1,i) + m1*rsd(1,k)
     &                             + m2*rsd(2,k) + m3*rsd(3,k)
                  zrsdt(2,i) = zrsdt(2,i) + m2*rsd(1,k)
     &                             + m4*rsd(2,k) + m5*rsd(3,k)
                  zrsdt(3,i) = zrsdt(3,i) + m3*rsd(1,k)
     &                             + m5*rsd(2,k) + m6*rsd(3,k)
                  zrsdt(1,k) = zrsdt(1,k) + m1*rsd(1,i)
     &                             + m2*rsd(2,i) + m3*rsd(3,i)
                  zrsdt(2,k) = zrsdt(2,k) + m2*rsd(1,i)
     &                             + m4*rsd(2,i) + m5*rsd(3,i)
                  zrsdt(3,k) = zrsdt(3,k) + m3*rsd(1,i)
     &                             + m5*rsd(2,i) + m6*rsd(3,i)
                  zrsdtp(1,i) = zrsdtp(1,i) + m1*rsdp(1,k)
     &                              + m2*rsdp(2,k) + m3*rsdp(3,k)
                  zrsdtp(2,i) = zrsdtp(2,i) + m2*rsdp(1,k)
     &                              + m4*rsdp(2,k) + m5*rsdp(3,k)
                  zrsdtp(3,i) = zrsdtp(3,i) + m3*rsdp(1,k)
     &                              + m5*rsdp(2,k) + m6*rsdp(3,k)
                  zrsdtp(1,k) = zrsdtp(1,k) + m1*rsdp(1,i)
     &                              + m2*rsdp(2,i) + m3*rsdp(3,i)
                  zrsdtp(2,k) = zrsdtp(2,k) + m2*rsdp(1,i)
     &                              + m4*rsdp(2,i) + m5*rsdp(3,i)
                  zrsdtp(3,k) = zrsdtp(3,k) + m3*rsdp(1,i)
     &                              + m5*rsdp(2,i) + m6*rsdp(3,i)
               end do
            end do
!$OMP END DO
c
c     transfer the results from local to global arrays
c
!$OMP DO
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  zrsd(j,i) = zrsd(j,i) + zrsdt(j,i)
                  zrsdp(j,i) = zrsdp(j,i) + zrsdtp(j,i)
               end do
            end do
!$OMP END DO
!$OMP END PARALLEL
         end if
c
c     perform deallocation of some local arrays
c
         deallocate (zrsdt)
         deallocate (zrsdtp)
c
c     build the off-diagonal elements of preconditioning matrix
c
      else if (mode.eq.'BUILD' .and. use_ulist) then
         m = 0
         do ii = 1, npole
            i = ipole(ii)
            mindex(i) = m
            m = m + 6*nulst(i)
         end do
c
c     perform dynamic allocation of some local arrays
c
         allocate (uscale(n))
         allocate (wscale(n))
c
c     set array needed to scale connected atom interactions
c
         do i = 1, n
            uscale(i) = 1.0d0
            wscale(i) = 1.0d0
         end do
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,x,y,z,polarity,
!$OMP& palpha,u1scale,u2scale,u3scale,u4scale,w2scale,w3scale,w4scale,
!$OMP& w5scale,n12,i12,n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,
!$OMP& np13,ip13,np14,ip14,use_thole,use_chgpen,nulst,ulst,mindex,minv)
!$OMP& firstprivate (uscale,wscale)
c
c     determine the off-diagonal elements of the preconditioner
c
!$OMP DO
         do ii = 1, npole
            i = ipole(ii)
            xi = x(i)
            yi = y(i)
            zi = z(i)
            poli = polarity(i)
            if (use_chgpen)  alphai = palpha(i)
c
c     set exclusion coefficients for connected atoms
c
            do j = 1, np11(i)
               uscale(ip11(j,i)) = u1scale
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = u2scale
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = u3scale
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = u4scale
            end do
            do j = 1, n12(i)
               wscale(i12(j,i)) = w2scale
            end do
            do j = 1, n13(i)
               wscale(i13(j,i)) = w3scale
            end do
            do j = 1, n14(i)
               wscale(i14(j,i)) = w4scale
            end do
            do j = 1, n15(i)
               wscale(i15(j,i)) = w5scale
            end do
c
c     evaluate all sites within the cutoff distance
c
            m = mindex(i)
            do kk = 1, nulst(i)
               k = ulst(kk,i)
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               call image (xr,yr,zr)
               r2 = xr*xr + yr* yr + zr*zr
               r = sqrt(r2)
               if (use_thole) then
                  call dampthole (i,k,5,r,dmpik)
                  dmpik(3) = uscale(k) * dmpik(3)
                  dmpik(5) = uscale(k) * dmpik(5)
               else if (use_chgpen) then
                  alphak = palpha(k)
                  call dampmut (r,alphai,alphak,dmpik)
                  dmpik(3) = wscale(k) * dmpik(3)
                  dmpik(5) = wscale(k) * dmpik(5)
               end if
               polik = poli * polarity(k)
               rr3 = dmpik(3) * polik / (r*r2)
               rr5 = 3.0d0 * dmpik(5) * polik / (r*r2*r2)
               minv(m+1) = rr5*xr*xr - rr3
               minv(m+2) = rr5*xr*yr
               minv(m+3) = rr5*xr*zr
               minv(m+4) = rr5*yr*yr - rr3
               minv(m+5) = rr5*yr*zr
               minv(m+6) = rr5*zr*zr - rr3
               m = m + 6
            end do
c
c     reset exclusion coefficients for connected atoms
c
            do j = 1, np11(i)
               uscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               uscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               uscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               uscale(ip14(j,i)) = 1.0d0
            end do
            do j = 1, n12(i)
               wscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               wscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               wscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               wscale(i15(j,i)) = 1.0d0
            end do
         end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
         deallocate (uscale)
         deallocate (wscale)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine inertia  --  principal moments of inertia  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "inertia" computes the principal moments of inertia for the
c     system, and optionally translates the center of mass to the
c     origin and rotates the principal axes onto the global axes
c
c        mode = 1     print the moments and principal axes
c        mode = 2     move coordinates to standard orientation
c        mode = 3     perform both of the above operations
c
c     literature reference:
c
c     H. Goldstein, C. Poole and J. Safko, "Classical Mechanics,
c     3rd Edition", Addison-Wesley, Boston, MA, 2001; see the Euler
c     angle xyz convention in Appendix A
c
c
      subroutine inertia (mode)
      use atoms
      use atomid
      use iounit
      use math
      implicit none
      integer i,j,k,mode
      real*8 weigh,total,dot
      real*8 xcm,ycm,zcm
      real*8 xx,xy,xz,yy,yz,zz
      real*8 xterm,yterm,zterm
      real*8 phi,theta,psi
      real*8 moment(3),vec(3,3)
      real*8 tensor(3,3),a(3,3)
      logical print,moved
c
c
c     decide upon the type of output desired
c
      print = .false.
      moved = .false.
      if (mode.eq.1 .or. mode.eq.3)  print = .true.
      if (mode.eq.2 .or. mode.eq.3)  moved = .true.
c
c     compute the position of the center of mass
c
      total = 0.0d0
      xcm = 0.0d0
      ycm = 0.0d0
      zcm = 0.0d0
      do i = 1, n
         weigh = mass(i)
         total = total + weigh
         xcm = xcm + x(i)*weigh
         ycm = ycm + y(i)*weigh
         zcm = zcm + z(i)*weigh
      end do
      xcm = xcm / total
      ycm = ycm / total
      zcm = zcm / total
c
c     compute and then diagonalize the inertia tensor
c
      xx = 0.0d0
      xy = 0.0d0
      xz = 0.0d0
      yy = 0.0d0
      yz = 0.0d0
      zz = 0.0d0
      do i = 1, n
         weigh = mass(i)
         xterm = x(i) - xcm
         yterm = y(i) - ycm
         zterm = z(i) - zcm
         xx = xx + xterm*xterm*weigh
         xy = xy + xterm*yterm*weigh
         xz = xz + xterm*zterm*weigh
         yy = yy + yterm*yterm*weigh
         yz = yz + yterm*zterm*weigh
         zz = zz + zterm*zterm*weigh
      end do
      tensor(1,1) = yy + zz
      tensor(2,1) = -xy
      tensor(3,1) = -xz
      tensor(1,2) = -xy
      tensor(2,2) = xx + zz
      tensor(3,2) = -yz
      tensor(1,3) = -xz
      tensor(2,3) = -yz
      tensor(3,3) = xx + yy
      call jacobi (3,tensor,moment,vec)
c
c     select the direction for each principal moment axis
c
      do i = 1, 2
         do j = 1, n
            xterm = vec(1,i) * (x(j)-xcm)
            yterm = vec(2,i) * (y(j)-ycm)
            zterm = vec(3,i) * (z(j)-zcm)
            dot = xterm + yterm + zterm
            if (dot .lt. 0.0d0) then
               do k = 1, 3
                  vec(k,i) = -vec(k,i)
               end do
            end if
            if (dot .ne. 0.0d0)  goto 10
         end do
   10    continue
      end do
c
c     moment axes must give a right-handed coordinate system
c
      xterm = vec(1,1) * (vec(2,2)*vec(3,3)-vec(2,3)*vec(3,2))
      yterm = vec(2,1) * (vec(1,3)*vec(3,2)-vec(1,2)*vec(3,3))
      zterm = vec(3,1) * (vec(1,2)*vec(2,3)-vec(1,3)*vec(2,2))
      dot = xterm + yterm + zterm
      if (dot .lt. 0.0d0) then
         do j = 1, 3
            vec(j,3) = -vec(j,3)
         end do
      end if
c
c     principal moment axes form rows of Euler rotation matrix
c
      if (moved) then
         do i = 1, 3
            do j = 1, 3
               a(i,j) = vec(j,i)
            end do
         end do
c
c     translate to origin, then apply Euler rotation matrix
c
         do i = 1, n
            xterm = x(i) - xcm
            yterm = y(i) - ycm
            zterm = z(i) - zcm
            x(i) = a(1,1)*xterm + a(1,2)*yterm + a(1,3)*zterm
            y(i) = a(2,1)*xterm + a(2,2)*yterm + a(2,3)*zterm
            z(i) = a(3,1)*xterm + a(3,2)*yterm + a(3,3)*zterm
         end do
      end if
c
c     print the center of mass and Euler angle values
c
      if (print) then
         write (iout,20)  xcm,ycm,zcm
   20    format (/,' Center of Mass Coordinates :',7x,3f13.6)
         call invert (3,vec)
         call roteuler (vec,phi,theta,psi)
         phi = radian * phi
         theta = radian * theta
         psi = radian * psi
         write (iout,30)  phi,theta,psi
   30    format (' Euler Angles (Phi/Theta/Psi) : ',4x,3f13.3)
c
c     print the moments of inertia and the principal axes
c
         write (iout,40)
   40    format (/,' Moments of Inertia and Principal Axes :',
     &           //,13x,'Moments (amu Ang^2)',
     &              12x,'X-, Y- and Z-Components of Axes')
         write (iout,50)  (moment(i),vec(1,i),vec(2,i),vec(3,i),i=1,3)
   50    format (3(/,11x,f16.3,9x,3f13.6))
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module inform  --  program I/O and flow control values  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     maxask    maximum number of queries for interactive input
c
c     gpucard   integer flag for GPU use (0=no GPU, 1=GPU present)
c     digits    decimal places output for energy and coordinates
c     iprint    steps between status printing (0=no printing)
c     iwrite    steps between coordinate saves (0=no saves)
c     isend     steps between socket communication (0=no sockets)
c     verbose   logical flag to turn on extra information printing
c     debug     logical flag to turn on extensive debug printing
c     silent    logical flag to turn off all information printing
c     holdup    logical flag to wait for carriage return on exit
c     abort     logical flag to stop execution at next chance
c
c
      module inform
      implicit none
      integer maxask
      parameter (maxask=5)
      integer gpucard,digits
      integer iprint,iwrite
      integer isend
      logical verbose,debug
      logical silent,holdup
      logical abort
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2012  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine initatom  --  setup atoms in periodic table  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "initatom" sets the atomic symbol, standard atomic weight,
c     van der Waals radius and covalent radius for each element in
c     the periodic table
c
c     literature references:
c
c     J. Emsley, The Elements, 3rd Edition, Oxford University Press,
c     (1999)  [relative atomic masses]
c
c     J. Meija, T. B. Coplen, M. Berglund, W. A. Brand, P. De Bievre,
c     M. Groning, N. E. Holden, J. Irrgeher, R. D. Loss, T. Walczyk and
c     R. Prohaska, Atomic Weights of the Elements 2013, Pure and Applied
c     Chemistry, 88, 265-291 (2016)  [standard atomic weights]
c
c     A. Bondi, van der Waals Volumes and Radii, Journal of Physical
c     Chemistry, 68, 441-451 (1964)  [original vdw radii; not used]
c
c     S. Alvarez, "A Cartography of the van der Waals Territories",
c     Dalton Transactions, 42, 8617-8636 (2013)  [vdw radii for most
c     elements 1-99]
c
c     B. Cordero, V. Gomez. A. E. Platero-Prats, M. Reves,
c     J. Echeverria, E. Cremades, F. Barragan and S. Alverez,
c     "Covalent Radii Revisited", Dalton Transactions, 2832-2838 (2008)
c     [covalent radii for elements 1-96]
c
c     P. Pyykko and M. Atsumi, "Molecular Single-Bond Covalent Radii
c     for Elements 1-118", Chemistry- A European Journal, 15, 187-197
c     (2009)  [covalent radii for elements 97-112]
c
c     B. Fricke and J. T. Waber, "Atomic and Ionic Radii of Superheavy
c     Elements", Journal of Chemical Physics, 56, 3246-3248 (1972)
c     [atomic radii for elements 104-118]
c
c
      subroutine initatom
      use ptable
      implicit none
      integer i
      real*8 amas(maxele)
      real*8 vrad(maxele)
      real*8 crad(maxele)
      character*3 asym(maxele)
c
c     atomic symbol for each element
c
      data asym  / 'H  ', 'He ', 'Li ', 'Be ', 'B  ', 'C  ', 'N  ',
     &             'O  ', 'F  ', 'Ne ', 'Na ', 'Mg ', 'Al ', 'Si ',
     &             'P  ', 'S  ', 'Cl ', 'Ar ', 'K  ', 'Ca ', 'Sc ',
     &             'Ti ', 'V  ', 'Cr ', 'Mn ', 'Fe ', 'Co ', 'Ni ',
     &             'Cu ', 'Zn ', 'Ga ', 'Ge ', 'As ', 'Se ', 'Br ',
     &             'Kr ', 'Rb ', 'Sr ', 'Y  ', 'Zr ', 'Nb ', 'Mo ',
     &             'Tc ', 'Ru ', 'Rh ', 'Pd ', 'Ag ', 'Cd ', 'In ',
     &             'Sn ', 'Sb ', 'Te ', 'I  ', 'Xe ', 'Cs ', 'Ba ',
     &             'La ', 'Ce ', 'Pr ', 'Nd ', 'Pm ', 'Sm ', 'Eu ',
     &             'Gd ', 'Tb ', 'Dy ', 'Ho ', 'Er ', 'Tm ', 'Yb ',
     &             'Lu ', 'Hf ', 'Ta ', 'W  ', 'Re ', 'Os ', 'Ir ',
     &             'Pt ', 'Au ', 'Hg ', 'Tl ', 'Pb ', 'Bi ', 'Po ',
     &             'At ', 'Rn ', 'Fr ', 'Ra ', 'Ac ', 'Th ', 'Pa ',
     &             'U  ', 'Np ', 'Pu ', 'Am ', 'Cm ', 'Bk ', 'Cf ',
     &             'Es ', 'Fm ', 'Md ', 'No ', 'Lr ', 'Rf ', 'Db ',
     &             'Sg ', 'Bh ', 'Hs ', 'Mt ', 'Ds ', 'Rg ', 'Cn ',
     &             'Nh ', 'Fl ', 'Mc ', 'Lv ', 'Ts ', 'Og ' /
c
c     standard atomic weight for each element
c
      data amas  /  1.008d0,   4.003d0,   6.941d0,   9.012d0,  10.811d0,
     &             12.011d0,  14.007d0,  15.999d0,  18.998d0,  20.180d0,
     &             22.990d0,  24.305d0,  26.982d0,  28.086d0,  30.974d0,
     &             32.066d0,  35.453d0,  39.948d0,  39.098d0,  40.078d0,
     &             44.956d0,  47.867d0,  50.942d0,  51.996d0,  54.938d0,
     &             55.845d0,  58.933d0,  58.693d0,  63.546d0,  65.380d0,
     &             69.723d0,  72.630d0,  74.922d0,  78.971d0,  79.904d0,
     &             83.798d0,  85.468d0,  87.620d0,  88.906d0,  91.224d0,
     &             92.906d0,  95.950d0,  98.906d0, 101.070d0, 102.910d0,
     &            106.420d0, 107.870d0, 112.410d0, 114.820d0, 118.710d0,
     &            121.760d0, 127.600d0, 126.900d0, 131.290d0, 132.910d0,
     &            137.330d0, 138.910d0, 140.120d0, 140.910d0, 144.240d0,
     &            144.913d0, 150.360d0, 151.960d0, 157.250d0, 158.930d0,
     &            162.500d0, 164.930d0, 167.260d0, 168.930d0, 173.050d0,
     &            174.970d0, 178.490d0, 180.950d0, 183.840d0, 186.210d0,
     &            190.230d0, 192.220d0, 195.080d0, 196.970d0, 200.590d0,
     &            204.383d0, 207.200d0, 208.980d0, 208.982d0, 209.987d0,
     &            222.017d0, 223.020d0, 226.025d0, 227.027d0, 232.038d0,
     &            231.036d0, 238.029d0, 237.048d0, 244.064d0, 243.061d0,
     &            247.070d0, 247.070d0, 251.080d0, 252.083d0, 257.095d0,
     &            258.098d0, 259.101d0, 262.110d0, 267.122d0, 270.131d0,
     &            269.129d0, 270.133d0, 270.134d0, 278.156d0, 281.165d0,
     &            281.166d0, 285.177d0, 286.182d0, 290.192d0, 290.196d0,
     &            293.205d0, 294.211d0, 295.216d0 /
c
c     van der Waals radius for each element (Angstroms)
c
      data vrad  / 1.20d0, 1.43d0, 2.12d0, 1.98d0, 1.91d0, 1.77d0,
     &             1.66d0, 1.50d0, 1.46d0, 1.58d0, 2.50d0, 2.51d0,
     &             2.25d0, 2.19d0, 1.90d0, 1.89d0, 1.82d0, 1.83d0,
     &             2.73d0, 2.62d0, 2.58d0, 2.46d0, 2.42d0, 2.45d0,
     &             2.45d0, 2.44d0, 2.40d0, 2.40d0, 2.38d0, 2.39d0,
     &             2.32d0, 2.29d0, 1.88d0, 1.82d0, 1.86d0, 2.25d0,
     &             3.21d0, 2.84d0, 2.75d0, 2.52d0, 2.56d0, 2.45d0,
     &             2.44d0, 2.46d0, 2.44d0, 2.15d0, 2.53d0, 2.49d0,
     &             2.43d0, 2.42d0, 2.47d0, 1.99d0, 2.04d0, 2.06d0,
     &             3.48d0, 3.03d0, 2.98d0, 2.88d0, 2.92d0, 2.95d0,
     &             2.90d0, 2.90d0, 2.87d0, 2.83d0, 2.79d0, 2.87d0,
     &             2.81d0, 2.83d0, 2.79d0, 2.80d0, 2.74d0, 2.63d0,
     &             2.53d0, 2.57d0, 2.49d0, 2.48d0, 2.41d0, 2.29d0,
     &             2.32d0, 2.45d0, 2.47d0, 2.60d0, 2.54d0, 2.93d0,
     &             2.88d0, 2.71d0, 2.82d0, 2.81d0, 2.80d0, 2.93d0,
     &             2.88d0, 2.71d0, 2.82d0, 2.81d0, 2.83d0, 3.05d0,
     &             3.40d0, 3.05d0, 2.70d0, 2.45d0, 2.46d0, 2.46d0,
     &             2.46d0, 1.49d0, 1.42d0, 1.36d0, 1.31d0, 1.26d0,
     &             1.22d0, 1.18d0, 1.14d0, 1.10d0, 1.31d0, 1.21d0,
     &             1.77d0, 1.51d0, 1.38d0, 1.31d0 /
c
c     covalent radius for each element (Angstroms)
c
      data crad  / 0.31d0, 0.28d0, 1.28d0, 0.96d0, 0.84d0, 0.76d0,
     &             0.71d0, 0.66d0, 0.57d0, 0.58d0, 1.66d0, 1.41d0,
     &             1.21d0, 1.11d0, 1.07d0, 1.05d0, 1.02d0, 1.06d0,
     &             2.03d0, 1.76d0, 1.70d0, 1.60d0, 1.53d0, 1.39d0,
     &             1.39d0, 1.32d0, 1.26d0, 1.24d0, 1.32d0, 1.22d0,
     &             1.22d0, 1.20d0, 1.19d0, 1.20d0, 1.20d0, 1.16d0,
     &             2.20d0, 1.95d0, 1.90d0, 1.75d0, 1.64d0, 1.54d0,
     &             1.47d0, 1.46d0, 1.42d0, 1.39d0, 1.45d0, 1.44d0,
     &             1.42d0, 1.39d0, 1.39d0, 1.38d0, 1.39d0, 1.40d0,
     &             2.44d0, 2.15d0, 2.07d0, 2.04d0, 2.03d0, 2.01d0,
     &             1.99d0, 1.98d0, 1.98d0, 1.96d0, 1.94d0, 1.92d0,
     &             1.92d0, 1.89d0, 1.90d0, 1.87d0, 1.87d0, 1.75d0,
     &             1.70d0, 1.62d0, 1.51d0, 1.44d0, 1.41d0, 1.36d0,
     &             1.36d0, 1.32d0, 1.45d0, 1.46d0, 1.48d0, 1.40d0,
     &             1.50d0, 1.50d0, 2.60d0, 2.21d0, 2.15d0, 2.06d0,
     &             2.00d0, 1.96d0, 1.90d0, 1.87d0, 1.80d0, 1.69d0,
     &             1.68d0, 1.68d0, 1.65d0, 1.67d0, 1.73d0, 1.76d0,
     &             1.61d0, 1.57d0, 1.49d0, 1.43d0, 1.41d0, 1.34d0,
     &             1.29d0, 1.28d0, 1.21d0, 1.22d0, 1.36d0, 1.43d0,
     &             1.62d0, 1.75d0, 1.65d0, 1.57d0 /
c
c
c     set the symbol, weight and radii for each element
c
      do i = 1, maxele
         atmass(i) = amas(i)
         elemnt(i) = asym(i)
         vdwrad(i) = vrad(i)
         covrad(i) = crad(i)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine initial  --  initial values and program setup  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "initial" sets up original values for some parameters and
c     variables that might not otherwise get initialized
c
c
      subroutine initial
      use align
      use atoms
      use bath
      use bound
      use boxes
      use cell
      use fft
      use files
      use freeze
      use group
      use inform
      use iounit
      use keys
      use linmin
      use minima
      use molcul
      use mutant
      use neigh
      use openmp
      use output
      use params
      use pdb
      use rigid
      use scales
      use sequen
      use socket
      use virial
      use warp
      use zclose
      implicit none
      integer i,j
!$    integer omp_get_num_procs
!$    integer omp_get_max_threads
!$    integer omp_get_max_active_levels
      logical first
      save first
      data first  / .true. /
c
c
c     default unit numbers for input and output
c
      input = 5
      iout = 6
c
c     display program banner and copyright notice
c
      if (first)  call promo
c
c     command line arguments to the program
c
      if (first)  call command
      if (first)  first = .false.
c
c     processors, threads and nested regions for OpenMP
c
      nproc = 1
      nthread = 1
      nnest = 1
!$    nproc = omp_get_num_procs ()
!$    nthread = omp_get_max_threads ()
!$    call omp_set_num_threads (nthread)
!$    nnest = omp_get_max_active_levels ()
!$    call omp_set_max_active_levels (nnest)
c
c     Intel compiler extensions to OpenMP, note 268435456 bytes is
c     2**28 bytes (256 MB); or set via KMP_STACKSIZE and KMP_BLOCKTIME
c     environment variables; comment for non-Intel compilers
c
c!$   call kmp_set_stacksize_s (268435456)
c!$   call kmp_set_blocktime (0)
c
c     atomic symbols, weights and radii
c
      call initatom
c
c     names of biopolymer residue types
c
      call initres
c
c     number of lines in the keyfile
c
      nkey = 0
c
c     number of lines in the parameter file
c
      nprm = 0
c
c     number of atoms in the system
c
      n = 0
c
c     number of molecules in the system
c
      nmol = 0
c
c     number of unit cell and replicates
c
      ncell = 1
c
c     number of atoms used in superposition
c
      nfit = 0
c
c     number of mutated atoms in the system
c
      nmut = 0
c
c     number of bonds added or deleted from Z-matrix
c
      nadd = 0
      ndel = 0
c
c     number of atoms and format for Protein Data Bank
c
      npdb = 0
      pdbtyp = 'PDB'
c
c     number of residues and chains in biopolymer sequence
c
      nseq = 0
      nchain = 0
c
c     highest numbered previous cycle file
c
      nprior = 0
c
c     pointer initialization for FFTW plans
c
      planf = 0
      planb = 0
c
c     information levels within the program
c
      verbose = .false.
      debug = .false.
      silent = .false.
      abort = .false.
c
c     integer flag for use of GPU coprocessor
c
      gpucard = 0
c
c     flag for use of holonomic constraints
c
      use_freeze = .false.
c
c     flag for use of atom groups
c
      use_group = .false.
c
c     flags for use of periodic boundaries
c
      use_bounds = .false.
      use_replica = .false.
      use_polymer = .false.
      use_wrap = .false.
c
c     flags for rebuilding of neighbor lists
c
      dovlst = .true.
      dodlst = .true.
      doclst = .true.
      domlst = .true.
      doulst = .true.
c
c     flags for temperature and pressure baths
c
      isothermal = .false.
      isobaric = .false.
c
c     flag for use of internal virial
c
      use_virial = .true.
c
c     flag for use of rigid bodies
c
      use_rigid = .false.
c
c     flag to show setting of optimization scale factors
c
      set_scale = .false.
c
c     flags for external Java socket communication
c
      sktstart = .false.
      use_socket = .false.
c
c     flags for potential energy smoothing
c
      use_smooth = .false.
      use_dem = .false.
      use_gda = .false.
      use_tophat = .false.
      use_stophat = .false.
c
c     format for output of coordinates
c
      archive = .true.
      binary = .false.
      coordtype = 'NONE'
c
c     default values for unit cell and lattice vectors
c
      xbox = 0.0d0
      ybox = 0.0d0
      zbox = 0.0d0
      alpha = 0.0d0
      beta = 0.0d0
      gamma = 0.0d0
      do i = 1, 3
         do j = 1, 3
            lvec(j,i) = 0.0d0
            recip(j,i) = 0.0d0
         end do
      end do
c
c     default values used by optimizations
c
      fctmin = 0.0d0
      maxiter = 0
      nextiter = 0
      iprint = -1
      iwrite = -1
      stpmax = 0.0d0
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2023 by Rae Corrigan & Jay W. Ponder  ##
c     ##                  All Rights Reserved                 ##
c     ##########################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine initneck  --  set implicit solvent neck values  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "initneck" sets the atom radius ranges as well as the neck
c     correction values for interstitial regions between atom pairs,
c     as used in implicit solvation models
c
c     literature reference:
c
c     R. A. Corrigan, A. C. Thiel, J. R. Lynn, T. L. Cassavant,
c     P. Ren, J. W. Ponder and M. J. Schnieders, "A Generalized
c     Kirkwood Implicit Solvent for the Polarizable AMOEBA Protein
c     Model", Journal of Chemical Physics, 159, 054102 (2023)
c
c
      subroutine initneck
      use solute
      implicit none
      integer i,j
      real*8 radbin(maxneck)
      real*8 aij(maxneck,maxneck)
      real*8 bij(maxneck,maxneck)
c
c
c     atom radius size bins (Angstroms)
c
      data radbin  / 0.80d0, 0.85d0, 0.90d0, 0.95d0, 1.00d0, 1.05d0,
     &               1.10d0, 1.15d0, 1.20d0, 1.25d0, 1.30d0, 1.35d0,
     &               1.40d0, 1.45d0, 1.50d0, 1.55d0, 1.60d0, 1.65d0,
     &               1.70d0, 1.75d0, 1.80d0, 1.85d0, 1.90d0, 1.95d0,
     &               2.00d0, 2.05d0, 2.10d0, 2.15d0, 2.20d0, 2.25d0,
     &               2.30d0, 2.35d0, 2.40d0, 2.45d0, 2.50d0, 2.55d0,
     &               2.60d0, 2.65d0, 2.70d0, 2.75d0, 2.80d0, 2.85d0,
     &               2.90d0, 2.95d0, 3.00d0 /
c
c     Aij neck correction constants
c
      data aij(1,:)  / 0.0000577616d0, 0.0000584661d0, 0.0000363925d0,
     &                 0.0000395472d0, 0.0000443202d0, 0.0000485507d0,
     &                 0.0000430862d0, 0.0000485067d0, 0.0000244504d0,
     &                 0.0000278293d0, 0.0000329908d0, 0.0000292135d0,
     &                 0.0000343621d0, 0.0000393724d0, 0.0000352501d0,
     &                 0.0000303823d0, 0.0000360595d0, 0.0000418690d0,
     &                 0.0000365804d0, 0.0000248824d0, 0.0000375656d0,
     &                 0.0000428918d0, 0.0000377450d0, 0.0000447160d0,
     &                 0.0000395375d0, 0.0000345934d0, 0.0000536114d0,
     &                 0.0000470958d0, 0.0000542111d0, 0.0000360263d0,
     &                 0.0000553398d0, 0.0000483197d0, 0.0000555466d0,
     &                 0.0000374290d0, 0.0000327412d0, 0.0000386635d0,
     &                 0.0000578345d0, 0.0000513194d0, 0.0000581077d0,
     &                 0.0000394022d0, 0.0000599546d0, 0.0000392112d0,
     &                 0.0000597613d0, 0.0000403186d0, 0.0000615149d0 /
      data aij(2,:)  / 0.0000446374d0, 0.0000460309d0, 0.0000475714d0,
     &                 0.0000225974d0, 0.0000318052d0, 0.0000275537d0,
     &                 0.0000296576d0, 0.0000339157d0, 0.0000295595d0,
     &                 0.0000344661d0, 0.0000395587d0, 0.0000197502d0,
     &                 0.0000300923d0, 0.0000272524d0, 0.0000187561d0,
     &                 0.0000272680d0, 0.0000247659d0, 0.0000214933d0,
     &                 0.0000252850d0, 0.0000223386d0, 0.0000261633d0,
     &                 0.0000398363d0, 0.0000363492d0, 0.0000412599d0,
     &                 0.0000363327d0, 0.0000422768d0, 0.0000367723d0,
     &                 0.0000425282d0, 0.0000374607d0, 0.0000325975d0,
     &                 0.0000383563d0, 0.0000253707d0, 0.0000301193d0,
     &                 0.0000200866d0, 0.0000299808d0, 0.0000263514d0,
     &                 0.0000304240d0, 0.0000349497d0, 0.0000408533d0,
     &                 0.0000268003d0, 0.0000407538d0, 0.0000357651d0,
     &                 0.0000418473d0, 0.0000278226d0, 0.0000419066d0 /
      data aij(3,:)  / 0.0000360721d0, 0.0000365794d0, 0.0000372415d0,
     &                 0.0000303637d0, 0.0000319835d0, 0.0000267215d0,
     &                 0.0000171087d0, 0.0000252702d0, 0.0000221094d0,
     &                 0.0000187747d0, 0.0000212341d0, 0.0000251617d0,
     &                 0.0000215761d0, 0.0000191079d0, 0.0000291389d0,
     &                 0.0000199177d0, 0.0000288958d0, 0.0000260343d0,
     &                 0.0000179669d0, 0.0000210581d0, 0.0000178820d0,
     &                 0.0000215615d0, 0.0000243911d0, 0.0000220007d0,
     &                 0.0000249689d0, 0.0000295075d0, 0.0000260062d0,
     &                 0.0000297050d0, 0.0000203093d0, 0.0000305802d0,
     &                 0.0000202272d0, 0.0000308984d0, 0.0000207930d0,
     &                 0.0000316764d0, 0.0000277135d0, 0.0000316983d0,
     &                 0.0000219362d0, 0.0000326865d0, 0.0000286724d0,
     &                 0.0000332929d0, 0.0000220858d0, 0.0000332871d0,
     &                 0.0000294921d0, 0.0000348374d0, 0.0000230989d0 /
      data aij(4,:)  / 0.0000398429d0, 0.0000223074d0, 0.0000298279d0,
     &                 0.0000315221d0, 0.0000187855d0, 0.0000264807d0,
     &                 0.0000169459d0, 0.0000180824d0, 0.0000162496d0,
     &                 0.0000233148d0, 0.0000157394d0, 0.0000174931d0,
     &                 0.0000152866d0, 0.0000230620d0, 0.0000205539d0,
     &                 0.0000234872d0, 0.0000213273d0, 0.0000181123d0,
     &                 0.0000210938d0, 0.0000186307d0, 0.0000216437d0,
     &                 0.0000146084d0, 0.0000222850d0, 0.0000149429d0,
     &                 0.0000170964d0, 0.0000153536d0, 0.0000177037d0,
     &                 0.0000208958d0, 0.0000237412d0, 0.0000164214d0,
     &                 0.0000239561d0, 0.0000166849d0, 0.0000188702d0,
     &                 0.0000167221d0, 0.0000188448d0, 0.0000172644d0,
     &                 0.0000194706d0, 0.0000174585d0, 0.0000259642d0,
     &                 0.0000177409d0, 0.0000199219d0, 0.0000235990d0,
     &                 0.0000202504d0, 0.0000234495d0, 0.0000156052d0 /
      data aij(5,:)  / 0.0000435754d0, 0.0000245527d0, 0.0000318302d0,
     &                 0.0000188461d0, 0.0000192238d0, 0.0000208396d0,
     &                 0.0000169209d0, 0.0000183816d0, 0.0000204363d0,
     &                 0.0000131412d0, 0.0000193141d0, 0.0000097655d0,
     &                 0.0000110841d0, 0.0000129627d0, 0.0000112003d0,
     &                 0.0000130467d0, 0.0000113669d0, 0.0000168195d0,
     &                 0.0000117549d0, 0.0000134876d0, 0.0000118881d0,
     &                 0.0000180528d0, 0.0000159126d0, 0.0000181928d0,
     &                 0.0000125940d0, 0.0000183351d0, 0.0000125678d0,
     &                 0.0000145035d0, 0.0000131847d0, 0.0000144906d0,
     &                 0.0000129840d0, 0.0000150912d0, 0.0000176485d0,
     &                 0.0000153063d0, 0.0000178114d0, 0.0000157934d0,
     &                 0.0000180763d0, 0.0000157725d0, 0.0000186835d0,
     &                 0.0000121847d0, 0.0000185069d0, 0.0000161900d0,
     &                 0.0000191223d0, 0.0000126643d0, 0.0000192108d0 /
      data aij(6,:)  / 0.0000505580d0, 0.0000264633d0, 0.0000205166d0,
     &                 0.0000195164d0, 0.0000204987d0, 0.0000160556d0,
     &                 0.0000127648d0, 0.0000137952d0, 0.0000155458d0,
     &                 0.0000176400d0, 0.0000146241d0, 0.0000124027d0,
     &                 0.0000103247d0, 0.0000120745d0, 0.0000105222d0,
     &                 0.0000124882d0, 0.0000140152d0, 0.0000095449d0,
     &                 0.0000141168d0, 0.0000074383d0, 0.0000142994d0,
     &                 0.0000098671d0, 0.0000112045d0, 0.0000132832d0,
     &                 0.0000113876d0, 0.0000135139d0, 0.0000116918d0,
     &                 0.0000137152d0, 0.0000118068d0, 0.0000140495d0,
     &                 0.0000093075d0, 0.0000144645d0, 0.0000126001d0,
     &                 0.0000142255d0, 0.0000128571d0, 0.0000148412d0,
     &                 0.0000128819d0, 0.0000152166d0, 0.0000099735d0,
     &                 0.0000151882d0, 0.0000133944d0, 0.0000154829d0,
     &                 0.0000135105d0, 0.0000154771d0, 0.0000106154d0 /
      data aij(7,:)  / 0.0000449657d0, 0.0000230612d0, 0.0000221541d0,
     &                 0.0000166532d0, 0.0000171555d0, 0.0000227174d0,
     &                 0.0000182899d0, 0.0000193198d0, 0.0000118768d0,
     &                 0.0000130396d0, 0.0000113361d0, 0.0000093799d0,
     &                 0.0000108573d0, 0.0000120843d0, 0.0000106342d0,
     &                 0.0000117938d0, 0.0000080569d0, 0.0000091361d0,
     &                 0.0000107718d0, 0.0000123647d0, 0.0000106453d0,
     &                 0.0000123678d0, 0.0000109954d0, 0.0000126151d0,
     &                 0.0000145692d0, 0.0000128038d0, 0.0000146248d0,
     &                 0.0000099091d0, 0.0000114200d0, 0.0000059787d0,
     &                 0.0000117991d0, 0.0000136370d0, 0.0000119830d0,
     &                 0.0000080880d0, 0.0000120147d0, 0.0000108970d0,
     &                 0.0000161522d0, 0.0000083711d0, 0.0000094980d0,
     &                 0.0000112647d0, 0.0000096319d0, 0.0000113677d0,
     &                 0.0000127823d0, 0.0000114549d0, 0.0000100471d0 /
      data aij(8,:)  / 0.0000280510d0, 0.0000266023d0, 0.0000144227d0,
     &                 0.0000188499d0, 0.0000184712d0, 0.0000146008d0,
     &                 0.0000195724d0, 0.0000161268d0, 0.0000073492d0,
     &                 0.0000137704d0, 0.0000111866d0, 0.0000072795d0,
     &                 0.0000081037d0, 0.0000092319d0, 0.0000078144d0,
     &                 0.0000089354d0, 0.0000102556d0, 0.0000090005d0,
     &                 0.0000059425d0, 0.0000090194d0, 0.0000080186d0,
     &                 0.0000069127d0, 0.0000082105d0, 0.0000093797d0,
     &                 0.0000082401d0, 0.0000093675d0, 0.0000082671d0,
     &                 0.0000071727d0, 0.0000064889d0, 0.0000097376d0,
     &                 0.0000087729d0, 0.0000098019d0, 0.0000088064d0,
     &                 0.0000059057d0, 0.0000089896d0, 0.0000077635d0,
     &                 0.0000070336d0, 0.0000047870d0, 0.0000094273d0,
     &                 0.0000080466d0, 0.0000093429d0, 0.0000083051d0,
     &                 0.0000096725d0, 0.0000109657d0, 0.0000097148d0 /
      data aij(9,:)  / 0.0000325317d0, 0.0000295175d0, 0.0000213868d0,
     &                 0.0000208878d0, 0.0000153087d0, 0.0000116695d0,
     &                 0.0000091353d0, 0.0000128753d0, 0.0000102693d0,
     &                 0.0000107086d0, 0.0000088500d0, 0.0000098955d0,
     &                 0.0000081413d0, 0.0000052255d0, 0.0000078083d0,
     &                 0.0000067997d0, 0.0000098737d0, 0.0000066979d0,
     &                 0.0000098507d0, 0.0000051252d0, 0.0000074307d0,
     &                 0.0000067922d0, 0.0000057491d0, 0.0000068223d0,
     &                 0.0000058920d0, 0.0000070420d0, 0.0000060742d0,
     &                 0.0000069635d0, 0.0000062687d0, 0.0000054473d0,
     &                 0.0000061911d0, 0.0000073394d0, 0.0000037836d0,
     &                 0.0000074661d0, 0.0000084983d0, 0.0000073838d0,
     &                 0.0000087027d0, 0.0000076952d0, 0.0000088636d0,
     &                 0.0000102208d0, 0.0000090108d0, 0.0000104452d0,
     &                 0.0000090944d0, 0.0000104765d0, 0.0000070232d0 /
      data aij(10,:) / 0.0000289111d0, 0.0000198943d0, 0.0000241993d0,
     &                 0.0000238536d0, 0.0000182705d0, 0.0000129878d0,
     &                 0.0000076255d0, 0.0000102719d0, 0.0000112418d0,
     &                 0.0000067659d0, 0.0000071756d0, 0.0000100155d0,
     &                 0.0000065300d0, 0.0000071811d0, 0.0000060818d0,
     &                 0.0000066768d0, 0.0000059369d0, 0.0000065993d0,
     &                 0.0000076971d0, 0.0000063984d0, 0.0000057069d0,
     &                 0.0000086185d0, 0.0000076581d0, 0.0000051018d0,
     &                 0.0000057661d0, 0.0000051292d0, 0.0000058121d0,
     &                 0.0000050955d0, 0.0000079236d0, 0.0000069082d0,
     &                 0.0000060582d0, 0.0000041682d0, 0.0000080245d0,
     &                 0.0000042302d0, 0.0000082046d0, 0.0000056029d0,
     &                 0.0000048280d0, 0.0000057624d0, 0.0000065014d0,
     &                 0.0000058246d0, 0.0000049969d0, 0.0000058491d0,
     &                 0.0000066001d0, 0.0000059999d0, 0.0000088507d0 /
      data aij(11,:) / 0.0000265006d0, 0.0000302279d0, 0.0000215102d0,
     &                 0.0000203741d0, 0.0000195197d0, 0.0000114271d0,
     &                 0.0000110442d0, 0.0000113577d0, 0.0000067378d0,
     &                 0.0000072687d0, 0.0000074058d0, 0.0000047733d0,
     &                 0.0000067184d0, 0.0000076291d0, 0.0000062951d0,
     &                 0.0000051957d0, 0.0000044871d0, 0.0000050768d0,
     &                 0.0000044211d0, 0.0000049880d0, 0.0000043518d0,
     &                 0.0000048796d0, 0.0000057445d0, 0.0000049576d0,
     &                 0.0000057224d0, 0.0000037798d0, 0.0000043883d0,
     &                 0.0000066161d0, 0.0000044279d0, 0.0000050580d0,
     &                 0.0000045758d0, 0.0000051723d0, 0.0000046936d0,
     &                 0.0000052703d0, 0.0000047182d0, 0.0000041352d0,
     &                 0.0000063088d0, 0.0000041672d0, 0.0000063473d0,
     &                 0.0000055519d0, 0.0000049210d0, 0.0000033576d0,
     &                 0.0000049766d0, 0.0000033829d0, 0.0000051220d0 /
      data aij(12,:) / 0.0000393068d0, 0.0000205177d0, 0.0000254533d0,
     &                 0.0000229604d0, 0.0000129838d0, 0.0000126427d0,
     &                 0.0000096583d0, 0.0000123670d0, 0.0000100764d0,
     &                 0.0000100625d0, 0.0000047514d0, 0.0000049466d0,
     &                 0.0000041283d0, 0.0000059449d0, 0.0000065208d0,
     &                 0.0000072136d0, 0.0000045347d0, 0.0000039272d0,
     &                 0.0000033654d0, 0.0000038633d0, 0.0000032913d0,
     &                 0.0000038211d0, 0.0000041976d0, 0.0000037860d0,
     &                 0.0000042838d0, 0.0000037697d0, 0.0000043641d0,
     &                 0.0000038556d0, 0.0000033089d0, 0.0000039242d0,
     &                 0.0000043859d0, 0.0000051678d0, 0.0000034265d0,
     &                 0.0000040012d0, 0.0000035224d0, 0.0000053110d0,
     &                 0.0000046531d0, 0.0000053869d0, 0.0000036188d0,
     &                 0.0000054308d0, 0.0000048054d0, 0.0000055242d0,
     &                 0.0000048512d0, 0.0000056159d0, 0.0000037853d0 /
      data aij(13,:) / 0.0000340677d0, 0.0000307596d0, 0.0000223668d0,
     &                 0.0000152946d0, 0.0000146712d0, 0.0000106255d0,
     &                 0.0000106032d0, 0.0000081832d0, 0.0000086244d0,
     &                 0.0000049411d0, 0.0000067545d0, 0.0000040421d0,
     &                 0.0000044178d0, 0.0000036241d0, 0.0000052208d0,
     &                 0.0000032905d0, 0.0000048780d0, 0.0000053199d0,
     &                 0.0000046459d0, 0.0000039440d0, 0.0000026124d0,
     &                 0.0000050097d0, 0.0000026014d0, 0.0000029505d0,
     &                 0.0000032710d0, 0.0000037980d0, 0.0000043410d0,
     &                 0.0000037740d0, 0.0000033662d0, 0.0000050175d0,
     &                 0.0000033958d0, 0.0000051015d0, 0.0000034086d0,
     &                 0.0000030335d0, 0.0000034235d0, 0.0000039828d0,
     &                 0.0000045344d0, 0.0000031386d0, 0.0000046458d0,
     &                 0.0000041624d0, 0.0000036086d0, 0.0000041947d0,
     &                 0.0000028209d0, 0.0000033460d0, 0.0000028613d0 /
      data aij(14,:) / 0.0000305973d0, 0.0000272968d0, 0.0000142276d0,
     &                 0.0000179127d0, 0.0000097246d0, 0.0000127507d0,
     &                 0.0000070473d0, 0.0000090593d0, 0.0000092161d0,
     &                 0.0000074076d0, 0.0000074685d0, 0.0000058617d0,
     &                 0.0000047016d0, 0.0000051588d0, 0.0000056952d0,
     &                 0.0000035730d0, 0.0000038387d0, 0.0000042402d0,
     &                 0.0000035579d0, 0.0000018248d0, 0.0000046133d0,
     &                 0.0000039370d0, 0.0000045159d0, 0.0000029244d0,
     &                 0.0000019710d0, 0.0000022822d0, 0.0000025439d0,
     &                 0.0000028944d0, 0.0000025756d0, 0.0000029250d0,
     &                 0.0000034260d0, 0.0000050361d0, 0.0000034605d0,
     &                 0.0000038688d0, 0.0000026949d0, 0.0000014049d0,
     &                 0.0000027321d0, 0.0000023567d0, 0.0000027913d0,
     &                 0.0000031218d0, 0.0000027763d0, 0.0000031969d0,
     &                 0.0000037163d0, 0.0000032316d0, 0.0000037723d0 /
      data aij(15,:) / 0.0000363524d0, 0.0000185238d0, 0.0000223944d0,
     &                 0.0000156641d0, 0.0000146928d0, 0.0000107770d0,
     &                 0.0000105276d0, 0.0000102180d0, 0.0000079337d0,
     &                 0.0000078580d0, 0.0000062276d0, 0.0000066384d0,
     &                 0.0000039738d0, 0.0000055727d0, 0.0000060414d0,
     &                 0.0000037461d0, 0.0000023444d0, 0.0000033734d0,
     &                 0.0000028739d0, 0.0000032262d0, 0.0000026725d0,
     &                 0.0000030603d0, 0.0000025932d0, 0.0000030096d0,
     &                 0.0000019791d0, 0.0000029386d0, 0.0000033334d0,
     &                 0.0000029324d0, 0.0000025033d0, 0.0000017645d0,
     &                 0.0000014959d0, 0.0000022899d0, 0.0000025847d0,
     &                 0.0000030273d0, 0.0000026349d0, 0.0000039712d0,
     &                 0.0000026279d0, 0.0000040671d0, 0.0000020776d0,
     &                 0.0000023832d0, 0.0000020939d0, 0.0000024085d0,
     &                 0.0000021149d0, 0.0000041807d0, 0.0000016785d0 /
      data aij(16,:) / 0.0000531068d0, 0.0000206882d0, 0.0000259899d0,
     &                 0.0000178808d0, 0.0000168038d0, 0.0000128055d0,
     &                 0.0000119227d0, 0.0000069103d0, 0.0000090425d0,
     &                 0.0000068286d0, 0.0000069793d0, 0.0000031585d0,
     &                 0.0000042989d0, 0.0000027028d0, 0.0000036738d0,
     &                 0.0000031193d0, 0.0000043434d0, 0.0000035227d0,
     &                 0.0000030391d0, 0.0000024934d0, 0.0000027944d0,
     &                 0.0000024067d0, 0.0000027907d0, 0.0000023644d0,
     &                 0.0000026945d0, 0.0000022659d0, 0.0000020013d0,
     &                 0.0000029627d0, 0.0000026172d0, 0.0000017442d0,
     &                 0.0000025980d0, 0.0000017461d0, 0.0000020037d0,
     &                 0.0000017818d0, 0.0000026313d0, 0.0000023219d0,
     &                 0.0000026522d0, 0.0000023901d0, 0.0000026985d0,
     &                 0.0000014157d0, 0.0000027079d0, 0.0000018522d0,
     &                 0.0000016312d0, 0.0000019179d0, 0.0000016703d0 /
      data aij(17,:) / 0.0000471466d0, 0.0000321678d0, 0.0000221166d0,
     &                 0.0000210526d0, 0.0000114910d0, 0.0000108287d0,
     &                 0.0000080777d0, 0.0000104203d0, 0.0000101134d0,
     &                 0.0000058443d0, 0.0000045067d0, 0.0000045975d0,
     &                 0.0000027454d0, 0.0000037782d0, 0.0000039918d0,
     &                 0.0000043093d0, 0.0000046405d0, 0.0000029403d0,
     &                 0.0000023896d0, 0.0000020792d0, 0.0000029414d0,
     &                 0.0000014845d0, 0.0000016390d0, 0.0000018155d0,
     &                 0.0000020600d0, 0.0000018173d0, 0.0000020305d0,
     &                 0.0000018045d0, 0.0000020275d0, 0.0000023056d0,
     &                 0.0000026380d0, 0.0000022906d0, 0.0000015633d0,
     &                 0.0000022861d0, 0.0000015702d0, 0.0000022925d0,
     &                 0.0000015926d0, 0.0000017741d0, 0.0000015991d0,
     &                 0.0000017969d0, 0.0000021445d0, 0.0000018491d0,
     &                 0.0000021663d0, 0.0000018937d0, 0.0000021829d0 /
      data aij(18,:) / 0.0000415033d0, 0.0000375035d0, 0.0000257317d0,
     &                 0.0000181483d0, 0.0000170401d0, 0.0000165719d0,
     &                 0.0000091912d0, 0.0000089667d0, 0.0000066295d0,
     &                 0.0000051660d0, 0.0000051868d0, 0.0000051552d0,
     &                 0.0000041581d0, 0.0000041949d0, 0.0000044142d0,
     &                 0.0000035882d0, 0.0000029449d0, 0.0000031798d0,
     &                 0.0000020273d0, 0.0000021690d0, 0.0000024377d0,
     &                 0.0000026775d0, 0.0000029680d0, 0.0000014909d0,
     &                 0.0000021480d0, 0.0000018690d0, 0.0000027312d0,
     &                 0.0000014150d0, 0.0000020266d0, 0.0000013942d0,
     &                 0.0000015678d0, 0.0000014176d0, 0.0000015601d0,
     &                 0.0000018280d0, 0.0000020424d0, 0.0000023951d0,
     &                 0.0000015782d0, 0.0000024117d0, 0.0000016197d0,
     &                 0.0000014155d0, 0.0000012558d0, 0.0000018686d0,
     &                 0.0000016359d0, 0.0000018949d0, 0.0000010017d0 /
      data aij(19,:) / 0.0000468296d0, 0.0000330068d0, 0.0000237247d0,
     &                 0.0000165336d0, 0.0000150520d0, 0.0000109676d0,
     &                 0.0000103584d0, 0.0000059806d0, 0.0000075019d0,
     &                 0.0000075639d0, 0.0000075577d0, 0.0000044171d0,
     &                 0.0000035406d0, 0.0000027896d0, 0.0000038483d0,
     &                 0.0000030165d0, 0.0000024502d0, 0.0000020229d0,
     &                 0.0000037725d0, 0.0000023248d0, 0.0000025725d0,
     &                 0.0000016526d0, 0.0000018416d0, 0.0000020307d0,
     &                 0.0000023292d0, 0.0000019462d0, 0.0000022344d0,
     &                 0.0000014452d0, 0.0000016743d0, 0.0000024751d0,
     &                 0.0000021503d0, 0.0000010914d0, 0.0000016308d0,
     &                 0.0000018570d0, 0.0000021221d0, 0.0000010982d0,
     &                 0.0000016425d0, 0.0000011133d0, 0.0000021459d0,
     &                 0.0000018960d0, 0.0000021557d0, 0.0000011360d0,
     &                 0.0000012755d0, 0.0000011503d0, 0.0000012923d0 /
      data aij(20,:) / 0.0000326803d0, 0.0000295857d0, 0.0000154475d0,
     &                 0.0000195504d0, 0.0000133752d0, 0.0000130826d0,
     &                 0.0000093108d0, 0.0000090846d0, 0.0000051384d0,
     &                 0.0000065258d0, 0.0000049655d0, 0.0000050318d0,
     &                 0.0000039301d0, 0.0000031064d0, 0.0000018937d0,
     &                 0.0000033983d0, 0.0000027192d0, 0.0000021941d0,
     &                 0.0000023262d0, 0.0000011684d0, 0.0000015864d0,
     &                 0.0000017653d0, 0.0000019394d0, 0.0000021477d0,
     &                 0.0000018003d0, 0.0000015654d0, 0.0000017271d0,
     &                 0.0000019541d0, 0.0000012911d0, 0.0000008739d0,
     &                 0.0000016831d0, 0.0000011063d0, 0.0000016687d0,
     &                 0.0000014377d0, 0.0000016576d0, 0.0000010945d0,
     &                 0.0000012820d0, 0.0000010911d0, 0.0000007782d0,
     &                 0.0000014342d0, 0.0000013165d0, 0.0000018913d0,
     &                 0.0000013170d0, 0.0000008899d0, 0.0000013269d0 /
      data aij(21,:) / 0.0000381583d0, 0.0000264565d0, 0.0000136612d0,
     &                 0.0000212466d0, 0.0000153348d0, 0.0000145316d0,
     &                 0.0000138739d0, 0.0000060648d0, 0.0000076347d0,
     &                 0.0000074893d0, 0.0000043282d0, 0.0000057183d0,
     &                 0.0000033840d0, 0.0000045556d0, 0.0000035441d0,
     &                 0.0000028461d0, 0.0000022853d0, 0.0000031916d0,
     &                 0.0000026005d0, 0.0000021084d0, 0.0000013651d0,
     &                 0.0000024956d0, 0.0000016110d0, 0.0000017750d0,
     &                 0.0000014880d0, 0.0000016813d0, 0.0000010862d0,
     &                 0.0000016184d0, 0.0000013616d0, 0.0000015542d0,
     &                 0.0000017206d0, 0.0000015449d0, 0.0000013086d0,
     &                 0.0000015137d0, 0.0000012941d0, 0.0000011585d0,
     &                 0.0000012793d0, 0.0000008977d0, 0.0000009980d0,
     &                 0.0000011586d0, 0.0000010254d0, 0.0000011655d0,
     &                 0.0000010218d0, 0.0000011671d0, 0.0000010320d0 /
      data aij(22,:) / 0.0000435206d0, 0.0000394602d0, 0.0000280329d0,
     &                 0.0000143528d0, 0.0000103966d0, 0.0000099195d0,
     &                 0.0000123591d0, 0.0000070629d0, 0.0000087274d0,
     &                 0.0000066090d0, 0.0000048718d0, 0.0000038172d0,
     &                 0.0000050202d0, 0.0000029810d0, 0.0000040378d0,
     &                 0.0000024193d0, 0.0000024874d0, 0.0000015771d0,
     &                 0.0000016403d0, 0.0000017939d0, 0.0000019398d0,
     &                 0.0000012193d0, 0.0000017244d0, 0.0000008475d0,
     &                 0.0000009524d0, 0.0000008041d0, 0.0000011807d0,
     &                 0.0000009651d0, 0.0000011501d0, 0.0000012202d0,
     &                 0.0000010892d0, 0.0000011977d0, 0.0000010599d0,
     &                 0.0000015547d0, 0.0000010348d0, 0.0000011765d0,
     &                 0.0000010241d0, 0.0000009188d0, 0.0000007943d0,
     &                 0.0000009237d0, 0.0000010314d0, 0.0000009055d0,
     &                 0.0000010352d0, 0.0000009196d0, 0.0000013384d0 /
      data aij(23,:) / 0.0000379248d0, 0.0000353934d0, 0.0000241508d0,
     &                 0.0000168891d0, 0.0000210529d0, 0.0000086678d0,
     &                 0.0000083510d0, 0.0000106765d0, 0.0000058348d0,
     &                 0.0000057662d0, 0.0000074621d0, 0.0000043406d0,
     &                 0.0000033715d0, 0.0000044195d0, 0.0000020552d0,
     &                 0.0000027516d0, 0.0000016638d0, 0.0000022213d0,
     &                 0.0000023581d0, 0.0000019527d0, 0.0000016003d0,
     &                 0.0000017368d0, 0.0000008516d0, 0.0000009200d0,
     &                 0.0000016828d0, 0.0000008623d0, 0.0000009286d0,
     &                 0.0000006197d0, 0.0000011498d0, 0.0000007848d0,
     &                 0.0000006628d0, 0.0000009788d0, 0.0000010822d0,
     &                 0.0000012385d0, 0.0000008152d0, 0.0000009435d0,
     &                 0.0000010686d0, 0.0000012014d0, 0.0000006276d0,
     &                 0.0000007030d0, 0.0000010605d0, 0.0000012119d0,
     &                 0.0000006389d0, 0.0000007195d0, 0.0000006456d0 /
      data aij(24,:) / 0.0000457913d0, 0.0000308903d0, 0.0000282516d0,
     &                 0.0000197423d0, 0.0000139036d0, 0.0000076554d0,
     &                 0.0000101164d0, 0.0000092286d0, 0.0000068324d0,
     &                 0.0000052054d0, 0.0000050091d0, 0.0000049163d0,
     &                 0.0000039143d0, 0.0000029462d0, 0.0000039499d0,
     &                 0.0000031099d0, 0.0000024405d0, 0.0000014864d0,
     &                 0.0000012048d0, 0.0000021759d0, 0.0000013931d0,
     &                 0.0000014556d0, 0.0000009208d0, 0.0000017108d0,
     &                 0.0000011004d0, 0.0000011923d0, 0.0000007721d0,
     &                 0.0000006708d0, 0.0000005731d0, 0.0000008092d0,
     &                 0.0000009072d0, 0.0000007914d0, 0.0000008763d0,
     &                 0.0000007716d0, 0.0000006536d0, 0.0000007653d0,
     &                 0.0000008561d0, 0.0000009956d0, 0.0000008472d0,
     &                 0.0000007539d0, 0.0000008319d0, 0.0000005765d0,
     &                 0.0000008451d0, 0.0000009713d0, 0.0000008480d0 /
      data aij(25,:) / 0.0000514751d0, 0.0000274557d0, 0.0000241481d0,
     &                 0.0000174373d0, 0.0000161298d0, 0.0000116871d0,
     &                 0.0000084217d0, 0.0000081004d0, 0.0000058484d0,
     &                 0.0000056938d0, 0.0000057532d0, 0.0000043019d0,
     &                 0.0000032347d0, 0.0000025748d0, 0.0000034234d0,
     &                 0.0000026896d0, 0.0000016029d0, 0.0000016452d0,
     &                 0.0000023736d0, 0.0000013932d0, 0.0000011273d0,
     &                 0.0000009500d0, 0.0000013052d0, 0.0000010750d0,
     &                 0.0000012044d0, 0.0000010077d0, 0.0000011046d0,
     &                 0.0000007011d0, 0.0000010268d0, 0.0000008714d0,
     &                 0.0000012822d0, 0.0000010702d0, 0.0000007283d0,
     &                 0.0000010366d0, 0.0000005479d0, 0.0000007812d0,
     &                 0.0000005332d0, 0.0000007670d0, 0.0000006899d0,
     &                 0.0000007700d0, 0.0000006826d0, 0.0000007637d0,
     &                 0.0000008807d0, 0.0000004626d0, 0.0000006769d0 /
      data aij(26,:) / 0.0000347279d0, 0.0000326038d0, 0.0000222389d0,
     &                 0.0000203032d0, 0.0000186389d0, 0.0000135396d0,
     &                 0.0000074878d0, 0.0000093982d0, 0.0000069447d0,
     &                 0.0000051305d0, 0.0000038953d0, 0.0000049720d0,
     &                 0.0000038543d0, 0.0000038303d0, 0.0000017387d0,
     &                 0.0000013908d0, 0.0000018492d0, 0.0000018676d0,
     &                 0.0000011554d0, 0.0000016034d0, 0.0000009913d0,
     &                 0.0000010369d0, 0.0000011030d0, 0.0000015670d0,
     &                 0.0000013066d0, 0.0000011031d0, 0.0000009195d0,
     &                 0.0000007778d0, 0.0000010981d0, 0.0000009562d0,
     &                 0.0000010346d0, 0.0000011776d0, 0.0000007583d0,
     &                 0.0000005111d0, 0.0000005726d0, 0.0000011004d0,
     &                 0.0000009317d0, 0.0000004887d0, 0.0000005500d0,
     &                 0.0000008051d0, 0.0000005530d0, 0.0000004756d0,
     &                 0.0000005513d0, 0.0000006031d0, 0.0000005515d0 /
      data aij(27,:) / 0.0000404627d0, 0.0000279374d0, 0.0000254737d0,
     &                 0.0000173416d0, 0.0000166276d0, 0.0000090743d0,
     &                 0.0000084501d0, 0.0000108659d0, 0.0000080225d0,
     &                 0.0000045088d0, 0.0000044169d0, 0.0000057245d0,
     &                 0.0000033186d0, 0.0000043660d0, 0.0000034171d0,
     &                 0.0000015607d0, 0.0000020522d0, 0.0000012726d0,
     &                 0.0000016999d0, 0.0000013417d0, 0.0000018688d0,
     &                 0.0000015245d0, 0.0000009452d0, 0.0000007794d0,
     &                 0.0000008405d0, 0.0000011825d0, 0.0000007598d0,
     &                 0.0000008210d0, 0.0000007108d0, 0.0000007647d0,
     &                 0.0000006612d0, 0.0000007339d0, 0.0000008145d0,
     &                 0.0000007040d0, 0.0000006095d0, 0.0000008740d0,
     &                 0.0000003513d0, 0.0000006717d0, 0.0000005660d0,
     &                 0.0000004997d0, 0.0000009522d0, 0.0000005060d0,
     &                 0.0000005619d0, 0.0000005063d0, 0.0000004323d0 /
      data aij(28,:) / 0.0000472063d0, 0.0000323179d0, 0.0000294752d0,
     &                 0.0000207416d0, 0.0000113045d0, 0.0000136112d0,
     &                 0.0000129076d0, 0.0000071735d0, 0.0000091135d0,
     &                 0.0000052733d0, 0.0000039191d0, 0.0000038507d0,
     &                 0.0000022739d0, 0.0000029313d0, 0.0000017476d0,
     &                 0.0000029817d0, 0.0000017682d0, 0.0000014044d0,
     &                 0.0000018903d0, 0.0000011418d0, 0.0000015945d0,
     &                 0.0000009870d0, 0.0000010526d0, 0.0000011160d0,
     &                 0.0000011997d0, 0.0000013110d0, 0.0000010830d0,
     &                 0.0000006980d0, 0.0000009891d0, 0.0000006386d0,
     &                 0.0000005495d0, 0.0000006040d0, 0.0000006782d0,
     &                 0.0000004347d0, 0.0000004971d0, 0.0000004232d0,
     &                 0.0000004838d0, 0.0000006935d0, 0.0000003617d0,
     &                 0.0000004015d0, 0.0000003611d0, 0.0000003155d0,
     &                 0.0000005902d0, 0.0000003968d0, 0.0000004545d0 /
      data aij(29,:) / 0.0000534708d0, 0.0000373744d0, 0.0000196796d0,
     &                 0.0000137544d0, 0.0000129458d0, 0.0000119235d0,
     &                 0.0000088305d0, 0.0000111632d0, 0.0000062367d0,
     &                 0.0000059625d0, 0.0000034417d0, 0.0000044561d0,
     &                 0.0000033301d0, 0.0000025232d0, 0.0000019586d0,
     &                 0.0000027071d0, 0.0000015804d0, 0.0000012263d0,
     &                 0.0000016555d0, 0.0000017219d0, 0.0000010458d0,
     &                 0.0000008561d0, 0.0000006975d0, 0.0000009600d0,
     &                 0.0000013346d0, 0.0000008501d0, 0.0000004210d0,
     &                 0.0000005776d0, 0.0000008267d0, 0.0000009169d0,
     &                 0.0000004551d0, 0.0000005061d0, 0.0000007113d0,
     &                 0.0000006128d0, 0.0000006790d0, 0.0000004531d0,
     &                 0.0000005155d0, 0.0000005740d0, 0.0000006449d0,
     &                 0.0000002634d0, 0.0000004837d0, 0.0000005547d0,
     &                 0.0000004790d0, 0.0000004165d0, 0.0000004781d0 /
      data aij(30,:) / 0.0000471509d0, 0.0000331027d0, 0.0000226179d0,
     &                 0.0000161311d0, 0.0000144893d0, 0.0000107687d0,
     &                 0.0000104009d0, 0.0000128476d0, 0.0000071831d0,
     &                 0.0000053734d0, 0.0000030440d0, 0.0000051224d0,
     &                 0.0000039650d0, 0.0000022452d0, 0.0000017674d0,
     &                 0.0000017430d0, 0.0000017813d0, 0.0000014173d0,
     &                 0.0000018887d0, 0.0000008757d0, 0.0000012001d0,
     &                 0.0000016279d0, 0.0000012946d0, 0.0000004971d0,
     &                 0.0000008642d0, 0.0000005591d0, 0.0000006041d0,
     &                 0.0000006461d0, 0.0000005270d0, 0.0000007557d0,
     &                 0.0000004882d0, 0.0000007062d0, 0.0000005940d0,
     &                 0.0000008734d0, 0.0000005615d0, 0.0000004848d0,
     &                 0.0000004202d0, 0.0000004705d0, 0.0000004021d0,
     &                 0.0000004565d0, 0.0000003960d0, 0.0000004488d0,
     &                 0.0000004998d0, 0.0000005792d0, 0.0000003821d0 /
      data aij(31,:) / 0.0000408712d0, 0.0000290825d0, 0.0000201809d0,
     &                 0.0000184693d0, 0.0000127543d0, 0.0000122856d0,
     &                 0.0000089579d0, 0.0000087349d0, 0.0000048255d0,
     &                 0.0000062188d0, 0.0000059289d0, 0.0000044984d0,
     &                 0.0000019907d0, 0.0000033642d0, 0.0000034197d0,
     &                 0.0000026227d0, 0.0000012039d0, 0.0000015836d0,
     &                 0.0000009945d0, 0.0000013051d0, 0.0000017849d0,
     &                 0.0000010646d0, 0.0000005240d0, 0.0000007062d0,
     &                 0.0000005767d0, 0.0000006087d0, 0.0000008726d0,
     &                 0.0000005467d0, 0.0000007758d0, 0.0000006348d0,
     &                 0.0000007039d0, 0.0000003514d0, 0.0000006567d0,
     &                 0.0000002671d0, 0.0000006217d0, 0.0000006907d0,
     &                 0.0000005847d0, 0.0000001470d0, 0.0000004367d0,
     &                 0.0000003746d0, 0.0000003283d0, 0.0000003639d0,
     &                 0.0000004146d0, 0.0000003630d0, 0.0000004069d0 /
      data aij(32,:) / 0.0000365867d0, 0.0000334092d0, 0.0000233935d0,
     &                 0.0000211266d0, 0.0000148841d0, 0.0000145388d0,
     &                 0.0000102065d0, 0.0000099718d0, 0.0000095120d0,
     &                 0.0000041586d0, 0.0000052071d0, 0.0000030423d0,
     &                 0.0000030232d0, 0.0000022968d0, 0.0000023000d0,
     &                 0.0000030274d0, 0.0000022943d0, 0.0000010722d0,
     &                 0.0000011058d0, 0.0000014789d0, 0.0000009014d0,
     &                 0.0000009248d0, 0.0000009830d0, 0.0000010354d0,
     &                 0.0000014149d0, 0.0000011942d0, 0.0000005606d0,
     &                 0.0000006027d0, 0.0000005065d0, 0.0000004217d0,
     &                 0.0000005883d0, 0.0000005132d0, 0.0000003302d0,
     &                 0.0000004589d0, 0.0000006648d0, 0.0000003397d0,
     &                 0.0000004773d0, 0.0000003190d0, 0.0000004559d0,
     &                 0.0000003103d0, 0.0000005849d0, 0.0000003016d0,
     &                 0.0000005635d0, 0.0000003806d0, 0.0000002617d0 /
      data aij(33,:) / 0.0000424740d0, 0.0000299616d0, 0.0000274655d0,
     &                 0.0000188374d0, 0.0000175698d0, 0.0000126091d0,
     &                 0.0000089948d0, 0.0000068101d0, 0.0000083814d0,
     &                 0.0000048968d0, 0.0000060247d0, 0.0000059532d0,
     &                 0.0000020417d0, 0.0000044737d0, 0.0000025919d0,
     &                 0.0000020128d0, 0.0000020369d0, 0.0000012489d0,
     &                 0.0000016173d0, 0.0000012975d0, 0.0000013224d0,
     &                 0.0000010382d0, 0.0000008390d0, 0.0000008790d0,
     &                 0.0000009452d0, 0.0000009921d0, 0.0000006307d0,
     &                 0.0000006689d0, 0.0000003338d0, 0.0000007868d0,
     &                 0.0000005076d0, 0.0000004219d0, 0.0000003654d0,
     &                 0.0000008632d0, 0.0000004278d0, 0.0000003612d0,
     &                 0.0000002445d0, 0.0000005864d0, 0.0000002315d0,
     &                 0.0000004357d0, 0.0000002247d0, 0.0000004156d0,
     &                 0.0000002193d0, 0.0000003178d0, 0.0000002730d0 /
      data aij(34,:) / 0.0000503599d0, 0.0000451538d0, 0.0000316354d0,
     &                 0.0000217532d0, 0.0000202497d0, 0.0000144337d0,
     &                 0.0000104958d0, 0.0000100705d0, 0.0000074034d0,
     &                 0.0000054909d0, 0.0000041189d0, 0.0000040598d0,
     &                 0.0000030289d0, 0.0000030085d0, 0.0000029895d0,
     &                 0.0000023332d0, 0.0000018003d0, 0.0000013931d0,
     &                 0.0000018829d0, 0.0000014630d0, 0.0000006967d0,
     &                 0.0000009205d0, 0.0000012416d0, 0.0000007812d0,
     &                 0.0000010583d0, 0.0000006536d0, 0.0000009038d0,
     &                 0.0000004477d0, 0.0000010522d0, 0.0000006597d0,
     &                 0.0000005567d0, 0.0000004616d0, 0.0000006575d0,
     &                 0.0000003344d0, 0.0000002766d0, 0.0000003963d0,
     &                 0.0000005688d0, 0.0000001793d0, 0.0000004153d0,
     &                 0.0000004620d0, 0.0000003992d0, 0.0000004404d0,
     &                 0.0000002976d0, 0.0000004364d0, 0.0000003740d0 /
      data aij(35,:) / 0.0000430595d0, 0.0000397799d0, 0.0000271616d0,
     &                 0.0000143472d0, 0.0000176142d0, 0.0000168235d0,
     &                 0.0000093500d0, 0.0000067329d0, 0.0000066446d0,
     &                 0.0000082213d0, 0.0000061390d0, 0.0000046372d0,
     &                 0.0000034811d0, 0.0000034735d0, 0.0000026730d0,
     &                 0.0000026634d0, 0.0000015581d0, 0.0000021099d0,
     &                 0.0000012381d0, 0.0000016679d0, 0.0000010186d0,
     &                 0.0000010483d0, 0.0000008241d0, 0.0000011290d0,
     &                 0.0000005475d0, 0.0000005724d0, 0.0000004661d0,
     &                 0.0000006409d0, 0.0000004075d0, 0.0000005660d0,
     &                 0.0000004676d0, 0.0000006678d0, 0.0000005536d0,
     &                 0.0000004588d0, 0.0000003086d0, 0.0000002600d0,
     &                 0.0000002221d0, 0.0000004089d0, 0.0000005910d0,
     &                 0.0000002319d0, 0.0000003286d0, 0.0000002849d0,
     &                 0.0000003188d0, 0.0000001718d0, 0.0000003117d0 /
      data aij(36,:) / 0.0000503956d0, 0.0000262755d0, 0.0000184690d0,
     &                 0.0000169051d0, 0.0000157560d0, 0.0000113206d0,
     &                 0.0000108187d0, 0.0000079141d0, 0.0000075536d0,
     &                 0.0000055140d0, 0.0000054540d0, 0.0000040614d0,
     &                 0.0000039965d0, 0.0000023509d0, 0.0000030468d0,
     &                 0.0000018116d0, 0.0000023451d0, 0.0000013890d0,
     &                 0.0000014094d0, 0.0000011387d0, 0.0000011426d0,
     &                 0.0000007091d0, 0.0000009704d0, 0.0000007647d0,
     &                 0.0000008029d0, 0.0000011008d0, 0.0000003155d0,
     &                 0.0000004312d0, 0.0000004596d0, 0.0000004817d0,
     &                 0.0000005269d0, 0.0000005676d0, 0.0000003706d0,
     &                 0.0000004006d0, 0.0000004315d0, 0.0000004775d0,
     &                 0.0000003098d0, 0.0000003407d0, 0.0000004886d0,
     &                 0.0000004152d0, 0.0000001682d0, 0.0000003093d0,
     &                 0.0000002068d0, 0.0000002292d0, 0.0000002008d0 /
      data aij(37,:) / 0.0000334173d0, 0.0000309726d0, 0.0000218877d0,
     &                 0.0000196442d0, 0.0000138546d0, 0.0000130794d0,
     &                 0.0000094927d0, 0.0000068714d0, 0.0000086744d0,
     &                 0.0000063898d0, 0.0000037817d0, 0.0000048166d0,
     &                 0.0000046345d0, 0.0000026610d0, 0.0000015855d0,
     &                 0.0000020759d0, 0.0000027141d0, 0.0000020849d0,
     &                 0.0000016433d0, 0.0000012979d0, 0.0000007813d0,
     &                 0.0000010596d0, 0.0000004958d0, 0.0000008546d0,
     &                 0.0000008928d0, 0.0000005593d0, 0.0000009962d0,
     &                 0.0000006205d0, 0.0000006694d0, 0.0000004270d0,
     &                 0.0000004437d0, 0.0000003712d0, 0.0000005299d0,
     &                 0.0000003383d0, 0.0000004823d0, 0.0000002425d0,
     &                 0.0000004443d0, 0.0000004843d0, 0.0000004110d0,
     &                 0.0000001667d0, 0.0000001831d0, 0.0000001992d0,
     &                 0.0000002251d0, 0.0000003165d0, 0.0000001686d0 /
      data aij(38,:) / 0.0000389225d0, 0.0000356628d0, 0.0000246098d0,
     &                 0.0000234810d0, 0.0000158826d0, 0.0000154517d0,
     &                 0.0000109594d0, 0.0000061715d0, 0.0000077203d0,
     &                 0.0000057494d0, 0.0000072006d0, 0.0000031528d0,
     &                 0.0000032123d0, 0.0000024479d0, 0.0000023896d0,
     &                 0.0000023499d0, 0.0000018589d0, 0.0000010985d0,
     &                 0.0000014288d0, 0.0000011269d0, 0.0000015138d0,
     &                 0.0000011720d0, 0.0000009382d0, 0.0000009879d0,
     &                 0.0000006065d0, 0.0000008389d0, 0.0000005190d0,
     &                 0.0000007012d0, 0.0000005724d0, 0.0000004774d0,
     &                 0.0000003925d0, 0.0000005365d0, 0.0000002703d0,
     &                 0.0000004855d0, 0.0000004093d0, 0.0000003496d0,
     &                 0.0000003709d0, 0.0000002481d0, 0.0000002089d0,
     &                 0.0000001810d0, 0.0000001978d0, 0.0000001719d0,
     &                 0.0000003092d0, 0.0000001622d0, 0.0000002294d0 /
      data aij(39,:) / 0.0000337803d0, 0.0000404714d0, 0.0000284070d0,
     &                 0.0000198125d0, 0.0000183754d0, 0.0000174965d0,
     &                 0.0000126377d0, 0.0000121499d0, 0.0000086656d0,
     &                 0.0000051637d0, 0.0000063642d0, 0.0000036800d0,
     &                 0.0000027442d0, 0.0000046261d0, 0.0000027739d0,
     &                 0.0000020991d0, 0.0000027411d0, 0.0000015953d0,
     &                 0.0000016454d0, 0.0000010057d0, 0.0000013415d0,
     &                 0.0000010441d0, 0.0000008211d0, 0.0000011139d0,
     &                 0.0000004134d0, 0.0000004295d0, 0.0000005796d0,
     &                 0.0000003604d0, 0.0000004939d0, 0.0000003153d0,
     &                 0.0000004360d0, 0.0000004611d0, 0.0000003900d0,
     &                 0.0000005448d0, 0.0000003467d0, 0.0000004915d0,
     &                 0.0000002450d0, 0.0000002082d0, 0.0000002350d0,
     &                 0.0000002486d0, 0.0000002168d0, 0.0000002377d0,
     &                 0.0000001597d0, 0.0000002236d0, 0.0000001948d0 /
      data aij(40,:) / 0.0000513067d0, 0.0000471119d0, 0.0000328458d0,
     &                 0.0000132586d0, 0.0000211621d0, 0.0000154592d0,
     &                 0.0000085830d0, 0.0000106377d0, 0.0000060140d0,
     &                 0.0000058815d0, 0.0000073820d0, 0.0000042029d0,
     &                 0.0000054567d0, 0.0000041212d0, 0.0000018646d0,
     &                 0.0000023994d0, 0.0000014275d0, 0.0000018493d0,
     &                 0.0000011151d0, 0.0000011543d0, 0.0000009245d0,
     &                 0.0000012066d0, 0.0000007246d0, 0.0000007519d0,
     &                 0.0000004803d0, 0.0000008191d0, 0.0000005011d0,
     &                 0.0000004138d0, 0.0000004368d0, 0.0000003569d0,
     &                 0.0000006387d0, 0.0000005261d0, 0.0000004315d0,
     &                 0.0000002781d0, 0.0000003871d0, 0.0000001946d0,
     &                 0.0000003503d0, 0.0000002314d0, 0.0000002482d0,
     &                 0.0000002172d0, 0.0000003055d0, 0.0000001223d0,
     &                 0.0000002858d0, 0.0000001905d0, 0.0000002117d0 /
      data aij(41,:) / 0.0000450816d0, 0.0000408154d0, 0.0000282845d0,
     &                 0.0000155178d0, 0.0000138761d0, 0.0000175937d0,
     &                 0.0000098262d0, 0.0000121258d0, 0.0000069414d0,
     &                 0.0000066229d0, 0.0000029233d0, 0.0000048194d0,
     &                 0.0000037116d0, 0.0000036148d0, 0.0000027563d0,
     &                 0.0000016149d0, 0.0000009741d0, 0.0000012561d0,
     &                 0.0000012827d0, 0.0000016831d0, 0.0000010254d0,
     &                 0.0000010378d0, 0.0000014009d0, 0.0000008403d0,
     &                 0.0000008877d0, 0.0000009243d0, 0.0000009675d0,
     &                 0.0000003626d0, 0.0000004818d0, 0.0000003920d0,
     &                 0.0000003302d0, 0.0000004548d0, 0.0000002250d0,
     &                 0.0000003083d0, 0.0000003321d0, 0.0000003601d0,
     &                 0.0000001838d0, 0.0000002508d0, 0.0000001319d0,
     &                 0.0000003035d0, 0.0000000966d0, 0.0000001703d0,
     &                 0.0000002389d0, 0.0000002086d0, 0.0000000873d0 /
      data aij(42,:) / 0.0000516615d0, 0.0000359046d0, 0.0000250255d0,
     &                 0.0000176967d0, 0.0000162043d0, 0.0000117023d0,
     &                 0.0000111500d0, 0.0000083372d0, 0.0000080845d0,
     &                 0.0000057760d0, 0.0000057683d0, 0.0000042198d0,
     &                 0.0000042307d0, 0.0000031731d0, 0.0000018613d0,
     &                 0.0000018786d0, 0.0000018362d0, 0.0000018880d0,
     &                 0.0000011419d0, 0.0000019392d0, 0.0000015208d0,
     &                 0.0000005532d0, 0.0000005717d0, 0.0000005781d0,
     &                 0.0000007821d0, 0.0000004847d0, 0.0000005016d0,
     &                 0.0000004026d0, 0.0000005570d0, 0.0000007553d0,
     &                 0.0000003651d0, 0.0000002375d0, 0.0000004137d0,
     &                 0.0000004454d0, 0.0000003721d0, 0.0000003077d0,
     &                 0.0000002562d0, 0.0000001692d0, 0.0000001437d0,
     &                 0.0000003380d0, 0.0000001705d0, 0.0000002396d0,
     &                 0.0000001596d0, 0.0000002284d0, 0.0000001911d0 /
      data aij(43,:) / 0.0000345441d0, 0.0000316241d0, 0.0000286584d0,
     &                 0.0000206648d0, 0.0000186795d0, 0.0000136872d0,
     &                 0.0000097047d0, 0.0000096665d0, 0.0000091419d0,
     &                 0.0000067531d0, 0.0000038985d0, 0.0000048445d0,
     &                 0.0000028978d0, 0.0000037146d0, 0.0000021550d0,
     &                 0.0000021547d0, 0.0000016273d0, 0.0000009960d0,
     &                 0.0000012967d0, 0.0000013308d0, 0.0000008052d0,
     &                 0.0000010640d0, 0.0000008348d0, 0.0000008528d0,
     &                 0.0000008847d0, 0.0000003357d0, 0.0000004374d0,
     &                 0.0000005905d0, 0.0000002889d0, 0.0000005062d0,
     &                 0.0000005427d0, 0.0000003357d0, 0.0000003624d0,
     &                 0.0000002976d0, 0.0000004179d0, 0.0000002635d0,
     &                 0.0000003711d0, 0.0000001854d0, 0.0000003373d0,
     &                 0.0000001698d0, 0.0000002400d0, 0.0000001599d0,
     &                 0.0000001739d0, 0.0000001177d0, 0.0000002124d0 /
      data aij(44,:) / 0.0000408929d0, 0.0000365974d0, 0.0000338537d0,
     &                 0.0000239837d0, 0.0000219789d0, 0.0000159079d0,
     &                 0.0000148083d0, 0.0000064093d0, 0.0000047381d0,
     &                 0.0000060372d0, 0.0000058068d0, 0.0000056862d0,
     &                 0.0000032968d0, 0.0000024911d0, 0.0000024593d0,
     &                 0.0000019073d0, 0.0000019128d0, 0.0000019005d0,
     &                 0.0000014645d0, 0.0000009027d0, 0.0000008974d0,
     &                 0.0000012109d0, 0.0000007360d0, 0.0000005796d0,
     &                 0.0000007748d0, 0.0000003802d0, 0.0000005085d0,
     &                 0.0000004071d0, 0.0000004279d0, 0.0000004439d0,
     &                 0.0000003642d0, 0.0000002963d0, 0.0000003129d0,
     &                 0.0000003366d0, 0.0000003574d0, 0.0000001793d0,
     &                 0.0000001519d0, 0.0000002667d0, 0.0000001760d0,
     &                 0.0000002482d0, 0.0000001261d0, 0.0000002263d0,
     &                 0.0000001493d0, 0.0000002143d0, 0.0000000869d0 /
      data aij(45,:) / 0.0000460894d0, 0.0000423271d0, 0.0000297879d0,
     &                 0.0000205531d0, 0.0000193030d0, 0.0000178901d0,
     &                 0.0000130914d0, 0.0000096919d0, 0.0000091541d0,
     &                 0.0000052562d0, 0.0000039234d0, 0.0000038485d0,
     &                 0.0000029218d0, 0.0000028777d0, 0.0000021609d0,
     &                 0.0000021577d0, 0.0000022213d0, 0.0000012807d0,
     &                 0.0000010154d0, 0.0000007967d0, 0.0000006264d0,
     &                 0.0000008077d0, 0.0000006542d0, 0.0000006707d0,
     &                 0.0000006786d0, 0.0000005617d0, 0.0000004357d0,
     &                 0.0000005927d0, 0.0000004775d0, 0.0000003001d0,
     &                 0.0000003137d0, 0.0000002632d0, 0.0000002739d0,
     &                 0.0000002881d0, 0.0000003141d0, 0.0000002009d0,
     &                 0.0000002152d0, 0.0000003873d0, 0.0000001959d0,
     &                 0.0000001287d0, 0.0000002305d0, 0.0000001938d0,
     &                 0.0000002115d0, 0.0000003004d0, 0.0000001533d0 /
c
c     Bij neck correction constants
c
      data bij(1,:)  / -1.20d0, -1.05d0, -1.30d0, -1.15d0, -1.00d0,
     &                 -0.85d0, -0.90d0, -0.75d0, -1.20d0, -1.05d0,
     &                 -0.90d0, -0.95d0, -0.80d0, -0.65d0, -0.70d0,
     &                 -0.75d0, -0.60d0, -0.45d0, -0.50d0, -0.75d0,
     &                 -0.40d0, -0.25d0, -0.30d0, -0.15d0, -0.20d0,
     &                 -0.25d0,  0.10d0,  0.05d0,  0.20d0, -0.05d0,
     &                  0.30d0,  0.25d0,  0.40d0,  0.15d0,  0.10d0,
     &                  0.25d0,  0.60d0,  0.55d0,  0.70d0,  0.45d0,
     &                  0.80d0,  0.55d0,  0.90d0,  0.65d0,  1.00d0 /
      data bij(2,:)  / -1.25d0, -1.10d0, -0.95d0, -1.40d0, -1.05d0,
     &                 -1.10d0, -0.95d0, -0.80d0, -0.85d0, -0.70d0,
     &                 -0.55d0, -1.00d0, -0.65d0, -0.70d0, -0.95d0,
     &                 -0.60d0, -0.65d0, -0.70d0, -0.55d0, -0.60d0,
     &                 -0.45d0, -0.10d0, -0.15d0,  0.00d0, -0.05d0,
     &                  0.10d0,  0.05d0,  0.20d0,  0.15d0,  0.10d0,
     &                  0.25d0,  0.00d0,  0.15d0, -0.10d0,  0.25d0,
     &                  0.20d0,  0.35d0,  0.50d0,  0.65d0,  0.40d0,
     &                  0.75d0,  0.70d0,  0.85d0,  0.60d0,  0.95d0 /
      data bij(3,:)  / -1.30d0, -1.15d0, -1.00d0, -1.05d0, -0.90d0,
     &                 -0.95d0, -1.20d0, -0.85d0, -0.90d0, -0.95d0,
     &                 -0.80d0, -0.65d0, -0.70d0, -0.75d0, -0.40d0,
     &                 -0.65d0, -0.30d0, -0.35d0, -0.60d0, -0.45d0,
     &                 -0.50d0, -0.35d0, -0.20d0, -0.25d0, -0.10d0,
     &                  0.05d0,  0.00d0,  0.15d0, -0.10d0,  0.25d0,
     &                  0.00d0,  0.35d0,  0.10d0,  0.45d0,  0.40d0,
     &                  0.55d0,  0.30d0,  0.65d0,  0.60d0,  0.75d0,
     &                  0.50d0,  0.85d0,  0.80d0,  0.95d0,  0.70d0 /
      data bij(4,:)  / -1.15d0, -1.40d0, -1.05d0, -0.90d0, -1.15d0,
     &                 -0.80d0, -1.05d0, -0.90d0, -0.95d0, -0.60d0,
     &                 -0.85d0, -0.70d0, -0.75d0, -0.40d0, -0.45d0,
     &                 -0.30d0, -0.35d0, -0.40d0, -0.25d0, -0.30d0,
     &                 -0.15d0, -0.40d0, -0.05d0, -0.30d0, -0.15d0,
     &                 -0.20d0, -0.05d0,  0.10d0,  0.25d0,  0.00d0,
     &                  0.35d0,  0.10d0,  0.25d0,  0.20d0,  0.35d0,
     &                  0.30d0,  0.45d0,  0.40d0,  0.75d0,  0.50d0,
     &                  0.65d0,  0.80d0,  0.75d0,  0.90d0,  0.65d0 /
      data bij(5,:)  / -1.00d0, -1.25d0, -0.90d0, -1.15d0, -1.00d0,
     &                 -0.85d0, -0.90d0, -0.75d0, -0.60d0, -0.85d0,
     &                 -0.50d0, -0.95d0, -0.80d0, -0.65d0, -0.70d0,
     &                 -0.55d0, -0.60d0, -0.25d0, -0.50d0, -0.35d0,
     &                 -0.40d0, -0.05d0, -0.10d0,  0.05d0, -0.20d0,
     &                  0.15d0, -0.10d0,  0.05d0,  0.00d0,  0.15d0,
     &                  0.10d0,  0.25d0,  0.40d0,  0.35d0,  0.50d0,
     &                  0.45d0,  0.60d0,  0.55d0,  0.70d0,  0.45d0,
     &                  0.80d0,  0.75d0,  0.90d0,  0.65d0,  1.00d0 /
      data bij(6,:)  / -0.85d0, -1.10d0, -1.15d0, -1.00d0, -0.85d0,
     &                 -0.90d0, -0.95d0, -0.80d0, -0.65d0, -0.50d0,
     &                 -0.55d0, -0.60d0, -0.65d0, -0.50d0, -0.55d0,
     &                 -0.40d0, -0.25d0, -0.50d0, -0.15d0, -0.60d0,
     &                 -0.05d0, -0.30d0, -0.15d0,  0.00d0, -0.05d0,
     &                  0.10d0,  0.05d0,  0.20d0,  0.15d0,  0.30d0,
     &                  0.05d0,  0.40d0,  0.35d0,  0.50d0,  0.45d0,
     &                  0.60d0,  0.55d0,  0.70d0,  0.45d0,  0.80d0,
     &                  0.75d0,  0.90d0,  0.85d0,  1.00d0,  0.75d0 /
      data bij(7,:)  / -0.90d0, -1.15d0, -1.00d0, -1.05d0, -0.90d0,
     &                 -0.55d0, -0.60d0, -0.45d0, -0.70d0, -0.55d0,
     &                 -0.60d0, -0.65d0, -0.50d0, -0.35d0, -0.40d0,
     &                 -0.25d0, -0.50d0, -0.35d0, -0.20d0, -0.05d0,
     &                 -0.10d0,  0.05d0,  0.00d0,  0.15d0,  0.30d0,
     &                  0.25d0,  0.40d0,  0.15d0,  0.30d0, -0.15d0,
     &                  0.40d0,  0.55d0,  0.50d0,  0.25d0,  0.60d0,
     &                  0.55d0,  0.90d0,  0.45d0,  0.60d0,  0.75d0,
     &                  0.70d0,  0.85d0,  1.00d0,  0.95d0,  0.90d0 /
      data bij(8,:)  / -1.15d0, -1.00d0, -1.25d0, -0.90d0, -0.75d0,
     &                 -0.80d0, -0.45d0, -0.50d0, -0.95d0, -0.40d0,
     &                 -0.45d0, -0.70d0, -0.55d0, -0.40d0, -0.45d0,
     &                 -0.30d0, -0.15d0, -0.20d0, -0.45d0, -0.10d0,
     &                 -0.15d0, -0.20d0, -0.05d0,  0.10d0,  0.05d0,
     &                  0.20d0,  0.15d0,  0.10d0,  0.05d0,  0.40d0,
     &                  0.35d0,  0.50d0,  0.45d0,  0.20d0,  0.55d0,
     &                  0.50d0,  0.45d0,  0.20d0,  0.75d0,  0.70d0,
     &                  0.85d0,  0.80d0,  0.95d0,  1.10d0,  1.05d0 /
      data bij(9,:)  / -1.00d0, -0.85d0, -0.90d0, -0.75d0, -0.80d0,
     &                 -0.85d0, -0.90d0, -0.55d0, -0.60d0, -0.45d0,
     &                 -0.50d0, -0.35d0, -0.40d0, -0.65d0, -0.30d0,
     &                 -0.35d0,  0.00d0, -0.25d0,  0.10d0, -0.35d0,
     &                  0.00d0, -0.05d0, -0.10d0,  0.05d0,  0.00d0,
     &                  0.15d0,  0.10d0,  0.25d0,  0.20d0,  0.15d0,
     &                  0.30d0,  0.45d0,  0.00d0,  0.55d0,  0.70d0,
     &                  0.65d0,  0.80d0,  0.75d0,  0.90d0,  1.05d0,
     &                  1.00d0,  1.15d0,  1.10d0,  1.25d0,  1.00d0 /
      data bij(10,:) / -1.05d0, -1.10d0, -0.75d0, -0.60d0, -0.65d0,
     &                 -0.70d0, -0.95d0, -0.60d0, -0.45d0, -0.70d0,
     &                 -0.55d0, -0.20d0, -0.45d0, -0.30d0, -0.35d0,
     &                 -0.20d0, -0.25d0, -0.10d0,  0.05d0,  0.00d0,
     &                 -0.05d0,  0.30d0,  0.25d0,  0.00d0,  0.15d0,
     &                  0.10d0,  0.25d0,  0.20d0,  0.55d0,  0.50d0,
     &                  0.45d0,  0.20d0,  0.75d0,  0.30d0,  0.85d0,
     &                  0.60d0,  0.55d0,  0.70d0,  0.85d0,  0.80d0,
     &                  0.75d0,  0.90d0,  1.05d0,  1.00d0,  1.35d0 /
      data bij(11,:) / -1.10d0, -0.75d0, -0.80d0, -0.65d0, -0.50d0,
     &                 -0.75d0, -0.60d0, -0.45d0, -0.70d0, -0.55d0,
     &                 -0.40d0, -0.65d0, -0.30d0, -0.15d0, -0.20d0,
     &                 -0.25d0, -0.30d0, -0.15d0, -0.20d0, -0.05d0,
     &                 -0.10d0,  0.05d0,  0.20d0,  0.15d0,  0.30d0,
     &                  0.05d0,  0.20d0,  0.55d0,  0.30d0,  0.45d0,
     &                  0.40d0,  0.55d0,  0.50d0,  0.65d0,  0.60d0,
     &                  0.55d0,  0.90d0,  0.65d0,  1.00d0,  0.95d0,
     &                  0.90d0,  0.65d0,  1.00d0,  0.75d0,  1.10d0 /
      data bij(12,:) / -0.75d0, -1.00d0, -0.65d0, -0.50d0, -0.75d0,
     &                 -0.60d0, -0.65d0, -0.30d0, -0.35d0, -0.20d0,
     &                 -0.65d0, -0.50d0, -0.55d0, -0.20d0, -0.05d0,
     &                  0.10d0, -0.15d0, -0.20d0, -0.25d0, -0.10d0,
     &                 -0.15d0,  0.00d0,  0.15d0,  0.10d0,  0.25d0,
     &                  0.20d0,  0.35d0,  0.30d0,  0.25d0,  0.40d0,
     &                  0.55d0,  0.70d0,  0.45d0,  0.60d0,  0.55d0,
     &                  0.90d0,  0.85d0,  1.00d0,  0.75d0,  1.10d0,
     &                  1.05d0,  1.20d0,  1.15d0,  1.30d0,  1.05d0 /
      data bij(13,:) / -0.80d0, -0.65d0, -0.70d0, -0.75d0, -0.60d0,
     &                 -0.65d0, -0.50d0, -0.55d0, -0.40d0, -0.65d0,
     &                 -0.30d0, -0.55d0, -0.40d0, -0.45d0, -0.10d0,
     &                 -0.35d0,  0.00d0,  0.15d0,  0.10d0,  0.05d0,
     &                 -0.20d0,  0.35d0, -0.10d0,  0.05d0,  0.20d0,
     &                  0.35d0,  0.50d0,  0.45d0,  0.40d0,  0.75d0,
     &                  0.50d0,  0.85d0,  0.60d0,  0.55d0,  0.70d0,
     &                  0.85d0,  1.00d0,  0.75d0,  1.10d0,  1.05d0,
     &                  1.00d0,  1.15d0,  0.90d0,  1.05d0,  1.00d0 /
      data bij(14,:) / -0.85d0, -0.70d0, -0.95d0, -0.60d0, -0.85d0,
     &                 -0.50d0, -0.75d0, -0.40d0, -0.25d0, -0.30d0,
     &                 -0.15d0, -0.20d0, -0.25d0, -0.10d0,  0.05d0,
     &                 -0.20d0, -0.05d0,  0.10d0,  0.05d0, -0.40d0,
     &                  0.35d0,  0.30d0,  0.45d0,  0.20d0, -0.05d0,
     &                  0.10d0,  0.25d0,  0.40d0,  0.35d0,  0.50d0,
     &                  0.65d0,  1.00d0,  0.75d0,  0.90d0,  0.65d0,
     &                  0.20d0,  0.75d0,  0.70d0,  0.85d0,  1.00d0,
     &                  0.95d0,  1.10d0,  1.25d0,  1.20d0,  1.35d0 /
      data bij(15,:) / -0.70d0, -0.95d0, -0.60d0, -0.65d0, -0.50d0,
     &                 -0.55d0, -0.40d0, -0.25d0, -0.30d0, -0.15d0,
     &                 -0.20d0, -0.05d0, -0.30d0,  0.05d0,  0.20d0,
     &                 -0.05d0, -0.30d0,  0.05d0,  0.00d0,  0.15d0,
     &                  0.10d0,  0.25d0,  0.20d0,  0.35d0,  0.10d0,
     &                  0.45d0,  0.60d0,  0.55d0,  0.50d0,  0.25d0,
     &                  0.20d0,  0.55d0,  0.70d0,  0.85d0,  0.80d0,
     &                  1.15d0,  0.90d0,  1.25d0,  0.80d0,  0.95d0,
     &                  0.90d0,  1.05d0,  1.00d0,  1.55d0,  0.90d0 /
      data bij(16,:) / -0.35d0, -0.80d0, -0.45d0, -0.50d0, -0.35d0,
     &                 -0.40d0, -0.25d0, -0.50d0, -0.15d0, -0.20d0,
     &                 -0.05d0, -0.50d0, -0.15d0, -0.40d0, -0.05d0,
     &                 -0.10d0,  0.25d0,  0.20d0,  0.15d0,  0.10d0,
     &                  0.25d0,  0.20d0,  0.35d0,  0.30d0,  0.45d0,
     &                  0.40d0,  0.35d0,  0.70d0,  0.65d0,  0.40d0,
     &                  0.75d0,  0.50d0,  0.65d0,  0.60d0,  0.95d0,
     &                  0.90d0,  1.05d0,  1.00d0,  1.15d0,  0.70d0,
     &                  1.25d0,  1.00d0,  0.95d0,  1.10d0,  1.05d0 /
      data bij(17,:) / -0.40d0, -0.45d0, -0.50d0, -0.35d0, -0.60d0,
     &                 -0.45d0, -0.50d0, -0.15d0,  0.00d0, -0.25d0,
     &                 -0.30d0, -0.15d0, -0.40d0, -0.05d0,  0.10d0,
     &                  0.25d0,  0.40d0,  0.15d0,  0.10d0,  0.05d0,
     &                  0.40d0, -0.05d0,  0.10d0,  0.25d0,  0.40d0,
     &                  0.35d0,  0.50d0,  0.45d0,  0.60d0,  0.75d0,
     &                  0.90d0,  0.85d0,  0.60d0,  0.95d0,  0.70d0,
     &                  1.05d0,  0.80d0,  0.95d0,  0.90d0,  1.05d0,
     &                  1.20d0,  1.15d0,  1.30d0,  1.25d0,  1.40d0 /
      data bij(18,:) / -0.45d0, -0.30d0, -0.35d0, -0.40d0, -0.25d0,
     &                 -0.10d0, -0.35d0, -0.20d0, -0.25d0, -0.30d0,
     &                 -0.15d0,  0.00d0, -0.05d0,  0.10d0,  0.25d0,
     &                  0.20d0,  0.15d0,  0.30d0,  0.05d0,  0.20d0,
     &                  0.35d0,  0.50d0,  0.65d0,  0.20d0,  0.55d0,
     &                  0.50d0,  0.85d0,  0.40d0,  0.75d0,  0.50d0,
     &                  0.65d0,  0.60d0,  0.75d0,  0.90d0,  1.05d0,
     &                  1.20d0,  0.95d0,  1.30d0,  1.05d0,  1.00d0,
     &                  0.95d0,  1.30d0,  1.25d0,  1.40d0,  0.95d0 /
      data bij(19,:) / -0.30d0, -0.35d0, -0.40d0, -0.45d0, -0.30d0,
     &                 -0.35d0, -0.20d0, -0.45d0, -0.10d0,  0.05d0,
     &                  0.20d0, -0.05d0, -0.10d0, -0.15d0,  0.20d0,
     &                  0.15d0,  0.10d0,  0.05d0,  0.60d0,  0.35d0,
     &                  0.50d0,  0.25d0,  0.40d0,  0.55d0,  0.70d0,
     &                  0.65d0,  0.80d0,  0.55d0,  0.70d0,  1.05d0,
     &                  1.00d0,  0.55d0,  0.90d0,  1.05d0,  1.20d0,
     &                  0.75d0,  1.10d0,  0.85d0,  1.40d0,  1.35d0,
     &                  1.50d0,  1.05d0,  1.20d0,  1.15d0,  1.30d0 /
      data bij(20,:) / -0.55d0, -0.40d0, -0.65d0, -0.30d0, -0.35d0,
     &                 -0.20d0, -0.25d0, -0.10d0, -0.35d0,  0.00d0,
     &                 -0.05d0,  0.10d0,  0.05d0,  0.00d0, -0.25d0,
     &                  0.30d0,  0.25d0,  0.20d0,  0.35d0, -0.10d0,
     &                  0.25d0,  0.40d0,  0.55d0,  0.70d0,  0.65d0,
     &                  0.60d0,  0.75d0,  0.90d0,  0.65d0,  0.40d0,
     &                  0.95d0,  0.70d0,  1.05d0,  1.00d0,  1.15d0,
     &                  0.90d0,  1.05d0,  1.00d0,  0.75d0,  1.30d0,
     &                  1.25d0,  1.60d0,  1.35d0,  1.10d0,  1.45d0 /
      data bij(21,:) / -0.40d0, -0.45d0, -0.70d0, -0.15d0, -0.20d0,
     &                 -0.05d0,  0.10d0, -0.35d0,  0.00d0,  0.15d0,
     &                 -0.10d0,  0.25d0,  0.00d0,  0.35d0,  0.30d0,
     &                  0.25d0,  0.20d0,  0.55d0,  0.50d0,  0.45d0,
     &                  0.20d0,  0.75d0,  0.50d0,  0.65d0,  0.60d0,
     &                  0.75d0,  0.50d0,  0.85d0,  0.80d0,  0.95d0,
     &                  1.10d0,  1.05d0,  1.00d0,  1.15d0,  1.10d0,
     &                  1.05d0,  1.20d0,  0.95d0,  1.10d0,  1.25d0,
     &                  1.20d0,  1.35d0,  1.30d0,  1.45d0,  1.40d0 /
      data bij(22,:) / -0.25d0, -0.10d0, -0.15d0, -0.40d0, -0.45d0,
     &                 -0.30d0,  0.05d0, -0.20d0,  0.15d0,  0.10d0,
     &                  0.05d0,  0.00d0,  0.35d0,  0.10d0,  0.45d0,
     &                  0.20d0,  0.35d0,  0.10d0,  0.25d0,  0.40d0,
     &                  0.55d0,  0.30d0,  0.65d0,  0.20d0,  0.35d0,
     &                  0.30d0,  0.65d0,  0.60d0,  0.75d0,  0.90d0,
     &                  0.85d0,  1.00d0,  0.95d0,  1.30d0,  1.05d0,
     &                  1.20d0,  1.15d0,  1.10d0,  1.05d0,  1.20d0,
     &                  1.35d0,  1.30d0,  1.45d0,  1.40d0,  1.75d0 /
      data bij(23,:) / -0.30d0, -0.15d0, -0.20d0, -0.25d0,  0.10d0,
     &                 -0.35d0, -0.20d0,  0.15d0, -0.10d0,  0.05d0,
     &                  0.40d0,  0.15d0,  0.10d0,  0.45d0,  0.00d0,
     &                  0.35d0,  0.10d0,  0.45d0,  0.60d0,  0.55d0,
     &                  0.50d0,  0.65d0,  0.20d0,  0.35d0,  0.90d0,
     &                  0.45d0,  0.60d0,  0.35d0,  0.90d0,  0.65d0,
     &                  0.60d0,  0.95d0,  1.10d0,  1.25d0,  1.00d0,
     &                  1.15d0,  1.30d0,  1.45d0,  1.00d0,  1.15d0,
     &                  1.50d0,  1.65d0,  1.20d0,  1.35d0,  1.30d0 /
      data bij(24,:) / -0.15d0, -0.20d0, -0.05d0, -0.10d0, -0.15d0,
     &                 -0.40d0, -0.05d0,  0.10d0,  0.05d0,  0.00d0,
     &                  0.15d0,  0.30d0,  0.25d0,  0.20d0,  0.55d0,
     &                  0.50d0,  0.45d0,  0.20d0,  0.15d0,  0.70d0,
     &                  0.45d0,  0.60d0,  0.35d0,  0.90d0,  0.65d0,
     &                  0.80d0,  0.55d0,  0.50d0,  0.45d0,  0.80d0,
     &                  0.95d0,  0.90d0,  1.05d0,  1.00d0,  0.95d0,
     &                  1.10d0,  1.25d0,  1.40d0,  1.35d0,  1.30d0,
     &                  1.45d0,  1.20d0,  1.55d0,  1.70d0,  1.65d0 /
      data bij(25,:) /  0.00d0, -0.25d0, -0.10d0, -0.15d0,  0.00d0,
     &                 -0.05d0, -0.10d0,  0.05d0,  0.00d0,  0.15d0,
     &                  0.30d0,  0.25d0,  0.20d0,  0.15d0,  0.50d0,
     &                  0.45d0,  0.20d0,  0.35d0,  0.70d0,  0.45d0,
     &                  0.40d0,  0.35d0,  0.70d0,  0.65d0,  0.80d0,
     &                  0.75d0,  0.90d0,  0.65d0,  1.00d0,  0.95d0,
     &                  1.30d0,  1.25d0,  1.00d0,  1.35d0,  0.90d0,
     &                  1.25d0,  1.00d0,  1.35d0,  1.30d0,  1.45d0,
     &                  1.40d0,  1.55d0,  1.70d0,  1.25d0,  1.60d0 /
      data bij(26,:) / -0.25d0, -0.10d0, -0.15d0,  0.00d0,  0.15d0,
     &                  0.10d0, -0.15d0,  0.20d0,  0.15d0,  0.10d0,
     &                  0.05d0,  0.40d0,  0.35d0,  0.50d0,  0.05d0,
     &                  0.00d0,  0.35d0,  0.50d0,  0.25d0,  0.60d0,
     &                  0.35d0,  0.50d0,  0.65d0,  1.00d0,  0.95d0,
     &                  0.90d0,  0.85d0,  0.80d0,  1.15d0,  1.10d0,
     &                  1.25d0,  1.40d0,  1.15d0,  0.90d0,  1.05d0,
     &                  1.60d0,  1.55d0,  1.10d0,  1.25d0,  1.60d0,
     &                  1.35d0,  1.30d0,  1.45d0,  1.60d0,  1.55d0 /
      data bij(27,:) / -0.10d0, -0.15d0,  0.00d0, -0.05d0,  0.10d0,
     &                 -0.15d0,  0.00d0,  0.35d0,  0.30d0,  0.05d0,
     &                  0.20d0,  0.55d0,  0.30d0,  0.65d0,  0.60d0,
     &                  0.15d0,  0.50d0,  0.25d0,  0.60d0,  0.55d0,
     &                  0.90d0,  0.85d0,  0.60d0,  0.55d0,  0.70d0,
     &                  1.05d0,  0.80d0,  0.95d0,  0.90d0,  1.05d0,
     &                  1.00d0,  1.15d0,  1.30d0,  1.25d0,  1.20d0,
     &                  1.55d0,  0.90d0,  1.45d0,  1.40d0,  1.35d0,
     &                  1.90d0,  1.45d0,  1.60d0,  1.55d0,  1.50d0 /
      data bij(28,:) /  0.05d0,  0.00d0,  0.15d0,  0.10d0, -0.15d0,
     &                  0.20d0,  0.35d0,  0.10d0,  0.45d0,  0.20d0,
     &                  0.15d0,  0.30d0,  0.05d0,  0.40d0,  0.15d0,
     &                  0.70d0,  0.45d0,  0.40d0,  0.75d0,  0.50d0,
     &                  0.85d0,  0.60d0,  0.75d0,  0.90d0,  1.05d0,
     &                  1.20d0,  1.15d0,  0.90d0,  1.25d0,  1.00d0,
     &                  0.95d0,  1.10d0,  1.25d0,  1.00d0,  1.15d0,
     &                  1.10d0,  1.25d0,  1.60d0,  1.15d0,  1.30d0,
     &                  1.25d0,  1.20d0,  1.75d0,  1.50d0,  1.65d0 /
      data bij(29,:) /  0.20d0,  0.15d0, -0.10d0, -0.15d0,  0.00d0,
     &                  0.15d0,  0.10d0,  0.45d0,  0.20d0,  0.35d0,
     &                  0.10d0,  0.45d0,  0.40d0,  0.35d0,  0.30d0,
     &                  0.65d0,  0.40d0,  0.35d0,  0.70d0,  0.85d0,
     &                  0.60d0,  0.55d0,  0.50d0,  0.85d0,  1.20d0,
     &                  0.95d0,  0.50d0,  0.85d0,  1.20d0,  1.35d0,
     &                  0.90d0,  1.05d0,  1.40d0,  1.35d0,  1.50d0,
     &                  1.25d0,  1.40d0,  1.55d0,  1.70d0,  1.05d0,
     &                  1.60d0,  1.75d0,  1.70d0,  1.65d0,  1.80d0 /
      data bij(30,:) /  0.15d0,  0.10d0,  0.05d0,  0.00d0,  0.15d0,
     &                  0.10d0,  0.25d0,  0.60d0,  0.35d0,  0.30d0,
     &                  0.05d0,  0.60d0,  0.55d0,  0.30d0,  0.25d0,
     &                  0.40d0,  0.55d0,  0.50d0,  0.85d0,  0.40d0,
     &                  0.75d0,  1.10d0,  1.05d0,  0.40d0,  0.95d0,
     &                  0.70d0,  0.85d0,  1.00d0,  0.95d0,  1.30d0,
     &                  1.05d0,  1.40d0,  1.35d0,  1.70d0,  1.45d0,
     &                  1.40d0,  1.35d0,  1.50d0,  1.45d0,  1.60d0,
     &                  1.55d0,  1.70d0,  1.85d0,  2.00d0,  1.75d0 /
      data bij(31,:) /  0.10d0,  0.05d0,  0.00d0,  0.15d0,  0.10d0,
     &                  0.25d0,  0.20d0,  0.35d0,  0.10d0,  0.45d0,
     &                  0.60d0,  0.55d0,  0.10d0,  0.65d0,  0.80d0,
     &                  0.75d0,  0.30d0,  0.65d0,  0.40d0,  0.75d0,
     &                  1.10d0,  0.85d0,  0.40d0,  0.75d0,  0.70d0,
     &                  0.85d0,  1.20d0,  0.95d0,  1.30d0,  1.25d0,
     &                  1.40d0,  0.95d0,  1.50d0,  0.85d0,  1.60d0,
     &                  1.75d0,  1.70d0,  0.65d0,  1.60d0,  1.55d0,
     &                  1.50d0,  1.65d0,  1.80d0,  1.75d0,  1.90d0 /
      data bij(32,:) /  0.05d0,  0.20d0,  0.15d0,  0.30d0,  0.25d0,
     &                  0.40d0,  0.35d0,  0.50d0,  0.65d0,  0.20d0,
     &                  0.55d0,  0.30d0,  0.45d0,  0.40d0,  0.55d0,
     &                  0.90d0,  0.85d0,  0.40d0,  0.55d0,  0.90d0,
     &                  0.65d0,  0.80d0,  0.95d0,  1.10d0,  1.45d0,
     &                  1.40d0,  0.95d0,  1.10d0,  1.05d0,  1.00d0,
     &                  1.35d0,  1.30d0,  1.05d0,  1.40d0,  1.75d0,
     &                  1.30d0,  1.65d0,  1.40d0,  1.75d0,  1.50d0,
     &                  2.05d0,  1.60d0,  2.15d0,  1.90d0,  1.65d0 /
      data bij(33,:) /  0.20d0,  0.15d0,  0.30d0,  0.25d0,  0.40d0,
     &                  0.35d0,  0.30d0,  0.25d0,  0.60d0,  0.35d0,
     &                  0.70d0,  0.85d0,  0.20d0,  0.95d0,  0.70d0,
     &                  0.65d0,  0.80d0,  0.55d0,  0.90d0,  0.85d0,
     &                  1.00d0,  0.95d0,  0.90d0,  1.05d0,  1.20d0,
     &                  1.35d0,  1.10d0,  1.25d0,  0.80d0,  1.55d0,
     &                  1.30d0,  1.25d0,  1.20d0,  1.95d0,  1.50d0,
     &                  1.45d0,  1.20d0,  1.95d0,  1.30d0,  1.85d0,
     &                  1.40d0,  1.95d0,  1.50d0,  1.85d0,  1.80d0 /
      data bij(34,:) /  0.35d0,  0.50d0,  0.45d0,  0.40d0,  0.55d0,
     &                  0.50d0,  0.45d0,  0.60d0,  0.55d0,  0.50d0,
     &                  0.45d0,  0.60d0,  0.55d0,  0.70d0,  0.85d0,
     &                  0.80d0,  0.75d0,  0.70d0,  1.05d0,  1.00d0,
     &                  0.55d0,  0.90d0,  1.25d0,  1.00d0,  1.35d0,
     &                  1.10d0,  1.45d0,  1.00d0,  1.75d0,  1.50d0,
     &                  1.45d0,  1.40d0,  1.75d0,  1.30d0,  1.25d0,
     &                  1.60d0,  1.95d0,  1.10d0,  1.85d0,  2.00d0,
     &                  1.95d0,  2.10d0,  1.85d0,  2.20d0,  2.15d0 /
      data bij(35,:) /  0.30d0,  0.45d0,  0.40d0,  0.15d0,  0.50d0,
     &                  0.65d0,  0.40d0,  0.35d0,  0.50d0,  0.85d0,
     &                  0.80d0,  0.75d0,  0.70d0,  0.85d0,  0.80d0,
     &                  0.95d0,  0.70d0,  1.05d0,  0.80d0,  1.15d0,
     &                  0.90d0,  1.05d0,  1.00d0,  1.35d0,  0.90d0,
     &                  1.05d0,  1.00d0,  1.35d0,  1.10d0,  1.45d0,
     &                  1.40d0,  1.75d0,  1.70d0,  1.65d0,  1.40d0,
     &                  1.35d0,  1.30d0,  1.85d0,  2.20d0,  1.55d0,
     &                  1.90d0,  1.85d0,  2.00d0,  1.55d0,  2.10d0 /
      data bij(36,:) /  0.45d0,  0.20d0,  0.15d0,  0.30d0,  0.45d0,
     &                  0.40d0,  0.55d0,  0.50d0,  0.65d0,  0.60d0,
     &                  0.75d0,  0.70d0,  0.85d0,  0.60d0,  0.95d0,
     &                  0.70d0,  1.05d0,  0.80d0,  0.95d0,  0.90d0,
     &                  1.05d0,  0.80d0,  1.15d0,  1.10d0,  1.25d0,
     &                  1.60d0,  0.75d0,  1.10d0,  1.25d0,  1.40d0,
     &                  1.55d0,  1.70d0,  1.45d0,  1.60d0,  1.75d0,
     &                  1.90d0,  1.65d0,  1.80d0,  2.15d0,  2.10d0,
     &                  1.45d0,  2.00d0,  1.75d0,  1.90d0,  1.85d0 /
      data bij(37,:) /  0.20d0,  0.35d0,  0.30d0,  0.45d0,  0.40d0,
     &                  0.55d0,  0.50d0,  0.45d0,  0.80d0,  0.75d0,
     &                  0.50d0,  0.85d0,  1.00d0,  0.75d0,  0.50d0,
     &                  0.85d0,  1.20d0,  1.15d0,  1.10d0,  1.05d0,
     &                  0.80d0,  1.15d0,  0.70d0,  1.25d0,  1.40d0,
     &                  1.15d0,  1.70d0,  1.45d0,  1.60d0,  1.35d0,
     &                  1.50d0,  1.45d0,  1.80d0,  1.55d0,  1.90d0,
     &                  1.45d0,  2.00d0,  2.15d0,  2.10d0,  1.45d0,
     &                  1.60d0,  1.75d0,  1.90d0,  2.25d0,  1.80d0 /
      data bij(38,:) /  0.35d0,  0.50d0,  0.45d0,  0.60d0,  0.55d0,
     &                  0.70d0,  0.65d0,  0.40d0,  0.75d0,  0.70d0,
     &                  1.05d0,  0.60d0,  0.75d0,  0.70d0,  0.85d0,
     &                  1.00d0,  0.95d0,  0.70d0,  1.05d0,  1.00d0,
     &                  1.35d0,  1.30d0,  1.25d0,  1.40d0,  1.15d0,
     &                  1.50d0,  1.25d0,  1.60d0,  1.55d0,  1.50d0,
     &                  1.45d0,  1.80d0,  1.35d0,  1.90d0,  1.85d0,
     &                  1.80d0,  1.95d0,  1.70d0,  1.65d0,  1.60d0,
     &                  1.75d0,  1.70d0,  2.25d0,  1.80d0,  2.15d0 /
      data bij(39,:) /  0.30d0,  0.65d0,  0.60d0,  0.55d0,  0.70d0,
     &                  0.85d0,  0.80d0,  0.95d0,  0.90d0,  0.65d0,
     &                  1.00d0,  0.75d0,  0.70d0,  1.25d0,  1.00d0,
     &                  0.95d0,  1.30d0,  1.05d0,  1.20d0,  0.95d0,
     &                  1.30d0,  1.25d0,  1.20d0,  1.55d0,  0.90d0,
     &                  1.05d0,  1.40d0,  1.15d0,  1.50d0,  1.25d0,
     &                  1.60d0,  1.75d0,  1.70d0,  2.05d0,  1.80d0,
     &                  2.15d0,  1.70d0,  1.65d0,  1.80d0,  1.95d0,
     &                  1.90d0,  2.05d0,  1.80d0,  2.15d0,  2.10d0 /
      data bij(40,:) /  0.65d0,  0.80d0,  0.75d0,  0.30d0,  0.85d0,
     &                  0.80d0,  0.55d0,  0.90d0,  0.65d0,  0.80d0,
     &                  1.15d0,  0.90d0,  1.25d0,  1.20d0,  0.75d0,
     &                  1.10d0,  0.85d0,  1.20d0,  0.95d0,  1.10d0,
     &                  1.05d0,  1.40d0,  1.15d0,  1.30d0,  1.05d0,
     &                  1.60d0,  1.35d0,  1.30d0,  1.45d0,  1.40d0,
     &                  1.95d0,  1.90d0,  1.85d0,  1.60d0,  1.95d0,
     &                  1.50d0,  2.05d0,  1.80d0,  1.95d0,  1.90d0,
     &                  2.25d0,  1.60d0,  2.35d0,  2.10d0,  2.25d0 /
      data bij(41,:) /  0.60d0,  0.75d0,  0.70d0,  0.45d0,  0.60d0,
     &                  0.95d0,  0.70d0,  1.05d0,  0.80d0,  0.95d0,
     &                  0.50d0,  1.05d0,  1.00d0,  1.15d0,  1.10d0,
     &                  0.85d0,  0.60d0,  0.95d0,  1.10d0,  1.45d0,
     &                  1.20d0,  1.35d0,  1.70d0,  1.45d0,  1.60d0,
     &                  1.75d0,  1.90d0,  1.25d0,  1.60d0,  1.55d0,
     &                  1.50d0,  1.85d0,  1.40d0,  1.75d0,  1.90d0,
     &                  2.05d0,  1.60d0,  1.95d0,  1.50d0,  2.25d0,
     &                  1.40d0,  1.95d0,  2.30d0,  2.25d0,  1.60d0 /
      data bij(42,:) /  0.75d0,  0.70d0,  0.65d0,  0.60d0,  0.75d0,
     &                  0.70d0,  0.85d0,  0.80d0,  0.95d0,  0.90d0,
     &                  1.05d0,  1.00d0,  1.15d0,  1.10d0,  0.85d0,
     &                  1.00d0,  1.15d0,  1.30d0,  1.05d0,  1.60d0,
     &                  1.55d0,  0.90d0,  1.05d0,  1.20d0,  1.55d0,
     &                  1.30d0,  1.45d0,  1.40d0,  1.75d0,  2.10d0,
     &                  1.65d0,  1.40d0,  1.95d0,  2.10d0,  2.05d0,
     &                  2.00d0,  1.95d0,  1.70d0,  1.65d0,  2.40d0,
     &                  1.95d0,  2.30d0,  2.05d0,  2.40d0,  2.35d0 /
      data bij(43,:) /  0.50d0,  0.65d0,  0.80d0,  0.75d0,  0.90d0,
     &                  0.85d0,  0.80d0,  0.95d0,  1.10d0,  1.05d0,
     &                  0.80d0,  1.15d0,  0.90d0,  1.25d0,  1.00d0,
     &                  1.15d0,  1.10d0,  0.85d0,  1.20d0,  1.35d0,
     &                  1.10d0,  1.45d0,  1.40d0,  1.55d0,  1.70d0,
     &                  1.05d0,  1.40d0,  1.75d0,  1.30d0,  1.85d0,
     &                  2.00d0,  1.75d0,  1.90d0,  1.85d0,  2.20d0,
     &                  1.95d0,  2.30d0,  1.85d0,  2.40d0,  1.95d0,
     &                  2.30d0,  2.05d0,  2.20d0,  1.95d0,  2.50d0 /
      data bij(44,:) /  0.65d0,  0.80d0,  0.95d0,  0.90d0,  1.05d0,
     &                  1.00d0,  1.15d0,  0.70d0,  0.65d0,  1.00d0,
     &                  1.15d0,  1.30d0,  1.05d0,  1.00d0,  1.15d0,
     &                  1.10d0,  1.25d0,  1.40d0,  1.35d0,  1.10d0,
     &                  1.25d0,  1.60d0,  1.35d0,  1.30d0,  1.65d0,
     &                  1.20d0,  1.55d0,  1.50d0,  1.65d0,  1.80d0,
     &                  1.75d0,  1.70d0,  1.85d0,  2.00d0,  2.15d0,
     &                  1.70d0,  1.65d0,  2.20d0,  1.95d0,  2.30d0,
     &                  1.85d0,  2.40d0,  2.15d0,  2.50d0,  1.85d0 /
      data bij(45,:) /  0.80d0,  0.95d0,  0.90d0,  0.85d0,  1.00d0,
     &                  1.15d0,  1.10d0,  1.05d0,  1.20d0,  0.95d0,
     &                  0.90d0,  1.05d0,  1.00d0,  1.15d0,  1.10d0,
     &                  1.25d0,  1.40d0,  1.15d0,  1.10d0,  1.05d0,
     &                  1.00d0,  1.35d0,  1.30d0,  1.45d0,  1.60d0,
     &                  1.55d0,  1.50d0,  1.85d0,  1.80d0,  1.55d0,
     &                  1.70d0,  1.65d0,  1.80d0,  1.95d0,  2.10d0,
     &                  1.85d0,  2.00d0,  2.55d0,  2.10d0,  1.85d0,
     &                  2.40d0,  2.35d0,  2.50d0,  2.85d0,  2.40d0 /
c
c
c     set atom radii and parameter values for neck corrections
c
      do i = 1, maxneck
         rneck(i) = radbin(i)
         do j = 1, maxneck
            aneck(j,i) = aij(j,i)
            bneck(j,i) = bij(j,i)
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine initprm  --  initialize force field parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "initprm" completely initializes a force field by setting all
c     parameters to zero and using defaults for control values
c
c
      subroutine initprm
      use angpot
      use bndpot
      use chgpot
      use ctrpot
      use dsppot
      use expol
      use extfld
      use fields
      use ielscf
      use kanang
      use kangs
      use kantor
      use katoms
      use kbonds
      use kcflux
      use kchrge
      use kcpen
      use kctrn
      use kdipol
      use kdsp
      use kexpl
      use khbond
      use kiprop
      use kitors
      use kmulti
      use kopbnd
      use kopdst
      use korbs
      use kpitor
      use kpolpr
      use kpolr
      use krepl
      use ksolut
      use kstbnd
      use ksttor
      use ktorsn
      use ktrtor
      use kurybr
      use kvdws
      use kvdwpr
      use math
      use mplpot
      use polpot
      use reppot
      use rxnpot
      use solpot
      use sizes
      use solute
      use urypot
      use torpot
      use units
      use uprior
      use vdwpot
      implicit none
      integer i,j
      character*3 blank3
      character*8 blank8
      character*12 blank12
      character*16 blank16
      character*20 blank20
      character*24 blank24
c
c
c     define blank character strings of various lengths
c
      blank3 = '   '
      blank8 = '        '
      blank12 = '            '
      blank16 = '                '
      blank20 = '                    '
      blank24 = '                        '
c
c     initialize strings of parameter atom types and classes
c
      do i = 1, maxnvp
         kvpr(i) = blank8
      end do
      do i = 1, maxnhb
         khb(i) = blank8
      end do
      do i = 1, maxnb
         kb(i) = blank8
      end do
      do i = 1, maxnb5
         kb5(i) = blank8
      end do
      do i = 1, maxnb4
         kb4(i) = blank8
      end do
      do i = 1, maxnb3
         kb3(i) = blank8
      end do
      do i = 1, maxnel
         kel(i) = blank12
      end do
      do i = 1, maxna
         ka(i) = blank12
      end do
      do i = 1, maxna5
         ka5(i) = blank12
      end do
      do i = 1, maxna4
         ka4(i) = blank12
      end do
      do i = 1, maxna3
         ka3(i) = blank12
      end do
      do i = 1, maxnap
         kap(i) = blank12
      end do
      do i = 1, maxnaf
         kaf(i) = blank12
      end do
      do i = 1, maxnsb
         ksb(i) = blank12
      end do
      do i = 1, maxnu
         ku(i) = blank12
      end do
      do i = 1, maxnopb
         kopb(i) = blank16
      end do
      do i = 1, maxnopd
         kopd(i) = blank16
      end do
      do i = 1, maxndi
         kdi(i) = blank16
      end do
      do i = 1, maxnti
         kti(i) = blank16
      end do
      do i = 1, maxnt
         kt(i) = blank16
      end do
      do i = 1, maxnt5
         kt5(i) = blank16
      end do
      do i = 1, maxnt4
         kt4(i) = blank16
      end do
      do i = 1, maxnpt
         kpt(i) = blank8
      end do
      do i = 1, maxnbt
         kbt(i) = blank16
      end do
      do i = 1, maxnat
         kat(i) = blank16
      end do
      do i = 1, maxntt
         ktt(i) = blank20
      end do
      do i = 1, maxnd
         kd(i) = blank8
      end do
      do i = 1, maxnd5
         kd5(i) = blank8
      end do
      do i = 1, maxnd4
         kd4(i) = blank8
      end do
      do i = 1, maxnd3
         kd3(i) = blank8
      end do
      do i = 1, maxnmp
         kmp(i) = blank12
      end do
      do i = 1, maxnpp
         kppr(i) = blank8
      end do
      do i = 1, maxncfb
         kcfb(i) = blank8
      end do
      do i = 1, maxncfa
         kcfa(i) = blank12
      end do
      do i = 1, maxnpi
         kpi(i) = blank8
      end do
      do i = 1, maxnpi5
         kpi5(i) = blank8
      end do
      do i = 1, maxnpi4
         kpi4(i) = blank8
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(atmcls))  allocate (atmcls(maxtyp))
      if (.not. allocated(atmnum))  allocate (atmnum(maxtyp))
      if (.not. allocated(ligand))  allocate (ligand(maxtyp))
      if (.not. allocated(weight))  allocate (weight(maxtyp))
      if (.not. allocated(symbol))  allocate (symbol(maxtyp))
      if (.not. allocated(describe))  allocate (describe(maxtyp))
      if (.not. allocated(anan))  allocate (anan(3,maxclass))
      if (.not. allocated(rad))  allocate (rad(maxtyp))
      if (.not. allocated(eps))  allocate (eps(maxtyp))
      if (.not. allocated(rad4))  allocate (rad4(maxtyp))
      if (.not. allocated(eps4))  allocate (eps4(maxtyp))
      if (.not. allocated(reduct))  allocate (reduct(maxtyp))
      if (.not. allocated(prsiz))  allocate (prsiz(maxclass))
      if (.not. allocated(prdmp))  allocate (prdmp(maxclass))
      if (.not. allocated(prele))  allocate (prele(maxclass))
      if (.not. allocated(dspsix))  allocate (dspsix(maxclass))
      if (.not. allocated(dspdmp))  allocate (dspdmp(maxclass))
      if (.not. allocated(chg))  allocate (chg(maxtyp))
      if (.not. allocated(cpele))  allocate (cpele(maxclass))
      if (.not. allocated(cpalp))  allocate (cpalp(maxclass))
      if (.not. allocated(polr))  allocate (polr(maxtyp))
      if (.not. allocated(athl))  allocate (athl(maxtyp))
      if (.not. allocated(dthl))  allocate (dthl(maxtyp))
      if (.not. allocated(pgrp))  allocate (pgrp(maxval,maxtyp))
      if (.not. allocated(pepk))  allocate (pepk(maxclass))
      if (.not. allocated(peppre))  allocate (peppre(maxclass))
      if (.not. allocated(pepdmp))  allocate (pepdmp(maxclass))
      if (.not. allocated(pepl))  allocate (pepl(maxclass))
      if (.not. allocated(ctchg))  allocate (ctchg(maxclass))
      if (.not. allocated(ctdmp))  allocate (ctdmp(maxclass))
      if (.not. allocated(pbr))  allocate (pbr(maxtyp))
      if (.not. allocated(csr))  allocate (csr(maxtyp))
      if (.not. allocated(gkr))  allocate (gkr(maxtyp))
      if (.not. allocated(snk))  allocate (snk(maxtyp))
      if (.not. allocated(electron))  allocate (electron(maxclass))
      if (.not. allocated(ionize))  allocate (ionize(maxclass))
      if (.not. allocated(repulse))  allocate (repulse(maxclass))
      if (.not. allocated(biotyp))  allocate (biotyp(maxbio))
c
c     initialize values of force field model parameters
c
      forcefield = blank20
      do i = 1, maxtyp
         atmcls(i) = 0
         atmnum(i) = 0
         ligand(i) = 0
         weight(i) = 0.0d0
         symbol(i) = blank3
         describe(i) = blank24
         rad(i) = 0.0d0
         eps(i) = 0.0d0
         rad4(i) = 0.0d0
         eps4(i) = 0.0d0
         reduct(i) = 0.0d0
         chg(i) = 0.0d0
         polr(i) = 0.0d0
         athl(i) = 0.0d0
         dthl(i) = 0.0d0
         do j = 1, maxval
            pgrp(j,i) = 0
         end do
         pbr(i) = 0.0d0
         csr(i) = 0.0d0
         gkr(i) = 0.0d0
         snk(i) = 0.0d0
      end do
      do i = 1, maxclass
         do j = 1, 3
            anan(j,i) = 0.0d0
         end do
         prsiz(i) = 0.0d0
         prdmp(i) = 0.0d0
         prele(i) = 0.0d0
         dspsix(i) = 0.0d0
         dspdmp(i) = 0.0d0
         cpele(i) = 0.0d0
         cpalp(i) = 0.0d0
         pepk(i) = 0.0d0
         peppre(i) = 0.0d0
         pepdmp(i) = 0.0d0
         pepl(i) = .false.
         ctchg(i) = 0.0d0
         ctdmp(i) = 0.0d0
         electron(i) = 0.0d0
         ionize(i) = 0.0d0
         repulse(i) = 0.0d0
      end do
      do i = 1, maxbio
         biotyp(i) = 0
      end do
c
c     set default control parameters for local geometry terms
c
      bndtyp = 'HARMONIC'
      bndunit = 1.0d0
      cbnd = 0.0d0
      qbnd = 0.0d0
      angunit = 1.0d0 / radian**2
      cang = 0.0d0
      qang = 0.0d0
      pang = 0.0d0
      sang = 0.0d0
      stbnunit = 1.0d0 / radian
      ureyunit = 1.0d0
      cury = 0.0d0
      qury = 0.0d0
      aaunit = 1.0d0 / radian**2
      opbtyp = 'W-D-C'
      opbunit = 1.0d0 / radian**2
      copb = 0.0d0
      qopb = 0.0d0
      popb = 0.0d0
      sopb = 0.0d0
      opdunit = 1.0d0
      copd = 0.0d0
      qopd = 0.0d0
      popd = 0.0d0
      sopd = 0.0d0
      idihunit = 1.0d0 / radian**2
      itorunit = 1.0d0
      torsunit = 1.0d0
      ptorunit = 1.0d0
      storunit = 1.0d0
      atorunit = 1.0d0 / radian
      ttorunit = 1.0d0
c
c     set default control parameters for van der Waals terms
c
      vdwindex = 'CLASS'
      vdwtyp = 'LENNARD-JONES'
      radrule = 'ARITHMETIC'
      radtyp = 'R-MIN'
      radsiz = 'RADIUS'
      epsrule = 'GEOMETRIC'
      gausstyp = 'NONE'
      ngauss = 0
      abuck = 0.0d0
      bbuck = 0.0d0
      cbuck = 0.0d0
      ghal = 0.12d0
      dhal = 0.07d0
      v2scale = 0.0d0
      v3scale = 0.0d0
      v4scale = 1.0d0
      v5scale = 1.0d0
      use_vcorr = .false.
c
c     set default control parameters for repulsion terms
c
      r2scale = 0.0d0
      r3scale = 0.0d0
      r4scale = 1.0d0
      r5scale = 1.0d0
c
c     set default control parameters for dispersion terms
c
      dsp2scale = 0.0d0
      dsp3scale = 0.0d0
      dsp4scale = 1.0d0
      dsp5scale = 1.0d0
      use_dcorr = .false.
c
c     set default control parameters for charge-charge terms
c
      electric = coulomb
      dielec = 1.0d0
      ebuffer = 0.0d0
      c1scale = 0.0d0
      c2scale = 0.0d0
      c3scale = 0.0d0
      c4scale = 1.0d0
      c5scale = 1.0d0
      neutnbr = .false.
      neutcut = .false.
      use_exfld = .false.
      do i = 1, 3
         exfld(i) = 0.0d0
      end do
c
c     set default control parameters for atomic multipole terms
c
      pentyp = 'GORDON1'
      m2scale = 0.0d0
      m3scale = 0.0d0
      m4scale = 1.0d0
      m5scale = 1.0d0
      d1scale = 0.0d0
      d2scale = 1.0d0
      d3scale = 1.0d0
      d4scale = 1.0d0
      use_chgpen = .false.
c
c     set default control parameters for polarization terms
c
      poltyp = 'MUTUAL'
      scrtyp = 'S2U'
      politer = 100
      poleps = 0.000001d0
      uaccel = 2.0d0
      p2scale = 0.0d0
      p3scale = 0.0d0
      p4scale = 1.0d0
      p5scale = 1.0d0
      p2iscale = 0.0d0
      p3iscale = 0.0d0
      p4iscale = 0.5d0
      p5iscale = 1.0d0
      u1scale = 1.0d0
      u2scale = 1.0d0
      u3scale = 1.0d0
      u4scale = 1.0d0
      w2scale = 1.0d0
      w3scale = 1.0d0
      w4scale = 1.0d0
      w5scale = 1.0d0
      use_thole = .true.
      use_tholed = .false.
      use_pred = .false.
      use_ielscf = .false.
      dpequal = .false.
      use_expol = .false.
c
c     set default control parameters for charge transfer terms
c
      ctrntyp = 'SEPARATE'
c
c     set default control parameters for implicit solvation
c
      solvtyp = blank8
      borntyp = blank8
c
c     set default control parameters for reaction field
c
      rfsize = 1000000.0d0
      rfbulkd = 80.0d0
      rfterms = 1
c
c     initialize some Merck Molecular force field parameters
c
      call initmmff
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine initmmff  --  initialize some MMFF parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "initmmff" initializes some parameter values for the Merck
c     Molecular force field
c
c
      subroutine initmmff
      use ktorsn
      use merck
      implicit none
      integer i,j,k
      character*16 blank16
c
c
c     define blank character strings of various lengths
c
      blank16 = '                '
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(mmff_ka))
     &   allocate (mmff_ka(0:100,100,0:100))
      if (.not. allocated(mmff_ka1))
     &   allocate (mmff_ka1(0:100,100,0:100))
      if (.not. allocated(mmff_ka2))
     &   allocate (mmff_ka2(0:100,100,0:100))
      if (.not. allocated(mmff_ka3))
     &   allocate (mmff_ka3(0:100,100,0:100))
      if (.not. allocated(mmff_ka4))
     &   allocate (mmff_ka4(0:100,100,0:100))
      if (.not. allocated(mmff_ka5))
     &   allocate (mmff_ka5(0:100,100,0:100))
      if (.not. allocated(mmff_ka6))
     &   allocate (mmff_ka6(0:100,100,0:100))
      if (.not. allocated(mmff_ka7))
     &   allocate (mmff_ka7(0:100,100,0:100))
      if (.not. allocated(mmff_ka8))
     &   allocate (mmff_ka8(0:100,100,0:100))
      if (.not. allocated(mmff_ang0))
     &   allocate (mmff_ang0(0:100,100,0:100))
      if (.not. allocated(mmff_ang1))
     &   allocate (mmff_ang1(0:100,100,0:100))
      if (.not. allocated(mmff_ang2))
     &   allocate (mmff_ang2(0:100,100,0:100))
      if (.not. allocated(mmff_ang3))
     &   allocate (mmff_ang3(0:100,100,0:100))
      if (.not. allocated(mmff_ang4))
     &   allocate (mmff_ang4(0:100,100,0:100))
      if (.not. allocated(mmff_ang5))
     &   allocate (mmff_ang5(0:100,100,0:100))
      if (.not. allocated(mmff_ang6))
     &   allocate (mmff_ang6(0:100,100,0:100))
      if (.not. allocated(mmff_ang7))
     &   allocate (mmff_ang7(0:100,100,0:100))
      if (.not. allocated(mmff_ang8))
     &   allocate (mmff_ang8(0:100,100,0:100))
      if (.not. allocated(stbn_abc))
     &   allocate (stbn_abc(100,100,100))
      if (.not. allocated(stbn_cba))
     &   allocate (stbn_cba(100,100,100))
      if (.not. allocated(stbn_abc1))
     &   allocate (stbn_abc1(100,100,100))
      if (.not. allocated(stbn_cba1))
     &   allocate (stbn_cba1(100,100,100))
      if (.not. allocated(stbn_abc2))
     &   allocate (stbn_abc2(100,100,100))
      if (.not. allocated(stbn_cba2))
     &   allocate (stbn_cba2(100,100,100))
      if (.not. allocated(stbn_abc3))
     &   allocate (stbn_abc3(100,100,100))
      if (.not. allocated(stbn_cba3))
     &   allocate (stbn_cba3(100,100,100))
      if (.not. allocated(stbn_abc4))
     &   allocate (stbn_abc4(100,100,100))
      if (.not. allocated(stbn_cba4))
     &   allocate (stbn_cba4(100,100,100))
      if (.not. allocated(stbn_abc5))
     &   allocate (stbn_abc5(100,100,100))
      if (.not. allocated(stbn_cba5))
     &   allocate (stbn_cba5(100,100,100))
      if (.not. allocated(stbn_abc6))
     &   allocate (stbn_abc6(100,100,100))
      if (.not. allocated(stbn_cba6))
     &   allocate (stbn_cba6(100,100,100))
      if (.not. allocated(stbn_abc7))
     &   allocate (stbn_abc7(100,100,100))
      if (.not. allocated(stbn_cba7))
     &   allocate (stbn_cba7(100,100,100))
      if (.not. allocated(stbn_abc8))
     &   allocate (stbn_abc8(100,100,100))
      if (.not. allocated(stbn_cba8))
     &   allocate (stbn_cba8(100,100,100))
      if (.not. allocated(stbn_abc9))
     &   allocate (stbn_abc9(100,100,100))
      if (.not. allocated(stbn_cba9))
     &   allocate (stbn_cba9(100,100,100))
      if (.not. allocated(stbn_abc10))
     &   allocate (stbn_abc10(100,100,100))
      if (.not. allocated(stbn_cba10))
     &   allocate (stbn_cba10(100,100,100))
      if (.not. allocated(stbn_abc11))
     &   allocate (stbn_abc11(100,100,100))
      if (.not. allocated(stbn_cba11))
     &   allocate (stbn_cba11(100,100,100))
c
c     initialize values for MMFF atom class equivalencies
c
      do i = 1, 5
         do j = 1, 500
            eqclass(j,i) = 1000
         end do
      end do
c
c     initialize values for MMFF aromatic ring parameters
c
      do i = 1, 6
         do j = 1, maxtyp
            mmffarom(j,i) = 0
            mmffaromc(j,i) = 0
            mmffaroma(j,i) = 0
         end do
      end do
c
c     initialize values for MMFF bond stretching parameters
c
      do i = 1, 100
         do j = 1, 100
            mmff_kb(j,i) = 1000.0d0
            mmff_kb1(j,i) = 1000.0d0
            mmff_b0(j,i) = 1000.0d0
            mmff_b1(j,i) = 1000.0d0
         end do
      end do
c
c     initialize values for MMFF angle bending parameters
c
      do i = 0, 100
         do j = 1, 100
            do k = 0, 100
               mmff_ka(k,j,i) = 1000.0d0
               mmff_ka1(k,j,i) = 1000.0d0
               mmff_ka2(k,j,i) = 1000.0d0
               mmff_ka3(k,j,i) = 1000.0d0
               mmff_ka4(k,j,i) = 1000.0d0
               mmff_ka5(k,j,i) = 1000.0d0
               mmff_ka6(k,j,i) = 1000.0d0
               mmff_ka7(k,j,i) = 1000.0d0
               mmff_ka8(k,j,i) = 1000.0d0
               mmff_ang0(k,j,i) = 1000.0d0
               mmff_ang1(k,j,i) = 1000.0d0
               mmff_ang2(k,j,i) = 1000.0d0
               mmff_ang3(k,j,i) = 1000.0d0
               mmff_ang4(k,j,i) = 1000.0d0
               mmff_ang5(k,j,i) = 1000.0d0
               mmff_ang6(k,j,i) = 1000.0d0
               mmff_ang7(k,j,i) = 1000.0d0
               mmff_ang8(k,j,i) = 1000.0d0
            end do
         end do
      end do
c
c     initialize values for MMFF stretch-bend parameters
c
      do i = 1, 100
         do j = 1, 100
            do k = 1, 100
               stbn_abc(k,j,i) = 1000.0d0
               stbn_cba(k,j,i) = 1000.0d0
               stbn_abc1(k,j,i) = 1000.0d0
               stbn_cba1(k,j,i) = 1000.0d0
               stbn_abc2(k,j,i) = 1000.0d0
               stbn_cba2(k,j,i) = 1000.0d0
               stbn_abc3(k,j,i) = 1000.0d0
               stbn_cba3(k,j,i) = 1000.0d0
               stbn_abc4(k,j,i) = 1000.0d0
               stbn_cba4(k,j,i) = 1000.0d0
               stbn_abc5(k,j,i) = 1000.0d0
               stbn_cba5(k,j,i) = 1000.0d0
               stbn_abc6(k,j,i) = 1000.0d0
               stbn_cba6(k,j,i) = 1000.0d0
               stbn_abc7(k,j,i) = 1000.0d0
               stbn_cba7(k,j,i) = 1000.0d0
               stbn_abc8(k,j,i) = 1000.0d0
               stbn_cba8(k,j,i) = 1000.0d0
               stbn_abc9(k,j,i) = 1000.0d0
               stbn_cba9(k,j,i) = 1000.0d0
               stbn_abc10(k,j,i) = 1000.0d0
               stbn_cba10(k,j,i) = 1000.0d0
               stbn_abc11(k,j,i) = 1000.0d0
               stbn_cba11(k,j,i) = 1000.0d0
            end do
         end do
      end do
c
c     initialize values for MMFF torsional parameters
c
      do i = 1, maxnt
         kt(i) = blank16
         kt_1(i) = blank16
         kt_2(i) = blank16
         t1(1,i) = 1000.0d0
         t1(2,i) = 1000.0d0
         t2(1,i) = 1000.0d0
         t2(2,i) = 1000.0d0
         t3(1,i) = 1000.0d0
         t3(2,i) = 1000.0d0
         t1_1(1,i) = 1000.0d0
         t1_1(2,i) = 1000.0d0
         t2_1(1,i) = 1000.0d0
         t2_1(2,i) = 1000.0d0
         t3_1(1,i) = 1000.0d0
         t3_1(2,i) = 1000.0d0
         t1_2(1,i) = 1000.0d0
         t1_2(2,i) = 1000.0d0
         t2_2(1,i) = 1000.0d0
         t2_2(2,i) = 1000.0d0
         t3_2(1,i) = 1000.0d0
         t3_2(2,i) = 1000.0d0
      end do
c
c     initialize values for MMFF bond charge increment parameters
c
      do i = 1, 100
         do j = 1, 100
            bci(j,i) = 1000.0d0
            bci_1(j,i) = 1000.0d0
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine initres  --  setup biopolymer residue names  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "initres" sets biopolymer residue names and biotype codes used
c     in PDB file conversion and automated generation of structures
c
c
      subroutine initres
      use resdue
      implicit none
      integer i
      integer nt(maxamino),cat(maxamino)
      integer ct(maxamino),hnt(maxamino)
      integer ot(maxamino),hat(maxamino)
      integer cbt(maxamino)
      integer nn(maxamino),can(maxamino)
      integer cn(maxamino),hnn(maxamino)
      integer on(maxamino),han(maxamino)
      integer nc(maxamino),cac(maxamino)
      integer cc(maxamino),hnc(maxamino)
      integer oc(maxamino),hac(maxamino)
      integer o5t(maxnuc),c5t(maxnuc)
      integer h51t(maxnuc),h52t(maxnuc)
      integer c4t(maxnuc),h4t(maxnuc)
      integer o4t(maxnuc),c1t(maxnuc)
      integer h1t(maxnuc),c3t(maxnuc)
      integer h3t(maxnuc),c2t(maxnuc)
      integer h21t(maxnuc),o2t(maxnuc)
      integer h22t(maxnuc),o3t(maxnuc)
      integer pt(maxnuc),opt(maxnuc)
      integer h5tt(maxnuc),h3tt(maxnuc)
      character*1 acid1(maxamino)
      character*1 base1(maxnuc)
      character*3 acid3(maxamino)
      character*3 base3(maxnuc)
c
c     supported amino acid 1-letter and 3-letter codes
c
      data acid1  / 'G', 'A', 'V', 'L', 'I', 'S', 'T', 'C', 'C', 'c',
     &              'P', 'F', 'Y', 'y', 'W', 'H', 'U', 'Z', 'D', 'd',
     &              'N', 'E', 'e', 'Q', 'M', 'K', 'k', 'R', 'O', 'B',
     &              'J', 't', 'f', 'a', 'x', 'n', 'm', 'X' /
      data acid3  / 'GLY', 'ALA', 'VAL', 'LEU', 'ILE', 'SER', 'THR',
     &              'CYS', 'CYX', 'CYD', 'PRO', 'PHE', 'TYR', 'TYD',
     &              'TRP', 'HIS', 'HID', 'HIE', 'ASP', 'ASH', 'ASN',
     &              'GLU', 'GLH', 'GLN', 'MET', 'LYS', 'LYD', 'ARG',
     &              'ORN', 'AIB', 'PCA', 'H2N', 'FOR', 'ACE', 'COH',
     &              'NH2', 'NME', 'UNK' /
c
c     supported nucleotide 1-letter and 3-letter codes
c
      data base1  / 'A', 'G', 'C', 'U', 'D', 'B', 'I', 'T', '1', '2',
     &              '3', 'X' /
      data base3  / '  A', '  G', '  C', '  U', ' DA', ' DG', ' DC',
     &              ' DT', ' MP', ' DP', ' TP', 'UNK' /
c
c     biopolymer types for mid-chain peptide backbone atoms
c
      data nt   /   1,   7,  15,  27,  41,  55,  65,  77,  87,  96,
     &            105, 116, 131, 147, 162, 185, 202, 218, 234, 244,
     &            256, 268, 280, 294, 308, 321, 337, 353, 370, 384,
     &            391,   0,   0,   0,   0,   0,   0,   1 /
      data cat  /   2,   8,  16,  28,  42,  56,  66,  78,  88,  97,
     &            106, 117, 132, 148, 163, 186, 203, 219, 235, 245,
     &            257, 269, 281, 295, 309, 322, 338, 354, 371, 385,
     &            392,   0,   0,   0,   0,   0,   0,   2 /
      data ct   /   3,   9,  17,  29,  43,  57,  67,  79,  89,  98,
     &            107, 118, 133, 149, 164, 187, 204, 220, 236, 246,
     &            258, 270, 282, 296, 310, 323, 339, 355, 372, 386,
     &            393,   0,   0,   0,   0,   0,   0,   3 /
      data hnt  /   4,  10,  18,  30,  44,  58,  68,  80,  90,  99,
     &              0, 119, 134, 150, 165, 188, 205, 221, 237, 247,
     &            259, 271, 283, 297, 311, 324, 340, 356, 373, 387,
     &            394,   0,   0,   0,   0,   0,   0,   4 /
      data ot   /   5,  11,  19,  31,  45,  59,  69,  81,  91, 100,
     &            108, 120, 135, 151, 166, 189, 206, 222, 238, 248,
     &            260, 272, 284, 298, 312, 325, 341, 357, 374, 388,
     &            395,   0,   0,   0,   0,   0,   0,   5 /
      data hat  /   6,  12,  20,  32,  46,  60,  70,  82,  92, 101,
     &            109, 121, 136, 152, 167, 190, 207, 223, 239, 249,
     &            261, 273, 285, 299, 313, 326, 342, 358, 375,   0,
     &            396,   0,   0,   0,   0,   0,   0,   6 /
      data cbt  /   0,  13,  21,  33,  47,  61,  71,  83,  93, 102,
     &            110, 122, 137, 153, 168, 191, 208, 224, 240, 250,
     &            262, 274, 286, 300, 314, 327, 343, 359, 376, 389,
     &            397,   0,   0,   0,   0,   0,   0,   0 /
c
c     biopolymer types for N-terminal peptide backbone atoms
c
      data nn   / 403, 409, 415, 421, 427, 433, 439, 445, 451, 457,
     &            463, 471, 477, 483, 489, 495, 501, 507, 513, 519,
     &            525, 531, 537, 543, 549, 555, 561, 567, 573, 579,
     &            391, 762,   0,   0,   0,   0,   0, 403 /
      data can  / 404, 410, 416, 422, 428, 434, 440, 446, 452, 458,
     &            464, 472, 478, 484, 490, 496, 502, 508, 514, 520,
     &            526, 532, 538, 544, 550, 556, 562, 568, 574, 580,
     &            392,   0,   0, 767,   0,   0,   0, 404 /
      data cn   / 405, 411, 417, 423, 429, 435, 441, 447, 453, 459,
     &            465, 473, 479, 485, 491, 497, 503, 509, 515, 521,
     &            527, 533, 539, 545, 551, 557, 563, 569, 575, 581,
     &            393,   0, 764, 769,   0,   0,   0, 405 /
      data hnn  / 406, 412, 418, 424, 430, 436, 442, 448, 454, 460,
     &            466, 474, 480, 486, 492, 498, 504, 510, 516, 522,
     &            528, 534, 540, 546, 552, 558, 564, 570, 576, 582,
     &            394, 763,   0,   0,   0,   0,   0, 406 /
      data on   / 407, 413, 419, 425, 431, 437, 443, 449, 455, 461,
     &            467, 475, 481, 487, 493, 499, 505, 511, 517, 523,
     &            529, 535, 541, 547, 553, 559, 565, 571, 577, 583,
     &            395,   0, 766, 770,   0,   0,   0, 407 /
      data han  / 408, 414, 420, 426, 432, 438, 444, 450, 456, 462,
     &            468, 476, 482, 488, 494, 500, 506, 512, 518, 524,
     &            530, 536, 542, 548, 554, 560, 566, 572, 578,   0,
     &            396,   0, 765, 768,   0,   0,   0, 408 /
c
c     biopolymer types for C-terminal peptide backbone atoms
c
      data nc   / 584, 590, 596, 602, 608, 614, 620, 626, 632, 638,
     &            644, 649, 655, 661, 667, 673, 679, 685, 691, 697,
     &            703, 709, 715, 721, 727, 733, 739, 745, 751, 757,
     &              0,   0,   0,   0, 773, 775, 777, 584 /
      data cac  / 585, 591, 597, 603, 609, 615, 621, 627, 633, 639,
     &            645, 650, 656, 662, 668, 674, 680, 686, 692, 698,
     &            704, 710, 716, 722, 728, 734, 740, 746, 752, 758,
     &              0,   0,   0,   0,   0,   0, 779, 585 /
      data cc   / 586, 592, 598, 604, 610, 616, 622, 628, 634, 640,
     &            646, 651, 657, 663, 669, 675, 681, 687, 693, 699,
     &            705, 711, 717, 723, 729, 735, 741, 747, 753, 759,
     &              0,   0,   0,   0, 771,   0,   0, 586 /
      data hnc  / 587, 593, 599, 605, 611, 617, 623, 629, 635, 641,
     &              0, 652, 658, 664, 670, 676, 682, 688, 694, 700,
     &            706, 712, 718, 724, 730, 736, 742, 748, 754, 760,
     &              0,   0,   0,   0, 774, 776, 778, 587 /
      data oc   / 588, 594, 600, 606, 612, 618, 624, 630, 636, 642,
     &            647, 653, 659, 665, 671, 677, 683, 689, 695, 701,
     &            707, 713, 719, 725, 731, 737, 743, 749, 755, 761,
     &              0,   0,   0,   0, 772,   0,   0, 588 /
      data hac  / 589, 595, 601, 607, 613, 619, 625, 631, 637, 643,
     &            648, 654, 660, 666, 672, 678, 684, 690, 696, 702,
     &            708, 714, 720, 726, 732, 738, 744, 750, 756,   0,
     &              0,   0,   0,   0,   0,   0, 780, 589 /
c
c     biopolymer types for nucleotide phosphate and sugar atoms
c
      data o5t   / 1001, 1031, 1062, 1090, 1117, 1146, 1176, 1203,
     &                0,    0,    0,    0 /
      data c5t   / 1002, 1032, 1063, 1091, 1118, 1147, 1177, 1204,
     &                0,    0,    0,    0 /
      data h51t  / 1003, 1033, 1064, 1092, 1119, 1148, 1178, 1205,
     &                0,    0,    0,    0 /
      data h52t  / 1004, 1034, 1065, 1093, 1120, 1149, 1179, 1206,
     &                0,    0,    0,    0 /
      data c4t   / 1005, 1035, 1066, 1094, 1121, 1150, 1180, 1207,
     &                0,    0,    0,    0 /
      data h4t   / 1006, 1036, 1067, 1095, 1122, 1151, 1181, 1208,
     &                0,    0,    0,    0 /
      data o4t   / 1007, 1037, 1068, 1096, 1123, 1152, 1182, 1209,
     &                0,    0,    0,    0 /
      data c1t   / 1008, 1038, 1069, 1097, 1124, 1153, 1183, 1210,
     &                0,    0,    0,    0 /
      data h1t   / 1009, 1039, 1070, 1098, 1125, 1154, 1184, 1211,
     &                0,    0,    0,    0 /
      data c3t   / 1010, 1040, 1071, 1099, 1126, 1155, 1185, 1212,
     &                0,    0,    0,    0 /
      data h3t   / 1011, 1041, 1072, 1100, 1127, 1156, 1186, 1213,
     &                0,    0,    0,    0 /
      data c2t   / 1012, 1042, 1073, 1101, 1128, 1157, 1187, 1214,
     &                0,    0,    0,    0 /
      data h21t  / 1013, 1043, 1074, 1102, 1129, 1158, 1188, 1215,
     &                0,    0,    0,    0 /
      data o2t   / 1014, 1044, 1075, 1103,    0,    0,    0,    0,
     &                0,    0,    0,    0 /
      data h22t  / 1015, 1045, 1076, 1104, 1130, 1159, 1189, 1216,
     &                0,    0,    0,    0 /
      data o3t   / 1016, 1046, 1077, 1105, 1131, 1160, 1190, 1217,
     &                0,    0,    0,    0 /
      data pt    / 1230, 1230, 1230, 1230, 1242, 1242, 1242, 1242,
     &                0,    0,    0,    0 /
      data opt   / 1231, 1231, 1231, 1231, 1243, 1243, 1243, 1243,
     &                0,    0,    0,    0 /
      data h5tt  / 1233, 1233, 1233, 1233, 1245, 1245, 1245, 1245,
     &                0,    0,    0,    0 /
      data h3tt  / 1238, 1238, 1238, 1238, 1250, 1250, 1250, 1250,
     &                0,    0,    0,    0 /
c
c
c     set amino acid names and peptide backbone biotypes
c
      do i = 1, maxamino
         amino(i) = acid3(i)
         amino1(i) = acid1(i)
         ntyp(i) = nt(i)
         catyp(i) = cat(i)
         ctyp(i) = ct(i)
         hntyp(i) = hnt(i)
         otyp(i) = ot(i)
         hatyp(i) = hat(i)
         cbtyp(i) = cbt(i)
         nntyp(i) = nn(i)
         cantyp(i) = can(i)
         cntyp(i) = cn(i)
         hnntyp(i) = hnn(i)
         ontyp(i) = on(i)
         hantyp(i) = han(i)
         nctyp(i) = nc(i)
         cactyp(i) = cac(i)
         cctyp(i) = cc(i)
         hnctyp(i) = hnc(i)
         octyp(i) = oc(i)
         hactyp(i) = hac(i)
      end do
c
c     set values for the 1- and 3-letter nucleotide names
c
      do i = 1, maxnuc
         nuclz(i) = base3(i)
         nuclz1(i) = base1(i)
         o5typ(i) = o5t(i)
         c5typ(i) = c5t(i)
         h51typ(i) = h51t(i)
         h52typ(i) = h52t(i)
         c4typ(i) = c4t(i)
         h4typ(i) = h4t(i)
         o4typ(i) = o4t(i)
         c1typ(i) = c1t(i)
         h1typ(i) = h1t(i)
         c3typ(i) = c3t(i)
         h3typ(i) = h3t(i)
         c2typ(i) = c2t(i)
         h21typ(i) = h21t(i)
         o2typ(i) = o2t(i)
         h22typ(i) = h22t(i)
         o3typ(i) = o3t(i)
         ptyp(i) = pt(i)
         optyp(i) = opt(i)
         h5ttyp(i) = h5tt(i)
         h3ttyp(i) = h3tt(i)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine initrot  --  set bonds for dihedral rotation  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "initrot" sets the torsional angles which are to be rotated
c     in subsequent computation, by default automatically selects
c     all rotatable single bonds; optionally makes atoms inactive
c     when they are not moved by any torsional rotation
c
c     note that internal coordinates must already be setup
c
c
      subroutine initrot
      use atoms
      use couple
      use group
      use inform
      use iounit
      use math
      use omega
      use potent
      use restrn
      use rotbnd
      use usage
      use zcoord
      implicit none
      integer i,j,j1,j2
      integer mode,iring
      integer bond1,bond2
      integer attach1,attach2
      integer nlist,nfixed
      integer, allocatable :: list(:)
      integer, allocatable :: ifixed(:,:)
      logical exist,query
      logical rotate,rotcheck
      logical use_partial
      character*240 record
      character*240 string
c
c
c     initialize the number of rotatable torsional angles
c
      nomega = 0
c
c     use partial structure, mark inactive any atoms that do not move;
c     faster for limited torsions, only use with pairwise potentials
c
      use_partial = .true.
      if (use_polar)  use_partial = .false.
c
c     use shortest rotlist if there is no absolute coordinate frame
c
      use_short = .true.
      if (use_group)  use_short = .false.
      if (npfix .ne. 0)  use_short = .false.
c
c     choose automatic or manual selection of torsional angles
c
      mode = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  mode
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' Selection of Torsional Angles for Rotation :',
     &           //,'    0  - Automatic Selection of Torsional Angles',
     &            /,'    1  - Manual Selection of Angles to Rotate',
     &            /,'    2  - Manual Selection of Angles to Freeze',
     &           //,' Enter the Method of Choice [0] :  ',$)
         read (input,30)  mode
   30    format (i10)
      end if
      if (mode.ne.1 .and. mode.ne.2)  mode = 0
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(iomega))  allocate (iomega(2,n))
      if (.not. allocated(zline))  allocate (zline(n))
      if (.not. allocated(dihed))  allocate (dihed(n))
c
c     manual selection of the torsional angles to be rotated
c
      if (mode .eq. 1) then
         do while (.true.)
            nomega = nomega + 1
            j1 = 0
            j2 = 0
            write (iout,40)  nomega
   40       format (/,' Enter Atoms in Rotatable Bond',i5,' :  ',$)
            read (input,50)  record
   50       format (a240)
            read (record,*,err=80,end=80)  j1,j2
            if (j1.eq.0 .and. j2.eq.0)  goto 80
            do i = 4, n
               if (iz(4,i) .eq. 0) then
                  bond1 = iz(1,i)
                  bond2 = iz(2,i)
                  attach1 = n12(bond1)
                  attach2 = n12(bond2)
                  if (attach1.gt.1 .and. attach2.gt.1) then
                     if ((bond1.eq.j1 .and. bond2.eq.j2) .or.
     &                   (bond1.eq.j2 .and. bond2.eq.j1)) then
                        if (rotcheck(bond1,bond2)) then
                           iomega(1,nomega) = bond1
                           iomega(2,nomega) = bond2
                           dihed(nomega) = ztors(i) / radian
                           zline(nomega) = i
                           goto 70
                        end if
                     end if
                  end if
               end if
            end do
            nomega = nomega - 1
            write (iout,60)  j1,j2
   60       format (/,' INITROT  --  Bond between Atoms',2i6,
     &                 ' is not Rotatable')
   70       continue
         end do
   80    continue
         nomega = nomega - 1
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (ifixed(2,n))
c
c     manual selection of the torsional angles to be frozen
c
      nfixed = 0
      if (mode .eq. 2) then
         do i = 1, n
            ifixed(1,i) = 0
            ifixed(2,i) = 0
            write (iout,90)  i
   90       format (/,' Enter Atoms in Frozen Bond',i5,' :  ',$)
            read (input,100)  record
  100       format (a240)
            read (record,*,err=110,end=110)  ifixed(1,i),ifixed(2,i)
            if (ifixed(1,i).eq.0 .or. ifixed(2,i).eq.0)  goto 110
            nfixed = nfixed + 1
         end do
  110    continue
      end if
c
c     perform the automatic selection of torsional angles to rotate
c
      if (mode.eq.0 .or. mode.eq.2) then
         do i = 4, n
            if (iz(4,i) .eq. 0) then
               rotate = .true.
               bond1 = iz(1,i)
               bond2 = iz(2,i)
c
c     do not rotate a bond if either bonded atom is univalent
c
               attach1 = n12(bond1)
               attach2 = n12(bond2)
               if (attach1.le.1 .or. attach2.le.1)  rotate = .false.
c
c     do not rotate a bond contained within a small ring
c
               iring = 0
               call chkring (iring,bond1,bond2,0,0)
               if (iring .ne. 0)  rotate = .false.
c
c     do not rotate bonds explicitly frozen by the user
c
               if (mode.eq.2 .and. rotate) then
                  do j = 1, nfixed
                     j1 = ifixed(1,j)
                     j2 = ifixed(2,j)
                     if ((bond1.eq.j1 .and. bond2.eq.j2) .or.
     &                   (bond1.eq.j2 .and. bond2.eq.j1)) then
                        rotate = .false.
                        goto 120
                     end if
                  end do
               end if
  120          continue
c
c     do not rotate bonds with inactive atoms on both sides
c
               if (rotate) then
                  if (.not. rotcheck(bond1,bond2))  rotate = .false.
               end if
c
c     check for possible duplication of rotatable bonds
c
               if (rotate) then
                  do j = 1, nomega
                     j1 = iomega(1,j)
                     j2 = iomega(2,j)
                     if ((bond1.eq.j1 .and. bond2.eq.j2) .or.
     &                   (bond1.eq.j2 .and. bond2.eq.j1)) then
                        write (iout,130)  bond1,bond2
  130                   format (/,' INITROT  --  Rotation about',2i6,
     &                             ' occurs more than once in Z-matrix')
                        call fatal
                     end if
                  end do
                  nomega = nomega + 1
                  iomega(1,nomega) = bond1
                  iomega(2,nomega) = bond2
                  dihed(nomega) = ztors(i) / radian
                  zline(nomega) = i
               end if
            end if
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (ifixed)
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
c
c     make inactive the atoms not rotatable via any torsion
c
      if (use_partial .and. nuse.eq.n) then
         do i = 1, n
            use(i) = .false.
         end do
         do i = 1, nomega
            bond1 = iomega(1,i)
            bond2 = iomega(2,i)
            call rotlist (bond1,bond2)
            do j = 1, nrot
               use(rot(j)) = .true.
            end do
         end do
         nuse = 0
         do i = 1, n
            if (use(i))  nuse = nuse + 1
         end do
         if (debug .and. nuse.gt.0 .and. nuse.lt.n) then
            nlist = 0
            do i = 1, n
               if (use(i)) then
                  nlist = nlist + 1
                  list(nlist) = i
               end if
            end do
            write (iout,140)
  140       format (/,' List of Active Atoms for Torsional',
     &                    ' Calculations :',/)
            write (iout,150)  (list(i),i=1,nlist)
  150       format (3x,10i7)
         end if
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (list)
c
c     write out the number of rotatable torsions to be used
c
      if (nomega .eq. 0) then
         write (iout,160)
  160    format (/,' INITROT  --  No Torsions for Subsequent',
     &              ' Computation')
         call fatal
      end if
      write (iout,170)  nomega
  170 format (/,' Number of Torsions Used in Derivative',
     &           ' Computation :',i6)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function rotcheck  --  check for fixed atoms across bond  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "rotcheck" tests a specified candidate rotatable bond for
c     the disallowed case where inactive atoms are found on both
c     sides of the candidate bond
c
c
      function rotcheck (base,partner)
      use atoms
      use rotbnd
      use usage
      implicit none
      integer i,base,partner
      logical rotcheck,value
      logical, allocatable :: list(:)
c
c
c     initialize status and find atoms on short side of the bond
c
      value = .true.
      call rotlist (base,partner)
c
c     rotation is allowed if all atoms on one side are active
c
      do i = 1, nrot
         if (.not. use(rot(i))) then
            value = .false.
            goto 10
         end if
      end do
   10 continue
c
c     if short side had inactive atoms, check the other side
c
      if (.not. value) then
         allocate (list(n))
         do i = 1, n
            list(i) = .true.
         end do
         do i = 1, nrot
            list(rot(i)) = .false.
         end do
         do i = 1, n
            if (list(i) .and. .not.use(i))  goto 20
         end do
         value = .true.
   20    continue
         deallocate (list)
      end if
c
c     set the final return value of the function
c
      rotcheck = value
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine insert  --  insert atom into coordinates list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "insert" adds the specified atom to the Cartesian
c     coordinates list and shifts the remaining atoms
c
c
      subroutine insert (iatom)
      use atomid
      use atoms
      use couple
      use inform
      use iounit
      implicit none
      integer i,j,iatom
c
c
c     increase by one the total number of atoms
c
      n = n + 1
c
c     shift the atom coordinates, types and connectivities
c
      do i = n, iatom+1, -1
         name(i) = name(i-1)
         x(i) = x(i-1)
         y(i) = y(i-1)
         z(i) = z(i-1)
         type(i) = type(i-1)
         n12(i) = n12(i-1)
         do j = 1, n12(i)
            i12(j,i) = i12(j,i-1)
         end do
      end do
c
c     put new atom at the origin with a big atom type number
c
      name(iatom) = 'NEW'
      x(iatom) = 0.0d0
      y(iatom) = 0.0d0
      z(iatom) = 0.0d0
      type(iatom) = maxtyp + 1
      n12(iatom) = 0
c
c     shift the connected atom lists to allow the insertion
c
      do i = 1, n
         do j = 1, n12(i)
            if (i12(j,i) .ge. iatom) then
               i12(j,i) = i12(j,i) + 1
            end if
         end do
      end do
c
c     write a message to describe the atom insertion
c
      if (debug) then
         write (iout,10)  iatom
   10    format (' INSERT  --  Inserting Atom Number :',i9)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  program intedit  --  edit and display Z-matrix file  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "intedit" allows the user to extract information from
c     or alter the values within an internal coordinates file
c
c
      program intedit
      use atomid
      use atoms
      use files
      use iounit
      use katoms
      use zcoord
      implicit none
      integer i,j,k,l,m
      integer izmt,space
      integer freeunit
      integer trimtext
      integer numrow,numcol
      integer next,number(4)
      real*8 value,geometry
      logical changed,error
      character*4 word
      character*240 zmtfile
      character*240 record
c
c
c     read coordinate file and force field definition
c
      call initial
      call getint
      call field
c
c     print out the instructions for the program
c
      next = 1
      changed = .false.
      error = .false.
   10 continue
      call zhelp
c
c     start of main loop, examine or change Z-matrix elements
c
   20 continue
      m = 0
      write (iout,30)
   30 format (/,' INTEDIT>  ',$)
      read (input,40)  record
   40 format (a240)
c
c     interpret any user entered text command
c
      space = 1
      call getword (record,word,space)
      call upcase (word)
      if (word .eq. 'EXIT') then
         if (changed) then
            izmt = freeunit ()
            zmtfile = filename(1:leng)//'.int'
            call version (zmtfile,'new')
            open (unit=izmt,file=zmtfile,status='new')
            call prtint (izmt)
            close (unit=izmt)
            write (iout,50)  zmtfile(1:trimtext(zmtfile))
   50       format (/,' Z-Matrix Internal Coordinates written to :  ',a)
         else
            write (iout,60)
   60       format (/,' The Z-Matrix was not Changed;',
     &                 ' No File was Written')
         end if
         goto 410
      else if (word .eq. 'QUIT') then
         goto 410
      else if (word .eq. 'SHOW') then
         write (iout,70)
   70    format ()
         call prtint (iout)
c
c     get the number of atoms entered by the user
c
      else
         do i = 1, 4
            number(i) = 0
         end do
         read (record,*,err=10,end=80)  (number(i),i=1,4)
   80    continue
         do i = 1, 4
            if (number(i) .ne. 0)  m = i
            if (number(i) .gt. n) then
               write (iout,90)  n
   90          format (/,' Warning; Only',i6,' Atoms are Present',
     &                     ' in the Z-matrix')
               goto 20
            end if
         end do
         if (m .eq. 0) then
            m = 1
            number(1) = next
         end if
      end if
c
c     get information about a single specified atom
c
      if (m .eq. 1) then
         i = number(1)
         write (iout,100)  i
  100    format (/,' Atom Number :',i8)
         write (iout,110)  name(i)
  110    format (' Atom Name :',6x,a4)
         write (iout,120)  describe(type(i))
  120    format (' Atom Type :',5x,a20)
         write (iout,130)  type(i)
  130    format (' Type Number :',i8)
         if (i .eq. 1) then
            write (iout,140)
  140       format (/,' Atom 1 is at the Coordinate System Origin')
         else
            write (iout,150)
  150       format (/,' Internal Coordinate Structural Definition :',/)
            write (iout,160)  iz(1,i),-i,zbond(i)
  160       format (1x,2i6,17x,'Distance Value :',f14.4)
            if (i .gt. 2) then
               write (iout,170)  iz(2,i),-iz(1,i),-i,zang(i)
  170          format (1x,3i6,11x,'Bond Angle Value :',f12.4)
               if (i .gt. 3) then
                  if (iz(4,i) .eq. 0) then
                     write (iout,180) iz(3,i),-iz(2,i),
     &                                -iz(1,i),-i,ztors(i)
  180                format (1x,4i6,5x,'Dihedral Angle :',f14.4)
                  else
                     write (iout,190)  iz(3,i),-iz(1,i),-i,ztors(i)
  190                format (1x,3i6,11x,'Bond Angle Value :',f12.4)
                     write (iout,200)  iz(4,i)
  200                format (30x,'Chirality Flag :',6x,i6)
                  end if
               end if
            end if
         end if
         next = i + 1
         if (next .gt. n)  next = 1
c
c     chirality change for an atom was requested
c
      else if (m.eq.2 .and. number(2).lt.0) then
         do i = 1, n
            if (iz(4,i).ne.0 .and. iz(1,i).eq.number(1)) then
               changed = .true.
               write (iout,210)  i
  210          format (/,' Inverting Chirality of Atom : ',i6)
               iz(4,i) = -iz(4,i)
            end if
         end do
         next = number(1)
         call makexyz
c
c     information about a specified bond or distance
c
      else if (m .eq. 2) then
         i = max(number(1),number(2))
         j = min(number(1),number(2))
         if (min(i,j).le.0 .and. max(i,j).gt.n) then
            write (iout,220)
  220       format (/,' Invalid Atom Number')
            error = .true.
         else
            if (j .ne. iz(1,i)) then
               value = geometry (i,j,0,0)
               write (iout,230)  value
  230          format (/,' The Current Distance is : ',f9.4)
               write (iout,240)
  240          format (' That Bond is not in the Z-matrix')
            else
               write (iout,250)  zbond(i)
  250          format (/,' The Current Distance is : ',f9.4)
               call zvalue ('Bond Length',zbond(i),changed)
               next = i
            end if
         end if
c
c     an atom type change was requested
c
      else if (m.eq.3 .and. number(2).lt.0) then
         if (number(3).gt.0 .and. number(3).le.maxtyp) then
            changed = .true.
            write (iout,260)  describe(type(number(1)))
  260       format (/,' Old Atom Type is :  ',a20)
            type(number(1)) = number(3)
            write (iout,270)  describe(type(number(1)))
  270       format (' New Atom Type is :  ',a20)
         else
            write (iout,280)
  280       format (/,' Invalid Atom Type; Valid Types are :',/)
            numrow = (maxtyp+2) / 3
            numcol = 2
            do i = 1, numrow
               if (i .gt. numrow-2+mod(maxtyp-1,3))  numcol = 1
               write (iout,290)  (j*numrow+i,describe(j*numrow+i),
     &                                      j=0,numcol)
  290          format (1x,3(i3,1x,a20,2x))
            end do
         end if
c
c     information about a specified bond angle
c
      else if (m .eq. 3) then
         i = max(number(1),number(3))
         j = number(2)
         k = min(number(1),number(3))
         if (min(i,j,k).le.0 .or. max(i,j,k).gt.n) then
            write (iout,300)
  300       format (/,' Invalid Atom Number')
            error = .true.
         else
            if (iz(1,i) .ne. j) then
               value = geometry (i,j,k,0)
               write (iout,310)  value
  310          format (/,' The Bond Angle Value is :  ',f9.4)
               write (iout,320)
  320          format (' That Bond Angle is not in the Z-matrix')
            else if (iz(2,i) .eq. k) then
               write (iout,330)  zang(i)
  330          format (/,' The Bond Angle Value is :  ',f9.4)
               call zvalue ('Bond Angle',zang(i),changed)
               next = i
            else if (iz(3,i).eq.k .and. iz(4,i).ne.0) then
               write (iout,340)  ztors(i)
  340          format (/,' The Bond Angle Value is :  ',f9.4)
               call zvalue ('Bond Angle',ztors(i),changed)
               next = i
            else
               value = geometry (i,j,k,0)
               write (iout,350)  value
  350          format (/,' The Bond Angle Value is :  ',f9.4)
               write (iout,360)
  360          format (' That Bond Angle is not in the Z-matrix')
            end if
         end if
c
c    information about a specified dihedral angle
c
      else if (m .eq. 4) then
         if (number(1) .gt. number(4)) then
            i = number(1)
            j = number(2)
            k = number(3)
            l = number(4)
         else
            i = number(4)
            j = number(3)
            k = number(2)
            l = number(1)
         end if
         if (min(i,j,k,l).le.0 .or. max(i,j,k,l).gt.n) then
            write (iout,370)
  370       format (/,' Invalid Atom Number')
            error = .true.
         else
            if (iz(1,i).ne.j .or. iz(2,i).ne.k .or.
     &          iz(3,i).ne.l .or. iz(4,i).ne.0) then
               value = geometry (i,j,k,l)
               write (iout,380)  value
  380          format (/,' The Dihedral Angle Value is :  ',f9.4)
               write (iout,390)
  390          format (' That Dihedral Angle is not in the Z-matrix')
            else
               write (iout,400)  ztors(i)
  400          format (/,' The Dihedral Angle Value is :  ',f9.4)
               call zvalue ('Dihedral Angle',ztors(i),changed)
               next = i
            end if
         end if
      end if
c
c     print instructions for the program if needed
c
      if (error) then
         error = .false.
         call zhelp
      end if
      goto 20
c
c     perform any final tasks before program exit
c
  410 continue
      call final
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine zhelp  --  print Z-matrix editing instructions  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "zhelp" prints the general information and instructions
c     for the Z-matrix editing program
c
c
      subroutine zhelp
      use iounit
      implicit none
c
c
c     print the help and information message for Z-matrix editing
c
      write (iout,10)
   10 format (/,' If a single atom number is entered, the',
     &           ' current definition of',
     &        /,' the atom will be displayed.',
     &        //,' If two atom numbers are entered, the output',
     &           ' gives the distance',
     &        /,' between the atoms, and asks for a new bond',
     &           ' length if applicable;',
     &        /,' Entry of three atoms shows the angle, and',
     &           ' entry of four atoms',
     &        /,' will display the corresponding dihedral angle.',
     &        //,' To change the chirality at an atom, enter',
     &           ' its number and -1.',
     &        /,' To change the type of an atom, enter its',
     &           ' number, -1, and the',
     &        /,' new atom type number.')
      write (iout,20)
   20 format (/,' A carriage return at the prompt will display',
     &           ' the atom last',
     &        /,' changed or the next atom after the one just',
     &           ' examined.',
     &        //,' Typing SHOW will display the contents of the',
     &           ' current Z-matrix.',
     &        //,' Entering EXIT writes a new file then stops,',
     &           ' while QUIT aborts.')
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine zvalue  --  gets user input Z-matrix value  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "zvalue" gets user supplied values for selected coordinates
c     as needed by the internal coordinate editing program
c
c
      subroutine zvalue (text,x,changed)
      use iounit
      implicit none
      integer length
      integer trimtext
      real*8 x,xnew
      logical changed
      character*240 record
      character*(*) text
c
c
c     ask the user for the new internal coordinate value
c
      xnew = x
      write (iout,10)  text
   10 format (/,' Enter the New ',a,' :  ',$)
      read (input,20)  record
   20 format (a240)
      length = trimtext (record)
      if (length .ne. 0) then
         read (record,*,end=30,err=30)  xnew
   30    continue
      end if
c
c     return with the altered value and recompute coordinates
c
      if (xnew .ne. x) then
         changed = .true.
         x = xnew
         call makexyz
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module inter  --  sum of intermolecular energy components  ##
c     ##                                                             ##
c     #################################################################
c
c
c     einter   total intermolecular potential energy
c
c
      module inter
      implicit none
      real*8 einter
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  program intxyz  --  internal to Cartesian coordinates  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "intxyz" takes as input an internal coordinates file,
c     converts to and then writes out Cartesian coordinates
c
c
      program intxyz
      use files
      use iounit
      use titles
      implicit none
      integer ixyz,freeunit
      character*240 xyzfile
c
c
c     get and read the internal coordinates file;
c     conversion to Cartesians is done in "getint"
c
      call initial
      call getint
      write (iout,10)  title(1:ltitle)
   10 format (/,' Title :  ',a)
c
c     write out the Cartesian coordinates file
c
      ixyz = freeunit ()
      xyzfile = filename(1:leng)//'.xyz'
      call version (xyzfile,'new')
      open (unit=ixyz,file=xyzfile,status='new')
      call prtxyz (ixyz)
      close (unit=ixyz)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  function invbeta  --  inverse Beta distribution function  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "invbeta" computes the inverse Beta distribution function
c     via a combination of Newton iteration and bisection search
c
c     literature reference:
c
c     K. L. Majumder and G. P. Bhattacharjee, "Inverse of the
c     Incomplete Beta Function Ratio", Applied Statistics, 22,
c     411-414 (1973)
c
c
      function invbeta (a,b,y)
      implicit none
      real*8 eps
      parameter (eps=1.0d-5)
      real*8 invbeta,a,b,y
      real*8 x,x0,x1
      real*8 aexp,bexp,beta
      real*8 mean,stdev
      real*8 betai,gammln
      real*8 slope,error
      logical done
      external betai
c
c
c     use limiting values when input argument is out of range
c
      done = .false.
      if (y .le. 0.0d0) then
         x = 0.0d0
         done = .true.
      else if (y .ge. 1.0d0) then
         x = 1.0d0
         done = .true.
      end if
c
c     initial guess from mean and variance of probability function
c
      if (.not. done) then
         aexp = a - 1.0d0
         bexp = b - 1.0d0
         beta = exp(gammln(a) + gammln(b) - gammln(a+b))
         mean = a / (a+b)
         stdev = sqrt(a*b/((a+b+1.0d0)*(a+b)**2))
         if (y.gt.0.0d0 .and. y.le.0.167d0) then
            x = mean + (y/0.167d0-2.0d0)*stdev
         else if (y.gt.0.167d0 .and. y.lt.0.833d0) then
            x = mean + (y/0.333d0-1.5d0)*stdev
         else if (y.ge.0.833d0 .and. y.lt.1.0d0) then
            x = mean + (y/0.167d0-4.0d0)*stdev
         end if
         x = max(eps,min(1.0d0-eps,x))
      end if
c
c     refine inverse distribution value via Newton iteration
c
      do while (.not. done)
         slope = (x**aexp * (1.0d0-x)**bexp) / beta
         error = betai(a,b,x) - y
         x = x - error/slope
         if (abs(error) .lt. eps)  done = .true.
         if (x.lt.0.0d0 .or. x.gt.1.0d0)  done = .true.
      end do
c
c     try bisection search if Newton iteration moved out of range
c
      if (x.lt.0.0d0 .or. x.gt.1.0d0) then
         x0 = 0.0d0
         x1 = 1.0d0
         done = .false.
      end if
c
c     refine inverse distribution value via bisection search
c
      do while (.not. done)
         x = 0.5d0 * (x0+x1)
         error = betai(a,b,x) - y
         if (error .gt. 0.0d0)  x1 = x
         if (error .lt. 0.0d0)  x0 = x
         if (abs(error) .lt. eps)  done = .true.
      end do
c
c     return best estimate of the inverse beta distribution value
c
      invbeta = x
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  function betai  --  cumulative Beta distribution function  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "betai" evaluates the cumulative Beta distribution function
c     as the probability that a random variable from a distribution
c     with Beta parameters "a" and "b" will be less than "x"
c
c
      function betai (a,b,x)
      implicit none
      real*8 betai,a,b,x
      real*8 bt,gammln
      real*8 betacf
      external betacf
c
c
c     get cumulative distribution directly or via reflection
c
      if (x .le. 0.0d0) then
         betai = 0.0d0
      else if (x .ge. 1.0d0) then
         betai = 1.0d0
      else
         bt = exp(gammln(a+b) - gammln(a) - gammln(b)
     &               + a*log(x) + b*log(1.0d0-x))
         if (x .lt. (a+1.0d0)/(a+b+2.0d0)) then
            betai = (bt/a) * betacf (a,b,x)
         else
            betai = 1.0d0 - (bt/b) * betacf (b,a,1.0d0-x)
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  function betacf  --  continued fraction routine for betai  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "betacf" computes a rapidly convergent continued fraction needed
c     by routine "betai" to evaluate the cumulative Beta distribution
c
c
      function betacf (a,b,x)
      implicit none
      integer maxiter
      real*8 eps,delta
      parameter (maxiter=100)
      parameter (eps=1.0d-10)
      parameter (delta=1.0d-30)
      integer i
      real*8 betacf,a,b,x
      real*8 m,m2,aa
      real*8 c,d,del,h
      real*8 qab,qam,qap
c
c
c     establish an initial guess for the Beta continued fraction
c
      qab = a + b
      qap = a + 1.0d0
      qam = a - 1.0d0
      c = 1.0d0
      d = 1.0d0 - qab*x/qap
      if (abs(d) .lt. delta)  d = delta
      d = 1.0d0 / d
      h = d
c
c     iteratively improve the continued fraction to convergence
c
      do i = 1, maxiter
         m = dble(i)
         m2 = 2.0d0 * m
         aa = m * (b-m) * x / ((qam+m2)*(a+m2))
         d = 1.0d0 + aa*d
         if (abs(d) .lt. delta)  d = delta
         c = 1.0d0 + aa/c
         if (abs(c) .lt. delta)  c = delta
         d = 1.0d0 / d
         h = h * d * c
         aa = -(a+m) * (qab+m) * x / ((a+m2)*(qap+m2))
         d = 1.0d0 + aa*d
         if (abs(d) .lt. delta)  d = delta
         c = 1.0d0 + aa/c
         if (abs(c) .lt. delta)  c = delta
         d = 1.0d0 / d
         del = d * c
         h = h * del
         if (abs(del-1.0d0) .lt. eps)  goto 10
      end do
   10 continue
      betacf = h
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function gammln  --  natural log of the Gamma function  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "gammln" uses a series expansion due to Lanczos to compute
c     the natural logarithm of the Gamma function at "x" in [0,1]
c
c
      function gammln (x)
      implicit none
      real*8 step,c0,c1,c2,c3,c4,c5,c6
      parameter (step=2.5066282746310005d0)
      parameter (c0=1.000000000190015d0)
      parameter (c1=7.618009172947146d1)
      parameter (c2=-8.650532032941677d1)
      parameter (c3=2.401409824083091d1)
      parameter (c4=-1.231739572450155d0)
      parameter (c5=1.208650973866179d-3)
      parameter (c6=-5.395239384953d-6)
      real*8 gammln,x
      real*8 series,temp
c
c
c     get the natural log of Gamma via a series expansion
c
      temp = x + 5.5d0
      temp = (x+0.5d0)*log(temp) - temp
      series = c0 + c1/(x+1.0d0) + c2/(x+2.0d0) + c3/(x+3.0d0)
     &            + c4/(x+4.0d0) + c5/(x+5.0d0) + c6/(x+6.0d0)
      gammln = temp + log(step*series/x)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine invert  --  gauss-jordan matrix inversion  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "invert" inverts a matrix using the Gauss-Jordan method
c
c     variables and parameters:
c
c     n     dimension of the matrix to be inverted
c     a     matrix to invert; contains inverse on exit
c
c
      subroutine invert (n,a)
      use iounit
      implicit none
      integer i,j,k,n
      integer icol,irow
      integer, allocatable :: ipivot(:)
      integer, allocatable :: indxc(:)
      integer, allocatable :: indxr(:)
      real*8 big,temp
      real*8 pivot
      real*8 a(n,*)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (ipivot(n))
      allocate (indxc(n))
      allocate (indxr(n))
c
c     perform matrix inversion via the Gauss-Jordan algorithm
c
      do i = 1, n
         ipivot(i) = 0
      end do
      do i = 1, n
         big = 0.0d0
         do j = 1, n
            if (ipivot(j) .ne. 1) then
               do k = 1, n
                  if (ipivot(k) .eq. 0) then
                     if (abs(a(j,k)) .ge. big) then
                        big = abs(a(j,k))
                        irow = j
                        icol = k
                     end if
                  else if (ipivot(k) .gt. 1) then
                     write (iout,10)
   10                format (/,' INVERT  --  Cannot Invert',
     &                          ' a Singular Matrix')
                     call fatal
                  end if
               end do
            end if
         end do
         ipivot(icol) = ipivot(icol) + 1
         if (irow .ne. icol) then
            do j = 1, n
               temp = a(irow,j)
               a(irow,j) = a(icol,j)
               a(icol,j) = temp
            end do
         end if
         indxr(i) = irow
         indxc(i) = icol
         if (a(icol,icol) .eq. 0.0d0) then
            write (iout,20)
   20       format (/,' INVERT  --  Cannot Invert a Singular Matrix')
            call fatal
         end if
         pivot = a(icol,icol)
         a(icol,icol) = 1.0d0
         do j = 1, n
            a(icol,j) = a(icol,j) / pivot
         end do
         do j = 1, n
            if (j .ne. icol) then
               temp = a(j,icol)
               a(j,icol) = 0.0d0
               do k = 1, n
                  a(j,k) = a(j,k) - a(icol,k)*temp
               end do
            end if
         end do
      end do
      do i = n, 1, -1
         if (indxr(i) .ne. indxc(i)) then
            do k = 1, n
               temp = a(k,indxr(i))
               a(k,indxr(i)) = a(k,indxc(i))
               a(k,indxc(i)) = temp
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (ipivot)
      deallocate (indxc)
      deallocate (indxr)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module iounit  --  Fortran input/output unit numbers  ##
c     ##                                                        ##
c     ############################################################
c
c
c     input   Fortran I/O unit for main input (default=5)
c     iout    Fortran I/O unit for main output (default=6)
c
c
      module iounit
      implicit none
      integer input
      integer iout
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine jacobi  --  jacobi matrix diagonalization  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "jacobi" performs a matrix diagonalization of a real
c     symmetric matrix by the method of Jacobi rotations
c
c     variables and parameters:
c
c     n     dimension of the matrix to be diagonalized
c     a     input with the matrix to be diagonalized; only
c              the upper triangle and diagonal are required
c     d     returned with the eigenvalues in ascending order
c     v     returned with the eigenvectors of the matrix
c     b     temporary work vector
c     z     temporary work vector
c
c
      subroutine jacobi (n,a,d,v)
      use iounit
      implicit none
      integer i,j,k
      integer n,ip,iq
      integer nrot,maxrot
      real*8 sm,tresh,s,c,t
      real*8 theta,tau,h,g,p
      real*8 d(*)
      real*8, allocatable :: b(:)
      real*8, allocatable :: z(:)
      real*8 a(n,*)
      real*8 v(n,*)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (b(n))
      allocate (z(n))
c
c     setup and initialization
c
      maxrot = 100
      nrot = 0
      do ip = 1, n
         do iq = 1, n
            v(ip,iq) = 0.0d0
         end do
         v(ip,ip) = 1.0d0
      end do
      do ip = 1, n
         b(ip) = a(ip,ip)
         d(ip) = b(ip)
         z(ip) = 0.0d0
      end do
c
c     perform the jacobi rotations
c
      do i = 1, maxrot
         sm = 0.0d0
         do ip = 1, n-1
            do iq = ip+1, n
               sm = sm + abs(a(ip,iq))
            end do
         end do
         if (sm .eq. 0.0d0)  goto 10
         if (i .lt. 4) then
            tresh = 0.2d0*sm / n**2
         else
            tresh = 0.0d0
         end if
         do ip = 1, n-1
            do iq = ip+1, n
               g = 100.0d0 * abs(a(ip,iq))
               if (i.gt.4 .and. abs(d(ip))+g.eq.abs(d(ip))
     &                    .and. abs(d(iq))+g.eq.abs(d(iq))) then
                  a(ip,iq) = 0.0d0
               else if (abs(a(ip,iq)) .gt. tresh) then
                  h = d(iq) - d(ip)
                  if (abs(h)+g .eq. abs(h)) then
                     t = a(ip,iq) / h
                  else
                     theta = 0.5d0*h / a(ip,iq)
                     t = 1.0d0 / (abs(theta)+sqrt(1.0d0+theta**2))
                     if (theta .lt. 0.0d0)  t = -t
                  end if
                  c = 1.0d0 / sqrt(1.0d0+t**2)
                  s = t * c
                  tau = s / (1.0d0+c)
                  h = t * a(ip,iq)
                  z(ip) = z(ip) - h
                  z(iq) = z(iq) + h
                  d(ip) = d(ip) - h
                  d(iq) = d(iq) + h
                  a(ip,iq) = 0.0d0
                  do j = 1, ip-1
                     g = a(j,ip)
                     h = a(j,iq)
                     a(j,ip) = g - s*(h+g*tau)
                     a(j,iq) = h + s*(g-h*tau)
                  end do
                  do j = ip+1, iq-1
                     g = a(ip,j)
                     h = a(j,iq)
                     a(ip,j) = g - s*(h+g*tau)
                     a(j,iq) = h + s*(g-h*tau)
                  end do
                  do j = iq+1, n
                     g = a(ip,j)
                     h = a(iq,j)
                     a(ip,j) = g - s*(h+g*tau)
                     a(iq,j) = h + s*(g-h*tau)
                  end do
                  do j = 1, n
                     g = v(j,ip)
                     h = v(j,iq)
                     v(j,ip) = g - s*(h+g*tau)
                     v(j,iq) = h + s*(g-h*tau)
                  end do
                  nrot = nrot + 1
               end if
            end do
         end do
         do ip = 1, n
            b(ip) = b(ip) + z(ip)
            d(ip) = b(ip)
            z(ip) = 0.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (b)
      deallocate (z)
c
c     print warning if not converged
c
   10 continue
      if (nrot .eq. maxrot) then
         write (iout,20)
   20    format (/,' JACOBI  --  Matrix Diagonalization not Converged')
      end if
c
c     sort the eigenvalues and vectors
c
      do i = 1, n-1
         k = i
         p = d(i)
         do j = i+1, n
            if (d(j) .lt. p) then
               k = j
               p = d(j)
            end if
         end do
         if (k .ne. i) then
            d(k) = d(i)
            d(i) = p
            do j = 1, n
               p = v(j,i)
               v(j,i) = v(j,k)
               v(j,k) = p
            end do
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module kanang  --  angle-angle term forcefield parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     anan   angle-angle cross term parameters for each atom class
c
c
      module kanang
      implicit none
      real*8, allocatable :: anan(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine kangang  --  angle-angle parameter assignment  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "kangang" assigns the parameters for angle-angle cross term
c     interactions and processes new or changed parameter values
c
c
      subroutine kangang
      use angang
      use angbnd
      use atmlst
      use atomid
      use atoms
      use couple
      use inform
      use iounit
      use kanang
      use keys
      use potent
      use tors
      implicit none
      integer i,j,k,m,next
      integer it,ia,ic
      integer nang,jang,kang
      integer maxaa
      real*8 fa,faa,aak(3)
      logical header
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing angle-angle parameters
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. 'ANGANG ') then
            it = 0
            do j = 1, 3
               aak(j) = 0.0d0
            end do
            string = record(next:240)
            read (string,*,err=10,end=10)  it,(aak(j),j=1,3)
   10       continue
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Angle-Angle Parameters :',
     &                    //,5x,'Atom Class',12x,'K(AA)-1',8x,'K(AA)-2',
     &                       8x,'K(AA)-3',/)
               end if
               write (iout,30)  it,(aak(j),j=1,3)
   30          format (9x,i3,7x,3f15.3)
            end if
            do j = 1, 3
               anan(j,it) = aak(j)
            end do
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      maxaa = 15 * n
      if (allocated(iaa))  deallocate (iaa)
      if (allocated(kaa))  deallocate (kaa)
      allocate (iaa(2,maxaa))
      allocate (kaa(maxaa))
c
c     assign the angle-angle parameters for each angle pair
c
      nangang = 0
      do i = 1, n
         nang = n12(i) * (n12(i)-1) / 2
         it = class(i)
         if (it .ne. 0) then
            do j = 1, nang-1
               jang = anglist(j,i)
               ia = iang(1,jang)
               ic = iang(3,jang)
               m = 1
               if (atomic(ia) .le. 1)  m = m + 1
               if (atomic(ic) .le. 1)  m = m + 1
               fa = anan(m,it)
               do k = j+1, nang
                  kang = anglist(k,i)
                  ia = iang(1,kang)
                  ic = iang(3,kang)
                  m = 1
                  if (atomic(ia) .le. 1)  m = m + 1
                  if (atomic(ic) .le. 1)  m = m + 1
                  faa = fa * anan(m,it)
                  if (faa .ne. 0.0d0) then
                     nangang = nangang + 1
                     iaa(1,nangang) = jang
                     iaa(2,nangang) = kang
                     kaa(nangang) = faa
                  end if
               end do
            end do
         end if
      end do
c
c     turn off the angle-angle potential if it is not used
c
      if (nangang .eq. 0)  use_angang = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine kangle  --  angle bend parameter assignment  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "kangle" assigns the force constants and ideal angles for
c     the bond angles; also processes new or changed parameters
c
c
      subroutine kangle
      use angbnd
      use angpot
      use atomid
      use atoms
      use couple
      use fields
      use inform
      use iounit
      use kangs
      use keys
      use potent
      use usage
      implicit none
      integer i,j,k
      integer ia,ib,ic
      integer ita,itb,itc
      integer na,nap,naf
      integer na3,na4,na5
      integer jen,nhyd
      integer next,size
      integer minat,iring
      real*8 fc,an,pr
      real*8 an1,an2,an3
      logical header,done
      logical use_ring
      character*4 pa,pb,pc
      character*6 label
      character*12 blank,pt
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing angle bending parameters
c
      blank = '         '
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         iring = -1
         if (keyword(1:6) .eq. 'ANGLE ')  iring = 0
         if (keyword(1:7) .eq. 'ANGLE5 ')  iring = 5
         if (keyword(1:7) .eq. 'ANGLE4 ')  iring = 4
         if (keyword(1:7) .eq. 'ANGLE3 ')  iring = 3
         if (iring .ge. 0) then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            an2 = 0.0d0
            an3 = 0.0d0
            jen = 0
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,ic,fc,an1,an2,an3
   10       continue
            if (min(ia,ib,ic) .le. 0)  goto 190
            if (an2.ne.0.0d0 .or. an3.ne.0.0d0)  jen = 1
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Angle Bending Parameters :',
     &                    //,5x,'Atom Classes',13x,'K(B)',10x,'Angle',/)
               end if
               if (iring .eq. 0) then
                  if (jen .eq. 0) then
                     write (iout,30)  ia,ib,ic,fc,an1
   30                format (4x,3i4,3x,2f15.3)
                  else if (an1 .ne. 0.0d0) then
                     write (iout,40)  ia,ib,ic,fc,an1
   40                format (4x,3i4,3x,2f15.3,3x,'0-H''s')
                  end if
                  if (an2 .ne. 0.0d0) then
                     write (iout,50)  ia,ib,ic,fc,an2
   50                format (4x,3i4,3x,2f15.3,3x,'1-H''s')
                  end if
                  if (an3 .ne. 0.0d0) then
                     write (iout,60)  ia,ib,ic,fc,an3
   60                format (4x,3i4,3x,2f15.3,3x,'2-H''s')
                  end if
               else
                  if (iring .eq. 5)  label = '5-Ring'
                  if (iring .eq. 4)  label = '4-Ring'
                  if (iring .eq. 3)  label = '3-Ring'
                  if (jen .eq. 0) then
                     write (iout,70)  ia,ib,ic,fc,an1,label
   70                format (4x,3i4,3x,2f15.3,3x,a6)
                  else if (an1 .ne. 0.0d0) then
                     write (iout,80)  ia,ib,ic,fc,an1,label
   80                format (4x,3i4,3x,2f15.3,3x,a6,3x,'0-H''s')
                  end if
                  if (an2 .ne. 0.0d0) then
                     write (iout,90)  ia,ib,ic,fc,an2,label
   90                format (4x,3i4,3x,2f15.3,3x,a6,3x,'1-H''s')
                  end if
                  if (an3 .ne. 0.0d0) then
                     write (iout,100)  ia,ib,ic,fc,an3,label
  100                format (4x,3i4,3x,2f15.3,3x,a6,3x,'2-H''s')
                  end if
               end if
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            if (ia .le. ic) then
               pt = pa//pb//pc
            else
               pt = pc//pb//pa
            end if
            if (iring .eq. 0) then
               do j = 1, maxna
                  if (ka(j).eq.blank .or. ka(j).eq.pt) then
                     ka(j) = pt
                     acon(j) = fc
                     ang(1,j) = an1
                     ang(2,j) = an2
                     ang(3,j) = an3
                     goto 120
                  end if
               end do
               write (iout,110)
  110          format (/,' KANGLE  --  Too many Bond Angle',
     &                       ' Bending Parameters')
               abort = .true.
  120          continue
            else if (iring .eq. 5) then
               do j = 1, maxna5
                  if (ka5(j).eq.blank .or. ka5(j).eq.pt) then
                     ka5(j) = pt
                     acon5(j) = fc
                     ang5(1,j) = an1
                     ang5(2,j) = an2
                     ang5(3,j) = an3
                     goto 140
                  end if
               end do
               write (iout,130)
  130          format (/,' KANGLE  --  Too many 5-Ring Angle',
     &                       ' Bending Parameters')
               abort = .true.
  140          continue
            else if (iring .eq. 4) then
               do j = 1, maxna4
                  if (ka4(j).eq.blank .or. ka4(j).eq.pt) then
                     ka4(j) = pt
                     acon4(j) = fc
                     ang4(1,j) = an1
                     ang4(2,j) = an2
                     ang4(3,j) = an3
                     goto 160
                  end if
               end do
               write (iout,150)
  150          format (/,' KANGLE  --  Too many 4-Ring Angle',
     &                       ' Bending Parameters')
               abort = .true.
  160          continue
            else if (iring .eq. 3) then
               do j = 1, maxna3
                  if (ka3(j).eq.blank .or. ka3(j).eq.pt) then
                     ka3(j) = pt
                     acon3(j) = fc
                     ang3(1,j) = an1
                     ang3(2,j) = an2
                     ang3(3,j) = an3
                     goto 180
                  end if
               end do
               write (iout,170)
  170          format (/,' KANGLE  --  Too many 3-Ring Angle',
     &                       ' Bending Parameters')
               abort = .true.
  180          continue
            end if
  190       continue
         end if
      end do
c
c     process keywords containing in-plane angle bending parameters
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. 'ANGLEP ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            an2 = 0.0d0
            jen = 0
            string = record(next:240)
            read (string,*,err=200,end=200)  ia,ib,ic,fc,an1,an2
  200       continue
            if (an2 .ne. 0.0d0)  jen = 1
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,210)
  210             format (/,' Additional In-Plane Angle Bending',
     &                       ' Parameters :',
     &                    //,5x,'Atom Classes',13x,'K(B)',10x,'Angle',/)
               end if
               if (jen .eq. 0) then
                  write (iout,220)  ia,ib,ic,fc,an1
  220             format (4x,3i4,3x,2f15.3)
               else if (an1 .ne. 0.0d0) then
                  write (iout,230)  ia,ib,ic,fc,an1
  230             format (4x,3i4,3x,2f15.3,3x,'0-H''s')
               end if
               if (an2 .ne. 0.0d0) then
                  write (iout,240)  ia,ib,ic,fc,an2
  240             format (4x,3i4,3x,2f15.3,3x,'1-H''s')
               end if
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            if (ia .le. ic) then
               pt = pa//pb//pc
            else
               pt = pc//pb//pa
            end if
            do j = 1, maxnap
               if (kap(j).eq.blank .or. kap(j).eq.pt) then
                  kap(j) = pt
                  aconp(j) = fc
                  angp(1,j) = an1
                  angp(2,j) = an2
                  goto 260
               end if
            end do
            write (iout,250)
  250       format (/,' KANGLE  --  Too many In-Plane Angle',
     &                    ' Bending Parameters')
            abort = .true.
  260       continue
         end if
      end do
c
c     process keywords containing Fourier angle bending parameters
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. 'ANGLEF ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an = 0.0d0
            pr = 0.0d0
            string = record(next:240)
            read (string,*,err=270,end=270)  ia,ib,ic,fc,an,pr
  270       continue
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,280)
  280             format (/,' Additional Fourier Angle Bending',
     &                       ' Parameters :',
     &                    //,5x,'Atom Classes',13x,'K(B)',10x,'Shift',
     &                       9x,'Period',/)
               end if
               write (iout,290)  ia,ib,ic,fc,an,pr
  290          format (4x,3i4,3x,3f15.3)
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            if (ia .le. ic) then
               pt = pa//pb//pc
            else
               pt = pc//pb//pa
            end if
            do j = 1, maxnaf
               if (kaf(j).eq.blank .or. kaf(j).eq.pt) then
                  kaf(j) = pt
                  aconf(j) = fc
                  angf(1,j) = an
                  angf(2,j) = pr
                  goto 310
               end if
            end do
            write (iout,300)
  300       format (/,' KANGLE  --  Too many Fourier Angle',
     &                    ' Bending Parameters')
            abort = .true.
  310       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      na = maxna
      na5 = maxna5
      na4 = maxna4
      na3 = maxna3
      nap = maxnap
      naf = maxnaf
      do i = maxna, 1, -1
         if (ka(i) .eq. blank)  na = i - 1
      end do
      do i = maxna5, 1, -1
         if (ka5(i) .eq. blank)  na5 = i - 1
      end do
      do i = maxna4, 1, -1
         if (ka4(i) .eq. blank)  na4 = i - 1
      end do
      do i = maxna3, 1, -1
         if (ka3(i) .eq. blank)  na3 = i - 1
      end do
      do i = maxnap, 1, -1
         if (kap(i) .eq. blank)  nap = i - 1
      end do
      do i = maxnaf, 1, -1
         if (kaf(i) .eq. blank)  naf = i - 1
      end do
      use_ring = .false.
      if (min(na5,na4,na3) .ne. 0)  use_ring = .true.
c
c     set generic parameters for use with any number of hydrogens
c
      do i = 1, na
         if (ang(2,i).eq.0.0d0 .and. ang(3,i).eq.0.0d0) then
            ang(2,i) = ang(1,i)
            ang(3,i) = ang(1,i)
         end if
      end do
      do i = 1, na5
         if (ang5(2,i).eq.0.0d0 .and. ang5(3,i).eq.0.0d0) then
            ang5(2,i) = ang5(1,i)
            ang5(3,i) = ang5(1,i)
         end if
      end do
      do i = 1, na4
         if (ang4(2,i).eq.0.0d0 .and. ang4(3,i).eq.0.0d0) then
            ang4(2,i) = ang4(1,i)
            ang4(3,i) = ang4(1,i)
         end if
      end do
      do i = 1, na3
         if (ang3(2,i).eq.0.0d0 .and. ang3(3,i).eq.0.0d0) then
            ang3(2,i) = ang3(1,i)
            ang3(3,i) = ang3(1,i)
         end if
      end do
      do i = 1, nap
         if (angp(2,i) .eq. 0.0d0) then
            angp(2,i) = angp(1,i)
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(ak))  deallocate (ak)
      if (allocated(anat))  deallocate (anat)
      if (allocated(afld))  deallocate (afld)
      if (allocated(angtyp))  deallocate (angtyp)
      allocate (ak(nangle))
      allocate (anat(nangle))
      allocate (afld(nangle))
      allocate (angtyp(nangle))
c
c     use special angle parameter assignment method for MMFF
c
      if (forcefield .eq. 'MMFF94') then
         call kanglem
         return
      end if
c
c     assign ideal bond angle and force constant for each angle
c
      header = .true.
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         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
         ak(i) = 0.0d0
         anat(i) = 0.0d0
         afld(i) = 0.0d0
         angtyp(i) = 'HARMONIC'
         done = .false.
c
c     count number of non-angle hydrogens on the central atom
c
         nhyd = 1
         do j = 1, n12(ib)
            k = i12(j,ib)
            if (k.ne.ia .and. k.ne.ic .and. atomic(k).eq.1)
     &         nhyd = nhyd + 1
         end do
c
c     make a check for bond angles contained inside small rings
c
         iring = 0
         if (use_ring) then
            call chkring (iring,ia,ib,ic,0)
            if (iring .eq. 6)  iring = 0
            if (iring.eq.5 .and. na5.eq.0)  iring = 0
            if (iring.eq.4 .and. na4.eq.0)  iring = 0
            if (iring.eq.3 .and. na3.eq.0)  iring = 0
         end if
c
c     assign angle bending parameters for bond angles
c
         if (iring .eq. 0) then
            do j = 1, na
               if (ka(j).eq.pt .and. ang(nhyd,j).ne.0.0d0) then
                  ak(i) = acon(j)
                  anat(i) = ang(nhyd,j)
                  done = .true.
                  goto 320
               end if
            end do
c
c     assign bending parameters for 5-membered ring angles
c
         else if (iring .eq. 5) then
            do j = 1, na5
               if (ka5(j).eq.pt .and. ang5(nhyd,j).ne.0.0d0) then
                  ak(i) = acon5(j)
                  anat(i) = ang5(nhyd,j)
                  done = .true.
                  goto 320
               end if
            end do
c
c     assign bending parameters for 4-membered ring angles
c
         else if (iring .eq. 4) then
            do j = 1, na4
               if (ka4(j).eq.pt .and. ang4(nhyd,j).ne.0.0d0) then
                  ak(i) = acon4(j)
                  anat(i) = ang4(nhyd,j)
                  done = .true.
                  goto 320
               end if
            end do
c
c     assign bending parameters for 3-membered ring angles
c
         else if (iring .eq. 3) then
            do j = 1, na3
               if (ka3(j).eq.pt .and. ang3(nhyd,j).ne.0.0d0) then
                  ak(i) = acon3(j)
                  anat(i) = ang3(nhyd,j)
                  done = .true.
                  goto 320
               end if
            end do
         end if
c
c     assign in-plane angle bending parameters for bond angles
c
         if (.not.done .and. n12(ib).eq.3) then
            do j = 1, nap
               if (kap(j).eq.pt .and. angp(nhyd,j).ne.0.0d0) then
                  ak(i) = aconp(j)
                  anat(i) = angp(nhyd,j)
                  angtyp(i) = 'IN-PLANE'
                  done = .true.
                  goto 320
               end if
            end do
         end if
c
c     assign Fourier angle bending parameters for bond angles
c
         if (.not. done) then
            do j = 1, naf
               if (kaf(j) .eq. pt) then
                  ak(i) = aconf(j)
                  anat(i) = angf(1,j)
                  afld(i) = angf(2,j)
                  angtyp(i) = 'FOURIER'
                  done = .true.
                  goto 320
               end if
            end do
         end if
c
c     warning if suitable angle bending parameter not found
c
  320    continue
         minat = min(atomic(ia),atomic(ib),atomic(ic))
         if (minat .eq. 0)  done = .true.
         if (use_angle .and. .not.done) then
            if (use(ia) .or. use(ib) .or. use(ic))  abort = .true.
            if (header) then
               header = .false.
               write (iout,330)
  330          format (/,' Undefined Angle Bending Parameters :',
     &                 //,' Type',18x,'Atom Names',19x,
     &                    'Atom Classes',/)
            end if
            label = 'Angle '
            if (iring .eq. 5)  label = '5-Ring'
            if (iring .eq. 4)  label = '4-Ring'
            if (iring .eq. 3)  label = '3-Ring'
            write (iout,340)  label,ia,name(ia),ib,name(ib),
     &                        ic,name(ic),ita,itb,itc
  340       format (1x,a6,5x,3(i6,'-',a3),7x,3i5)
         end if
      end do
c
c     process keywords containing angle specific parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:6) .eq. 'ANGLE ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            string = record(next:240)
            read (string,*,err=350,end=350)  ia,ib,ic,fc,an1
  350       continue
            if (min(ia,ib,ic) .lt. 0) then
               ia = abs(ia)
               ib = abs(ib)
               ic = abs(ic)
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,360)
  360             format (/,' Additional Angle Parameters for',
     &                       ' Specific Angles :',
     &                    //,8x,'Atoms',17x,'K(B)',10x,'Angle',/)
               end if
               if (.not. silent) then
                  write (iout,370)  ia,ib,ic,fc,an1
  370             format (4x,3i4,3x,2f15.3)
               end if
               do j = 1, nangle
                  ita = iang(1,j)
                  itb = iang(2,j)
                  itc = iang(3,j)
                  if (ib .eq. itb) then
                     if ((ia.eq.ita .and. ic.eq.itc) .or.
     &                   (ia.eq.itc .and. ic.eq.ita)) then
                        ak(j) = fc
                        anat(j) = an1
                        angtyp(j) = 'HARMONIC'
                        goto 380
                     end if
                  end if
               end do
            end if
  380       continue
         end if
      end do
c
c     process keywords containing in-plane angle specific parameters
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. 'ANGLEP ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            string = record(next:240)
            read (string,*,err=390,end=390)  ia,ib,ic,fc,an1
  390       continue
            if (min(ia,ib,ic) .lt. 0) then
               ia = abs(ia)
               ib = abs(ib)
               ic = abs(ic)
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,400)
  400             format (/,' Additional In-Plane Angle Parameters',
     &                       ' for Specific Angles :',
     &                    //,8x,'Atoms',17x,'K(B)',10x,'Angle',/)
               end if
               if (.not. silent) then
                  write (iout,410)  ia,ib,ic,fc,an1
  410             format (4x,3i4,3x,2f15.3)
               end if
               if (ia .gt. ic) then
                  ita = ia
                  ia = ic
                  ic = ita
               end if
               do j = 1, nangle
                  if (ia.eq.iang(1,j) .and. ib.eq.iang(2,j)
     &                   .and. ic.eq.iang(3,j)) then
                     ak(j) = fc
                     anat(j) = an1
                     angtyp(j) = 'IN-PLANE'
                     goto 420
                  end if
               end do
            end if
  420       continue
         end if
      end do
c
c     process keywords containing Fourier angle specific parameters
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. 'ANGLEF ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an = 0.0d0
            pr = 0.0d0
            string = record(next:240)
            read (string,*,err=430,end=430)  ia,ib,ic,fc,an,pr
  430       continue
            if (min(ia,ib,ic) .lt. 0) then
               ia = abs(ia)
               ib = abs(ib)
               ic = abs(ic)
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,440)
  440             format (/,' Additional Fourier Angle Parameters',
     &                       ' for Specific Angles :',
     &                    //,8x,'Atoms',17x,'K(B)',10x,'Shift',
     &                       9x,'Period',/)
               end if
               if (.not. silent) then
                  write (iout,450)  ia,ib,ic,fc,an,pr
  450             format (4x,3i4,3x,3f15.3)
               end if
               if (ia .gt. ic) then
                  ita = ia
                  ia = ic
                  ic = ita
               end if
               do j = 1, nangle
                  if (ia.eq.iang(1,j) .and. ib.eq.iang(2,j)
     &                   .and. ic.eq.iang(3,j)) then
                     ak(j) = fc
                     anat(j) = an
                     afld(j) = pr
                     angtyp(j) = 'FOURIER'
                     goto 460
                  end if
               end do
            end if
  460       continue
         end if
      end do
c
c     turn off the angle bending potential if it is not used
c
      if (nangle .eq. 0)  use_angle = .false.
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine kanglem  --  MMFF angle parameter assignment  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "kanglem" assigns the force constants and ideal angles for
c     bond angles according to the Merck Molecular Force Field (MMFF)
c
c     literature reference:
c
c     T. A. Halgren, "Merck Molecular Force Field. I. Basis, Form,
c     Scope, Parametrization, and Performance of MMFF94", Journal of
c     Computational Chemistry, 17, 490-519 (1995)
c
c     T. A. Halgren, "Merck Molecular Force Field. V. Extension of
c     MMFF94 Using Experimental Data, Additional Computational Data,
c     and Empirical Rules", Journal of Computational Chemistry, 17,
c     616-641 (1995)
c
c
      subroutine kanglem
      use angbnd
      use angpot
      use atomid
      use atoms
      use bndstr
      use merck
      use potent
      use ring
      implicit none
      integer i,j,k,l,m
      integer ia,ib,ic
      integer ita,itb,itc
      integer ina,inb,inc
      integer itta,ittb,ittc
      integer bnd_ab,bnd_bc
      integer at,minat
      integer mclass
      real*8 d,beta
      real*8 z2(100),c(100)
      logical done
      logical ring3,ring4
c
c
c     set empirical rule parameters for some common elements
c
      do i = 1, 100
         z2(i) = 1000.0d0
         c(i) = 1000.0d0
      end do
      z2(1) = 1.395d0
      z2(5) = 0.0d0
      z2(6) = 2.494d0
      z2(7) = 2.711d0
      z2(8) = 3.045d0
      z2(9) = 2.847d0
      z2(14) = 2.350d0
      z2(15) = 2.350d0
      z2(16) = 2.980d0
      z2(17) = 2.909d0
      z2(35) = 3.017d0
      z2(33) = 0.0d0
      z2(53) = 3.086d0
      c(1) = 0.0d0
      c(5) = 0.704d0
      c(6) = 1.016d0
      c(7) = 1.113d0
      c(8) = 1.337d0
      c(9) = 0.0d0
      c(14) = 0.811d0
      c(15) = 1.068d0
      c(16) = 1.249d0
      c(17) = 1.078d0
      c(35) = 0.0d0
      c(33) = 0.825d0
      c(53) = 0.0d0
c
c     assign MMFF bond angle and force constant for each angle
c
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itta = type(ia)
         ittb = type(ib)
         ittc = type(ic)
         ina = atomic(ia)
         inb = atomic(ib)
         inc = atomic(ic)
c
c     set angle index value, accounting for MMFF bond type = 1
c
         at = 0
         do j = 1, nligne
            if ((ia.eq.bt_1(j,1) .and. ib.eq.bt_1(j,2)) .or.
     &          (ib.eq.bt_1(j,1) .and. ia.eq.bt_1(j,2))) then
               at = at + 1
            end if
            if ((ic.eq.bt_1(j,1) .and. ib.eq.bt_1(j,2)) .or.
     &          (ib.eq.bt_1(j,1) .and. ic.eq.bt_1(j,2))) then
               at = at + 1
            end if
         end do
c
c     determine if the atoms belong to a 3- or 4-membered ring
c
         ring3 = .false.
         ring4 = .false.
         do j = 1, nring3
            do k = 1, 3
               if (ia .eq. iring3(k,j)) then
                  do l = 1, 3
                     if (ib .eq. iring3(l,j)) then
                        do m = 1, 3
                           if (ic .eq. iring3(m,j))  ring3 = .true.
                        end do
                     end if
                  end do
               end if
            end do
         end do
         if (.not. ring3) then
            do j = 1, nring4
               do k = 1, 4
                  if (ia .eq. iring4(k,j)) then
                     do l = 1, 4
                        if (ib .eq. iring4(l,j)) then
                           do m = 1, 4
                              if (ic .eq. iring4(m,j))  ring4 = .true.
                           end do
                        end if
                     end do
                  end if
               end do
            end do
         end if
c
c     set special index value when 3- or 4-rings are present
c
         if (at.eq.0 .and. ring4) then
            at = 4
         else if (at.eq.1 .and. ring4) then
            at = 7
         else if (at.eq.2 .and. ring4) then
            at = 8
         else if (at.eq.0 .and. ring3) then
            at = 3
         else if (at.eq.1 .and. ring3) then
            at = 5
         else if (at.eq.2 .and. ring3) then
            at = 6
         end if
c
c     setup the atom class equivalencies assignment
c
         mclass = 0
   10    continue
         mclass = mclass + 1
         if (mclass .eq. 1) then
            ita = eqclass(itta,1)
            itb = eqclass(ittb,1)
            itc = eqclass(ittc,1)
         else if (mclass .eq. 2) then
            ita = eqclass(itta,2)
            itb = eqclass(ittb,2)
            itc = eqclass(ittc,2)
         else if (mclass .eq. 3) then
            ita = eqclass(itta,3)
            itb = eqclass(ittb,2)
            itc = eqclass(ittc,3)
         else if (mclass .eq. 4) then
            ita = eqclass(itta,4)
            itb = eqclass(ittb,2)
            itc = eqclass(ittc,4)
         else if (mclass .eq. 5) then
            ita = eqclass(itta,5)
            itb = eqclass(ittb,2)
            itc = eqclass(ittc,5)
         end if
         if (mclass .gt. 5) then
            goto 20
         else
            if (at .eq. 0) then
               ak(i) = mmff_ka(ita,itb,itc)
               anat(i) = mmff_ang0(ita,itb,itc)
            else if (at .eq. 1) then
               ak(i) = mmff_ka1(ita,itb,itc)
               anat(i) = mmff_ang1(ita,itb,itc)
            else if (at .eq. 2) then
               ak(i) = mmff_ka2(ita,itb,itc)
               anat(i) = mmff_ang2(ita,itb,itc)
            else if (at .eq. 3) then
               ak(i) = mmff_ka3(ita,itb,itc)
               anat(i) = mmff_ang3(ita,itb,itc)
            else if (at .eq. 4) then
               ak(i) = mmff_ka4(ita,itb,itc)
               anat(i) = mmff_ang4(ita,itb,itc)
            else if (at .eq. 5) then
               ak(i) = mmff_ka5(ita,itb,itc)
               anat(i) = mmff_ang5(ita,itb,itc)
            else if (at .eq. 6) then
               ak(i) = mmff_ka6(ita,itb,itc)
               anat(i) = mmff_ang6(ita,itb,itc)
            else if (at .eq. 7) then
               ak(i) = mmff_ka7(ita,itb,itc)
               anat(i) = mmff_ang7(ita,itb,itc)
            else if (at .eq. 8) then
               ak(i) = mmff_ka8(ita,itb,itc)
               anat(i) = mmff_ang8(ita,itb,itc)
            end if
c
c     use empirical rule to calculate the force constant
c
            if (mclass .eq. 5) then
               if (z2(ina) .eq. 1000.0d0)  goto 20
               if (z2(inb) .eq. 1000.0d0)  goto 20
               if (z2(inc) .eq. 1000.0d0)  goto 20
               if (c(ina) .eq. 1000.0d0)  goto 20
               if (c(inb) .eq. 1000.0d0)  goto 20
               if (c(inc) .eq. 1000.0d0)  goto 20
               do k = 1, nbond
                  if ((min(ia,ib).eq.ibnd(1,k)) .and.
     &                (max(ia,ib).eq.ibnd(2,k))) then
                     bnd_ab = k
                  end if
                  if ((min(ic,ib).eq.ibnd(1,k)) .and.
     &                (max(ic,ib).eq.ibnd(2,k))) then
                     bnd_bc = k
                  end if
               end do
               d = (bl(bnd_ab)-bl(bnd_bc))**2
     &                / (bl(bnd_ab)+bl(bnd_bc))**2
               beta = 1.0d0
               if (ring4)  beta = 0.85d0
               if (ring3)  beta = 0.05d0
               ak(i) = beta*1.75d0*z2(ina)*z2(inc)*c(inb)
     &                 / ((0.01745329252d0*anat(i))**2
     &                      *(bl(bnd_ab)+bl(bnd_bc))*exp(2.0d0*d))
            end if
            done = .true.
            if (ak(i) .eq. 1000.0d0)  done = .false.
            if (anat(i) .eq. 1000.0d0)  done = .false.
            if (.not. done)  goto 10
            goto 20
         end if
c
c     use empirical rule for ideal angle and force constant
c
   20    continue
         minat = min(ina,inb,inc)
         if (minat .eq. 0)  done = .true.
         if (.not. done) then
            if (use_angle) then
               anat(i) = 120.0d0
               if (crd(itb) .eq. 4)  anat(i) = 109.45d0
               if (crd(itb) .eq. 2) then
                  if (inb .eq. 8) then
                     anat(i) = 105.0d0
                  else if (inb .gt. 10) then
                     anat(i) = 95.0d0
                  else if (lin(itb) .eq. 1) then
                     anat(i) = 180.0d0
                  end if
               end if
               if (crd(itb).eq.3 .and. val(itb).eq.3
     &                .and. mltb(itb).eq.0) then
                  if (inb .eq. 7) then
                     anat(i) = 107.0d0
                  else
                     anat(i) = 92.0d0
                  end if
               end if
               if (ring3)  anat(i) = 60.0d0
               if (ring4)  anat(i) = 90.0d0
               do k = 1, nbond
                  if ((min(ia,ib).eq.ibnd(1,k)) .and.
     &                (max(ia,ib).eq.ibnd(2,k))) then
                     bnd_ab = k
                  end if
                  if ((min(ic,ib).eq.ibnd(1,k)) .and.
     &                (max(ic,ib).eq.ibnd(2,k))) then
                     bnd_bc = k
                  end if
               end do
               d = (bl(bnd_ab)-bl(bnd_bc))**2
     &                / (bl(bnd_ab)+bl(bnd_bc))**2
               beta = 1.0d0
               if (ring4)  beta = 0.85d0
               if (ring3)  beta = 0.05d0
               ak(i) = beta*1.75d0*z2(ina)*z2(inc)*c(inb)
     &                 / ((0.01745329252d0*anat(i))**2
     &                      *(bl(bnd_ab)+bl(bnd_bc))*exp(2.0d0*d))
            end if
         end if
         angtyp(i) = 'HARMONIC'
         if (anat(i) .eq. 180.0d0)  angtyp(i) = 'LINEAR'
      end do
c
c     turn off the angle bending potential if it is not used
c
      if (nangle .eq. 0)  use_angle = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module kangs  --  bond angle bend forcefield parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     maxna    maximum number of harmonic angle bend parameter entries
c     maxna5   maximum number of 5-membered ring angle bend entries
c     maxna4   maximum number of 4-membered ring angle bend entries
c     maxna3   maximum number of 3-membered ring angle bend entries
c     maxnap   maximum number of in-plane angle bend parameter entries
c     maxnaf   maximum number of Fourier angle bend parameter entries
c
c     acon     force constant parameters for harmonic angle bends
c     acon5    force constant parameters for 5-ring angle bends
c     acon4    force constant parameters for 4-ring angle bends
c     acon3    force constant parameters for 3-ring angle bends
c     aconp    force constant parameters for in-plane angle bends
c     aconf    force constant parameters for Fourier angle bends
c     ang      bond angle parameters for harmonic angle bends
c     ang5     bond angle parameters for 5-ring angle bends
c     ang4     bond angle parameters for 4-ring angle bends
c     ang3     bond angle parameters for 3-ring angle bends
c     angp     bond angle parameters for in-plane angle bends
c     angf     phase shift angle and periodicity for Fourier bends
c     ka       string of atom classes for harmonic angle bends
c     ka5      string of atom classes for 5-ring angle bends
c     ka4      string of atom classes for 4-ring angle bends
c     ka3      string of atom classes for 3-ring angle bends
c     kap      string of atom classes for in-plane angle bends
c     kaf      string of atom classes for Fourier angle bends
c
c
      module kangs
      implicit none
      integer maxna
      integer maxna5
      integer maxna4
      integer maxna3
      integer maxnap
      integer maxnaf
      real*8, allocatable :: acon(:)
      real*8, allocatable :: acon5(:)
      real*8, allocatable :: acon4(:)
      real*8, allocatable :: acon3(:)
      real*8, allocatable :: aconp(:)
      real*8, allocatable :: aconf(:)
      real*8, allocatable :: ang(:,:)
      real*8, allocatable :: ang5(:,:)
      real*8, allocatable :: ang4(:,:)
      real*8, allocatable :: ang3(:,:)
      real*8, allocatable :: angp(:,:)
      real*8, allocatable :: angf(:,:)
      character*12, allocatable :: ka(:)
      character*12, allocatable :: ka5(:)
      character*12, allocatable :: ka4(:)
      character*12, allocatable :: ka3(:)
      character*12, allocatable :: kap(:)
      character*12, allocatable :: kaf(:)
      save
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder  ##
c     ##                 All Rights Reserved                  ##
c     ##########################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine kangtor  --  angle-torsion parameter assignment  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "kangtor" assigns parameters for angle-torsion interactions
c     and processes new or changed parameter values
c
c
      subroutine kangtor
      use angtor
      use atmlst
      use atomid
      use atoms
      use couple
      use inform
      use iounit
      use keys
      use kantor
      use potent
      use tors
      implicit none
      integer i,j,k,l,m,nat
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer size,next
      real*8 at1,at2,at3
      real*8 at4,at5,at6
      logical header,swap
      character*4 pa,pb,pc,pd
      character*4 zeros
      character*16 blank
      character*16 pt
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing angle-torsion parameters
c
      blank = '                '
      zeros = '0000'
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:8) .eq. 'ANGTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            at1 = 0.0d0
            at2 = 0.0d0
            at3 = 0.0d0
            at4 = 0.0d0
            at5 = 0.0d0
            at6 = 0.0d0
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,ic,id,at1,at2,
     &                                     at3,at4,at5,at6
   10       continue
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Angle-Torsion Parameters :',
     &                    //,32x,'1st Angle',20x,'2nd Angle',
     &                    /,5x,'Atom Classes',7x,'1-Fold',3x,'2-Fold',
     &                      3x,'3-Fold',5x,'1-Fold',3x,'2-Fold',
     &                      3x,'3-Fold'/)
               end if
               write (iout,30)  ia,ib,ic,id,at1,at2,at3,at4,at5,at6
   30          format (2x,4i4,3x,3f9.3,2x,3f9.3)
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            if (ib .lt. ic) then
               pt = pa//pb//pc//pd
               swap = .false.
            else if (ic .lt. ib) then
               pt = pd//pc//pb//pa
               swap = .true.
            else if (ia .le. id) then
               pt = pa//pb//pc//pd
               swap = .false.
            else if (id .lt. ia) then
               pt = pd//pc//pb//pa
               swap = .true.
            end if
            do j = 1, maxnat
               if (kat(j).eq.blank .or. kat(j).eq.pt) then
                  kat(j) = pt
                  if (swap) then
                     atcon(1,j) = at4
                     atcon(2,j) = at5
                     atcon(3,j) = at6
                     atcon(4,j) = at1
                     atcon(5,j) = at2
                     atcon(6,j) = at3
                  else
                     atcon(1,j) = at1
                     atcon(2,j) = at2
                     atcon(3,j) = at3
                     atcon(4,j) = at4
                     atcon(5,j) = at5
                     atcon(6,j) = at6
                  end if
                  goto 50
               end if
            end do
            write (iout,40)
   40       format (/,' KANGTOR  --  Too many Angle-Torsion',
     &                 ' Parameters')
            abort = .true.
   50       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      nat = maxnat
      do i = maxnat, 1, -1
         if (kat(i) .eq. blank)  nat = i - 1
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(iat))  deallocate (iat)
      if (allocated(kant))  deallocate (kant)
      allocate (iat(3,ntors))
      allocate (kant(6,ntors))
c
c     assign the angle-torsion parameters for each torsion
c
      nangtor = 0
      if (nat .ne. 0) then
         do i = 1, ntors
            ia = itors(1,i)
            ib = itors(2,i)
            ic = itors(3,i)
            id = itors(4,i)
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            itd = class(id)
            size = 4
            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
               swap = .false.
            else if (itc .lt. itb) then
               pt = pd//pc//pb//pa
               swap = .true.
            else if (ita .le. itd) then
               pt = pa//pb//pc//pd
               swap = .false.
            else if (itd .lt. ita) then
               pt = pd//pc//pb//pa
               swap = .true.
            end if
            do j = 1, nat
               if (kat(j) .eq. pt) then
                  nangtor = nangtor + 1
                  if (swap) then
                     kant(1,nangtor) = atcon(4,j)
                     kant(2,nangtor) = atcon(5,j)
                     kant(3,nangtor) = atcon(6,j)
                     kant(4,nangtor) = atcon(1,j)
                     kant(5,nangtor) = atcon(2,j)
                     kant(6,nangtor) = atcon(3,j)
                  else
                     kant(1,nangtor) = atcon(1,j)
                     kant(2,nangtor) = atcon(2,j)
                     kant(3,nangtor) = atcon(3,j)
                     kant(4,nangtor) = atcon(4,j)
                     kant(5,nangtor) = atcon(5,j)
                     kant(6,nangtor) = atcon(6,j)
                  end if
                  iat(1,nangtor) = i
                  m = 0
                  do k = 1, n12(ib)-1
                     do l = k+1, n12(ib)
                        m = m + 1
                        if ((i12(k,ib).eq.ia .and. i12(l,ib).eq.ic) .or.
     &                     (i12(k,ib).eq.ic .and. i12(l,ib).eq.ia)) then
                           iat(2,nangtor) = anglist(m,ib)
                           goto 60
                        end if
                     end do
                  end do
   60             continue
                  m = 0
                  do k = 1, n12(ic)-1
                     do l = k+1, n12(ic)
                        m = m + 1
                        if ((i12(k,ic).eq.ib .and. i12(l,ic).eq.id) .or.
     &                     (i12(k,ic).eq.id .and. i12(l,ic).eq.ib)) then
                           iat(3,nangtor) = anglist(m,ic)
                           goto 70
                        end if
                     end do
                  end do
               end if
            end do
   70       continue
         end do
      end if
c
c     turn off the angle-torsion potential if it is not used
c
      if (nangtor .eq. 0)  use_angtor = .false.
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder  ##
c     ##                 All Rights Reserved                  ##
c     ##########################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module kantor  --  angle-torsion forcefield parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     maxnat   maximum number of angle-torsion parameter entries
c
c     atcon    torsional amplitude parameters for angle-torsion
c     kat      string of atom classes for angle-torsion terms
c
c
      module kantor
      implicit none
      integer maxnat
      real*8, allocatable :: atcon(:,:)
      character*16, allocatable :: kat(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine katom  --  atom type parameter assignment  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "katom" assigns an atom type definitions to each atom in
c     the structure and processes any new or changed values
c
c     literature reference:
c
c     K. A. Feenstra, B. Hess and H. J. C. Berendsen, "Improving
c     Efficiency of Large Time-Scale Molecular Dynamics Simulations
c     of Hydrogen-Rich Systems", Journal of Computational Chemistry,
c     8, 786-798 (1999)
c
c     C. W. Hopkins, S. Le Grand, R. C. Walker and A. E. Roitberg,
c     "Long-Time-Step Molecular Dynamics through Hydrogen Mass
c     Repartitioning", Journal of Chemical Theory and Computation,
c     11, 1864-1874 (2015)
c
c
      subroutine katom
      use atomid
      use atoms
      use couple
      use inform
      use iounit
      use katoms
      use keys
      implicit none
      integer i,j,k
      integer next,nhyd
      integer cls,atn,lig
      real*8 wght,sum
      real*8 hmax,hmass
      real*8 dmin,dmass
      logical header,heavy
      character*3 symb
      character*20 keyword
      character*24 notice
      character*240 record
      character*240 string
c
c
c     process keywords containing atom type parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:5) .eq. 'ATOM ') then
            k = 0
            cls = 0
            symb = ' '
            notice = ' '
            atn = 0
            wght = 0.0d0
            lig = 0
            call getnumb (record,k,next)
            if (k.gt.0 .and. k.le.maxtyp) then
               call getnumb (record,cls,next)
               if (cls .eq. 0)  cls = k
               atmcls(k) = cls
               call gettext (record,symb,next)
               call getstring (record,notice,next)
               string = record(next:240)
               read (string,*,err=40,end=40)  atn,wght,lig
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,10)
   10             format (/,' Additional Atom Definition Parameters :',
     &                    //,5x,'Type  Class  Symbol  Description',
     &                       15x,'Atomic',4x,'Mass',3x,'Valence',/)
               end if
               symbol(k) = symb
               describe(k) = notice
               atmnum(k) = atn
               weight(k) = wght
               ligand(k) = lig
               if (.not. silent) then
                  write (iout,20)  k,cls,symb,notice,atn,wght,lig
   20             format (1x,i8,i6,5x,a3,3x,a24,i6,f11.3,i6)
               end if
            else if (k .gt. maxtyp) then
               write (iout,30)
   30          format (/,' KATOM   --  Too many Atom Types;',
     &                    ' Increase MAXTYP')
               abort = .true.
            end if
   40       continue
         end if
      end do
c
c     transfer atom type values to individual atoms
c
      do i = 1, n
         k = type(i)
         if (k .eq. 0) then
            class(i) = 0
            atomic(i) = 0
            mass(i) = 0.0d0
            valnum(i) = 0
            story(i) = 'Undefined Atom Type     '
         else
            if (symbol(k) .ne. '   ')  name(i) = symbol(k)
            class(i) = atmcls(k)
            atomic(i) = atmnum(k)
            mass(i) = weight(k)
            valnum(i) = ligand(k)
            story(i) = describe(k)
         end if
      end do
c
c     repartition hydrogen masses to use "heavy" hydrogens
c
      heavy = .false.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:15) .eq. 'HEAVY-HYDROGEN ') then
            heavy = .true.
            hmax = 4.0d0
            read (string,*,err=50,end=50)  hmax
         end if
   50    continue
      end do
      if (heavy) then
         do i = 1, n
            nhyd = 0
            sum = mass(i)
            do j = 1, n12(i)
               k = i12(j,i)
               if (atomic(k) .eq. 1) then
                  nhyd = nhyd + 1
                  sum = sum + mass(k)
               end if
            end do
            hmass = min(hmax,sum/dble(nhyd+1))
            do j = 1, n12(i)
               k = i12(j,i)
               if (atomic(k) .eq. 1) then
                  dmass = hmass - mass(k)
                  mass(k) = hmass
                  mass(i) = mass(i) - dmass
               end if
            end do
         end do
         do i = 1, n
            if (mass(i) .lt. hmax) then
               dmass = hmax - mass(i)
               dmin = hmax + dmass
               do j = 1, n12(i)
                  k = i12(j,i)
                  if (mass(k) .gt. dmin) then
                     mass(k) = mass(k) - dmass
                     mass(i) = hmax
                     goto 60
                  end if
               end do
               do j = 1, n13(i)
                  k = i13(j,i)
                  if (mass(k) .gt. dmin) then
                     mass(k) = mass(k) - dmass
                     mass(i) = hmax
                     goto 60
                  end if
               end do
   60          continue
            end if
         end do
      end if
c
c     process keywords containing atom types for specific atoms
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:5) .eq. 'ATOM ') then
            k = 0
            symb = ' '
            notice = ' '
            atn = 0
            wght = 0.0d0
            lig = 0
            call getnumb (record,k,next)
            if (k.lt.0 .and. k.ge.-n) then
               call getnumb (record,cls,next)
               call gettext (record,symb,next)
               call getstring (record,notice,next)
               string = record(next:240)
               read (string,*,err=90,end=90)  atn,wght,lig
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,70)
   70             format (/,' Additional Atom Definitions for',
     &                       ' Specific Atoms :',
     &                    //,5x,'Atom  Class  Symbol  Description',
     &                       15x,'Atomic',4x,'Mass',3x,'Valence',/)
               end if
               k = -k
               if (cls .eq. 0)  cls = k
               class(k) = cls
               name(k) = symb
               story(k) = notice
               atomic(k) = atn
               mass(k) = wght
               valnum(k) = lig
               if (.not. silent) then
                  write (iout,80)  k,cls,symb,notice,atn,wght,lig
   80             format (1x,i8,i6,5x,a3,3x,a24,i6,f11.3,i6)
               end if
            end if
   90       continue
         end if
      end do
c
c     check for presence of undefined atom types or classes
c
      header = .true.
      do i = 1, n
         k = type(i)
         cls = class(i)
         if (k.lt.1 .or. k.gt.maxtyp
     &          .or. cls.lt.1 .or. cls.gt.maxclass) then
            abort = .true.
            if (header) then
               header = .false.
               write (iout,100)
  100          format (/,' Undefined Atom Types or Classes :',
     &                 //,' Type',10x,'Atom Number',5x,'Atom Type',
     &                    5x,'Atom Class',/)
            end if
            write (iout,110)  i,k,cls
  110       format (' Atom',9x,i8,10x,i5,10x,i5)
         end if
      end do
c
c     check the number of atoms attached to each atom
c
      header = .true.
      do i = 1, n
         if (n12(i) .ne. valnum(i)) then
            if (header) then
               header = .false.
               write (iout,120)
  120          format (/,' Atoms with an Unusual Number of Attached',
     &                    ' Atoms :',
     &                 //,' Type',11x,'Atom Name',6x,'Atom Type',7x,
     &                    'Expected',4x,'Found',/)
            end if
            write (iout,130)  i,name(i),type(i),valnum(i),n12(i)
  130       format (' Valence',4x,i8,'-',a3,8x,i5,10x,i5,5x,i5)
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module katoms  --  atom definition forcefield parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     atmcls     atom class number for each of the atom types
c     atmnum     atomic number for each of the atom types
c     ligand     number of atoms to be attached to each atom type
c     weight     average atomic mass of each atom type
c     symbol     modified atomic symbol for each atom type
c     describe   string identifying each of the atom types
c
c
      module katoms
      implicit none
      integer, allocatable :: atmcls(:)
      integer, allocatable :: atmnum(:)
      integer, allocatable :: ligand(:)
      real*8, allocatable :: weight(:)
      character*3, allocatable :: symbol(:)
      character*24, allocatable :: describe(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine kbond  --  bond stretch 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
      use atomid
      use atoms
      use bndstr
      use couple
      use fields
      use inform
      use iounit
      use kbonds
      use keys
      use potent
      use usage
      implicit none
      integer i,j
      integer ia,ib,ita,itb
      integer nb,nb5,nb4,nb3
      integer size,next
      integer minat,iring
      real*8 fc,bd
      logical header,done
      logical use_ring
      character*4 pa,pb
      character*6 label
      character*8 blank,pt
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing bond stretch parameters
c
      blank = '        '
      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
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,fc,bd
   10       continue
            if (min(ia,ib) .lt. 0)  goto 130
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Bond Stretching Parameters :',
     &                    //,5x,'Atom Classes',13x,'K(S)',9x,'Length',/)
               end if
               if (iring .eq. 0) then
                  write (iout,30)  ia,ib,fc,bd
   30             format (6x,2i4,5x,f15.3,f15.4)
               else
                  if (iring .eq. 5)  label = '5-Ring'
                  if (iring .eq. 4)  label = '4-Ring'
                  if (iring .eq. 3)  label = '3-Ring'
                  write (iout,40)  ia,ib,fc,bd,label
   40             format (6x,2i4,5x,f15.3,f15.4,3x,a6)
               end if
            end if
            size = 4
            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.blank .or. kb(j).eq.pt) then
                     kb(j) = pt
                     bcon(j) = fc
                     blen(j) = bd
                     goto 60
                  end if
               end do
               write (iout,50)
   50          format (/,' KBOND  --  Too many Bond Stretching',
     &                       ' Parameters')
               abort = .true.
   60          continue
            else if (iring .eq. 5) then
               do j = 1, maxnb5
                  if (kb5(j).eq.blank .or. kb5(j).eq.pt) then
                     kb5(j) = pt
                     bcon5(j) = fc
                     blen5(j) = bd
                     goto 80
                  end if
               end do
               write (iout,70)
   70          format (/,' KBOND  --  Too many 5-Ring Stretching',
     &                       ' Parameters')
               abort = .true.
   80          continue
            else if (iring .eq. 4) then
               do j = 1, maxnb4
                  if (kb4(j).eq.blank .or. kb4(j).eq.pt) then
                     kb4(j) = pt
                     bcon4(j) = fc
                     blen4(j) = bd
                     goto 100
                  end if
               end do
               write (iout,90)
   90          format (/,' KBOND  --  Too many 4-Ring Stretching',
     &                       ' Parameters')
               abort = .true.
  100          continue
            else if (iring .eq. 3) then
               do j = 1, maxnb3
                  if (kb3(j).eq.blank .or. kb3(j).eq.pt) then
                     kb3(j) = pt
                     bcon3(j) = fc
                     blen3(j) = bd
                     goto 120
                  end if
               end do
               write (iout,110)
  110          format (/,' KBOND  --  Too many 3-Ring Stretching',
     &                       ' Parameters')
               abort = .true.
  120          continue
            end if
  130       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      nb = maxnb
      nb5 = maxnb5
      nb4 = maxnb4
      nb3 = maxnb3
      do i = maxnb, 1, -1
         if (kb(i) .eq. blank)  nb = i - 1
      end do
      do i = maxnb5, 1, -1
         if (kb5(i) .eq. blank)  nb5 = i - 1
      end do
      do i = maxnb4, 1, -1
         if (kb4(i) .eq. blank)  nb4 = i - 1
      end do
      do i = maxnb3, 1, -1
         if (kb3(i) .eq. blank)  nb3 = i - 1
      end do
      use_ring = .false.
      if (min(nb5,nb4,nb3) .ne. 0)  use_ring = .true.
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(bk))  deallocate (bk)
      if (allocated(bl))  deallocate (bl)
      allocate (bk(nbond))
      allocate (bl(nbond))
c
c     use special bond parameter assignment method for MMFF
c
      if (forcefield .eq. 'MMFF94') then
         call kbondm
         return
      end if
c
c     assign ideal 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 = 4
         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
         done = .false.
c
c     make a check for bonds contained inside small rings
c
         iring = 0
         if (use_ring) then
            call chkring (iring,ia,ib,0,0)
            if (iring .eq. 6)  iring = 0
            if (iring.eq.5 .and. nb5.eq.0)  iring = 0
            if (iring.eq.4 .and. nb4.eq.0)  iring = 0
            if (iring.eq.3 .and. nb3.eq.0)  iring = 0
         end if
c
c     assign bond stretching parameters for each bond
c
         if (iring .eq. 0) then
            do j = 1, nb
               if (kb(j) .eq. pt) then
                  bk(i) = bcon(j)
                  bl(i) = blen(j)
                  done = .true.
                  goto 140
               end if
            end do
c
c     assign stretching parameters for 5-membered ring bonds
c
         else if (iring .eq. 5) then
            do j = 1, nb5
               if (kb5(j) .eq. pt) then
                  bk(i) = bcon5(j)
                  bl(i) = blen5(j)
                  done = .true.
                  goto 140
               end if
            end do
c
c     assign stretching parameters for 4-membered ring bonds
c
         else if (iring .eq. 4) then
            do j = 1, nb4
               if (kb4(j) .eq. pt) then
                  bk(i) = bcon4(j)
                  bl(i) = blen4(j)
                  done = .true.
                  goto 140
               end if
            end do
c
c     assign stretching parameters for 3-membered ring bonds
c
         else if (iring .eq. 3) then
            do j = 1, nb3
               if (kb3(j) .eq. pt) then
                  bk(i) = bcon3(j)
                  bl(i) = blen3(j)
                  done = .true.
                  goto 140
               end if
            end do
         end if
c
c     warning if suitable bond stretching parameter not found
c
  140    continue
         minat = min(atomic(ia),atomic(ib))
         if (minat .eq. 0)  done = .true.
         if (use_bond .and. .not.done) then
            if (use(ia) .or. use(ib))  abort = .true.
            if (header) then
               header = .false.
               write (iout,150)
  150          format (/,' Undefined Bond Stretching Parameters :',
     &                 //,' Type',13x,'Atom Names',11x,
     &                    'Atom Classes',/)
            end if
            label = 'Bond  '
            if (iring .eq. 5)  label = '5-Ring'
            if (iring .eq. 4)  label = '4-Ring'
            if (iring .eq. 3)  label = '3-Ring'
            write (iout,160)  label,ia,name(ia),ib,name(ib),ita,itb
  160       format (1x,a6,5x,i6,'-',a3,i6,'-',a3,7x,2i5)
         end if
      end do
c
c     process keywords containing bond specific parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:5) .eq. 'BOND ') then
            ia = 0
            ib = 0
            fc = 0.0d0
            bd = 0.0d0
            string = record(next:240)
            read (string,*,err=170,end=170)  ia,ib,fc,bd
  170       continue
            if (min(ia,ib) .lt. 0) then
               ia = abs(ia)
               ib = abs(ib)
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,180)
  180             format (/,' Additional Bond Parameters for',
     &                       ' Specific Bonds :',
     &                    //,8x,'Atoms',17x,'K(S)',9x,'Length',/)
               end if
               if (.not. silent) then
                  write (iout,190)  ia,ib,fc,bd
  190             format (6x,2i4,5x,f15.3,f15.4)
               end if
               do j = 1, nbond
                  ita = ibnd(1,j)
                  itb = ibnd(2,j)
                  if ((ia.eq.ita .and. ib.eq.itb) .or.
     &                (ib.eq.itb .and. ib.eq.ita)) then
                     bk(j) = fc
                     bl(j) = bd
                     goto 200
                  end if
               end do
            end if
  200       continue
         end if
      end do
c
c     check for electronegativity bond length corrections
c
      call keneg
c
c     turn off the bond stretch potential if it is not used
c
      if (nbond .eq. 0)  use_bond = .false.
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine keneg  --  assign electronegativity parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "keneg" applies primary and secondary electronegativity bond
c     length corrections to applicable bond parameters
c
c     note this version does not scale multiple corrections to the
c     same bond by increasing powers of 0.62 as in MM3
c
c
      subroutine keneg
      use angbnd
      use atmlst
      use atomid
      use bndstr
      use couple
      use inform
      use iounit
      use kbonds
      use keys
      use tors
      implicit none
      integer i,j,k,m,nel
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer size,next
      real*8 dl,factor
      logical header
      character*4 pa,pb,pc,pd
      character*12 blank
      character*12 pt,pt1,pt2
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing electronegativity parameters
c
      blank = '            '
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:9) .eq. 'ELECTNEG ') then
            ia = 0
            ib = 0
            ic = 0
            dl = 0.0d0
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,ic,dl
   10       continue
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Electronegativity',
     &                       ' Parameters :',
     &                    //,5x,'Atom Classes',18x,'dLength',/)
               end if
               write (iout,30)  ia,ib,ic,dl
   30          format (4x,3i4,14x,f12.4)
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            pt = pa//pb//pc
            do j = 1, maxnel
               if (kel(j).eq.blank .or. kel(j).eq.pt) then
                  kel(j) = pt
                  dlen(j) = dl
                  goto 50
               end if
            end do
            write (iout,40)
   40       format (/,' KENEG  --  Too many Electronegativity',
     &                    ' Parameters')
            abort = .true.
   50       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      nel = maxnel
      do i = 1, maxnel
         if (kel(i) .eq. blank) then
            nel = i - 1
            goto 60
         end if
      end do
   60 continue
c
c     check angles for primary electronegativity corrections
c
      if (nel .ne. 0) then
         do i = 1, nangle
            ia = iang(1,i)
            ib = iang(2,i)
            ic = iang(3,i)
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            size = 4
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            pt1 = pa//pb//pc
            pt2 = pc//pb//pa
c
c     search the parameter set for a match to either bond
c
            do j = 1, nel
               if (kel(j) .eq. pt1) then
                  do k = 1, n12(ia)
                     if (i12(k,ia) .eq. ib) then
                        m = bndlist(k,ia)
                        bl(m) = bl(m) + dlen(j)
                     end if
                  end do
                  goto 70
               else if (kel(j) .eq. pt2) then
                  do k = 1, n12(ic)
                     if (i12(k,ic) .eq. ib) then
                        m = bndlist(k,ic)
                        bl(m) = bl(m) + dlen(j)
                     end if
                  end do
                  goto 70
               end if
            end do
   70       continue
         end do
c
c     check torsions for secondary electronegativity corrections
c
         factor = 0.4d0
         do i = 1, ntors
            ia = itors(1,i)
            ib = itors(2,i)
            ic = itors(3,i)
            id = itors(4,i)
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            itd = class(id)
            size = 4
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            call numeral (itd,pd,size)
            pt1 = pa//pb//pd
            pt2 = pd//pc//pa
c
c     turn off electronegativity effect for attached hydrogens
c
            if (atomic(id) .le. 1)  pt1 = blank
            if (atomic(ia) .le. 1)  pt2 = blank
c
c     search the parameter set for a match to either bond
c
            do j = 1, nel
               if (kel(j) .eq. pt1) then
                  do k = 1, n12(ia)
                     if (i12(k,ia) .eq. ib) then
                        m = bndlist(k,ia)
                        bl(m) = bl(m) + factor*dlen(j)
                     end if
                  end do
                  goto 80
               else if (kel(j) .eq. pt2) then
                  do k = 1, n12(id)
                     if (i12(k,id) .eq. ic) then
                        m = bndlist(k,id)
                        bl(m) = bl(m) + factor*dlen(j)
                     end if
                  end do
                  goto 80
               end if
            end do
   80       continue
         end do
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine kbondm  --  assign MMFF bond stretch parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "kbondm" assigns a force constant and ideal bond length to
c     each bond according to the Merck Molecular Force Field (MMFF)
c
c     literature reference:
c
c     R. Blom and A. Haaland, "A Modification of the Schomaker-Stevenson
c     Rule for Prediction of Single Bond Distances", Journal of
c     Molecular Structure, 128, 21-27 (1985)
c
c
      subroutine kbondm
      use atomid
      use bndstr
      use keys
      use merck
      use potent
      implicit none
      integer i,j
      integer ia,ib
      integer ita,itb
      integer next,size
      integer minat
      integer, allocatable :: list(:)
      real*8 khia,khib,cst
      real*8 rad0a,rad0b
      logical header,done
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     perform dynamic allocation of some local arrays
c
      size = 40
      allocate (list(size))
c
c     get single bonds that could be double (MMFF bond type=1)
c
      nligne = 0
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:12) .eq. 'MMFF-PIBOND ') then
            do j = 1, size
               list(j) = 0
            end do
            string = record(next:240)
            read (string,*,err=10,end=10)  (list(j),j=1,size)
   10       continue
            do j = 1, size, 2
               if (list(j).ne.0 .and. list(j+1).ne.0) then
                  nligne = nligne + 1
                  bt_1(nligne,1) = list(j)
                  bt_1(nligne,2) = list(j+1)
               else
                  goto 20
               end if
            end do
   20       continue
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (list)
c
c     assign MMFF bond length and force constant values
c
      header = .true.
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ita = class(ia)
         itb = class(ib)
         if (ia .le. ib) then
            do j = 1, nligne
               if (ia.eq.bt_1(j,1) .and. ib.eq.bt_1(j,2)) then
                  bk(i) = mmff_kb1(ita,itb)
                  bl(i) = mmff_b1(ita,itb)
                  done = .true.
                  if (bk(i) .eq. 1000.0d0)  done = .false.
                  if (bl(i) .eq. 1000.0d0)  done = .false.
                  goto 30
               end if
            end do
            bk(i) = mmff_kb(ita,itb)
            bl(i) = mmff_b0(ita,itb)
            done = .true.
            if (bk(i) .eq. 1000.0d0)  done = .false.
            if (bl(i) .eq. 1000.0d0)  done = .false.
            goto 30
         else if (ib .le. ia) then
            do j = 1, nligne
               if (ib.eq.bt_1(j,1) .and. ia.eq.bt_1(j,2)) then
                  bk(i) = mmff_kb1(itb,ita)
                  bl(i) = mmff_b1(itb,ita)
                  done = .true.
                  if (bk(i) .eq. 1000.0d0)  done = .false.
                  if (bl(i) .eq. 1000.0d0)  done = .false.
                  goto 30
               end if
            end do
            bk(i) = mmff_kb(itb,ita)
            bl(i) = mmff_b0(itb,ita)
            done = .true.
            if (bk(i) .eq. 1000.0d0)  done = .false.
            if (bl(i) .eq. 1000.0d0)  done = .false.
            goto 30
         end if
c
c     estimate missing bond parameters via an empirical rule
c
   30    continue
         minat = min(atomic(ia),atomic(ib))
         if (minat .eq. 0)  done = .true.
         if (.not. done) then
            khia = paulel(atomic(ia))
            khib = paulel(atomic(ib))
            rad0a = rad0(atomic(ia))
            rad0b = rad0(atomic(ib))
            cst = 0.085d0
            if (atomic(ia).eq.1 .or. atomic(ib).eq.1)  cst = 0.05d0
            bl(i) = rad0a + rad0b - cst*abs(khia-khib)**1.4d0
            bk(i) = kbref(atomic(ia),atomic(ib))
     &                 * (r0ref(atomic(ia),atomic(ib))/bl(i))**6
         end if
      end do
c
c     turn off the bond stretch potential if it is not used
c
      if (nbond .eq. 0)  use_bond = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module kbonds  --  bond stretching forcefield parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     maxnb   maximum number of bond stretch parameter entries
c     maxnb5  maximum number of 5-membered ring bond stretch entries
c     maxnb4  maximum number of 4-membered ring bond stretch entries
c     maxnb3  maximum number of 3-membered ring bond stretch entries
c     maxnel  maximum number of electronegativity bond corrections
c
c     bcon    force constant parameters for harmonic bond stretch
c     bcon5   force constant parameters for 5-ring bond stretch
c     bcon4   force constant parameters for 4-ring bond stretch
c     bcon3   force constant parameters for 3-ring bond stretch
c     blen    bond length parameters for harmonic bond stretch
c     blen5   bond length parameters for 5-ring bond stretch
c     blen4   bond length parameters for 4-ring bond stretch
c     blen3   bond length parameters for 3-ring bond stretch
c     dlen    electronegativity bond length correction parameters
c     kb      string of atom classes for harmonic bond stretch
c     kb5     string of atom classes for 5-ring bond stretch
c     kb4     string of atom classes for 4-ring bond stretch
c     kb3     string of atom classes for 3-ring bond stretch
c     kel     string of atom classes for electronegativity corrections
c
c
      module kbonds
      implicit none
      integer maxnb
      integer maxnb5
      integer maxnb4
      integer maxnb3
      integer maxnel
      real*8, allocatable :: bcon(:)
      real*8, allocatable :: bcon5(:)
      real*8, allocatable :: bcon4(:)
      real*8, allocatable :: bcon3(:)
      real*8, allocatable :: blen(:)
      real*8, allocatable :: blen5(:)
      real*8, allocatable :: blen4(:)
      real*8, allocatable :: blen3(:)
      real*8, allocatable :: dlen(:)
      character*8, allocatable :: kb(:)
      character*8, allocatable :: kb5(:)
      character*8, allocatable :: kb4(:)
      character*8, allocatable :: kb3(:)
      character*12, allocatable :: kel(:)
      save
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2020 by Chengwen Liu & Jay W. Ponder  ##
c     ##                 All Rights Reserved                  ##
c     ##########################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module kcflux -- charge flux term forcefield parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     maxncfb   maximum number of bond stretch charge flux entries
c     maxncfa   maximum number of angle bend charge flux entries
c
c     cflb      charge flux over stretching of a bond length
c     cfla      charge flux over bending of a bond angle
c     cflab     charge flux over asymmetric bond within an angle
c     kcfb      string of atom classes for bond stretch charge flux
c     kcfa      string of atom classes for angle bend charge flux
c
c
      module kcflux
      implicit none
      integer maxncfb
      integer maxncfa
      real*8, allocatable :: cflb(:)
      real*8, allocatable :: cfla(:,:)
      real*8, allocatable :: cflab(:,:)
      character*8, allocatable :: kcfb(:)
      character*12, allocatable :: kcfa(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine kcharge  --  assign partial charge parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "kcharge" assigns partial charges to the atoms within
c     the structure and processes any new or changed values
c
c
      subroutine kcharge
      use atomid
      use atoms
      use charge
      use chgpot
      use couple
      use fields
      use inform
      use iounit
      use kchrge
      use keys
      use potent
      implicit none
      integer i,j,k,m
      integer ia,it,next
      integer, allocatable :: list(:)
      integer, allocatable :: nc12(:)
      real*8 cg
      logical header
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing partial charge parameters
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. 'CHARGE ') then
            ia = 0
            cg = 0.0d0
            string = record(next:240)
            read (string,*,err=40,end=40)  ia,cg
            if (ia .gt. 0) then
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,10)
   10             format (/,' Additional Atomic Partial Charge',
     &                       ' Parameters :',
     &                    //,5x,'Atom Type',14x,'Charge',/)
               end if
               if (ia .le. maxtyp) then
                  chg(ia) = cg
                  if (.not. silent) then
                     write (iout,20)  ia,cg
   20                format (6x,i6,7x,f15.4)
                  end if
               else
                  write (iout,30)
   30             format (/,' KCHARGE  --  Too many Partial Charge',
     &                       ' Parameters')
                  abort = .true.
               end if
            end if
   40       continue
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(iion))  deallocate (iion)
      if (allocated(jion))  deallocate (jion)
      if (allocated(kion))  deallocate (kion)
      if (allocated(pchg))  deallocate (pchg)
      if (allocated(pchg0))  deallocate (pchg0)
      allocate (iion(n))
      allocate (jion(n))
      allocate (kion(n))
      allocate (pchg(n))
      allocate (pchg0(n))
c
c     find and store all the atomic partial charges
c
      do i = 1, n
         pchg(i) = 0.0d0
         pchg0(i) = 0.0d0
         it = type(i)
         if (it .ne. 0) then
            pchg(i) = chg(it)
            pchg0(i) = pchg(i)
         end if
      end do
c
c     use special charge parameter assignment method for MMFF
c
      if (forcefield .eq. 'MMFF94')  call kchargem
c
c     process keywords containing atom specific partial charges
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. 'CHARGE ') then
            ia = 0
            cg = 0.0d0
            string = record(next:240)
            read (string,*,err=70,end=70)  ia,cg
            if (ia.lt.0 .and. ia.ge.-n) then
               ia = -ia
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,50)
   50             format (/,' Additional Partial Charges for',
     &                       ' Specific Atoms :',
     &                    //,8x,'Atom',16x,'Charge',/)
               end if
               if (.not. silent) then
                  write (iout,60)  ia,cg
   60             format (6x,i6,7x,f15.4)
               end if
               pchg(ia) = cg
            end if
   70       continue
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
      allocate (nc12(n))
c
c     remove zero or undefined partial charges from the list
c
      nion = 0
      do i = 1, n
         list(i) = 0
         if (pchg(i) .ne. 0.0d0) then
            nion = nion + 1
            iion(nion) = i
            jion(i) = i
            kion(i) = i
            list(i) = nion
         end if
      end do
c
c     optionally use neutral groups for neighbors and cutoffs
c
      if (neutnbr .or. neutcut) then
         do i = 1, n
            nc12(i) = 0
            do j = 1, n12(i)
               k = list(i12(j,i))
               if (k .ne. 0)  nc12(i) = nc12(i) + 1
            end do
         end do
         do i = 1, nion
            k = iion(i)
            if (n12(k) .eq. 1) then
               do j = 1, n12(k)
                  m = i12(j,k)
                  if (nc12(m) .gt. 1) then
                     if (neutnbr)  jion(k) = m
                     if (neutcut)  kion(k) = m
                  end if
               end do
            end if
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (nc12)
c
c     turn off charge-charge and charge-dipole terms if not used
c
      if (nion .eq. 0) then
         use_charge = .false.
         use_chgdpl = .false.
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine kchargem  --  assign MMFF charge parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "kchargem" assigns partial charges to the atoms according to
c     the Merck Molecular Force Field (MMFF)
c
c
      subroutine kchargem
      use atomid
      use atoms
      use charge
      use couple
      use merck
      implicit none
      integer i,j,k,m
      integer it,kt,bt
      integer ic,kc
      real*8, allocatable :: pbase(:)
      logical emprule
c
c
c     set and store MMFF base atomic partial charge values
c
      do i = 1, n
         it = type(i)
         pchg(i) = 0.0d0
         if (it .eq. 107)  pchg(i) = -0.5d0
         if (it .eq. 113) then
            pchg(i) = 0.0d0
            do j = 1, n12(i)
               k = i12(j,i)
               kt = type(k)
               if (kt .eq. 185)  pchg(i) = -0.5d0
            end do
         end if
         if (it .eq. 114)  pchg(i) = -1.0d0 / 3.0d0
         if (it .eq. 115)  pchg(i) = -3.0d0
         if (it .eq. 116)  pchg(i) = -0.5d0
         if (it .eq. 118)  pchg(i) = -0.5d0
         if (it .eq. 119)  pchg(i) = -2.0d0 / 3.0d0
         if (it .eq. 121)  pchg(i) = -0.25d0
         if (it .eq. 123)  pchg(i) = 1.0d0
         if (it .eq. 124)  pchg(i) = -1.0d0
         if (it .eq. 125)  pchg(i) = -1.0d0
         if (it .eq. 154)  pchg(i) = 1.0d0
         if (it .eq. 156)  pchg(i) = 1.0d0
         if (it .eq. 159)  pchg(i) = 1.0d0
         if (it .eq. 160)  pchg(i) = 1.0d0
         if (it .eq. 161)  pchg(i) = 0.5d0
         if (it .eq. 162)  pchg(i) = 1.0d0 / 3.0d0
         if (it .eq. 165)  pchg(i) = 1.0d0
         if (it .eq. 168) then
            do j = 1, n12(i)
               k = i12(j,i)
               kt = type(k)
               if (kt.eq.168 .or. kt.eq.142)  pchg(i) = 1.0d0
            end do
         end if
         if (it .eq. 169)  pchg(i) = -1.0d0
         if (it .eq. 182)  pchg(i) = -0.5d0
         if (it .eq. 183) then
            pchg(i) = -1.0d0
            do j = 1, n12(i)
               k = i12(j,i)
               kt = type(k)
               if (kt .eq. 87)  pchg(i) = -0.5d0
            end do
         end if
         if (it .eq. 195)  pchg(i) = 1.0d0
         if (it .eq. 196)  pchg(i) = 1.0d0
         if (it .eq. 197)  pchg(i) = 1.0d0
         if (it .eq. 201)  pchg(i) = 2.0d0
         if (it .eq. 202)  pchg(i) = 3.0d0
         if (it .eq. 203)  pchg(i) = -1.0d0
         if (it .eq. 204)  pchg(i) = -1.0d0
         if (it .eq. 205)  pchg(i) = -1.0d0
         if (it .eq. 206)  pchg(i) = 1.0d0
         if (it .eq. 207)  pchg(i) = 1.0d0
         if (it .eq. 208)  pchg(i) = 1.0d0
         if (it .eq. 209)  pchg(i) = 2.0d0
         if (it .eq. 210)  pchg(i) = 2.0d0
         if (it .eq. 211)  pchg(i) = 2.0d0
         if (it .eq. 212)  pchg(i) = 1.0d0
         if (it .eq. 213)  pchg(i) = 2.0d0
         if (it .eq. 214)  pchg(i) = 2.0d0
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (pbase(n))
c
c     modify MMFF base charges using a bond increment scheme
c
      do i = 1, n
         pbase(i) = pchg(i)
      end do
      do i = 1, n
         it = type(i)
         ic = class(i)
         if (pbase(i).lt.0.0d0 .or. it.eq.162) then
            pchg(i) = (1.0d0-crd(ic)*fcadj(ic)) * pbase(i)
         end if
         do j = 1, n12(i)
            k = i12(j,i)
            kt = type(k)
            kc = class(k)
            if (pbase(k).lt.0.0d0 .or. kt.eq.162) then
               pchg(i) = pchg(i) + fcadj(kc)*pbase(k)
            end if
            bt = 0
            do m = 1, nligne
               if ((i.eq.bt_1(m,1) .and. i12(j,i).eq.bt_1(m,2)).or.
     &                (i12(j,i).eq.bt_1(m,1) .and. i.eq.bt_1(m,2))) then
                  bt = 1
               end if
            end do
            emprule = .false.
            if (bt .eq. 1) then
               pchg(i) = pchg(i) + bci_1(kc,ic)
               if (bci_1(kc,ic) .eq. 1000.0d0) then
                  emprule = .true.
                  goto 10
               end if
            else if (bt .eq. 0) then
               pchg(i) = pchg(i) + bci(kc,ic)
               if (bci(kc,ic) .eq. 1000.0d0) then
                  emprule = .true.
                  goto 10
               end if
            end if
         end do
   10    continue
         if (emprule) then
            pchg(i) = (1.0d0-crd(ic)*fcadj(ic)) * pbase(i)
            do j = 1, n12(i)
               k = i12(j,i)
               kc = class(k)
               pchg(i) = pchg(i) + fcadj(kc)*pbase(i12(j,i))
            end do
            do j = 1, n12(i)
               k = i12(j,i)
               kc = class(k)
               bt = 0
               do k = 1, nligne
                  if ((i.eq.bt_1(k,1) .and.
     &                      i12(j,i).eq.bt_1(k,2)) .or.
     &                   (i12(j,i).eq.bt_1(k,1) .and.
     &                      i.eq.bt_1(k,2))) then
                     bt = 1
                  end if
               end do
               if (bt .eq. 1) then
                  if (bci_1(kc,ic) .eq. 1000.0d0) then
                     pchg(i) = pchg(i) + pbci(ic) - pbci(kc)
                  else
                     pchg(i) = pchg(i) + bci_1(kc,ic)
                  end if
               else if (bt .eq. 0) then
                  if (bci(kc,ic) .eq. 1000.0d0) then
                     pchg(i) = pchg(i) + pbci(ic) - pbci(kc)
                  else
                     pchg(i) = pchg(i) + bci(kc,ic)
                  end if
               end if
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (pbase)
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2020 by Chengwen Liu & Jay W. Ponder  ##
c     ##                 All Rights Reserved                  ##
c     ##########################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine kchgflx  --  charge flux parameter assignment  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "kchgflx" assigns bond stretch and angle bend charge flux
c     correction values and processes any new or changed values
c     for these parameters
c
c
      subroutine kchgflx
      use sizes
      use angbnd
      use atmlst
      use atomid
      use atoms
      use bndstr
      use cflux
      use couple
      use inform
      use iounit
      use kangs
      use kbonds
      use kcflux
      use keys
      use potent
      use usage
      implicit none
      integer i,j
      integer ia,ib,ic
      integer ita,itb,itc
      integer na,nb
      integer size,next
      real*8 cfb
      real*8 cfa1,cfa2
      real*8 cfb1,cfb2
      logical headerb
      logical headera
      character*4 pa,pb,pc
      character*8 blank8,pt2
      character*12 blank12,pt3
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing charge flux parameters
c
      blank8 = '        '
      blank12 = '            '
      size = 4
      headerb = .true.
      headera = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:9) .eq. 'BNDCFLUX ') then
            ia = 0
            ib = 0
            cfb = 0.0d0
            string = record(next:240)
            read (string,*,err=10,end=10) ia,ib,cfb
   10       continue
            if (headerb .and. .not.silent) then
               headerb = .false.
               write (iout,20)
   20          format (/,' Additional Bond Charge Flux Parameters :',
     &                 //,5x,'Atom Classes',19x,'K(CFB)',/)
            end if
            if (.not. silent) then
               write (iout,30)  ia,ib,cfb
   30          format (6x,2i4,13x,f15.6)
            end if
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            if (ia .le. ib) then
               pt2 = pa//pb
            else
               pt2 = pb//pa
            end if
            do j = 1, maxncfb
               if (kcfb(j).eq.blank8 .or. kcfb(j).eq.pt2) then
                  kcfb(j) = pt2
                  if (ia .lt. ib) then
                     cflb(j) = cfb
                  else if (ib .lt. ia) then
                     cflb(j) = -cfb
                  else
                     cflb(j) = 0.0d0
                     write (iout,40)
   40                format (/,' KCHGFLX  --  Bond Charge Flux for',
     &                          ' Identical Classes Set to Zero')
                  end if
                  goto 50
               end if
            end do
   50       continue
         else if (keyword(1:9) .eq. 'ANGCFLUX ') then
            ia = 0
            ib = 0
            ic = 0
            cfa1 = 0.0d0
            cfa2 = 0.0d0
            cfb1 = 0.0d0
            cfb2 = 0.0d0
            string = record(next:240)
            read (string,*,err=60,end=60) ia,ib,ic,cfa1,cfa2,cfb1,cfb2
   60       continue
            if (headera .and. .not.silent) then
               headera = .false.
               write (iout,70)
   70          format (/,' Additional Angle Charge Flux Parameters :',
     &                 //,5x,'Atom Classes',10x,'K(CFA1)',
     &                    7x,'K(CFA2)',7x,'K(CFB1)',7x,'K(CFB2)',/)
            end if
            if (.not. silent) then
               write (iout,80)  ia,ib,ic,cfa1,cfa2,cfb1,cfb2
   80          format (4x,3i4,4x,4f14.6)
            end if
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            if (ia .le. ic) then
               pt3 = pa//pb//pc
            else
               pt3 = pc//pb//pa
            end if
            do j = 1, maxncfa
               if (kcfa(j).eq.blank12 .or. kcfa(j).eq.pt3) then
                  kcfa(j) = pt3
                  if (ia .le. ic) then
                     cfla(1,j) = cfa1
                     cfla(2,j) = cfa2
                     cflab(1,j) = cfb1
                     cflab(2,j) = cfb2
                  else
                     cfla(1,j) = cfa2
                     cfla(2,j) = cfa1
                     cflab(1,j) = cfb2
                     cflab(2,j) = cfb1
                  end if
                  goto 90
               end if
            end do
   90       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      nb = maxncfb
      do i = maxncfb, 1, -1
         if (kcfb(i) .eq. blank8)  nb = i - 1
      end do
      na = maxncfa
      do i = maxncfa, 1, -1
         if (kcfa(i) .eq. blank12)  na = i - 1
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(bflx))  deallocate (bflx)
      if (allocated(aflx))  deallocate (aflx)
      if (allocated(abflx))  deallocate (abflx)
      allocate (bflx(nbond))
      allocate (aflx(2,nangle))
      allocate (abflx(2,nangle))
c
c     assign bond charge flux parameters for each bond
c
      nbflx = 0
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ita = class(ia)
         itb = class(ib)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            pt2 = pa//pb
         else
            pt2 = pb//pa
         end if
         bflx(i) = 0.0d0
         do j = 1, nb
            if (kcfb(j) .eq. pt2) then
               nbflx = nbflx + 1
               if (ita .le. itb) then
                  bflx(i) = cflb(j)
               else
                  bflx(i) = -cflb(j)
               end if
            end if
         end do
      end do
c
c    assign angle charge flux parameters for each angle
c
      naflx = 0
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pt3 = pa//pb//pc
         else
            pt3 = pc//pb//pa
         end if
         aflx(1,i) = 0.0d0
         aflx(2,i) = 0.0d0
         abflx(1,i) = 0.0d0
         abflx(2,i) = 0.0d0
         do j = 1, na
            if (kcfa(j) .eq. pt3) then
               naflx = naflx + 1
               if (ita .le. itc) then
                  aflx(1,i) = cfla(1,j)
                  aflx(2,i) = cfla(2,j)
                  abflx(1,i) = cflab(1,j)
                  abflx(2,i) = cflab(2,j)
               else
                  aflx(1,i) = cfla(2,j)
                  aflx(2,i) = cfla(1,j)
                  abflx(1,i) = cflab(2,j)
                  abflx(2,i) = cflab(1,j)
               end if
            end if
         end do
      end do
c
c     turn off bond and angle charge flux term if not used
c
      if (nbflx.eq.0 .and. naflx.eq.0)  use_chgflx = .false.
      if (.not.use_charge .and. .not.use_mpole
     &        .and. .not.use_polar)  use_chgflx = .false.
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine kchgtrn  --  charge transfer term assignment  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "kchgtrn" assigns charge magnitude and damping parameters for
c     charge transfer interactions and processes any new or changed
c     values for these parameters
c
c
      subroutine kchgtrn
      use atomid
      use atoms
      use chgpen
      use chgtrn
      use expol
      use inform
      use iounit
      use kctrn
      use keys
      use mplpot
      use mpole
      use polar
      use polpot
      use potent
      use sizes
      implicit none
      integer i,k
      integer ia,ic,next
      real*8 chtrn,actrn
      logical header
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing charge transfer parameters
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. 'CHGTRN ') then
            k = 0
            chtrn = 0.0d0
            actrn = 0.0d0
            call getnumb (record,k,next)
            string = record(next:240)
            read (string,*,err=10,end=10)  chtrn,actrn
   10       continue
            if (k .gt. 0) then
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Charge Transfer',
     &                       ' Parameters :',
     &                    //,5x,'Atom Class',13x,'Charge',11x,'Damp',/)
               end if
               if (k .le. maxclass) then
                  ctchg(k) = chtrn
                  ctdmp(k) = actrn
                  if (.not. silent) then
                     write (iout,30)  k,chtrn,actrn
   30                format (6x,i6,7x,f15.4,f15.4)
                  end if
               else
                  write (iout,40)
   40             format (/,' KCHGTRN  --  Too many Charge',
     &                       ' Transfer Parameters')
                  abort = .true.
               end if
            end if
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(chgct))  deallocate (chgct)
      if (allocated(dmpct))  deallocate (dmpct)
      allocate (chgct(n))
      allocate (dmpct(n))
c
c     assign the charge transfer charge and alpha parameters 
c
      nct = n
      do i = 1, n
         ic = class(i)
         chgct(i) = ctchg(ic)
         dmpct(i) = ctdmp(ic)
      end do
c
c     process keywords containing atom specific charge transfer
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. 'CHGTRN ') then
            ia = 0
            chtrn = 0.0d0
            actrn = 0.0d0
            string = record(next:240)
            read (string,*,err=70,end=70)  ia,chtrn,actrn
            if (ia.lt.0 .and. ia.ge.-n) then
               ia = -ia
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,50)
   50             format (/,' Additional Charge Transfer Values',
     &                       ' for Specific Atoms :',
     &                    //,8x,'Atom',16x,'Charge',11x,'Damp',/)
               end if
               if (.not. silent) then
                  write (iout,60)  ia,chtrn,actrn
   60             format (6x,i6,7x,f15.4,f15.4)
               end if
               chgct(ia) = chtrn
               dmpct(ia) = actrn
            end if
   70       continue
         end if
      end do
c
c     remove zero or undefined electrostatic sites from the list
c
      if (use_chgtrn) then
         npole = 0
         ncp = 0
         npolar = 0
         nexpol = 0
         nct = 0
         do i = 1, n
            if (polarity(i) .eq. 0.0d0)  douind(i) = .false.
            if (polsiz(i).ne.0 .or. polarity(i).ne.0.0d0 .or.
     &             chgct(i).ne.0.0d0 .or. dmpct(i).ne.0.0d0) then
               npole = npole + 1
               ipole(npole) = i
               pollist(i) = npole
               mono0(i) = pole(1,i)
               if (palpha(i) .ne. 0.0d0)  ncp = ncp + 1
               if (polarity(i) .ne. 0.0d0) then
                  npolar = npolar + 1
                  ipolar(npolar) = npole
                  douind(i) = .true.
               end if
               if (tholed(i) .ne. 0.0d0)  use_tholed = .true.
               if (kpep(i) .ne. 0.0d0)  nexpol = nexpol + 1
               if (chgct(i).ne.0.0d0 .or. dmpct(i).ne.0.0d0) then
                  nct = nct + 1
               end if
            end if
         end do
      end if
c
c     test multipoles at chiral sites and invert if necessary
c
      if (use_chgtrn)  call chkpole
c
c     turn off individual electrostatic potentials if not used
c
      if (npole .eq. 0)  use_mpole = .false.
      if (npolar .eq. 0)  use_polar = .false.
      if (ncp .ne. 0)  use_chgpen = .true.
      if (ncp .ne. 0)  use_thole = .false.
      if (use_tholed)  use_thole = .true.
      if (nexpol .ne. 0)  use_expol = .true.
      if (nct .eq. 0)  use_chgtrn = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module kchrge  --  partial charge forcefield parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     chg   partial charge parameters for each atom type
c
c
      module kchrge
      implicit none
      real*8, allocatable :: chg(:)
      save
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module kcpen  --  charge penetration forcefield parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     cpele     valence electron magnitude for each atom class
c     cpalp     alpha charge penetration parameter for each atom class
c
c
      module kcpen
      implicit none
      real*8, allocatable :: cpele(:)
      real*8, allocatable :: cpalp(:)
      save
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module kctrn  --  charge transfer forcefield parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     ctchg     charge transfer magnitude for each atom class
c     ctdmp     alpha charge transfer parameter for each atom class
c
c
      module kctrn
      implicit none
      real*8, allocatable :: ctchg(:)
      real*8, allocatable :: ctdmp(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module kdipol  --  bond dipole forcefield parameters  ##
c     ##                                                        ##
c     ############################################################
c
c
c     maxnd    maximum number of bond dipole parameter entries
c     maxnd5   maximum number of 5-membered ring dipole entries
c     maxnd4   maximum number of 4-membered ring dipole entries
c     maxnd3   maximum number of 3-membered ring dipole entries
c
c     dpl      dipole moment parameters for bond dipoles
c     dpl5     dipole moment parameters for 5-ring dipoles
c     dpl4     dipole moment parameters for 4-ring dipoles
c     dpl3     dipole moment parameters for 3-ring dipoles
c     pos      dipole position parameters for bond dipoles
c     pos5     dipole position parameters for 5-ring dipoles
c     pos4     dipole position parameters for 4-ring dipoles
c     pos3     dipole position parameters for 3-ring dipoles
c     kd       string of atom classes for bond dipoles
c     kd5      string of atom classes for 5-ring dipoles
c     kd4      string of atom classes for 4-ring dipoles
c     kd3      string of atom classes for 3-ring dipoles
c
c
      module kdipol
      implicit none
      integer maxnd
      integer maxnd5
      integer maxnd4
      integer maxnd3
      real*8, allocatable :: dpl(:)
      real*8, allocatable :: dpl5(:)
      real*8, allocatable :: dpl4(:)
      real*8, allocatable :: dpl3(:)
      real*8, allocatable :: pos(:)
      real*8, allocatable :: pos5(:)
      real*8, allocatable :: pos4(:)
      real*8, allocatable :: pos3(:)
      character*8, allocatable :: kd(:)
      character*8, allocatable :: kd5(:)
      character*8, allocatable :: kd4(:)
      character*8, allocatable :: kd3(:)
      save
      end
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
      use atmlst
      use atoms
      use bndstr
      use couple
      use dipole
      use inform
      use iounit
      use kdipol
      use keys
      use potent
      implicit none
      integer i,j,k
      integer ia,ib,ita,itb
      integer nd,nd5,nd4,nd3
      integer iring,size,next
      real*8 dp,ps
      logical header
      logical use_ring
      character*4 pa,pb
      character*6 label
      character*8 blank,pt
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing bond dipole parameters
c
      blank = '        '
      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:240)
            read (string,*,err=10,end=10)  ia,ib,dp,ps
   10       continue
            if (ia.gt.0 .and. ib.gt.0) then
               if (.not. silent) then
                  if (header) then
                     header = .false.
                     write (iout,20)
   20                format (/,' Additional Bond Dipole Moment ',
     &                          'Parameters :',
     &                       //,5x,'Atom Types',13x,'Moment',
     &                          8x,'Position',/)
                  end if
                  if (iring .eq. 0) then
                     write (iout,30)  ia,ib,dp,ps
   30                format (6x,2i4,5x,2f15.3)
                  else
                     if (iring .eq. 5)  label = '5-Ring'
                     if (iring .eq. 4)  label = '4-Ring'
                     if (iring .eq. 3)  label = '3-Ring'
                     write (iout,40)  ia,ib,dp,ps,label
   40                format (6x,2i4,5x,2f15.3,3x,a6)
                  end if
               end if
               size = 4
               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.blank .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 90
                     end if
                  end do
                  write (iout,50)
   50             format (/,' KDIPOLE  --  Too many Bond Dipole',
     &                       ' Moment Parameters')
                  abort = .true.
               else if (iring .eq. 5) then
                  do j = 1, maxnd5
                     if (kd5(j).eq.blank .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 90
                     end if
                  end do
                  write (iout,60)
   60             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.blank .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 90
                     end if
                  end do
                  write (iout,70)
   70             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.blank .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 90
                     end if
                  end do
                  write (iout,80)
   80             format (/,' KDIPOLE  --  Too many 3-Ring Bond',
     &                       ' Dipole Parameters')
                  abort = .true.
               end if
            end if
   90       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      nd = maxnd
      nd5 = maxnd5
      nd4 = maxnd4
      nd3 = maxnd3
      do i = maxnd, 1, -1
         if (kd(i) .eq. blank)  nd = i - 1
      end do
      do i = maxnd5, 1, -1
         if (kd5(i) .eq. blank)  nd5 = i - 1
      end do
      do i = maxnd4, 1, -1
         if (kd4(i) .eq. blank)  nd4 = i - 1
      end do
      do i = maxnd3, 1, -1
         if (kd3(i) .eq. blank)  nd3 = i - 1
      end do
      use_ring = .false.
      if (min(nd5,nd4,nd3) .ne. 0)  use_ring = .true.
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(idpl))  deallocate (idpl)
      if (allocated(bdpl))  deallocate (bdpl)
      if (allocated(sdpl))  deallocate (sdpl)
      allocate (idpl(2,nbond))
      allocate (bdpl(nbond))
      allocate (sdpl(nbond))
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 = 4
         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 contained inside small rings
c
         iring = 0
         if (use_ring) then
            call chkring (iring,ia,ib,0,0)
            if (iring .eq. 6)  iring = 0
            if (iring.eq.5 .and. nd5.eq.0)  iring = 0
            if (iring.eq.4 .and. nd4.eq.0)  iring = 0
            if (iring.eq.3 .and. nd3.eq.0)  iring = 0
         end if
c
c     try to assign bond dipole parameters for the bond
c
         if (iring .eq. 0) then
            do j = 1, nd
               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)
                  goto 100
               end if
            end do
         else if (iring .eq. 5) then
            do j = 1, nd5
               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)
                  goto 100
               end if
            end do
         else if (iring .eq. 4) then
            do j = 1, nd4
               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)
                  goto 100
               end if
            end do
         else if (iring .eq. 3) then
            do j = 1, nd3
               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)
                  goto 100
               end if
            end do
         end if
  100    continue
      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:240)
            read (string,*,err=110,end=110)  ia,ib,dp,ps
  110       continue
            if (ia.lt.0 .and. ib.lt.0) then
               ia = -ia
               ib = -ib
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,120)
  120             format (/,' Additional Bond Dipoles for',
     &                       ' Specific Bonds :',
     &                    //,5x,'Bonded Atoms',11x,'Moment',
     &                          8x,'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
                     if (.not. silent) then
                        write (iout,130)  ia,ib,dp,ps
  130                   format (4x,i5,' -',i5,3x,2f15.3)
                     end if
                     goto 140
                  end if
               end do
            end if
  140       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     turn off dipole-dipole and charge-dipole terms if not used
c
      if (ndipole .eq. 0) then
         use_dipole = .false.
         use_chgdpl = .false.
      end if
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine kdisp  --  dispersion parameter assignment  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "kdisp" assigns C6 coefficients and damping parameters for
c     dispersion interactions and processes any new or changed
c     values for these parameters
c
c
      subroutine kdisp
      use atomid
      use atoms
      use disp
      use dsppot
      use inform
      use iounit
      use kdsp
      use keys
      use limits
      use potent
      use sizes
      implicit none
      integer i,k,ii,kk
      integer ia,ic,next
      real*8 cs,adsp
      real*8 csixi
      logical header
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing damped dispersion parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:11) .eq. 'DISPERSION ') then
            k = 0
            cs = 0.0d0
            adsp = 0.0d0
            call getnumb (record,k,next)
            string = record(next:240)
            read (string,*,err=10,end=10)  cs,adsp
   10       continue
            if (k .gt. 0) then
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Damped Dispersion',
     &                       ' Parameters :',
     &                    //,5x,'Atom Class',16x,'C6',12x,'Damp',/)
               end if
               if (k .le. maxclass) then
                  dspsix(k) = cs
                  dspdmp(k) = adsp
                  if (.not. silent) then
                     write (iout,30)  k,cs,adsp
   30                format (6x,i6,7x,f15.4,f15.4)
                  end if
               else
                  write (iout,40)
   40             format (/,' KDISP  --  Too many Damped',
     &                       ' Dispersion Parameters')
                  abort = .true.
               end if
            end if
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(idisp))  deallocate (idisp)
      if (allocated(csix))  deallocate (csix)
      if (allocated(adisp))  deallocate (adisp)
      allocate (idisp(n))
      allocate (csix(n))
      allocate (adisp(n))
c
c     assign the dispersion C6 values and alpha parameters 
c
      do i = 1, n
         csix(i) = 0.0d0
         adisp(i) = 0.0d0
         ic = class(i)
         if (ic .ne. 0) then
            csix(i) = dspsix(ic)
            adisp(i) = dspdmp(ic)
         end if
      end do
c
c     process keywords containing atom specific dispersion parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:11) .eq. 'DISPERSION ') then
            ia = 0
            cs = 0.0d0
            adsp = 0.0d0
            string = record(next:240)
            read (string,*,err=70,end=70)  ia,cs,adsp
            if (ia.lt.0 .and. ia.ge.-n) then
               ia = -ia
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,50)
   50             format (/,' Additional Dispersion Values for',
     &                       ' Specific Atoms :',
     &                    //,8x,'Atom',19x,'C6',12x,'Damp',/)
               end if
               if (.not. silent) then
                  write (iout,60)  ia,cs,adsp
   60             format (6x,i6,7x,f15.4,f15.4)
               end if
               csix(ia) = cs
               adisp(ia) = adsp
            end if
   70       continue
         end if
      end do
c 
c     remove zero and undefined dispersion sites from the list
c     
      ndisp = 0
      do i = 1, n
         if (csix(i) .ne. 0.0d0) then 
            ndisp = ndisp + 1
            idisp(ndisp) = i
         end if
      end do
c
c     compute pairwise sum of C6 coefficients needed for PME
c
      csixpr = 0.0d0
      if (use_dewald) then
         do ii = 1, ndisp
            i = idisp(ii)
            csixi = csix(i)
            do kk = 1, ndisp
               k = idisp(kk)
               csixpr = csixpr + csixi*csix(k)
            end do
         end do
      end if
c
c     turn off the dispersion potential if not used
c
      if (ndisp .eq. 0)  use_disp = .false.
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module kdsp  --  damped dispersion forcefield parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     dspsix   C6 dispersion coefficient for each atom class
c     dspdmp   alpha dispersion parameter for each atom class
c
c
      module kdsp
      implicit none
      real*8, allocatable :: dspsix(:)
      real*8, allocatable :: dspdmp(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine kewald  --  setup for particle mesh Ewald sum  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "kewald" assigns particle mesh Ewald parameters and options
c     for a periodic system
c
c
      subroutine kewald
      use atoms
      use bound
      use boxes
      use chunks
      use ewald
      use fft
      use inform
      use iounit
      use keys
      use limits
      use openmp
      use pme
      use potent
      implicit none
      integer maxpower
      integer maxfft
      parameter (maxpower=63)
      parameter (maxfft=864)
      integer i,k,next
      integer nbig,minfft
      integer iefft1,idfft1
      integer iefft2,idfft2
      integer iefft3,idfft3
      integer multi(maxpower)
      real*8 delta,rmax
      real*8 edens,ddens
      real*8 size,slope
      real*8 fft1,fft2,fft3
      character*20 keyword
      character*240 record
      character*240 string
c
c     PME grid size must be even with factors of only 2, 3 and 5
c
      data multi  /   2,   4,   6,   8,  10,  12,  16,  18,  20,
     &               24,  30,  32,  36,  40,  48,  50,  54,  60,
     &               64,  72,  80,  90,  96, 100, 108, 120, 128,
     &              144, 150, 160, 162, 180, 192, 200, 216, 240,
     &              250, 256, 270, 288, 300, 320, 324, 360, 384,
     &              400, 432, 450, 480, 486, 500, 512, 540, 576,
     &              600, 640, 648, 720, 750, 768, 800, 810, 864 /
c
c
c     return if Ewald summation is not being used
c
      if (.not.use_ewald .and. .not.use_dewald)  return
c
c     set default values for Ewald options and parameters
c
      ffttyp = 'FFTPACK'
      if (nthread .gt. 1)  ffttyp = 'FFTW'
      boundary = 'TINFOIL'
      bseorder = 5
      bsporder = 5
      bsdorder = 4
      edens = 1.2d0
      ddens = 0.8d0
      aeewald = 0.4d0
      apewald = 0.4d0
      adewald = 0.4d0
      minfft = 16
c
c     estimate optimal values for the Ewald coefficient
c
      if (use_ewald)  call ewaldcof (aeewald,ewaldcut)
      if (use_dewald)  call ewaldcof (adewald,dewaldcut)
      if (use_ewald .and. use_polar)  apewald = aeewald
c
c     modify Ewald coefficient for small unitcell dimensions
c
      if (use_polar .and. use_bounds) then
         size = min(xbox,ybox,zbox)
         if (size .lt. 6.0d0) then
            slope = (1.0d0-apewald) / 2.0d0
            apewald = apewald + slope*(6.0d0-size)
            minfft = 64
            if (verbose) then
               write (iout,10)
   10          format (/,' KEWALD  --  Warning, PME Grid Expanded',
     &                    ' due to Small Cell Size')
            end if
         end if
      end if
c
c     set the system extent for nonperiodic Ewald summation
c
      if (.not. use_bounds) then
         call extent (rmax)
         xbox = 2.0d0 * (rmax+max(ewaldcut,dewaldcut))
         ybox = xbox
         zbox = xbox
         alpha = 90.0d0
         beta = 90.0d0
         gamma = 90.0d0
         orthogonal = .true.
         call lattice
         boundary = 'NONE'
         edens = 0.7d0
         ddens = 0.7d0
      end if
c
c     set defaults for electrostatic and dispersion grid sizes
c
      nefft1 = 0
      nefft2 = 0
      nefft3 = 0
      ndfft1 = 0
      ndfft2 = 0
      ndfft3 = 0
c
c     get default grid counts from periodic system dimensions
c
      delta = 1.0d-8
      iefft1 = int(xbox*edens-delta) + 1
      iefft2 = int(ybox*edens-delta) + 1
      iefft3 = int(zbox*edens-delta) + 1
      idfft1 = int(xbox*ddens-delta) + 1
      idfft2 = int(ybox*ddens-delta) + 1
      idfft3 = int(zbox*ddens-delta) + 1
c
c     search keywords for Ewald summation commands
c
      do i = 1, nkey
         record = keyline(i)
         next = 1
         call upcase (record)
         call gettext (record,keyword,next)
         string = record(next:240)
         if (keyword(1:12) .eq. 'FFT-PACKAGE ') then
            call getword (record,ffttyp,next)
         else if (keyword(1:12) .eq. 'EWALD-ALPHA ') then
            read (string,*,err=40,end=40)  aeewald
         else if (keyword(1:13) .eq. 'PEWALD-ALPHA ') then
            read (string,*,err=40,end=40)  apewald
         else if (keyword(1:13) .eq. 'DEWALD-ALPHA ') then
            read (string,*,err=40,end=40)  adewald
         else if (keyword(1:15) .eq. 'EWALD-BOUNDARY ') then
            boundary = 'VACUUM'
         else if (keyword(1:9) .eq. 'PME-GRID ') then
            fft1 = 0.0d0
            fft2 = 0.0d0
            fft3 = 0.0d0
            read (string,*,err=20,end=20)  fft1,fft2,fft3
   20       continue
            iefft1 = nint(fft1)
            iefft2 = nint(fft2)
            iefft3 = nint(fft3)
            if (iefft2 .eq. 0)  iefft2 = iefft1
            if (iefft3 .eq. 0)  iefft3 = iefft1
         else if (keyword(1:10) .eq. 'DPME-GRID ') then
            fft1 = 0.0d0
            fft2 = 0.0d0
            fft3 = 0.0d0
            read (string,*,err=30,end=30)  fft1,fft2,fft3
   30       continue
            idfft1 = nint(fft1)
            idfft2 = nint(fft2)
            idfft3 = nint(fft3)
            if (idfft2 .eq. 0)  idfft2 = idfft1
            if (idfft3 .eq. 0)  idfft3 = idfft1
         else if (keyword(1:10) .eq. 'PME-ORDER ') then
            read (string,*,err=40,end=40)  bseorder
         else if (keyword(1:11) .eq. 'PPME-ORDER ') then
            read (string,*,err=40,end=40)  bsporder
         else if (keyword(1:11) .eq. 'DPME-ORDER ') then
            read (string,*,err=40,end=40)  bsdorder
         end if
   40    continue
      end do
c
c     determine electrostatic grid size from allowed values
c
      if (use_ewald) then
         nefft1 = maxfft
         nefft2 = maxfft
         nefft3 = maxfft
         do i = maxpower, 1, -1
            k = multi(i)
            if (k .le. maxfft) then
               if (k .ge. iefft1)  nefft1 = k
               if (k .ge. iefft2)  nefft2 = k
               if (k .ge. iefft3)  nefft3 = k
            end if
         end do
         if (nefft1 .lt. minfft)  nefft1 = minfft
         if (nefft2 .lt. minfft)  nefft2 = minfft
         if (nefft3 .lt. minfft)  nefft3 = minfft
      end if
c
c     determine dispersion grid size from allowed values
c
      if (use_dewald) then
         ndfft1 = maxfft
         ndfft2 = maxfft
         ndfft3 = maxfft
         do i = maxpower, 1, -1
            k = multi(i)
            if (k .le. maxfft) then
               if (k .ge. idfft1)  ndfft1 = k
               if (k .ge. idfft2)  ndfft2 = k
               if (k .ge. idfft3)  ndfft3 = k
            end if
         end do
         if (ndfft1 .lt. minfft)  ndfft1 = minfft
         if (ndfft2 .lt. minfft)  ndfft2 = minfft
         if (ndfft3 .lt. minfft)  ndfft3 = minfft
      end if
c
c     check the particle mesh Ewald grid dimensions
c
      nbig = max(nefft1,nefft2,nefft3,ndfft1,ndfft2,ndfft3)
      if (nbig .gt. maxfft) then
         write (iout,50)
   50    format (/,' KEWALD  --  PME Grid Size Too Large;',
     &              ' Increase MAXFFT')
         call fatal
      end if
      if (use_ewald .and. (nefft1.lt.iefft1.or.
     &       nefft2.lt.iefft2.or.nefft3.lt.iefft3)) then
         write (iout,60)
   60    format (/,' KEWALD  --  Warning, Small Electrostatic',
     &              'PME Grid Size')
      end if
      if (use_dewald .and. (ndfft1.lt.idfft1.or.
     &       ndfft2.lt.idfft2.or.ndfft3.lt.idfft3)) then
         write (iout,70)
   70    format (/,' KEWALD  --  Warning, Small Dispersion',
     &              'PME Grid Size')
      end if
c
c     set maximum sizes for PME grid and B-spline order
c
      nfft1 = max(nefft1,ndfft1)
      nfft2 = max(nefft2,ndfft2)
      nfft3 = max(nefft3,ndfft3)
      bsorder = max(bseorder,bsporder,bsdorder)
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(bsmod1))  deallocate (bsmod1)
      if (allocated(bsmod2))  deallocate (bsmod2)
      if (allocated(bsmod3))  deallocate (bsmod3)
      if (allocated(bsbuild))  deallocate (bsbuild)
      if (allocated(thetai1))  deallocate (thetai1)
      if (allocated(thetai2))  deallocate (thetai2)
      if (allocated(thetai3))  deallocate (thetai3)
      if (allocated(pmetable))  deallocate (pmetable)
      allocate (bsmod1(nfft1))
      allocate (bsmod2(nfft2))
      allocate (bsmod3(nfft3))
      allocate (bsbuild(bsorder,bsorder))
      allocate (thetai1(4,bsorder,n))
      allocate (thetai2(4,bsorder,n))
      allocate (thetai3(4,bsorder,n))
      allocate (pmetable(n,6*nthread))
c
c     print a message listing some of the Ewald parameters
c
      if (verbose) then
         write (iout,80)
   80    format (/,' Particle Mesh Ewald Parameters :',
     &           //,5x,'Type',16x,'Ewald Alpha',4x,'Grid',
     &              ' Dimensions',4x,'Spline Order',/)
         if (use_ewald) then
            write (iout,90)  aeewald,nefft1,nefft2,nefft3,bseorder
   90       format (3x,'Electrostatics',9x,f8.4,5x,3i5,7x,i5)
            if (use_polar) then
               write (iout,100)  apewald,nefft1,nefft2,nefft3,bsporder
  100          format (3x,'Polarization',11x,f8.4,5x,3i5,7x,i5)
            end if
         end if
         if (use_dewald) then
            write (iout,110)  adewald,ndfft1,ndfft2,ndfft3,bsdorder
  110       format (3x,'Dispersion',13x,f8.4,5x,3i5,7x,i5)
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ewaldcof  --  estimation of Ewald coefficient  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ewaldcof" finds an Ewald coefficient such that all terms
c     beyond the specified cutoff distance will have a value less
c     than a specified tolerance
c
c
      subroutine ewaldcof (alpha,cutoff)
      implicit none
      integer i,k
      real*8 alpha,cutoff,eps
      real*8 x,xlo,xhi,y
      real*8 ratio,erfc
      external erfc
c
c
c     set tolerance value; use of 1.0d-8 over 1.0d-6 gives
c     larger Ewald coefficients to ensure gradient continuity
c
      eps = 1.0d-8
c
c     get approximate value from cutoff and tolerance
c
      ratio = eps + 1.0d0
      x = 0.5d0
      i = 0
      do while (ratio .ge. eps)
         i = i + 1
         x = 2.0d0 * x
         y = x * cutoff
         ratio = erfc(y) / cutoff
      end do
c
c     use a binary search to refine the coefficient
c
      k = i + 60
      xlo = 0.0d0
      xhi = x
      do i = 1, k
         x = (xlo+xhi) / 2.0d0
         y = x * cutoff
         ratio = erfc(y) / cutoff
         if (ratio .ge. eps) then
            xlo = x
         else
            xhi = x
         end if
      end do
      alpha = x
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine extent  --  find maximum interatomic distance  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "extent" finds the largest interatomic distance in a system
c
c
      subroutine extent (rmax)
      use atoms
      implicit none
      integer i,k
      real*8 xi,yi,zi
      real*8 xk,yk,zk
      real*8 r2,rmax
c
c
c     search all atom pairs to find the largest distance
c
      rmax = 0.0d0
      do i = 1, n-1
         xi = x(i)
         yi = y(i)
         zi = z(i)
         do k = i+1, n
            xk = x(k)
            yk = y(k)
            zk = z(k)
            r2 = (xk-xi)**2 + (yk-yi)**2 + (zk-zi)**2
            rmax = max(r2,rmax)
         end do
      end do
      rmax = sqrt(rmax)
      return
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2022 by Moses Chung, Zhi Wang & Jay Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module kexpl  --  exch-polarization forcefield parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     pepk     exchange-polarization spring constant for atom classes
c     peppre   exchange-polarization prefactor for atom classes
c     pepdmp   exchange-polarization damping alpha for atom classes
c     pepl     exchange-polarization logical flag for atom classes
c
c
      module kexpl
      implicit none
      real*8, allocatable :: pepk(:)
      real*8, allocatable :: peppre(:)
      real*8, allocatable :: pepdmp(:)
      logical, allocatable :: pepl(:)
      save
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2022 by Moses Chung, Zhi Wang & Jay Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine kexpol  --  exch-polar parameter assignment  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "kexpol" assigns the constant prefactor and damping alpha for
c     exchange polarization interactions and processes any new or
c     changed values for these parameters
c
c
      subroutine kexpol
      use atomid
      use atoms
      use expol
      use inform
      use iounit
      use kexpl
      use keys
      use sizes
      implicit none
      integer i,k,ia,ic
      integer ilpr,next
      real*8 kpr,ppr,apr
      logical header
      logical lpr
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing exchange polarization parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:8) .eq. 'EXCHPOL ') then
            k = 0
            kpr = 0.0d0
            ppr = 0.0d0
            apr = 0.0d0
            ilpr = 0
            lpr = .false.
            call getnumb (record,k,next)
            string = record(next:240)
            read (string,*,err=10,end=10)  kpr,ppr,apr,ilpr
            if (ilpr .ne. 0)  lpr = .true.
   10       continue
            if (k .gt. 0) then
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Exchange Polarization',
     &                       ' Parameters :',
     &                    //,5x,'Atom Class',7x,'Spring',8x,'Size',
     &                       8x,'Damp',8x,'Use',/)
               end if
               if (k .le. maxclass) then
                  pepk(k) = kpr
                  peppre(k) = ppr
                  pepdmp(k) = apr
                  pepl(k) = lpr
                  if (.not. silent) then
                     write (iout,30)  k,kpr,ppr,apr,lpr
   30                format (6x,i6,4x,2f12.4,f12.3,9x,l1)
                  end if
               else
                  write (iout,40)
   40             format (/,' KEXPOL  --  Too many Exch Polarization',
     &                       ' Parameters')
                  abort = .true.
               end if
            end if
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(kpep))  deallocate (kpep)
      if (allocated(prepep))  deallocate (prepep)
      if (allocated(dmppep))  deallocate (dmppep)
      if (allocated(lpep))  deallocate (lpep)
      if (allocated(polscale))  deallocate (polscale)
      if (allocated(polinv))  deallocate (polinv)
      allocate (kpep(n))
      allocate (prepep(n))
      allocate (dmppep(n))
      allocate (lpep(n))
      allocate (polscale(3,3,n))
      allocate (polinv(3,3,n))
c
c     assign the spring constant, prefactor and alpha parameters
c
      do i = 1, n
         kpep(i) = 0.0d0
         prepep(i) = 0.0d0
         dmppep(i) = 0.0d0
         lpep(i) = .false.
         ic = class(i)
         if (ic .ne. 0) then
            kpep(i) = pepk(ic)
            prepep(i) = peppre(ic)
            dmppep(i) = pepdmp(ic)
            lpep(i) = pepl(ic)
         end if
      end do
c
c     process keywords containing atom specific exchange polarization
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:8) .eq. 'EXCHPOL ') then
            ia = 0
            kpr = 0.0d0
            ppr = 0.0d0
            apr = 0.0d0
            ilpr = 0
            lpr = .false.
            string = record(next:240)
            read (string,*,err=70,end=70)  ia,kpr,ppr,apr,ilpr
            if (ilpr .ne. 0)  lpr = .true.
            if (ia.lt.0 .and. ia.ge.-n) then
               ia = -ia
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,50)
   50             format (/,' Additional Exchange Polarization Values',
     &                       ' for Specific Atoms :',
     &                    //,8x,'Atom',10x,'Spring',8x,'Size',
     &                       8x,'Damp',8x,'On'/)
               end if
               if (.not. silent) then
                  write (iout,60)  ia,kpr,ppr,apr,lpr
   60             format (6x,i6,4x,2f12.4,f12.3,9x,l1)
               end if
               kpep(ia) = kpr
               prepep(ia) = ppr
               dmppep(ia) = apr
               lpep(ia) = lpr
            end if
   70       continue
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2012  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine kextra  --  extra term parameter assignment  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "kextra" assigns parameters to any additional user defined
c     potential energy contribution
c
c
      subroutine kextra
      implicit none
c
c
c     add any setup for user-defined extra potential below here
c
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module keys  --  contents of the keyword control file  ##
c     ##                                                         ##
c     #############################################################
c
c
c     nkey      number of nonblank lines in the keyword file
c     keyline   contents of each individual keyword file line
c
c
      module keys
      implicit none
      integer nkey
      character*240, allocatable :: keyline(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine kfreeze  --  setup for holonomic constraints  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "kfreeze" initializes any holonomic constraints for use with
c     the SHAKE, RATTLE and SETTLE algorithms
c
c
      subroutine kfreeze
      use angbnd
      use atmlst
      use atomid
      use atoms
      use bndstr
      use bound
      use couple
      use freeze
      use keys
      use math
      use molcul
      use usage
      implicit none
      integer i,j,k,m
      integer ia,ib,ic
      integer ja,jb,jc
      integer next,ilist
      integer nhyd,nang
      integer ntotal
      integer maxrat
      integer maxwat
      integer maxwat4
      real*8 rab,rbc,rac
      real*8 cosine,ratio
      real*8 dom,doh
      logical done,proceed
      logical, allocatable :: keep(:)
      character*9 rattyp
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set defaults for constraints and convergence tolerance
c
      nrat = 0
      nratx = 0
      nwat = 0
      nwat4 = 0
      rateps = 0.000001d0
      use_freeze = .true.
c
c     perform dynamic allocation of some global arrays
c
      maxrat = 2 * n
      maxwat = n / 3
      maxwat4 = n / 4
      if (allocated(iratx))  deallocate (iratx)
      if (allocated(kratx))  deallocate (kratx)
      if (allocated(irat))  deallocate (irat)
      if (allocated(iwat))  deallocate (iwat)
      if (allocated(iwat4))  deallocate (iwat4)
      if (allocated(krat))  deallocate (krat)
      if (allocated(kwat))  deallocate (kwat)
      if (allocated(kwat4))  deallocate (kwat4)
      if (allocated(frzimage))  deallocate (frzimage)
      allocate (iratx(maxrat))
      allocate (kratx(maxrat))
      allocate (irat(2,maxrat))
      allocate (iwat(3,maxwat))
      allocate (iwat4(4,maxwat4))
      allocate (krat(maxrat))
      allocate (kwat(3,maxwat))
      allocate (kwat4(2,maxwat4))
      allocate (frzimage(maxrat))
c
c     process keywords containing holonomic constraint options
c
      do k = 1, nkey
         next = 1
         record = keyline(k)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:11) .eq. 'RATTLE-EPS ') then
            read (string,*,err=10,end=10)  rateps
         end if
   10    continue
      end do
c
c     process keywords containing rigid water constraints
c
      do k = 1, nkey
         next = 1
         record = keyline(k)
         call upcase (record)
         call gettext (record,keyword,next)
         if (keyword(1:7) .eq. 'FREEZE ') then
            call getword (record,rattyp,next)
            if (rattyp(1:5) .eq. 'WATER') then
               do i = 1, n
                  nhyd = 0
                  if (atomic(i) .eq. 8) then
                     do j = 1, n12(i)
                        ia = i12(j,i)
                        ja = atomic(ia)
                        if (ja .eq. 1)  nhyd = nhyd + 1
                     end do
                  end if
c
c     find and store rigid three-site water molecules
c
                  if (nhyd .ge. 2) then
                     nwat = nwat + 1
                     iwat(1,nwat) = i
                     nhyd = 0
                     do j = 1, n12(i)
                        ia = i12(j,i)
                        ja = atomic(ia)
                        if (ja .eq. 1) then
                           nhyd = nhyd + 1
                           if (nhyd .eq. 1)  iwat(2,nwat) = ia
                           if (nhyd .eq. 2)  iwat(3,nwat) = ia
                        end if
                     end do
                     ilist = bndlist(1,i)
                     rab = bl(ilist)
                     ilist = anglist(1,i)
                     cosine = cos(anat(ilist)/radian)
                     rac = sqrt(2.0d0*rab*rab*(1.0d0-cosine))
                     kwat(1,nwat) = rab
                     kwat(2,nwat) = rac
                     kwat(3,nwat) = anat(ilist)
c
c     find and store four-site waters and geometric values
c
                     if (n12(i) .eq. 3) then
                        nwat4 = nwat4 + 1
                        iwat4(1,nwat4) = i
                        dom = 0.0d0
                        doh = 0.0d0
                        cosine = 0.0d0
                        nhyd = 0
                        do j = 1, n12(i)
                           ia = i12(j,i)
                           ja = atomic(ia)
                           if (ja .eq. 1) then
                              nhyd = nhyd + 1
                              if (nhyd .eq. 1)  iwat4(2,nwat4) = ia
                              if (nhyd .eq. 2)  iwat4(3,nwat4) = ia
                           else if (ja .le. 0) then
                              iwat4(4,nwat4) = ia
                           end if
                        end do
                        do j = 1, n12(i)
                           ilist = bndlist(j,i)
                           ia = ibnd(1,ilist)
                           ib = ibnd(2,ilist)
                           ja = atomic(ia)
                           jb = atomic(ib)
                           if (use(ia) .or. use(ib)) then
                              if (ja.le.0 .or. jb.le.0) then
                                 dom = bl(ilist)
                              else if (ja.eq.1 .or. jb.eq.1) then
                                 doh = bl(ilist)
                              end if
                           end if
                        end do
                        nang = n12(i) * (n12(i)-1) / 2
                        do j = 1, nang
                           ilist = anglist(j,i)
                           ia = iang(1,ilist)
                           ib = iang(2,ilist)
                           ic = iang(3,ilist)
                           ja = atomic(ia)
                           jc = atomic(ic)
                           if (use(ia) .or. use(ib) .or. use(ic)) then
                              if (ja.eq.1 .and. jc.eq.1) then
                                 cosine = cos(0.5d0*anat(ilist)/radian)
                              end if
                           end if
                        end do
                        if (min(dom,doh,cosine) .gt. 0.0d0) then
                           ratio = dom / (doh*cosine)
                           kwat4(1,nwat4) = 1.0d0 - ratio
                           kwat4(2,nwat4) = 0.5d0 * ratio
                        else
                           nwat4 = nwat4 - 1
                        end if
                     end if
                  end if
               end do
            end if
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (keep(n))
c
c     find and store atoms contained in water molecules
c
      do i = 1, n
         keep(i) = .true.
      end do
      do i = 1, nwat
         do j = 1, 3
            keep(iwat(j,i)) = .false.
         end do
      end do
      do i = 1, nwat4
         keep(iwat4(1,i)) = .false.
      end do
c
c     process keywords containing other molecular constraints
c
      do k = 1, nkey
         next = 1
         record = keyline(k)
         call upcase (record)
         call gettext (record,keyword,next)
         if (keyword(1:7) .eq. 'FREEZE ') then
            call getword (record,rattyp,next)
c
c     constrain all bond lengths at their ideal values
c
            if (rattyp(1:5) .eq. 'BONDS') then
               do i = 1, nbond
                  ia = ibnd(1,i)
                  ib = ibnd(2,i)
                  proceed = (keep(ia) .or. keep(ib))
                  if (proceed)  proceed = (use(ia) .or. use(ib))
                  if (proceed) then
                     nrat = nrat + 1
                     irat(1,nrat) = ia
                     irat(2,nrat) = ib
                     krat(nrat) = bl(i)
                  end if
               end do
c
c     constrain bonds and independent angles at ideal values
c
            else if (rattyp(1:6) .eq. 'ANGLES') then
               do i = 1, nbond
                  ia = ibnd(1,i)
                  ib = ibnd(2,i)
                  proceed = (keep(ia) .or. keep(ib))
                  if (proceed)  proceed = (use(ia) .or. use(ib))
                  if (proceed) then
                     nrat = nrat + 1
                     irat(1,nrat) = ia
                     irat(2,nrat) = ib
                     krat(nrat) = bl(i)
                  end if
               end do
               do i = 1, n
                  if (n12(i) .gt. 1) then
                     do j = 1, 2*n12(i)-3
                        ilist = anglist(j,i)
                        ia = iang(1,ilist)
                        ib = iang(2,ilist)
                        ic = iang(3,ilist)
                        proceed = (keep(ia) .or. keep(ib) .or. keep(ic))
                        if (proceed)
     &                     proceed = (use(ia) .or. use(ib) .or. use(ic))
                        if (proceed) then
                           do m = 1, n12(ib)
                              if (i12(m,ib) .eq. ia) then
                                 rab = bl(bndlist(m,ib))
                              else if (i12(m,ib) .eq. ic) then
                                 rbc = bl(bndlist(m,ib))
                              end if
                           end do
                           cosine = cos(anat(ilist)/radian)
                           rac = sqrt(rab*rab+rbc*rbc
     &                                   -2.0d0*rab*rbc*cosine)
                           nrat = nrat + 1
                           irat(1,nrat) = ia
                           irat(2,nrat) = ic
                           krat(nrat) = rac
                           call chkangle (ia,ib,ic)
                        end if
                     end do
                  end if
               end do
c
c     fix bond length in diatomics to give a rigid molecule
c
            else if (rattyp(1:8) .eq. 'DIATOMIC') then
               do i = 1, nbond
                  ia = ibnd(1,i)
                  ib = ibnd(2,i)
                  ja = n12(ia)
                  jb = n12(ib)
                  proceed = (ja.eq.1 .and. jb.eq.1)
                  if (proceed)  proceed = (use(ia) .or. use(ib))
                  if (proceed) then
                     nrat = nrat + 1
                     irat(1,nrat) = ia
                     irat(2,nrat) = ib
                     krat(nrat) = bl(i)
                  end if
               end do
c
c     fix bonds and angle in triatomics to give a rigid molecule
c
            else if (rattyp(1:9) .eq. 'TRIATOMIC') then
               do i = 1, nangle
                  ia = iang(1,i)
                  ib = iang(2,i)
                  ic = iang(3,i)
                  ja = n12(ia)
                  jc = n12(ic)
                  proceed = (use(ia) .or. use(ib) .or. use(ic))
                  if (proceed)  proceed = (keep(ib))
                  if (proceed)  proceed = (ja.eq.1 .and. jc.eq.1)
                  if (proceed) then
                     rab = bl(bndlist(1,ia))
                     rbc = bl(bndlist(1,ic))
                     cosine = cos(anat(i)/radian)
                     rac = sqrt(rab**2+rbc**2-2.0d0*rab*rbc*cosine)
                     if (use(ia) .or. use(ib)) then
                        nrat = nrat + 1
                        irat(1,nrat) = ia
                        irat(2,nrat) = ib
                        krat(nrat) = rab
                     end if
                     if (use(ib) .or. use(ic)) then
                        nrat = nrat + 1
                        irat(1,nrat) = ib
                        irat(2,nrat) = ic
                        krat(nrat) = rbc
                     end if
                     if (use(ia) .or. use(ib) .or. use(ic)) then
                        nrat = nrat + 1
                        irat(1,nrat) = ia
                        irat(2,nrat) = ic
                        krat(nrat) = rac
                     end if
                  end if
               end do
c
c     fix all bonds to hydrogen atoms at their ideal length
c
            else if (rattyp(1:5) .ne. 'WATER') then
               do i = 1, nbond
                  ia = ibnd(1,i)
                  ib = ibnd(2,i)
                  ja = atomic(ia)
                  jb = atomic(ib)
                  proceed = (ja.eq.1 .or. jb.eq.1)
                  if (proceed)  proceed = (keep(ia) .or. keep(ib))
                  if (proceed)  proceed = (use(ia) .or. use(ib))
                  if (proceed) then
                     nrat = nrat + 1
                     irat(1,nrat) = ia
                     irat(2,nrat) = ib
                     krat(nrat) = bl(i)
                  end if
               end do
            end if
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (keep)
c
c     process keywords containing specific geometric constraints
c
      do k = 1, nkey
         next = 1
         record = keyline(k)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:16) .eq. 'FREEZE-DISTANCE ') then
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            rab = 0.0d0
            string = record(next:240)
            read (string,*,err=20,end=20)  rab
   20       continue
            if (rab .eq. 0.0d0) then
               do i = 1, n12(ia)
                  if (i12(i,ia) .eq. ib) then
                     rab = bl(bndlist(i,ia))
                  end if
               end do
            end if
            if (rab .eq. 0.0d0) then
               rab = sqrt((x(ia)-x(ib))**2 + (y(ia)-y(ib))**2
     &                           + (z(ia)-z(ib))**2)
            end if
            done = .false.
            do j = 1, nrat
               ja = irat(1,j)
               jb = irat(2,j)
               if ((ia.eq.ja .and. ib.eq.jb) .or.
     &             (ia.eq.jb .and. ib.eq.ja)) then
                  done = .true.
                  krat(j) = rab
               end if
            end do
            if (.not. done) then
               nrat = nrat + 1
               irat(1,nrat) = ia
               irat(2,nrat) = ib
               krat(nrat) = rab
            end if
c
c     process keywords containing atom group spatial constraints
c
         else if (keyword(1:13) .eq. 'FREEZE-PLANE ') then
            call getnumb (record,ia,next)
            nratx = nratx + 1
            iratx(nratx) = ia
            kratx(nratx) = 1
         else if (keyword(1:12) .eq. 'FREEZE-LINE ') then
            call getnumb (record,ia,next)
            nratx = nratx + 1
            iratx(nratx) = ia
            kratx(nratx) = 2
         else if (keyword(1:14) .eq. 'FREEZE-ORIGIN ') then
            call getnumb (record,ia,next)
            nratx = nratx + 1
            iratx(nratx) = ia
            kratx(nratx) = 3
         end if
      end do
c
c     find and remove any duplicate distance constraints
c
      do i = 1, nrat-1
         ia = irat(1,i)
         ib = irat(2,i)
         do j = i+1, nrat
            ja = irat(1,j)
            jb = irat(2,j)
            if ((ia.eq.ja .and. ib.eq.jb) .or.
     &          (ia.eq.jb .and. ib.eq.ja))  krat(j) = -1.0d0
         end do
      end do
      k = nrat
      do i = k, 1, -1
         if (krat(i) .lt. 0.0d0) then
            do j = i, k-1
               irat(1,j) = irat(1,j+1)
               irat(2,j) = irat(2,j+1)
               krat(j) = krat(j+1)
            end do
            nrat = nrat - 1
         end if
      end do
c
c     set flag to apply minimum image to intermolecular constraints
c
      do i = 1, nrat
         ia = irat(1,i)
         ib = irat(2,i)
         if (use_bounds .and. (molcule(ia).ne.molcule(ib))) then
            frzimage(i) = .true.
         else if (use_polymer) then
            frzimage(i) = .true.
         else
            frzimage(i) = .false.
         end if
      end do
c
c     turn off holonomic constraints if none are present
c
      ntotal = nrat + nratx + nwat + nwat4
      if (ntotal .eq. 0)  use_freeze = .false.
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine chkangle  --  eliminate redundant constraints  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "chkangle" tests angles to be constrained for their presence
c     in small rings and removes constraints that are redundant
c
c     note this version correctly handles multiple isolated small
c     rings, but should remove one additional redundant constraint
c     for each ring fusion
c
c
      subroutine chkangle (ia,ib,ic)
      use couple
      use freeze
      use ring
      implicit none
      integer i,j,k
      integer ia,ib,ic
      integer id,ie,imin
      logical remove
c
c
c     all internal angles of 3-membered rings are redundant
c
      remove = .false.
      if (nring3 .ne. 0) then
         do i = 1, n12(ia)
            j = i12(i,ia)
            if (j .eq. ic)  remove = .true.
         end do
      end if
c
c     for 4-membered rings, two internal angles are redundant
c
      if (nring4 .ne. 0) then
         do i = 1, n12(ia)
            id = i12(i,ia)
            if (id .ne. ib) then
               do j = 1, n12(id)
                  k = i12(j,id)
                  if (k .eq. ic) then
                     imin = min(ia,ib,ic,id)
                     if (ib .eq. imin)  remove = .true.
                     if (id .eq. imin)  remove = .true.
                  end if
               end do
            end if
         end do
      end if
c
c     for 5-membered rings, one internal angle is redundant
c
      if (nring5 .ne. 0) then
         do i = 1, n12(ia)
            id = i12(i,ia)
            if (id.ne.ib .and. id.ne.ic) then
               do j = 1, n12(ic)
                  ie = i12(j,ic)
                  if (ie.ne.ib .and. ie.ne.ia) then
                     do k = 1, n12(id)
                        if (i12(k,id) .eq. ie) then
                           imin = min(ia,ib,ic,id,ie)
                           if (ib .eq. imin)  remove = .true.
                        end if
                     end do
                  end if
               end do
            end if
         end do
      end if
c
c     remove the constraint from the list if it is redundant
c
      if (remove)  nrat = nrat - 1
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine kgeom  --  restraint term parameter assignment  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "kgeom" asisgns parameters for geometric restraint terms
c     to be included in the potential energy calculation
c
c
      subroutine kgeom
      use atomid
      use atoms
      use bound
      use couple
      use group
      use iounit
      use keys
      use molcul
      use potent
      use restrn
      implicit none
      integer i,j,k,next
      integer ia,ib,ic,id
      real*8 p1,p2,p3,p4,p5
      real*8 d1,d2,d3
      real*8 a1,a2,a3
      real*8 t1,t2,t3
      real*8 g1,g2,g3
      real*8 xr,yr,zr
      real*8 xcm,ycm,zcm
      real*8 geometry,weigh
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 c1,c2,c3
      real*8 vol,ratio
      logical exist,keep
      logical intermol
      character*1 letter
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set the default values for the restraint variables
c
      npfix = 0
      ndfix = 0
      nafix = 0
      ntfix = 0
      ngfix = 0
      nchir = 0
      depth = 0.0d0
      width = 0.0d0
      rflat = 0.0d0
      rwall = 0.0d0
      use_basin = .false.
      use_wall = .false.
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(ipfix))  allocate (ipfix(maxfix))
      if (.not. allocated(kpfix))  allocate (kpfix(3,maxfix))
      if (.not. allocated(idfix))  allocate (idfix(2,maxfix))
      if (.not. allocated(iafix))  allocate (iafix(3,maxfix))
      if (.not. allocated(itfix))  allocate (itfix(4,maxfix))
      if (.not. allocated(igfix))  allocate (igfix(2,maxfix))
      if (.not. allocated(xpfix))  allocate (xpfix(maxfix))
      if (.not. allocated(ypfix))  allocate (ypfix(maxfix))
      if (.not. allocated(zpfix))  allocate (zpfix(maxfix))
      if (.not. allocated(pfix))  allocate (pfix(2,maxfix))
      if (.not. allocated(dfix))  allocate (dfix(3,maxfix))
      if (.not. allocated(afix))  allocate (afix(3,maxfix))
      if (.not. allocated(tfix))  allocate (tfix(3,maxfix))
      if (.not. allocated(gfix))  allocate (gfix(3,maxfix))
c
c     search the keywords for restraint parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
c
c     get atom restrained to a specified position range
c
         if (keyword(1:18) .eq. 'RESTRAIN-POSITION ') then
            ia = 0
            ib = 0
            p1 = 0.0d0
            p2 = 0.0d0
            p3 = 0.0d0
            p4 = 0.0d0
            p5 = 0.0d0
            next = 1
            call getnumb (string,ia,next)
            if (ia.ge.1 .and. ia.le.n) then
               p1 = x(ia)
               p2 = y(ia)
               p3 = z(ia)
               string = string(next:240)
               read (string,*,err=10,end=10)  p1,p2,p3,p4,p5
   10          continue
               if (p4 .eq. 0.0d0)  p4 = 100.0d0
               npfix = npfix + 1
               if (npfix .gt. maxfix) then
                  write (iout,20)
   20             format (/,' KGEOM  --  Too many Position Restraints;',
     &                       ' Increase MAXFIX')
                  call fatal
               end if
               ipfix(npfix) = ia
               kpfix(1,npfix) = 1
               kpfix(2,npfix) = 1
               kpfix(3,npfix) = 1
               xpfix(npfix) = p1
               ypfix(npfix) = p2
               zpfix(npfix) = p3
               pfix(1,npfix) = p4
               pfix(2,npfix) = p5
            else if (ia.ge.-n .and. ia.le.-1) then
               ia = abs(ia)
               call getnumb (string,ib,next)
               ib = min(abs(ib),n)
               string = string(next:240)
               read (string,*,err=30,end=30)  p1,p2
   30          continue
               if (p1 .eq. 0.0d0)  p1 = 100.0d0
               if (npfix+ib-ia+1 .gt. maxfix) then
                  write (iout,40)
   40             format (/,' KGEOM  --  Too many Position Restraints;',
     &                       ' Increase MAXFIX')
                  call fatal
               end if
               do j = ia, ib
                  npfix = npfix + 1
                  ipfix(npfix) = j
                  kpfix(1,npfix) = 1
                  kpfix(2,npfix) = 1
                  kpfix(3,npfix) = 1
                  xpfix(npfix) = x(j)
                  ypfix(npfix) = y(j)
                  zpfix(npfix) = z(j)
                  pfix(1,npfix) = p1
                  pfix(2,npfix) = p2
               end do
            end if
c
c     get atom restrained to a specified position range
c
         else if (keyword(1:15) .eq. 'RESTRAIN-PLANE ') then
            letter = ' '
            ia = 0
            p1 = 0.0d0
            p2 = 0.0d0
            p3 = 0.0d0
            next = 1
            call getword (string,letter,next)
            call upcase (letter)
            string = string(next:240)
            read (string,*,err=50,end=50)  ia,p1,p2,p3
   50       continue
            if (p2 .eq. 0.0d0)  p2 = 100.0d0
            npfix = npfix + 1
            if (npfix .gt. maxfix) then
               write (iout,60)
   60          format (/,' KGEOM  --  Too many Plane Restraints;',
     &                    ' Increase MAXFIX')
               call fatal
            end if
            ipfix(npfix) = ia
            kpfix(1,npfix) = 0
            kpfix(2,npfix) = 0
            kpfix(3,npfix) = 0
            if (letter .eq. 'X') then
               kpfix(1,npfix) = 1
               xpfix(npfix) = p1
            else if (letter .eq. 'Y') then
               kpfix(2,npfix) = 1
               ypfix(npfix) = p1
            else if (letter .eq. 'Z') then
               kpfix(3,npfix) = 1
               zpfix(npfix) = p1
            end if
            pfix(1,npfix) = p2
            pfix(2,npfix) = p3
c
c     get atoms restrained to a specified distance range
c
         else if (keyword(1:18) .eq. 'RESTRAIN-DISTANCE ') then
            ia = 0
            ib = 0
            d1 = 100.0d0
            d2 = 0.0d0
            d3 = 0.0d0
            exist = .false.
            read (string,*,err=70,end=70)  ia,ib,d1,d2
            exist = .true.
   70       continue
            read (string,*,err=80,end=80)  ia,ib,d1,d2,d3
   80       continue
            if (.not. exist) then
               xr = x(ia) - x(ib)
               yr = y(ia) - y(ib)
               zr = z(ia) - z(ib)
               intermol = (molcule(ia) .ne. molcule(ib))
               if (use_bounds .and. intermol)  call image (xr,yr,zr)
               d2 = sqrt(xr*xr + yr*yr + zr*zr)
            end if
            if (d3 .eq. 0.0d0)  d3 = d2
            ndfix = ndfix + 1
            if (ndfix .gt. maxfix) then
               write (iout,90)
   90          format (/,' KGEOM  --  Too many Distance Restraints;',
     &                    ' Increase MAXFIX')
               call fatal
            end if
            idfix(1,ndfix) = ia
            idfix(2,ndfix) = ib
            dfix(1,ndfix) = d1
            dfix(2,ndfix) = d2
            dfix(3,ndfix) = d3
c
c     get atoms restrained to a specified angle range
c
         else if (keyword(1:15) .eq. 'RESTRAIN-ANGLE ') then
            ia = 0
            ib = 0
            ic = 0
            a1 = 10.0d0
            a2 = 0.0d0
            a3 = 0.0d0
            exist = .false.
            read (string,*,err=100,end=100)  ia,ib,ic,a1,a2
            exist = .true.
  100       continue
            read (string,*,err=110,end=110)  ia,ib,ic,a1,a2,a3
  110       continue
            if (.not. exist)  a2 = geometry (ia,ib,ic,0)
            if (a3 .eq. 0.0d0)  a3 = a2
            nafix = nafix + 1
            if (nafix .gt. maxfix) then
               write (iout,120)
  120          format (/,' KGEOM  --  Too many Angle Restraints;',
     &                    ' Increase MAXFIX')
               call fatal
            end if
            iafix(1,nafix) = ia
            iafix(2,nafix) = ib
            iafix(3,nafix) = ic
            afix(1,nafix) = a1
            afix(2,nafix) = a2
            afix(3,nafix) = a3
c
c     get atoms restrained to a specified torsion range
c
         else if (keyword(1:17).eq.'RESTRAIN-TORSION ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            t1 = 1.0d0
            t2 = 0.0d0
            t3 = 0.0d0
            exist = .false.
            read (string,*,err=130,end=130)  ia,ib,ic,id,t1,t2
            exist = .true.
  130       continue
            read (string,*,err=140,end=140)  ia,ib,ic,id,t1,t2,t3
            exist = .true.
  140       continue
            if (.not. exist)  t2 = geometry (ia,ib,ic,id)
            if (t3 .eq. 0.0d0)  t3 = t2
            do while (t2 .gt. 180.0d0)
               t2 = t2 - 360.0d0
            end do
            do while (t2 .lt. -180.0d0)
               t2 = t2 + 360.0d0
            end do
            do while (t3 .gt. 180.0d0)
               t3 = t3 - 360.0d0
            end do
            do while (t3 .lt. -180.0d0)
               t3 = t3 + 360.0d0
            end do
            ntfix = ntfix + 1
            if (ntfix .gt. maxfix) then
               write (iout,150)
  150          format (/,' KGEOM  --  Too many Torsion Restraints;',
     &                    ' Increase MAXFIX')
               call fatal
            end if
            itfix(1,ntfix) = ia
            itfix(2,ntfix) = ib
            itfix(3,ntfix) = ic
            itfix(4,ntfix) = id
            tfix(1,ntfix) = t1
            tfix(2,ntfix) = t2
            tfix(3,ntfix) = t3
c
c     get groups restrained to a specified distance range
c
         else if (keyword(1:16) .eq. 'RESTRAIN-GROUPS ') then
            ia = 0
            ib = 0
            g1 = 100.0d0
            g2 = 0.0d0
            g3 = 0.0d0
            exist = .false.
            read (string,*,err=160,end=160)  ia,ib,g1,g2
            exist = .true.
  160       continue
            read (string,*,err=170,end=170)  ia,ib,g1,g2,g3
  170       continue
            if (.not. exist) then
               xcm = 0.0d0
               ycm = 0.0d0
               zcm = 0.0d0
               do j = igrp(1,ia), igrp(2,ia)
                  k = kgrp(j)
                  weigh = mass(k)
                  xcm = xcm + x(k)*weigh
                  ycm = ycm + y(k)*weigh
                  zcm = zcm + z(k)*weigh
               end do
               weigh = max(1.0d0,grpmass(ia))
               xr = xcm / weigh
               yr = ycm / weigh
               zr = zcm / weigh
               xcm = 0.0d0
               ycm = 0.0d0
               zcm = 0.0d0
               do j = igrp(1,ib), igrp(2,ib)
                  k = kgrp(j)
                  weigh = mass(k)
                  xcm = xcm + x(k)*weigh
                  ycm = ycm + y(k)*weigh
                  zcm = zcm + z(k)*weigh
               end do
               weigh = max(1.0d0,grpmass(ib))
               xr = xr - xcm/weigh
               yr = yr - ycm/weigh
               zr = zr - zcm/weigh
               intermol = (molcule(kgrp(igrp(1,ia))) .ne.
     &                     molcule(kgrp(igrp(1,ib))))
               if (use_bounds .and. intermol)  call image (xr,yr,zr)
               g2 = sqrt(xr*xr + yr*yr + zr*zr)
            end if
            if (g3 .eq. 0.0d0)  g3 = g2
            ngfix = ngfix + 1
            if (ngfix .gt. maxfix) then
               write (iout,180)
  180          format (/,' KGEOM  --  Too many Group Restraints;',
     &                    ' Increase MAXFIX')
               call fatal
            end if
            igfix(1,ngfix) = ia
            igfix(2,ngfix) = ib
            gfix(1,ngfix) = g1
            gfix(2,ngfix) = g2
            gfix(3,ngfix) = g3
c
c     maintain chirality as found in the original input structure
c
         else if (keyword(1:18) .eq. 'ENFORCE-CHIRALITY ') then
            if (.not. allocated(ichir))  allocate (ichir(4,n))
            if (.not. allocated(chir))  allocate (chir(3,n))
            do j = 1, n
               if (n12(j) .eq. 4) then
                  ia = i12(1,j)
                  ib = i12(2,j)
                  ic = i12(3,j)
                  id = i12(4,j)
                  keep = .true.
                  if (n12(ia) .eq. 1) then
                     if (type(ia) .eq. type(ib))  keep = .false.
                     if (type(ia) .eq. type(ic))  keep = .false.
                     if (type(ia) .eq. type(id))  keep = .false.
                  else if (n12(ib) .eq. 1) then
                     if (type(ib) .eq. type(ic))  keep = .false.
                     if (type(ib) .eq. type(id))  keep = .false.
                  else if (n12(ic) .eq. 1) then
                     if (type(ic) .eq. type(id))  keep = .false.
                  end if
                  if (keep) then
                     nchir = nchir + 1
                     ichir(1,nchir) = ia
                     ichir(2,nchir) = ib
                     ichir(3,nchir) = ic
                     ichir(4,nchir) = id
                     xad = x(ia) - x(id)
                     yad = y(ia) - y(id)
                     zad = z(ia) - z(id)
                     xbd = x(ib) - x(id)
                     ybd = y(ib) - y(id)
                     zbd = z(ib) - z(id)
                     xcd = x(ic) - x(id)
                     ycd = y(ic) - y(id)
                     zcd = z(ic) - z(id)
                     c1 = ybd*zcd - zbd*ycd
                     c2 = ycd*zad - zcd*yad
                     c3 = yad*zbd - zad*ybd
                     vol = xad*c1 + xbd*c2 + xcd*c3
                     ratio = abs(vol/(xad*xbd*xcd))
                     chir(1,nchir) = 10.0d0
                     if (ratio .gt. 0.1d0) then
                        chir(2,nchir) = 0.5d0 * vol
                        chir(3,nchir) = 2.0d0 * vol
                     else
                        chir(2,nchir) = -2.0d0 * abs(vol)
                        chir(3,nchir) = 2.0d0 * abs(vol)
                     end if
                  end if
               end if
            end do
c
c     setup any shallow Gaussian basin restraint between atoms
c
         else if (keyword(1:6) .eq. 'BASIN ') then
            depth = 0.0d0
            width = 0.0d0
            rflat = 0.0d0
            read (string,*,err=190,end=190)  depth,width,rflat
  190       continue
            use_basin = .true.
            if (depth .eq. 0.0d0)  use_basin = .false.
            if (width .eq. 0.0d0)  use_basin = .false.
            if (depth .gt. 0.0d0)  depth = -depth
c
c     setup any spherical droplet restraint between atoms
c
         else if (keyword(1:5) .eq. 'WALL ') then
            rwall = 0.0d0
            read (string,*,err=200,end=200)  rwall
  200       continue
            if (rwall .gt. 0.0d0)  use_wall = .true.
         end if
      end do
c
c     turn off the geometric restraint potential if it is not used
c
      if (max(npfix,ndfix,nafix,ntfix,ngfix,nchir).eq.0 .and.
     &       .not.use_basin .and. .not.use_wall)  use_geom = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module khbond  --  H-bonding term forcefield parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     maxnhb   maximum number of hydrogen bonding pair entries
c
c     radhb    radius parameter for hydrogen bonding pairs
c     epshb    well depth parameter for hydrogen bonding pairs
c     khb      string of atom types for hydrogen bonding pairs
c
c
      module khbond
      implicit none
      integer maxnhb
      real*8, allocatable :: radhb(:)
      real*8, allocatable :: epshb(:)
      character*8, allocatable :: khb(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine kimprop  --  improper dihedral parameters  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "kimprop" assigns potential parameters to each improper
c     dihedral in the structure and processes any changed values
c
c
      subroutine kimprop
      use atomid
      use atoms
      use couple
      use improp
      use inform
      use iounit
      use keys
      use kiprop
      use potent
      use tors
      implicit none
      integer i,j,k,ndi
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer size,next
      real*8 tk,tv,symm
      logical header,done
      character*4 pa,pb,pc,pd
      character*8 zero8
      character*12 zero12
      character*16 blank
      character*16 pti,pt0
      character*16 pt1,pt2
      character*16 pt3,pt4
      character*16 pt5,pt6
      character*16 pt(6)
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing improper dihedral parameters
c
      blank = '                '
      zero8 = '00000000'
      zero12 = '000000000000'
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:9) .eq. 'IMPROPER ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            tk = 0.0d0
            tv = 0.0d0
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,ic,id,tk,tv
   10       continue
            if (min(ia,ib,ic,id) .lt. 0)  goto 50
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            pti = pa//pb//pc//pd
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Improper Dihedral',
     &                       ' Parameters :',
     &                    //,5x,'Atom Classes',12x,'K(ID)',
     &                       10x,'Angle',/)
               end if
               write (iout,30)  ia,ib,ic,id,tk,tv
   30          format (2x,4i4,4x,f12.3,f15.3)
            end if
            do j = 1, maxndi
               if (kdi(j).eq.blank .or. kdi(j).eq.pti) then
                  kdi(j) = pti
                  dcon(j) = tk
                  tdi(j) = tv
                  goto 50
               end if
            end do
            write (iout,40)
   40       format (/,' KIMPROP  --  Too many Improper Dihedral',
     &                 ' Parameters')
            abort = .true.
   50       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      ndi = maxndi
      do i = maxndi, 1, -1
         if (kdi(i) .eq. blank)  ndi = i - 1
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(iiprop))  deallocate (iiprop)
      if (allocated(kprop))  deallocate (kprop)
      if (allocated(vprop))  deallocate (vprop)
      allocate (iiprop(4,6*n))
      allocate (kprop(6*n))
      allocate (vprop(6*n))
c
c     assign improper dihedral parameters for each improper angle;
c     multiple symmetrical parameters are given partial weights
c
      niprop = 0
      if (ndi .ne. 0) then
         do i = 1, n
            if (n12(i) .eq. 3) then
               ia = i
               ib = i12(1,i)
               ic = i12(2,i)
               id = i12(3,i)
               ita = class(ia)
               itb = class(ib)
               itc = class(ic)
               itd = class(id)
               size = 4
               call numeral (ita,pa,size)
               call numeral (itb,pb,size)
               call numeral (itc,pc,size)
               call numeral (itd,pd,size)
               pt(1) = pa//pb//pc//pd
               pt(2) = pa//pb//pd//pc
               pt(3) = pa//pc//pb//pd
               pt(4) = pa//pc//pd//pb
               pt(5) = pa//pd//pb//pc
               pt(6) = pa//pd//pc//pb
               pt6 = pa//zero8//pd
               pt5 = pa//zero8//pc
               pt4 = pa//zero8//pb
               pt3 = pa//pd//zero8
               pt2 = pa//pc//zero8
               pt1 = pa//pb//zero8
               pt0 = pa//zero12
               symm = 1.0d0
               if (pb.eq.pc .or. pb.eq.pd .or. pc.eq.pd)  symm = 2.0d0
               if (pb.eq.pc .and. pb.eq.pd .and. pc.eq.pd)  symm = 6.0d0
               done = .false.
               do j = 1, ndi
                  if (kdi(j)(1:4) .eq. pa) then
                     do k = 1, 6
                        if (kdi(j) .eq. pt(k)) then
                           niprop = niprop + 1
                           iiprop(1,niprop) = ia
                           if (k .eq. 1) then
                              iiprop(2,niprop) = ib
                              iiprop(3,niprop) = ic
                              iiprop(4,niprop) = id
                           else if (k .eq. 2) then
                              iiprop(2,niprop) = ib
                              iiprop(3,niprop) = id
                              iiprop(4,niprop) = ic
                           else if (k .eq. 3) then
                              iiprop(2,niprop) = ic
                              iiprop(3,niprop) = ib
                              iiprop(4,niprop) = id
                           else if (k .eq. 4) then
                              iiprop(2,niprop) = ic
                              iiprop(3,niprop) = id
                              iiprop(4,niprop) = ib
                           else if (k .eq. 5) then
                              iiprop(2,niprop) = id
                              iiprop(3,niprop) = ib
                              iiprop(4,niprop) = ic
                           else if (k .eq. 6) then
                              iiprop(2,niprop) = id
                              iiprop(3,niprop) = ic
                              iiprop(4,niprop) = ib
                           end if
                           kprop(niprop) = dcon(j) / symm
                           vprop(niprop) = tdi(j)
                           done = .true.
                           goto 60
                        end if
                     end do
                  end if
               end do
   60          continue
               if (.not. done) then
                  do j = 1, ndi
                     if (kdi(j).eq.pt1 .or. kdi(j).eq.pt4) then
                        symm = 1.0d0
                        niprop = niprop + 1
                        iiprop(1,niprop) = ia
                        iiprop(2,niprop) = ic
                        iiprop(3,niprop) = id
                        iiprop(4,niprop) = ib
                        kprop(niprop) = dcon(j) / symm
                        vprop(niprop) = tdi(j)
                     else if (kdi(j).eq.pt2 .or. kdi(j).eq.pt5) then
                        symm = 1.0d0
                        niprop = niprop + 1
                        iiprop(1,niprop) = ia
                        iiprop(2,niprop) = id
                        iiprop(3,niprop) = ib
                        iiprop(4,niprop) = ic
                        kprop(niprop) = dcon(j) / symm
                        vprop(niprop) = tdi(j)
                     else if (kdi(j).eq.pt3 .or. kdi(j).eq.pt6) then
                        symm = 1.0d0
                        niprop = niprop + 1
                        iiprop(1,niprop) = ia
                        iiprop(2,niprop) = ib
                        iiprop(3,niprop) = ic
                        iiprop(4,niprop) = id
                        kprop(niprop) = dcon(j) / symm
                        vprop(niprop) = tdi(j)
                     end if
                  end do
               end if
               if (.not. done) then
                  do j = 1, ndi
                     if (kdi(j) .eq. pt0) then
                        symm = 3.0d0
                        do k = 1, 3
                           niprop = niprop + 1
                           iiprop(1,niprop) = ia
                           if (k .eq. 1) then
                              iiprop(2,niprop) = ib
                              iiprop(3,niprop) = ic
                              iiprop(4,niprop) = id
                           else if (k .eq. 2) then
                              iiprop(2,niprop) = ic
                              iiprop(3,niprop) = id
                              iiprop(4,niprop) = ib
                           else if (k .eq. 3) then
                              iiprop(2,niprop) = id
                              iiprop(3,niprop) = ib
                              iiprop(4,niprop) = ic
                           end if
                           kprop(niprop) = dcon(j) / symm
                           vprop(niprop) = tdi(j)
                        end do
                        goto 70
                     end if
                  end do
               end if
   70          continue
            end if
         end do
      end if
c
c     process keywords with improper dihedral specific parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:9) .eq. 'IMPROPER ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            tk = 0.0d0
            tv = 0.0d0
            string = record(next:240)
            read (string,*,err=80,end=80)  ia,ib,ic,id,tk,tv
   80       continue
            if (min(ia,ib,ic,id) .lt. 0) then
               ia = abs(ia)
               ib = abs(ib)
               ic = abs(ic)
               id = abs(id)
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,90)
   90             format (/,' Additional Improper Dihedral Specific',
     &                       ' Parameters :',
     &                    //,8x,'Atoms',16x,'K(ID)',10x,'Angle',/)
               end if
               if (.not. silent) then
                  write (iout,100)  ia,ib,ic,id,tk,tv
  100             format (2x,4i4,4x,f12.3,f15.3)
               end if
               do j = 1, niprop
                  ita = iiprop(1,j)
                  itb = iiprop(2,j)
                  itc = iiprop(3,j)
                  itd = iiprop(4,j)
                  if (ia.eq.ita .and. ib.eq.itb .and.
     &                ic.eq.itc .and. id.eq.itd) then
                     kprop(j) = tk
                     vprop(j) = tv
                     goto 110
                  end if
               end do
            end if
  110       continue
         end if
      end do
c
c     turn off the improper dihedral potential if it is not used
c
      if (niprop .eq. 0)  use_improp = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine kimptor  --  improper torsion parameters  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "kimptor" assigns torsional parameters to each improper
c     torsion in the structure and processes any changed values
c
c
      subroutine kimptor
      use atomid
      use atoms
      use couple
      use imptor
      use inform
      use iounit
      use keys
      use kitors
      use math
      use potent
      use tors
      implicit none
      integer i,j,k,nti
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer size,next
      integer ft(6)
      real*8 angle,symm
      real*8 vt(6),st(6)
      logical header,done
      character*4 pa,pb,pc,pd
      character*4 zeros
      character*16 blank
      character*16 pti,ptz
      character*16 pt0,pt1
      character*16 pt2,pt3
      character*16 pt(6)
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing improper torsion parameters
c
      blank = '                '
      zeros = '0000'
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:8) .eq. 'IMPTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do j = 1, 6
               vt(j) = 0.0d0
               st(j) = 0.0d0
               ft(j) = 0
            end do
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,ic,id,
     &                                     (vt(j),st(j),ft(j),j=1,3)
   10       continue
            if (min(ia,ib,ic,id) .lt. 0)  goto 50
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            pti = pa//pb//pc//pd
            call torphase (ft,vt,st)
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Improper Torsion Parameters :',
     &                    //,5x,'Atom Classes',11x,'1-Fold',
     &                       9x,'2-Fold',9x,'3-Fold',/)
               end if
               write (iout,30)  ia,ib,ic,id,(vt(j),st(j),j=1,3)
   30          format (2x,4i4,3x,3(f9.3,f6.1))
            end if
            do j = 1, maxnti
               if (kti(j).eq.blank .or. kti(j).eq.pti) then
                  kti(j) = pti
                  ti1(1,j) = vt(1)
                  ti1(2,j) = st(1)
                  ti2(1,j) = vt(2)
                  ti2(2,j) = st(2)
                  ti3(1,j) = vt(3)
                  ti3(2,j) = st(3)
                  goto 50
               end if
            end do
            write (iout,40)
   40       format (/,' KIMPTOR  --  Too many Improper Torsion',
     &                 ' Parameters')
            abort = .true.
   50       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      nti = maxnti
      do i = maxnti, 1, -1
         if (kti(i) .eq. blank)  nti = i - 1
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(iitors))  deallocate (iitors)
      if (allocated(itors1))  deallocate (itors1)
      if (allocated(itors2))  deallocate (itors2)
      if (allocated(itors3))  deallocate (itors3)
      allocate (iitors(4,6*n))
      allocate (itors1(4,6*n))
      allocate (itors2(4,6*n))
      allocate (itors3(4,6*n))
c
c     assign improper torsion parameters for each improper torsion;
c     multiple symmetrical parameters are given partial weights
c
      nitors = 0
      if (nti .ne. 0) then
         do i = 1, n
            if (n12(i) .eq. 3) then
               ia = i12(1,i)
               ib = i12(2,i)
               ic = i
               id = i12(3,i)
               ita = class(ia)
               itb = class(ib)
               itc = class(ic)
               itd = class(id)
               size = 4
               call numeral (ita,pa,size)
               call numeral (itb,pb,size)
               call numeral (itc,pc,size)
               call numeral (itd,pd,size)
               pt(1) = pa//pb//pc//pd
               pt(2) = pb//pa//pc//pd
               pt(3) = pa//pd//pc//pb
               pt(4) = pd//pa//pc//pb
               pt(5) = pb//pd//pc//pa
               pt(6) = pd//pb//pc//pa
               pt3 = zeros//zeros//pc//pd
               pt2 = zeros//zeros//pc//pb
               pt1 = zeros//zeros//pc//pa
               pt0 = zeros//zeros//pc//zeros
               symm = 1.0d0
               if (pa.eq.pb .or. pa.eq.pd .or. pb.eq.pd)  symm = 2.0d0
               if (pa.eq.pb .and. pa.eq.pd .and. pb.eq.pd)  symm = 6.0d0
               done = .false.
               do j = 1, nti
                  if (kti(j)(9:12) .eq. pc) then
                     do k = 1, 6
                        if (kti(j) .eq. pt(k)) then
                           nitors = nitors + 1
                           iitors(3,nitors) = ic
                           if (k .eq. 1) then
                              iitors(1,nitors) = ia
                              iitors(2,nitors) = ib
                              iitors(4,nitors) = id
                           else if (k .eq. 2) then
                              iitors(1,nitors) = ib
                              iitors(2,nitors) = ia
                              iitors(4,nitors) = id
                           else if (k .eq. 3) then
                              iitors(1,nitors) = ia
                              iitors(2,nitors) = id
                              iitors(4,nitors) = ib
                           else if (k .eq. 4) then
                              iitors(1,nitors) = id
                              iitors(2,nitors) = ia
                              iitors(4,nitors) = ib
                           else if (k .eq. 5) then
                              iitors(1,nitors) = ib
                              iitors(2,nitors) = id
                              iitors(4,nitors) = ia
                           else if (k .eq. 6) then
                              iitors(1,nitors) = id
                              iitors(2,nitors) = ib
                              iitors(4,nitors) = ia
                           end if
                           itors1(1,nitors) = ti1(1,j) / symm
                           itors1(2,nitors) = ti1(2,j)
                           itors2(1,nitors) = ti2(1,j) / symm
                           itors2(2,nitors) = ti2(2,j)
                           itors3(1,nitors) = ti3(1,j) / symm
                           itors3(2,nitors) = ti3(2,j)
                           done = .true.
                        end if
                     end do
                  end if
               end do
               if (.not. done) then
                  do j = 1, nti
                     if (kti(j)(9:12) .eq. pc) then
                        do k = 1, 6
                           ptz = zeros//pt(k)(5:16)
                           if (kti(j) .eq. ptz) then
                              nitors = nitors + 1
                              iitors(3,nitors) = ic
                              if (k .eq. 1) then
                                 iitors(1,nitors) = ia
                                 iitors(2,nitors) = ib
                                 iitors(4,nitors) = id
                              else if (k .eq. 2) then
                                 iitors(1,nitors) = ib
                                 iitors(2,nitors) = ia
                                 iitors(4,nitors) = id
                              else if (k .eq. 3) then
                                 iitors(1,nitors) = ia
                                 iitors(2,nitors) = id
                                 iitors(4,nitors) = ib
                              else if (k .eq. 4) then
                                 iitors(1,nitors) = id
                                 iitors(2,nitors) = ia
                                 iitors(4,nitors) = ib
                              else if (k .eq. 5) then
                                 iitors(1,nitors) = ib
                                 iitors(2,nitors) = id
                                 iitors(4,nitors) = ia
                              else if (k .eq. 6) then
                                 iitors(1,nitors) = id
                                 iitors(2,nitors) = ib
                                 iitors(4,nitors) = ia
                              end if
                              itors1(1,nitors) = ti1(1,j) / symm
                              itors1(2,nitors) = ti1(2,j)
                              itors2(1,nitors) = ti2(1,j) / symm
                              itors2(2,nitors) = ti2(2,j)
                              itors3(1,nitors) = ti3(1,j) / symm
                              itors3(2,nitors) = ti3(2,j)
                              done = .true.
                           end if
                        end do
                     end if
                  end do
               end if
               if (.not. done) then
                  do j = 1, nti
                     if (kti(j) .eq. pt1) then
                        symm = 3.0d0
                        do k = 1, 3
                           nitors = nitors + 1
                           iitors(3,nitors) = ic
                           if (k .eq. 1) then
                              iitors(1,nitors) = ia
                              iitors(2,nitors) = ib
                              iitors(4,nitors) = id
                           else if (k .eq. 2) then
                              iitors(1,nitors) = ib
                              iitors(2,nitors) = id
                              iitors(4,nitors) = ia
                           else if (k .eq. 3) then
                              iitors(1,nitors) = id
                              iitors(2,nitors) = ia
                              iitors(4,nitors) = ib
                           end if
                           itors1(1,nitors) = ti1(1,j) / symm
                           itors1(2,nitors) = ti1(2,j)
                           itors2(1,nitors) = ti2(1,j) / symm
                           itors2(2,nitors) = ti2(2,j)
                           itors3(1,nitors) = ti3(1,j) / symm
                           itors3(2,nitors) = ti3(2,j)
                        end do
                        done = .true.
                     else if (kti(j) .eq. pt2) then
                        symm = 3.0d0
                        do k = 1, 3
                           nitors = nitors + 1
                           iitors(3,nitors) = ic
                           if (k .eq. 1) then
                              iitors(1,nitors) = ia
                              iitors(2,nitors) = ib
                              iitors(4,nitors) = id
                           else if (k .eq. 2) then
                              iitors(1,nitors) = ib
                              iitors(2,nitors) = id
                              iitors(4,nitors) = ia
                           else if (k .eq. 3) then
                              iitors(1,nitors) = id
                              iitors(2,nitors) = ia
                              iitors(4,nitors) = ib
                           end if
                           itors1(1,nitors) = ti1(1,j) / symm
                           itors1(2,nitors) = ti1(2,j)
                           itors2(1,nitors) = ti2(1,j) / symm
                           itors2(2,nitors) = ti2(2,j)
                           itors3(1,nitors) = ti3(1,j) / symm
                           itors3(2,nitors) = ti3(2,j)
                        end do
                        done = .true.
                     else if (kti(j) .eq. pt3) then
                        symm = 3.0d0
                        do k = 1, 3
                           nitors = nitors + 1
                           iitors(3,nitors) = ic
                           if (k .eq. 1) then
                              iitors(1,nitors) = ia
                              iitors(2,nitors) = ib
                              iitors(4,nitors) = id
                           else if (k .eq. 2) then
                              iitors(1,nitors) = ib
                              iitors(2,nitors) = id
                              iitors(4,nitors) = ia
                           else if (k .eq. 3) then
                              iitors(1,nitors) = id
                              iitors(2,nitors) = ia
                              iitors(4,nitors) = ib
                           end if
                           itors1(1,nitors) = ti1(1,j) / symm
                           itors1(2,nitors) = ti1(2,j)
                           itors2(1,nitors) = ti2(1,j) / symm
                           itors2(2,nitors) = ti2(2,j)
                           itors3(1,nitors) = ti3(1,j) / symm
                           itors3(2,nitors) = ti3(2,j)
                        end do
                        done = .true.
                     end if
                  end do
               end if
               if (.not. done) then
                  do j = 1, nti
                     if (kti(j) .eq. pt0) then
                        symm = 3.0d0
                        do k = 1, 3
                           nitors = nitors + 1
                           iitors(3,nitors) = ic
                           if (k .eq. 1) then
                              iitors(1,nitors) = ia
                              iitors(2,nitors) = ib
                              iitors(4,nitors) = id
                           else if (k .eq. 2) then
                              iitors(1,nitors) = ib
                              iitors(2,nitors) = id
                              iitors(4,nitors) = ia
                           else if (k .eq. 3) then
                              iitors(1,nitors) = id
                              iitors(2,nitors) = ia
                              iitors(4,nitors) = ib
                           end if
                           itors1(1,nitors) = ti1(1,j) / symm
                           itors1(2,nitors) = ti1(2,j)
                           itors2(1,nitors) = ti2(1,j) / symm
                           itors2(2,nitors) = ti2(2,j)
                           itors3(1,nitors) = ti3(1,j) / symm
                           itors3(2,nitors) = ti3(2,j)
                        end do
                     end if
                  end do
               end if
            end if
         end do
      end if
c
c     process keywords with improper torsion specific parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:8) .eq. 'IMPTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do j = 1, 6
               vt(j) = 0.0d0
               st(j) = 0.0d0
               ft(j) = 0
            end do
            string = record(next:240)
            read (string,*,err=60,end=60)  ia,ib,ic,id,
     &                                     (vt(j),st(j),ft(j),j=1,3)
   60       continue
            if (min(ia,ib,ic,id) .lt. 0) then
               ia = abs(ia)
               ib = abs(ib)
               ic = abs(ic)
               id = abs(id)
               call torphase (ft,vt,st)
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,70)
   70             format (/,' Additional Improper Torsion Specific',
     &                       ' Parameters :',
     &                    //,8x,'Atoms',15x,'1-Fold',9x,'2-Fold',
     &                       9x,'3-Fold',/)
               end if
               if (.not. silent) then
                  write (iout,80)  ia,ib,ic,id,(vt(j),st(j),j=1,3)
   80             format (2x,4i4,3x,3(f9.3,f6.1))
               end if
               do j = 1, nitors
                  ita = iitors(1,j)
                  itb = iitors(2,j)
                  itc = iitors(3,j)
                  itd = iitors(4,j)
                  if (ia.eq.ita .and. ib.eq.itb .and.
     &                ic.eq.itc .and. id.eq.itd) then
                     itors1(1,j) = vt(1)
                     itors1(2,j) = st(1)
                     itors2(1,j) = vt(2)
                     itors2(2,j) = st(2)
                     itors3(1,j) = vt(3)
                     itors3(2,i) = st(3)
                     goto 90
                  end if
               end do
            end if
   90       continue
         end if
      end do
c
c     find the cosine and sine of the phase angle for each torsion
c
      do i = 1, nitors
         angle = itors1(2,i) / radian
         itors1(3,i) = cos(angle)
         itors1(4,i) = sin(angle)
         angle = itors2(2,i) / radian
         itors2(3,i) = cos(angle)
         itors2(4,i) = sin(angle)
         angle = itors3(2,i) / radian
         itors3(3,i) = cos(angle)
         itors3(4,i) = sin(angle)
      end do
c
c     turn off the improper torsion potential if it is not used
c
      if (nitors .eq. 0)  use_imptor = .false.
      return
      end
c
c
c     ###############################################################
c     ##  COPYRIGHT (C) 2014 by Alex Albaugh & Jay William Ponder  ##
c     ##                    All Rights Reserved                    ##
c     ###############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine kinetic  --  compute kinetic energy components  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "kinetic" computes the total kinetic energy and kinetic energy
c     tensor components by summing over the velocities
c
c
      subroutine kinetic (eksum,ekin,temp)
      use atomid
      use atoms
      use bath
      use group
      use mdstuf
      use moldyn
      use rgddyn
      use units
      use usage
      implicit none
      integer i,j,k,m
      integer start,stop
      real*8 eksum,temp
      real*8 weigh
      real*8 term,value
      real*8 xr,yr,zr
      real*8 x2,y2,z2
      real*8 xcm,ycm,zcm
      real*8 ekin(3,3)
      real*8 inert(3,3)
c
c
c     zero out the temperature and kinetic energy components
c
      temp = 0.0d0
      eksum = 0.0d0
      do i = 1, 3
         do j = 1, 3
            ekin(j,i) = 0.0d0
         end do
      end do
c
c     get the total kinetic energy and tensor for atomic sites
c
      if (integrate .ne. 'RIGIDBODY') then
         do i = 1, nuse
            m = iuse(i)
            term = 0.5d0 * mass(m) / ekcal
            do j = 1, 3
               do k = 1, 3
                  value = term * v(j,m) * v(k,m)
                  ekin(k,j) = ekin(k,j) + value
               end do
            end do
         end do
         eksum = ekin(1,1) + ekin(2,2) + ekin(3,3)
c
c     get the total kinetic energy and tensor for rigid bodies
c
      else
         do i = 1, ngrp
            start = igrp(1,i)
            stop = igrp(2,i)
            xcm = 0.0d0
            ycm = 0.0d0
            zcm = 0.0d0
            do j = start, stop
               k = kgrp(j)
               weigh = mass(k)
               xcm = xcm + x(k)*weigh
               ycm = ycm + y(k)*weigh
               zcm = zcm + z(k)*weigh
            end do
            xcm = xcm / grpmass(i)
            ycm = ycm / grpmass(i)
            zcm = zcm / grpmass(i)
c
c     find the inertial tensor relative to the center of mass
c
            do j = 1, 3
               do k = 1, 3
                  inert(k,j) = 0.0d0
               end do
            end do
            do j = start, stop
               k = kgrp(j)
               xr = x(k) - xcm
               yr = y(k) - ycm
               zr = z(k) - zcm
               x2 = xr * xr
               y2 = yr * yr
               z2 = zr * zr
               weigh = mass(k)
               inert(1,1) = inert(1,1) + weigh*(y2+z2)
               inert(2,1) = inert(2,1) - weigh*xr*yr
               inert(3,1) = inert(3,1) - weigh*xr*zr
               inert(2,2) = inert(2,2) + weigh*(x2+z2)
               inert(3,2) = inert(3,2) - weigh*yr*zr
               inert(3,3) = inert(3,3) + weigh*(x2+y2)
            end do
            inert(1,2) = inert(2,1)
            inert(1,3) = inert(3,1)
            inert(2,3) = inert(3,2)
c
c     increment the kinetic energy due to translational motion
c
            term = 0.5d0 * grpmass(i) / ekcal
            do j = 1, 3
               do k = 1, 3
                  value = term * vc(j,i) * vc(k,i)
                  ekin(k,j) = ekin(k,j) + value
                  if (j .eq. k)  eksum = eksum + value
               end do
            end do
c
c     increment the kinetic energy due to rotational motion
c
            term = 0.5d0 / ekcal
            do j = 1, 3
               do k = 1, 3
                  value = term * inert(k,j) * wc(j,i) * wc(k,i)
                  eksum = eksum + value
               end do
            end do
         end do
      end if
c
c     set the instantaneous temperature from total kinetic energy
c
      temp = 2.0d0 * eksum / (dble(nfree) * gasconst)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine kinaux -- compute iEL dipole kinetic energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "kinaux" computes the total kinetic energy and temperature
c     for auxiliary dipole variables used in iEL polarization
c
c
      subroutine kinaux (temp_aux,temp_auxp)
      use atoms
      use ielscf
      use usage
      implicit none
      integer i,j,k,m
      real*8 term
      real*8 vj,vjp
      real*8 vk,vkp
      real*8 temp_aux
      real*8 temp_auxp
      real*8 eksum_aux
      real*8 eksum_auxp
      real*8 ekaux(3,3)
      real*8 ekauxp(3,3)
c
c
c     zero out the temperature and kinetic energy components
c
      temp_aux = 0.0d0
      temp_auxp = 0.0d0
      do i = 1, 3
         do j = 1, 3
            ekaux(j,i) = 0.0d0
            ekauxp(j,i) = 0.0d0
         end do
      end do
c
c     get the kinetic energy tensor for auxiliary variables
c
      do i = 1, nuse
         m = iuse(i)
         term = 0.5d0
         do j = 1, 3
            vj = vaux(j,m)
            vjp = vpaux(j,m)
            do k = 1, 3
               vk = vaux(k,m)
               vkp = vpaux(k,m)
               ekaux(k,j) = ekaux(k,j) + term*vj*vk
               ekauxp(k,j) = ekauxp(k,j) + term*vjp*vkp
            end do
         end do
      end do
c
c     find the total kinetic energy and auxiliary temperatures
c
      eksum_aux = ekaux(1,1) + ekaux(2,2) + ekaux(3,3)
      eksum_auxp = ekauxp(1,1) + ekauxp(2,2) + ekauxp(3,3)
      if (nfree_aux .ne. 0) then
         temp_aux = 2.0d0 * eksum_aux / dble(nfree_aux)
         temp_auxp = 2.0d0 * eksum_auxp / dble(nfree_aux)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module kiprop  --  improper dihedral forcefield parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     maxndi   maximum number of improper dihedral parameter entries
c
c     dcon     force constant parameters for improper dihedrals
c     tdi      ideal dihedral angle values for improper dihedrals
c     kdi      string of atom classes for improper dihedral angles
c
c
      module kiprop
      implicit none
      integer maxndi
      real*8, allocatable :: dcon(:)
      real*8, allocatable :: tdi(:)
      character*16, allocatable :: kdi(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module kitors  --  improper torsion forcefield parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     maxnti   maximum number of improper torsion parameter entries
c
c     ti1      torsional parameters for improper 1-fold rotation
c     ti2      torsional parameters for improper 2-fold rotation
c     ti3      torsional parameters for improper 3-fold rotation
c     kti      string of atom classes for improper torsional parameters
c
c
      module kitors
      implicit none
      integer maxnti
      real*8, allocatable :: ti1(:,:)
      real*8, allocatable :: ti2(:,:)
      real*8, allocatable :: ti3(:,:)
      character*16, allocatable :: kti(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2000  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine kmetal  --  ligand field parameter assignment  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "kmetal" assigns ligand field parameters to transition metal
c     atoms and processes any new or changed parameter values
c
c
      subroutine kmetal
      implicit none
c
c
c     add any setup for ligand field parameters below here
c
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1994  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine kmpole  --  multipole parameter assignment  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "kmpole" assigns atomic multipole moments to the atoms of
c     the structure and processes any new or changed values
c
c
      subroutine kmpole
      use atomid
      use atoms
      use chgpen
      use couple
      use inform
      use iounit
      use kcpen
      use keys
      use kmulti
      use math
      use mplpot
      use mpole
      use polar
      use polgrp
      use potent
      use units
      implicit none
      integer i,j,k,l,m
      integer ji,ki,li
      integer it,jt,kt,lt
      integer ic,imp,nmp
      integer size,next
      integer number
      integer kz,kx,ky
      integer ztyp,xtyp,ytyp
      integer polmax
      integer, allocatable :: mpt(:)
      integer, allocatable :: mpz(:)
      integer, allocatable :: mpx(:)
      integer, allocatable :: mpy(:)
      real*8 pel,pal
      real*8 mpl(13)
      logical header,path
      character*4 pa,pb,pc,pd
      character*8 axt
      character*16 blank,pt
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     count the number of existing multipole parameters
c
      blank = '                '
      nmp = maxnmp
      do i = maxnmp, 1, -1
         if (kmp(i) .eq. blank)  nmp = i - 1
      end do
c
c     find and count new multipole parameters in the keyfile
c
      imp = 0
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:10) .eq. 'MULTIPOLE ') then
            k = 0
            string = record(next:240)
            read (string,*,err=10,end=10)  k,kz,kx,ky,mpl(1)
            goto 40
   10       continue
            read (string,*,err=20,end=20)  k,kz,kx,mpl(1)
            goto 40
   20       continue
            read (string,*,err=30,end=30)  k,kz,mpl(1)
            goto 40
   30       continue
            read (string,*,err=50,end=50)  k,mpl(1)
   40       continue
            if (k .gt. 0) then
               record = keyline(i+1)
               read (record,*,err=50,end=50)  mpl(2),mpl(3),mpl(4)
               record = keyline(i+2)
               read (record,*,err=50,end=50)  mpl(5)
               record = keyline(i+3)
               read (record,*,err=50,end=50)  mpl(8),mpl(9)
               record = keyline(i+4)
               read (record,*,err=50,end=50)  mpl(11),mpl(12),mpl(13)
               imp = imp + 1
            end if
   50       continue
         end if
      end do
c
c     check for too many combined parameter values
c
      nmp = nmp + imp
      if (nmp .gt. maxnmp) then
         write (iout,60)
   60    format (/,' KMPOLE  --  Too many Atomic Multipole',
     &              ' Parameters')
         abort = .true.
      end if
c
c     move existing parameters to make room for new values
c
      if (imp .ne. 0) then
         do j = nmp, imp+1, -1
            k = j - imp
            kmp(j) = kmp(k)
            mpaxis(j) = mpaxis(k)
            do m = 1, 13
               multip(m,j) = multip(m,k)
            end do
         end do
      end if
c
c     process keywords containing atomic multipole parameters
c
      imp = 0
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:10) .eq. 'MULTIPOLE ') then
            k = 0
            kz = 0
            kx = 0
            ky = 0
            axt = 'Z-then-X'
            do j = 1, 13
               mpl(j) = 0.0d0
            end do
            string = record(next:240)
            read (string,*,err=70,end=70)  k,kz,kx,ky,mpl(1)
            goto 100
   70       continue
            ky = 0
            read (string,*,err=80,end=80)  k,kz,kx,mpl(1)
            goto 100
   80       continue
            kx = 0
            read (string,*,err=90,end=90)  k,kz,mpl(1)
            goto 100
   90       continue
            kz = 0
            read (string,*,err=130,end=130)  k,mpl(1)
  100       continue
            if (k .gt. 0) then
               if (kz .eq. 0)  axt = 'None'
               if (kz.ne.0 .and. kx.eq.0)  axt = 'Z-Only'
               if (kz.lt.0 .or. kx.lt.0)  axt = 'Bisector'
               if (kx.lt.0 .and. ky.lt.0)  axt = 'Z-Bisect'
               if (max(kz,kx,ky) .lt. 0)  axt = '3-Fold'
               kz = abs(kz)
               kx = abs(kx)
               ky = abs(ky)
               record = keyline(i+1)
               read (record,*,err=130,end=130)  mpl(2),mpl(3),mpl(4)
               record = keyline(i+2)
               read (record,*,err=130,end=130)  mpl(5)
               record = keyline(i+3)
               read (record,*,err=130,end=130)  mpl(8),mpl(9)
               record = keyline(i+4)
               read (record,*,err=130,end=130)  mpl(11),mpl(12),mpl(13)
               mpl(6) = mpl(8)
               mpl(7) = mpl(11)
               mpl(10) = mpl(12)
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,110)
  110             format (/,' Additional Atomic Multipole Parameters :',
     &                    //,5x,'Atom Type',5x,'Coordinate Frame',
     &                       ' Definition',9x,'Multipole Moments')
               end if
               if (.not. silent) then
                  write (iout,120)  k,kz,kx,ky,axt,(mpl(j),j=1,5),
     &                             mpl(8),mpl(9),(mpl(j),j=11,13)
  120             format (/,6x,i6,3x,i6,1x,i6,1x,i6,3x,a8,3x,f9.5,
     &                       /,49x,3f9.5,/,49x,f9.5,
     &                       /,49x,2f9.5,/,49x,3f9.5)
               end if
               size = 4
               call numeral (k,pa,size)
               call numeral (kz,pb,size)
               call numeral (kx,pc,size)
               call numeral (ky,pd,size)
               pt = pa//pb//pc//pd
               imp = imp + 1
               kmp(imp) = pt
               mpaxis(imp) = axt
               do j = 1, 13
                  multip(j,imp) = mpl(j)
               end do
            end if
  130       continue
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(ipole))  deallocate (ipole)
      if (allocated(polsiz))  deallocate (polsiz)
      if (allocated(pollist))  deallocate (pollist)
      if (allocated(zaxis))  deallocate (zaxis)
      if (allocated(xaxis))  deallocate (xaxis)
      if (allocated(yaxis))  deallocate (yaxis)
      if (allocated(pole))  deallocate (pole)
      if (allocated(rpole))  deallocate (rpole)
      if (allocated(mono0))  deallocate (mono0)
      if (allocated(polaxe))  deallocate (polaxe)
      if (allocated(np11))  deallocate (np11)
      if (allocated(np12))  deallocate (np12)
      if (allocated(np13))  deallocate (np13)
      if (allocated(np14))  deallocate (np14)
      allocate (ipole(n))
      allocate (polsiz(n))
      allocate (pollist(n))
      allocate (zaxis(n))
      allocate (xaxis(n))
      allocate (yaxis(n))
      allocate (pole(maxpole,n))
      allocate (rpole(maxpole,n))
      allocate (mono0(n))
      allocate (polaxe(n))
      allocate (np11(n))
      allocate (np12(n))
      allocate (np13(n))
      allocate (np14(n))
c
c     zero out local axes, multipoles and polarization attachments
c
      do i = 1, n
         ipole(i) = 0
         polsiz(i) = 0
         pollist(i) = 0
         zaxis(i) = 0
         xaxis(i) = 0
         yaxis(i) = 0
         polaxe(i) = 'None'
         do j = 1, 13
            pole(j,i) = 0.0d0
         end do
         mono0(i) = 0.0d0
         np11(i) = 0
         np12(i) = 0
         np13(i) = 0
         np14(i) = 0
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (mpt(maxnmp))
      allocate (mpz(maxnmp))
      allocate (mpx(maxnmp))
      allocate (mpy(maxnmp))
c
c     store the atom types associated with each parameter
c
      do i = 1, nmp
         mpt(i) = number(kmp(i)(1:4))
         mpz(i) = number(kmp(i)(5:8))
         mpx(i) = number(kmp(i)(9:12))
         mpy(i) = number(kmp(i)(13:16))
      end do
c
c     assign multipole parameters via only 1-2 connected atoms
c
      do i = 1, n
         it = type(i)
         do imp = 1, nmp
            if (it .eq. mpt(imp)) then
               ztyp = mpz(imp)
               xtyp = mpx(imp)
               ytyp = mpy(imp)
               do j = 1, n12(i)
                  ji = i12(j,i)
                  jt = type(ji)
                  if (jt .eq. ztyp) then
                     do k = 1, n12(i)
                        ki = i12(k,i)
                        kt = type(ki)
                        if (kt.eq.xtyp .and. ki.ne.ji) then
                           if (ytyp .eq. 0) then
                              pollist(i) = i
                              zaxis(i) = ji
                              xaxis(i) = ki
                              polaxe(i) = mpaxis(imp)
                              do m = 1, 13
                                 pole(m,i) = multip(m,imp)
                              end do
                              goto 140
                           end if
                           do l = 1, n12(i)
                              li = i12(l,i)
                              lt = type(li)
                              if (lt.eq.ytyp .and. li.ne.ji
     &                               .and. li.ne.ki) then
                                 pollist(i) = i
                                 zaxis(i) = ji
                                 xaxis(i) = ki
                                 yaxis(i) = li
                                 polaxe(i) = mpaxis(imp)
                                 do m = 1, 13
                                    pole(m,i) = multip(m,imp)
                                 end do
                                 goto 140
                              end if
                           end do
                        end if
                     end do
                  end if
               end do
            end if
         end do
c
c     assign multipole parameters via 1-2 and 1-3 connected atoms
c
         do imp = 1, nmp
            if (it .eq. mpt(imp)) then
               ztyp = mpz(imp)
               xtyp = mpx(imp)
               ytyp = mpy(imp)
               do j = 1, n12(i)
                  ji = i12(j,i)
                  jt = type(ji)
                  if (jt .eq. ztyp) then
                     do k = 1, n13(i)
                        ki = i13(k,i)
                        kt = type(ki)
                        path = .false.
                        do m = 1, n12(ki)
                           if (i12(m,ki) .eq. ji)  path = .true.
                        end do
                        if (kt.eq.xtyp .and. path) then
                           if (ytyp .eq. 0) then
                              pollist(i) = i
                              zaxis(i) = ji
                              xaxis(i) = ki
                              polaxe(i) = mpaxis(imp)
                              do m = 1, 13
                                 pole(m,i) = multip(m,imp)
                              end do
                              goto 140
                           end if
                           do l = 1, n13(i)
                              li = i13(l,i)
                              lt = type(li)
                              path = .false.
                              do m = 1, n12(li)
                                 if (i12(m,li) .eq. ji)  path = .true.
                              end do
                              if (lt.eq.ytyp .and. li.ne.ki
     &                               .and. path) then
                                 pollist(i) = i
                                 zaxis(i) = ji
                                 xaxis(i) = ki
                                 yaxis(i) = li
                                 polaxe(i) = mpaxis(imp)
                                 do m = 1, 13
                                    pole(m,i) = multip(m,imp)
                                 end do
                                 goto 140
                              end if
                           end do
                        end if
                     end do
                  end if
               end do
            end if
         end do
c
c     assign multipole parameters via only a z-defining atom
c
         do imp = 1, nmp
            if (it .eq. mpt(imp)) then
               ztyp = mpz(imp)
               xtyp = mpx(imp)
               ytyp = mpy(imp)
               do j = 1, n12(i)
                  ji = i12(j,i)
                  jt = type(ji)
                  if (jt .eq. ztyp) then
                     if (xtyp .eq. 0) then
                        pollist(i) = i
                        zaxis(i) = ji
                        polaxe(i) = mpaxis(imp)
                        do m = 1, 13
                           pole(m,i) = multip(m,imp)
                        end do
                        goto 140
                     end if
                  end if
               end do
            end if
         end do
c
c     assign multipole parameters via no connected atoms
c
         do imp = 1, nmp
            if (it .eq. mpt(imp)) then
               ztyp = mpz(imp)
               xtyp = mpx(imp)
               ytyp = mpy(imp)
               if (ztyp .eq. 0) then
                  pollist(i) = i
                  polaxe(i) = mpaxis(imp)
                  do m = 1, 13
                     pole(m,i) = multip(m,imp)
                  end do
                  goto 140
               end if
            end if
         end do
  140    continue
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (mpt)
      deallocate (mpz)
      deallocate (mpx)
      deallocate (mpy)
c
c     process keywords with multipole parameters for specific atoms
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:10) .eq. 'MULTIPOLE ') then
            k = 0
            kz = 0
            kx = 0
            ky = 0
            axt = 'Z-then-X'
            do j = 1, 13
               mpl(j) = 0.0d0
            end do
            string = record(next:240)
            read (string,*,err=150,end=150)  k,kz,kx,ky,mpl(1)
            goto 180
  150       continue
            ky = 0
            read (string,*,err=160,end=160)  k,kz,kx,mpl(1)
            goto 180
  160       continue
            kx = 0
            read (string,*,err=170,end=170)  k,kz,mpl(1)
            goto 180
  170       continue
            kz = 0
            read (string,*,err=210,end=210)  k,mpl(1)
  180       continue
            if (k.lt.0 .and. k.ge.-n) then
               k = -k
               if (kz .eq. 0)  axt = 'None'
               if (kz.ne.0 .and. kx.eq.0)  axt = 'Z-Only'
               if (kz.lt.0 .or. kx.lt.0)  axt = 'Bisector'
               if (kx.lt.0 .and. ky.lt.0)  axt = 'Z-Bisect'
               if (max(kz,kx,ky) .lt. 0)  axt = '3-Fold'
               kz = abs(kz)
               kx = abs(kx)
               ky = abs(ky)
               record = keyline(i+1)
               read (record,*,err=210,end=210)  mpl(2),mpl(3),mpl(4)
               record = keyline(i+2)
               read (record,*,err=210,end=210)  mpl(5)
               record = keyline(i+3)
               read (record,*,err=210,end=210)  mpl(8),mpl(9)
               record = keyline(i+4)
               read (record,*,err=210,end=210)  mpl(11),mpl(12),mpl(13)
               mpl(6) = mpl(8)
               mpl(7) = mpl(11)
               mpl(10) = mpl(12)
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,190)
  190             format (/,' Additional Atomic Multipoles',
     &                       ' for Specific Atoms :',
     &                    //,5x,'Atom',10x,'Coordinate Frame',
     &                       ' Definition',9x,'Multipole Moments')
               end if
               if (.not. silent) then
                  write (iout,200)  k,kz,kx,ky,axt,(mpl(j),j=1,5),
     &                              mpl(8),mpl(9),(mpl(j),j=11,13)
  200             format (/,3x,i6,6x,i6,1x,i6,1x,i6,3x,a8,3x,f9.5,
     &                       /,49x,3f9.5,/,49x,f9.5,
     &                       /,49x,2f9.5,/,49x,3f9.5)
               end if
               pollist(k) = k
               zaxis(k) = kz
               xaxis(k) = kx
               yaxis(k) = ky
               polaxe(k) = axt
               do j = 1, 13
                  pole(j,k) = mpl(j)
               end do
            end if
  210       continue
         end if
      end do
c
c     convert the dipole and quadrupole moments to Angstroms,
c     quadrupole divided by 3 for use as traceless values
c
      do i = 1, n
         do k = 2, 4
            pole(k,i) = pole(k,i) * bohr
         end do
         do k = 5, 13
            pole(k,i) = pole(k,i) * bohr**2 / 3.0d0
         end do
      end do
c
c     get the order of the multipole expansion at each site
c
      npole = n
      polmax = 0
      do i = 1, n
         size = 0
         do k = 1, maxpole
            if (pole(k,i) .ne. 0.0d0)  size = max(k,size)
         end do
         if (size .gt. 4) then
            size = 13
         else if (size .gt. 1) then
            size = 4
         end if
         polsiz(i) = size
         polmax = max(polmax,size)
      end do
c
c     warn if there are sites with no atomic multipole values
c
      if (polmax .ne. 0) then
         header = .true.
         do i = 1, n
            if (pollist(i) .eq. 0) then
               if (header) then
                  header = .false.
                  write (iout,220)
  220             format (/,' Undefined Atomic Multipole',
     &                       ' Parameters :',/)
               end if 
               write (iout,230)  i
  230          format (' Warning, No Multipole Parameters',
     &                    ' for Atom',i7)
            end if
            pollist(i) = 0
         end do
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (.not. use_polar) then
         if (allocated(uind))  deallocate (uind)
         if (allocated(uinp))  deallocate (uinp)
         if (allocated(uinds))  deallocate (uinds)
         if (allocated(uinps))  deallocate (uinps)
         allocate (uind(3,n))
         allocate (uinp(3,n))
         allocate (uinds(3,n))
         allocate (uinps(3,n))
c
c     if polarization not used, zero out induced dipoles
c
         do i = 1, n
            do j = 1, 3
               uind(j,i) = 0.0d0
               uinp(j,i) = 0.0d0
               uinds(j,i) = 0.0d0
               uinps(j,i) = 0.0d0
            end do
         end do
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(pcore))  deallocate (pcore)
      if (allocated(pval))  deallocate (pval)
      if (allocated(pval0))  deallocate (pval0)
      if (allocated(palpha))  deallocate (palpha)
      allocate (pcore(n))
      allocate (pval(n))
      allocate (pval0(n))
      allocate (palpha(n))
c
c     find new charge penetration parameters in the keyfile
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. 'CHGPEN ') then
            k = 0
            pel = 0.0d0
            pal = 0.0d0
            string = record(next:240)
            read (string,*,err=260,end=260)  k,pel,pal
            cpele(k) = abs(pel)
            cpalp(k) = pal
            if (header .and. .not.silent) then
               header = .false.
               write (iout,240)
  240          format (/,' Additional Charge Penetration Parameters :',
     &                 //,5x,'Atom Class',11x,'Core Chg',11x,'Damp',/)
            end if
            if (.not. silent) then
               write (iout,250)  k,pel,pal
  250          format (6x,i6,7x,f15.3,f15.4)
            end if
  260       continue
         end if
      end do
c
c     assign the charge penetration charge and alpha parameters 
c
      ncp = 0
      do i = 1, n
         pcore(i) = 0.0d0
         pval(i) = pole(1,i)
         pval0(i) = pval(i)
         palpha(i) = 0.0d0
         ic = class(i)
         if (ic .ne. 0) then
            pcore(i) = cpele(ic)
            pval(i) = pole(1,i) - cpele(ic)
            pval0(i) = pval(i)
            palpha(i) = cpalp(ic)
         end if
      end do
c
c     process keywords with charge penetration for specific atoms
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. 'CHGPEN ') then
            k = 0
            pel = 0.0d0
            pal = 0.0d0
            string = record(next:240)
            read (string,*,err=290,end=290)  k,pel,pal
            if (k.lt.0 .and. k.ge.-n) then
               k = -k
               pcore(k) = abs(pel)
               pval(k) = pole(1,k) - abs(pel)
               palpha(k) = pal
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,270)
  270             format (/,' Additional Charge Penetration',
     &                       ' for Specific Atoms :',
     &                    //,5x,'Atom',17x,'Core Chg',11x,'Damp',/)
               end if
               if (.not. silent) then
                  write (iout,280)  k,pel,pal
  280             format (6x,i6,7x,f15.3,f15.4)
               end if
            end if
  290       continue
         end if
      end do
c
c     remove zero or undefined electrostatic sites from the list
c
      if ((use_mpole .or. use_repel .or. use_solv) .and.
     &      .not.use_polar .and. .not.use_chgtrn) then
         npole = 0
         ncp = 0
         do i = 1, n
            if (polsiz(i) .ne. 0) then
               npole = npole + 1
               ipole(npole) = i
               pollist(i) = npole
               mono0(i) = pole(1,i)
               if (palpha(i) .ne. 0.0d0)  ncp = ncp + 1
            end if
         end do
      end if
c
c     test multipoles at chiral sites and invert if necessary
c
      if (use_mpole .and. .not.use_polar .and. .not.use_chgtrn)
     &   call chkpole
c
c     turn off atomic multipole potentials if not used
c
      if (npole .eq. 0)  use_mpole = .false.
      if (ncp .ne. 0)  use_chgpen = .true.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module kmulti  --  atomic multipole forcefield parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     maxnmp   maximum number of atomic multipole parameter entries
c
c     multip   atomic monopole, dipole and quadrupole values
c     mpaxis   type of local axis definition for atomic multipoles
c     kmp      string of atom types for atomic multipoles
c
c
      module kmulti
      implicit none
      integer maxnmp
      real*8, allocatable :: multip(:,:)
      character*8, allocatable :: mpaxis(:)
      character*16, allocatable :: kmp(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine kopbend  --  out-of-plane bending parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "kopbend" assigns the force constants for out-of-plane bends
c     at trigonal centers via Wilson-Decius-Cross or Allinger angles;
c     also processes any new or changed parameter values
c
c
      subroutine kopbend
      use angbnd
      use atomid
      use atoms
      use couple
      use fields
      use inform
      use iounit
      use keys
      use kopbnd
      use opbend
      use potent
      use usage
      implicit none
      integer i,j,k,it
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer nopb,size
      integer next,number
      real*8 fopb
      logical header,done
      logical, allocatable :: jopb(:)
      character*4 pa,pb,pc,pd
      character*4 zero4
      character*8 zero8
      character*16 blank,pt
      character*16 pt0,pt1
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing out-of-plane bend parameters
c
      blank = '                '
      zero4 = '0000'
      zero8 = '00000000'
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'OPBEND ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            fopb = 0.0d0
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,ic,id,fopb
   10       continue
            if (min(ia,ib,ic,id) .lt. 0)  goto 50
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            if (ic .le. id) then
               pt = pa//pb//pc//pd
            else
               pt = pa//pb//pd//pc
            end if
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Out-of-Plane Bend',
     &                       ' Parameters :',
     &                    //,5x,'Atom Classes',19x,'K(OPB)',/)
               end if
               write (iout,30)  ia,ib,ic,id,fopb
   30          format (4x,4i4,10x,f12.3)
            end if
            size = 4
            do j = 1, maxnopb
               if (kopb(j).eq.blank .or. kopb(j).eq.pt) then
                  kopb(j) = pt
                  opbn(j) = fopb
                  goto 50
               end if
            end do
            write (iout,40)
   40       format (/,' KOPBEND --  Too many Out-of-Plane',
     &                 ' Angle Bending Parameters')
            abort = .true.
   50       continue
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(iopb))  deallocate (iopb)
      if (allocated(opbk))  deallocate (opbk)
      allocate (iopb(nangle))
      allocate (opbk(nangle))
c
c     use special out-of-plane bend parameter assignment for MMFF
c
      if (forcefield .eq. 'MMFF94') then
         call kopbendm
         return
      end if
c
c     determine the total number of forcefield parameters
c
      nopb = maxnopb
      do i = maxnopb, 1, -1
         if (kopb(i) .eq. blank)  nopb = i - 1
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (jopb(maxclass))
c
c     make list of atom classes using out-of-plane bending
c
      do i = 1, maxclass
         jopb(i) = .false.
      end do
      do i = 1, maxnopb
         if (kopb(i) .eq. blank)  goto 60
         it = number(kopb(i)(5:8))
         jopb(it) = .true.
      end do
   60 continue
c
c     assign out-of-plane bending parameters for each angle
c
      nopbend = 0
      if (nopb .ne. 0) then
         header = .true.
         do i = 1, nangle
            ib = iang(2,i)
            itb = class(ib)
            if (jopb(itb) .and. n12(ib).eq.3) then
               ia = iang(1,i)
               ita = class(ia)
               ic = iang(3,i)
               itc = class(ic)
               id = iang(4,i)
               itd = class(id)
               size = 4
               call numeral (ita,pa,size)
               call numeral (itb,pb,size)
               call numeral (itc,pc,size)
               call numeral (itd,pd,size)
               if (ita .le. itc) then
                  pt = pd//pb//pa//pc
               else
                  pt = pd//pb//pc//pa
               end if
               pt1 = pd//pb//zero8
               pt0 = zero4//pb//zero8
               done = .false.
               do j = 1, nopb
                  if (kopb(j) .eq. pt) then
                     nopbend = nopbend + 1
                     iopb(nopbend) = i
                     opbk(nopbend) = opbn(j)
                     done = .true.
                     goto 70
                  end if
               end do
               do j = 1, nopb
                  if (kopb(j) .eq. pt1) then
                     nopbend = nopbend + 1
                     iopb(nopbend) = i
                     opbk(nopbend) = opbn(j)
                     done = .true.
                     goto 70
                  end if
               end do
               do j = 1, nopb
                  if (kopb(j) .eq. pt0) then
                     nopbend = nopbend + 1
                     iopb(nopbend) = i
                     opbk(nopbend) = opbn(j)
                     done = .true.
                     goto 70
                  end if
               end do
   70          continue
               if (use_opbend .and. .not.done) then
                  if (use(ia) .or. use(ib) .or. use(ic) .or. use(id))
     &               abort = .true.
                  if (header) then
                     header = .false.
                     write (iout,80)
   80                format (/,' Undefined Out-of-Plane Bend',
     &                          ' Parameters :',
     &                       //,' Type',24x,'Atom Names',24x,
     &                          'Atom Classes',/)
                  end if
                  write (iout,90)  id,name(id),ib,name(ib),ia,name(ia),
     &                             ic,name(ic),itd,itb,ita,itc
   90             format (' Angle-OP',3x,4(i6,'-',a3),5x,4i5)
               end if
            else
               iang(4,i) = ib
            end if
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (jopb)
c
c     get keywords with out-of-plane bending specific params
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. 'OPBEND ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            fopb = 0.0d0
            string = record(next:240)
            read (string,*,err=100,end=100)  ia,ib,ic,id,fopb
  100       continue
            if (min(ia,ib,ic,id) .lt. 0) then
               ia = abs(ia)
               ib = abs(ib)
               ic = abs(ic)
               id = abs(id)
               if (.not.silent .and. header) then
                  header = .false.
                  write (iout,110)
  110             format (/,' Additional Out-of-Plane Bending',
     &                       ' Parameters for Specific Atoms :',
     &                    //,8x,'Atoms',23x,'K(OPB)',/)
               end if
               if (.not. silent) then
                  write (iout,120)  ia,ib,ic,id,fopb
  120             format (4x,4i4,10x,2f12.3)
               end if
               do j = 1, nopbend
                  k = iopb(j)
                  ita = iang(1,k)
                  itb = iang(2,k)
                  itc = iang(3,k)
                  itd = iang(4,k)
                  if (ia.eq.itd .and. ib.eq.itb) then
                     if ((ic.eq.ita.and.id.eq.itc) .or.
     &                   (ic.eq.itc.and.id.eq.ita)) then
                        opbk(j) = fopb
                        goto 130
                     end if
                  end if
               end do
            end if
  130       continue
         end if
      end do
c
c     turn off the out-of-plane bending term if it is not used
c
      if (nopbend .eq. 0)  use_opbend = .false.
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine kopbendm  --  MMFF out-of-plane bend parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "kopbendm" assigns the force constants for out-of-plane bends
c     according to the Merck Molecular Force Field (MMFF)
c
c
      subroutine kopbendm
      use angbnd
      use atomid
      use atoms
      use kopbnd
      use merck
      use opbend
      use potent
      implicit none
      integer i,j,m
      integer nopb,size
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer itta,ittb
      integer ittc,ittd
      character*4 pa,pb,pc,pd
      character*16 blank,pt
c
c
c     determine the total number of forcefield parameters
c
      blank = '                '
      nopb = maxnopb
      do i = maxnopb, 1, -1
         if (kopb(i) .eq. blank)  nopb = i - 1
      end do
c
c     assign MMFF out-of-plane bending parameter values
c
      nopbend = 0
      if (nopb .ne. 0) then
         do i = 1, nangle
            ia = iang(1,i)
            ib = iang(2,i)
            ic = iang(3,i)
            id = iang(4,i)
            if (min(ia,ib,ic,id) .gt. 0) then
               itta = type(ia)
               ittb = type(ib)
               ittc = type(ic)
               ittd = type(id)
               m = 0
   10          continue
               m = m + 1
               if (m .eq. 1) then
                  ita = eqclass(itta,1)
                  itb = eqclass(ittb,1)
                  itc = eqclass(ittc,1)
                  itd = eqclass(ittd,1)
               else if (m .eq. 2) then
                  ita = eqclass(itta,2)
                  itb = eqclass(ittb,2)
                  itc = eqclass(ittc,2)
                  itd = eqclass(ittd,2)
               else if (m .eq. 3) then
                  ita = eqclass(itta,3)
                  itb = eqclass(ittb,2)
                  itc = eqclass(ittc,3)
                  itd = eqclass(ittd,3)
               else if (m .eq. 4) then
                  ita = eqclass(itta,4)
                  itb = eqclass(ittb,2)
                  itc = eqclass(ittc,4)
                  itd = eqclass(ittd,4)
               else if (m .eq. 5) then
                  ita = eqclass(itta,5)
                  itb = eqclass(ittb,2)
                  itc = eqclass(ittc,5)
                  itd = eqclass(ittd,5)
               end if
               if (m .gt. 5) then
                  nopbend = nopbend + 1
                  iopb(nopbend) = i
                  opbk(nopbend) = 0.0d0
               else
                  size = 4
                  call numeral (ita,pa,size)
                  call numeral (itb,pb,size)
                  call numeral (itc,pc,size)
                  call numeral (itd,pd,size)
                  if (itd.le.ita .and. itd.le.itc) then
                     if (ita .le. itc) then
                        pt = pd//pb//pa//pc
                     else
                        pt = pd//pb//pc//pa
                     end if
                  else if (ita.le.itc .and. ita.le.itd) then
                     if (itd .le. itc) then
                        pt = pa//pb//pd//pc
                     else
                        pt = pa//pb//pc//pd
                     end if
                  else if (itc.le.ita .and. itc.le.itd) then
                     if (ita .le. itd) then
                        pt = pc//pb//pa//pd
                     else
                        pt = pc//pb//pd//pa
                     end if
                  end if
                  do j = 1, nopb
                     if (kopb(j) .eq. pt) then
                        nopbend = nopbend + 1
                        iopb(nopbend) = i
                        opbk(nopbend) = opbn(j)
                        goto 20
                     end if
                  end do
                  if (class(ib).eq.8 .or. class(ib).eq.17 .or.
     &                class(ib).eq.26 .or. class(ib).eq.43 .or.
     &                class(ib).eq.49 .or. class(ib).eq.73 .or.
     &                class(ib).eq.82) then
                     nopbend = nopbend + 1
                     iopb(nopbend) = i
                     opbk(nopbend) = 0.0d0
                     goto 20
                  end if
                  goto 10
   20             continue
               end if
            end if
         end do
      end if
c
c     turn off the out-of-plane bending term if it is not used
c
      if (nopbend .eq. 0)  use_opbend = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module kopbnd  --  out-of-plane bend forcefield parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     maxnopb   maximum number of out-of-plane bending entries
c
c     opbn      force constant parameters for out-of-plane bending
c     kopb      string of atom classes for out-of-plane bending
c
c
      module kopbnd
      implicit none
      integer maxnopb
      real*8, allocatable :: opbn(:)
      character*16, allocatable :: kopb(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine kopdist  --  out-of-plane distance parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "kopdist" assigns the force constants for out-of-plane
c     distance at trigonal centers via the central atom height;
c     also processes any new or changed parameter values
c
c
      subroutine kopdist
      use angbnd
      use atmlst
      use atomid
      use atoms
      use couple
      use inform
      use iounit
      use keys
      use kopdst
      use opdist
      use potent
      implicit none
      integer i,j,nopd
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer imin,itmin
      integer size,next
      real*8 fopd
      logical header
      character*4 pa,pb,pc,pd
      character*12 zeros
      character*16 blank
      character*16 pt,pt0
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing out-of-plane distance parameters
c
      blank = '                '
      zeros = '000000000000'
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'OPDIST ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            fopd = 0.0d0
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,ic,id,fopd
   10       continue
            if (min(ia,ib,ic,id) .lt. 0)  goto 50
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            imin = min(ib,ic,id)
            if (ib .eq. imin) then
               if (ic .le. id) then
                  pt = pa//pb//pc//pd
               else
                  pt = pa//pb//pd//pc
               end if
            else if (ic .eq. imin) then
               if (ib .le. id) then
                  pt = pa//pc//pb//pd
               else
                  pt = pa//pc//pd//pb
               end if
            else if (id .eq. imin) then
               if (ib .le. ic) then
                  pt = pa//pd//pb//pc
               else
                  pt = pa//pd//pc//pb
               end if
            end if
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Out-of-Plane Distance',
     &                       ' Parameters :',
     &                    //,5x,'Atom Classes',19x,'K(OPD)',/)
               end if
               write (iout,30)  ia,ib,ic,id,fopd
   30          format (4x,4i4,10x,2f12.3)
            end if
            do j = 1, maxnopd
               if (kopd(j).eq.blank .or. kopd(j).eq.pt) then
                  kopd(j) = pt
                  opds(j) = fopd
                  goto 50
               end if
            end do
            write (iout,40)
   40       format (/,' KOPDIST  --  Too many Out-of-Plane Distance',
     &                 ' Parameters')
            abort = .true.
   50       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      nopd = maxnopd
      do i = maxnopd, 1, -1
         if (kopd(i) .eq. blank)  nopd = i - 1
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(iopd))  deallocate (iopd)
      if (allocated(opdk))  deallocate (opdk)
      allocate (iopd(4,n))
      allocate (opdk(n))
c
c     assign out-of-plane distance parameters for trigonal sites
c
      nopdist = 0
      if (nopd .ne. 0) then
         do i = 1, n
            if (n12(i) .eq. 3) then
               ia = i
               ib = i12(1,i)
               ic = i12(2,i)
               id = i12(3,i)
               ita = class(ia)
               itb = class(ib)
               itc = class(ic)
               itd = class(id)
               size = 4
               call numeral (ita,pa,size)
               call numeral (itb,pb,size)
               call numeral (itc,pc,size)
               call numeral (itd,pd,size)
               itmin = min(itb,itc,itd)
               if (itb .eq. itmin) then
                  if (itc .le. itd) then
                     pt = pa//pb//pc//pd
                  else
                     pt = pa//pb//pd//pc
                  end if
               else if (itc .eq. itmin) then
                  if (itb .le. itd) then
                     pt = pa//pc//pb//pd
                  else
                     pt = pa//pc//pd//pb
                  end if
               else if (itd .eq. itmin) then
                  if (itb .le. itc) then
                     pt = pa//pd//pb//pc
                  else
                     pt = pa//pd//pc//pb
                  end if
               end if
               pt0 = pa//zeros
               do j = 1, nopd
                  if (kopd(j) .eq. pt) then
                     nopdist = nopdist + 1
                     iopd(1,nopdist) = ia
                     iopd(2,nopdist) = ib
                     iopd(3,nopdist) = ic
                     iopd(4,nopdist) = id
                     opdk(nopdist) = opds(j)
                     goto 60
                  end if
               end do
               do j = 1, nopd
                  if (kopd(j) .eq. pt0) then
                     nopdist = nopdist + 1
                     iopd(1,nopdist) = ia
                     iopd(2,nopdist) = ib
                     iopd(3,nopdist) = ic
                     iopd(4,nopdist) = id
                     opdk(nopdist) = opds(j)
                     goto 60
                  end if
               end do
   60          continue
            end if
         end do
      end if
c
c     get keywords with out-of-plane distance specific params
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. 'OPDIST ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            fopd = 0.0d0
            string = record(next:240)
            read (string,*,err=70,end=70)  ia,ib,ic,id,fopd
   70       continue
            if (min(ia,ib,ic,id) .lt. 0) then
               ia = abs(ia)
               ib = abs(ib)
               ic = abs(ic)
               id = abs(id)
               if (.not.silent .and. header) then
                  header = .false.
                  write (iout,80)
   80             format (/,' Additional Out-of-Plane Distance',
     &                       ' Parameters for Specific Atoms :',
     &                    //,8x,'Atoms',23x,'K(OPD)',/)
               end if
               if (.not. silent) then
                  write (iout,90)  ia,ib,ic,id,fopd
   90             format (4x,4i4,10x,2f12.3)
               end if
               do j = 1, nopdist
                  ita = iopd(1,j)
                  itb = iopd(2,j)
                  itc = iopd(3,j)
                  itd = iopd(4,j)
                  if (ia .eq. ita) then
                     if (ib .eq. itb) then
                        if ((ic.eq.itc.and.id.eq.itd) .or.
     &                      (ic.eq.itd.and.id.eq.itc)) then
                           opdk(j) = fopd
                           goto 100
                        end if
                     else if (ic .eq. itb) then
                        if ((ib.eq.itc.and.id.eq.itd) .or.
     &                      (ib.eq.itd.and.id.eq.itc)) then
                           opdk(j) = fopd
                           goto 100
                        end if
                     else if (id .eq. itb) then
                        if ((ib.eq.itc.and.ic.eq.itd) .or.
     &                      (ib.eq.itd.and.ic.eq.itc)) then
                           opdk(j) = fopd
                           goto 100
                        end if
                     end if
                  end if
               end do
            end if
  100       continue
         end if
      end do
c
c     turn off out-of-plane distance potential if it is not used
c
      if (nopdist .eq. 0)  use_opdist = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module kopdst  --  out-of-plane distance forcefield params  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     maxnopd   maximum number of out-of-plane distance entries
c
c     opds      force constant parameters for out-of-plane distance
c     kopd      string of atom classes for out-of-plane distance
c
c
      module kopdst
      implicit none
      integer maxnopd
      real*8, allocatable :: opds(:)
      character*16, allocatable :: kopd(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine korbit  --  conjugated pisystem orbital setup  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "korbit" assigns pi-orbital parameters to conjugated systems
c     and processes any new or changed parameters
c
c
      subroutine korbit
      use atomid
      use atoms
      use bndstr
      use inform
      use iounit
      use keys
      use korbs
      use orbits
      use piorbs
      use pistuf
      use tors
      use units
      implicit none
      integer i,j,k,jt
      integer ia,ib,ita,itb
      integer npi,npi5,npi4
      integer size,next,iring
      real*8 elect,ioniz
      real*8 repuls
      real*8 sslop,tslop
      logical header
      logical use_ring
      character*4 pa,pb
      character*6 label
      character*8 blank,pt
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing pisystem atom parameters
c
      blank = '        '
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'PIATOM ') then
            ia = 0
            elect = 0.0d0
            ioniz = 0.0d0
            repuls = 0.0d0
            string = record(next:240)
            read (string,*,err=10)  ia,elect,ioniz,repuls
   10       continue
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Pisystem Atom Parameters :',
     &                    //,5x,'Atom Type',12x,'Electron',
     &                       5x,'Ionization',6x,'Repulsion',/)
               end if
               write (iout,30)  ia,elect,ioniz,repuls
   30          format (6x,i6,10x,f12.3,3x,f12.3,3x,f12.3)
            end if
            if (ia.gt.0 .and. ia.le.maxclass) then
               electron(ia) = elect
               ionize(ia) = ioniz
               repulse(ia) = repuls
            else
               write (iout,40)
   40          format (/,' KORBIT  --  Too many Atom Classes;',
     &                    ' Increase MAXCLASS')
               abort = .true.
            end if
         end if
      end do
c
c     process keywords containing pisystem bond 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. 'PIBOND ')  iring = 0
         if (keyword(1:8) .eq. 'PIBOND5 ')  iring = 5
         if (keyword(1:8) .eq. 'PIBOND4 ')  iring = 4
         if (iring .ge. 0) then
            ia = 0
            ib = 0
            sslop = 0.0d0
            tslop = 0.0d0
            string = record(next:240)
            read (string,*,err=50)  ia,ib,sslop,tslop
   50       continue
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,60)
   60             format (/,' Additional Pisystem Bond Parameters :',
     &                    //,5x,'Atom Types',12x,'d Force',7x,
     &                       'd Length',/)
               end if
               if (iring .eq. 0) then
                  write (iout,70)  ia,ib,sslop,tslop
   70             format (6x,2i4,8x,f12.3,3x,f12.3)
               else
                  if (iring .eq. 5)  label = '5-Ring'
                  if (iring .eq. 4)  label = '4-Ring'
                  write (iout,80)  ia,ib,sslop,tslop,label
   80             format (6x,2i4,8x,f12.3,3x,f12.3,3x,a6)
               end if
            end if
            size = 4
            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, maxnpi
                  if (kpi(j).eq.blank .or. kpi(j).eq.pt) then
                     kpi(j) = pt
                     sslope(j) = sslop
                     tslope(j) = tslop
                     goto 100
                  end if
               end do
               write (iout,90)
   90          format (/,' KORBIT  --  Too many Pisystem Bond',
     &                    ' Type Parameters')
               abort = .true.
  100          continue
            else if (iring .eq. 5) then
               do j = 1, maxnpi5
                  if (kpi5(j).eq.blank .or. kpi5(j).eq.pt) then
                     kpi5(j) = pt
                     sslope5(j) = sslop
                     tslope5(j) = tslop
                     goto 120
                  end if
               end do
               write (iout,110)
  110          format (/,' KORBIT  --  Too many 5-Ring Pisystem Bond',
     &                    ' Type Parameters')
               abort = .true.
  120          continue
            else if (iring .eq. 4) then
               do j = 1, maxnpi4
                  if (kpi4(j).eq.blank .or. kpi4(j).eq.pt) then
                     kpi4(j) = pt
                     sslope4(j) = sslop
                     tslope4(j) = tslop
                     goto 140
                  end if
               end do
               write (iout,130)
  130          format (/,' KORBIT  --  Too many 4-Ring Pisystem Bond',
     &                    ' Type Parameters')
               abort = .true.
  140          continue
            end if
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      npi = maxnpi
      npi5 = maxnpi5
      npi4 = maxnpi4
      do i = maxnpi, 1, -1
         if (kpi(i) .eq. blank)  npi = i - 1
      end do
      do i = maxnpi5, 1, -1
         if (kpi5(i) .eq. blank)  npi5 = i - 1
      end do
      do i = maxnpi4, 1, -1
         if (kpi4(i) .eq. blank)  npi4 = i - 1
      end do
      use_ring = .false.
      if (min(npi5,npi4) .ne. 0)  use_ring = .true.
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(qorb))  deallocate (qorb)
      if (allocated(worb))  deallocate (worb)
      if (allocated(emorb))  deallocate (emorb)
      if (allocated(bkpi))  deallocate (bkpi)
      if (allocated(blpi))  deallocate (blpi)
      if (allocated(kslope))  deallocate (kslope)
      if (allocated(lslope))  deallocate (lslope)
      if (allocated(torsp2))  deallocate (torsp2)
      allocate (qorb(n))
      allocate (worb(n))
      allocate (emorb(n))
      allocate (bkpi(nbond))
      allocate (blpi(nbond))
      allocate (kslope(nbond))
      allocate (lslope(nbond))
      allocate (torsp2(ntors))
c
c     assign the values characteristic of the piatom types
c
      do i = 1, norbit
         j = iorbit(i)
         jt = type(j)
         qorb(j) = electron(jt)
         worb(j) = ionize(jt) / evolt
         emorb(j) = repulse(jt) / evolt
      end do
c
c     assign parameters for all bonds between piatoms;
c     store the original bond lengths and force constants
c
      do i = 1, nbpi
         j = ibpi(1,i)
         ia = iorbit(ibpi(2,i))
         ib = iorbit(ibpi(3,i))
         ita = class(ia)
         itb = class(ib)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            pt = pa//pb
         else
            pt = pb//pa
         end if
c
c     make a check for bonds contained inside small rings
c
         iring = 0
         if (use_ring) then
            call chkring (iring,ia,ib,0,0)
            if (iring .eq. 6)  iring = 0
            if (iring.eq.5 .and. npi5.eq.0)  iring = 0
            if (iring.eq.4 .and. npi4.eq.0)  iring = 0
            if (iring .eq. 3)  iring = 0
         end if
c
c     assign conjugated bond parameters for each pibond
c
         if (iring .eq. 0) then
            do k = 1, npi
               if (kpi(k) .eq. pt) then
                  bkpi(j) = bk(j)
                  blpi(j) = bl(j)
                  kslope(j) = sslope(k)
                  lslope(j) = tslope(k)
                  goto 170
               end if
            end do
c
c     assign bond parameters for 5-membered ring pibonds
c
         else if (iring .eq. 5) then
            do k = 1, npi5
               if (kpi5(k) .eq. pt) then
                  bkpi(j) = bk(j)
                  blpi(j) = bl(j)
                  kslope(j) = sslope5(k)
                  lslope(j) = tslope5(k)
                  goto 170
               end if
            end do
c
c     assign bond parameters for 4-membered ring pibonds
c
         else if (iring .eq. 4) then
            do k = 1, npi4
               if (kpi4(k) .eq. pt) then
                  bkpi(j) = bk(j)
                  blpi(j) = bl(j)
                  kslope(j) = sslope4(k)
                  lslope(j) = tslope4(k)
                  goto 170
               end if
            end do
         end if
c
c     warning if suitable conjugated pibond parameters not found
c
         abort = .true.
         if (header) then
            header = .false.
            write (iout,150)
  150       format (/,' Undefined Conjugated Pibond Parameters :',
     &              //,' Type',13x,'Atom Names',11x,
     &                 'Atom Classes',/)
         end if
         label = 'Pibond'
         if (iring .eq. 5)  label = '5-Ring'
         if (iring .eq. 4)  label = '4-Ring'
         write (iout,160)  label,ia,name(ia),ib,name(ib),ita,itb
  160    format (1x,a6,5x,i6,'-',a3,i6,'-',a3,7x,2i5)
  170    continue
      end do
c
c     store original 2-fold torsional constants across pibonds
c
      do i = 1, ntors
         torsp2(i) = tors2(1,i)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module korbs  --  pisystem orbital forcefield parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     maxnpi     maximum number of pisystem bond parameter entries
c     maxnpi5    maximum number of 5-membered ring pibond entries
c     maxnpi4    maximum number of 4-membered ring pibond entries
c
c     electron   number of pi-electrons for each atom class
c     ionize     ionization potential for each atom class
c     repulse    repulsion integral value for each atom class
c     sslope     slope for bond stretch vs. pi-bond order
c     sslope5    slope for 5-ring bond stretch vs. pi-bond order
c     sslope4    slope for 4-ring bond stretch vs. pi-bond order
c     tslope     slope for 2-fold torsion vs. pi-bond order
c     tslope5    slope for 5-ring 2-fold torsion vs. pi-bond order
c     tslope4    slope for 4-ring 2-fold torsion vs. pi-bond order
c     kpi        string of atom classes for pisystem bonds
c     kpi5       string of atom classes for 5-ring pisystem bonds
c     kpi4       string of atom classes for 4-ring pisystem bonds
c
c
      module korbs
      implicit none
      integer maxnpi
      integer maxnpi5
      integer maxnpi4
      real*8, allocatable :: electron(:)
      real*8, allocatable :: ionize(:)
      real*8, allocatable :: repulse(:)
      real*8, allocatable :: sslope(:)
      real*8, allocatable :: sslope5(:)
      real*8, allocatable :: sslope4(:)
      real*8, allocatable :: tslope(:)
      real*8, allocatable :: tslope5(:)
      real*8, allocatable :: tslope4(:)
      character*8, allocatable :: kpi(:)
      character*8, allocatable :: kpi5(:)
      character*8, allocatable :: kpi4(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module kpitor  --  pi-system torsion forcefield parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     maxnpt   maximum number of pi-system torsion parameter entries
c
c     ptcon    force constant parameters for pi-system torsions
c     kpt      string of atom classes for pi-system torsion terms
c
c
      module kpitor
      implicit none
      integer maxnpt
      real*8, allocatable :: ptcon(:)
      character*8, allocatable :: kpt(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine kpitors  --  find pi-system torsion parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "kpitors" assigns pi-system torsion parameters to torsions
c     needing them, and processes any new or changed values
c
c
      subroutine kpitors
      use atomid
      use atoms
      use bndstr
      use couple
      use inform
      use iounit
      use keys
      use kpitor
      use pitors
      use potent
      use tors
      implicit none
      integer i,j,npt
      integer ia,ib
      integer ita,itb
      integer size,next
      real*8 tp
      logical header
      character*4 pa,pb
      character*8 blank,pt
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing pi-system torsion parameters
c
      blank = '        '
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'PITORS ') then
            ia = 0
            ib = 0
            tp = 0.0d0
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,tp
   10       continue
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Pi-Orbital Torsion',
     &                       ' Parameters :',
     &                    //,5x,'Atom Classes',7x,'2-Fold',/)
               end if
               write (iout,30)  ia,ib,tp
   30          format (6x,2i4,4x,f12.3)
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            if (ia .le. ib) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            do j = 1, maxnpt
               if (kpt(j).eq.blank .or. kpt(j).eq.pt) then
                  kpt(j) = pt
                  ptcon(j) = tp
                  goto 50
               end if
            end do
            write (iout,40)
   40       format (/,' KPITORS  --  Too many Pi-Orbital Torsion',
     &                 ' Parameters')
            abort = .true.
   50       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      npt = maxnpt
      do i = maxnpt, 1, -1
         if (kpt(i) .eq. blank)  npt = i - 1
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(ipit))  deallocate (ipit)
      if (allocated(kpit))  deallocate (kpit)
      allocate (ipit(6,ntors))
      allocate (kpit(ntors))
c
c     assign pi-system torsion parameters as required
c
      npitors = 0
      if (npt .ne. 0) then
         do i = 1, nbond
            ia = ibnd(1,i)
            ib = ibnd(2,i)
            if (n12(ia).eq.3 .and. n12(ib).eq.3) then
               ita = class(ia)
               itb = class(ib)
               size = 4
               call numeral (ita,pa,size)
               call numeral (itb,pb,size)
               if (ita .le. itb) then
                  pt = pa//pb
               else
                  pt = pb//pa
               end if
               do j = 1, npt
                  if (kpt(j) .eq. pt) then
                     npitors = npitors + 1
                     kpit(npitors) = ptcon(j)
                     ipit(1,npitors) = i12(1,ia)
                     ipit(2,npitors) = i12(2,ia)
                     ipit(3,npitors) = ia
                     ipit(4,npitors) = ib
                     ipit(5,npitors) = i12(1,ib)
                     ipit(6,npitors) = i12(2,ib)
                     if (i12(1,ia) .eq. ib)
     &                  ipit(1,npitors) = i12(3,ia)
                     if (i12(2,ia) .eq. ib)
     &                  ipit(2,npitors) = i12(3,ia)
                     if (i12(1,ib) .eq. ia)
     &                  ipit(5,npitors) = i12(3,ib)
                     if (i12(2,ib) .eq. ia)
     &                  ipit(6,npitors) = i12(3,ib)
                     goto 60
                  end if
               end do
            end if
   60       continue
         end do
      end if
c
c     turn off the pi-system torsion potential if it is not used
c
      if (npitors .eq. 0)  use_pitors = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine kpolar  --  assign polarizability parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "kpolar" assigns atomic dipole polarizabilities to the atoms
c     within the structure and processes any new or changed values
c
c     literature references:
c
c     A. C. Simmonett, F. C. Pickard IV, J. W. Ponder and B. R. Brooks,
c     "An Empirical Extrapolation Scheme for Efficient Treatment of
c     Induced Dipoles", Journal of Chemical Physics, 145, 164101 (2016)
c     [OPT method]
c
c     F. Aviat, L. Lagardere and J.-P. Piquemal, "The Truncated
c     Conjugate Gradient (TCG), a Non-Iterative/Fixed-Cost Strategy for
c     Computing Polarization in Molecular Dynamics: Fast Evaluation of
c     Analytical Forces", Journal of Chemical Physics, 147, 161724
c     (2018)  [TCG method]
c
c
      subroutine kpolar
      use atoms
      use chgpen
      use expol
      use inform
      use iounit
      use keys
      use kpolpr
      use kpolr
      use mplpot
      use mpole
      use polar
      use polopt
      use polpot
      use polpcg
      use poltcg
      use potent
      implicit none
      integer i,j,k
      integer ii,kk
      integer ia,ib,it
      integer next,size
      integer nlist,npg
      integer number
      integer pg(maxval)
      integer, allocatable :: list(:)
      integer, allocatable :: rlist(:)
      real*8 pol,thl,thd
      real*8 sixth
      logical header
      character*4 pa,pb
      character*8 blank,pt
      character*20 keyword
      character*20 text
      character*240 record
      character*240 string
c
c
c     set the default values for polarization variables
c
      polprt = .false.
c
c     set defaults for PCG induced dipole parameters
c
      pcgprec = .true.
      pcgguess = .true.
      pcgpeek = 1.0d0
c
c     set defaults for TCG induced dipole parameters
c
      tcgorder = 0
      tcgguess = .true.
      tcgpeek = 1.0d0
      if (poltyp .eq. 'TCG   ')  poltyp = 'TCG2  '
      if (poltyp .eq. 'TCG0  ') then
         poltyp = 'DIRECT'
      else if (poltyp .eq. 'TCG1  ') then
         poltyp = 'TCG   '
         tcgorder = 1
      else if (poltyp(1:3) .eq. 'TCG') then
         poltyp = 'TCG   '
         tcgorder = 2
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(copt))  deallocate (copt)
      if (allocated(copm))  deallocate (copm)
      allocate (copt(0:maxopt))
      allocate (copm(0:maxopt))
c
c     set defaults for OPT induced dipole coefficients
c
      optorder = 0
      do i = 0, maxopt
         copt(i) = 0.0d0
         copm(i) = 0.0d0
      end do
      if (poltyp .eq. 'OPT   ')  poltyp = 'OPT4  '
      if (poltyp .eq. 'OPT1  ') then
         copt(0) = 0.530d0
         copt(1) = 0.604d0
      else if (poltyp .eq. 'OPT2  ') then
         copt(0) = 0.042d0
         copt(1) = 0.635d0
         copt(2) = 0.414d0
      else if (poltyp .eq. 'OPT3  ') then
         copt(0) = -0.132d0
         copt(1) = 0.218d0
         copt(2) = 0.637d0
         copt(3) = 0.293d0
      else if (poltyp .eq. 'OPT4  ') then
         copt(0) = -0.071d0
         copt(1) = -0.096d0
         copt(2) = 0.358d0
         copt(3) = 0.587d0
         copt(4) = 0.216d0
      else if (poltyp .eq. 'OPT5  ') then
         copt(0) = -0.005d0
         copt(1) = -0.129d0
         copt(2) = -0.026d0
         copt(3) = 0.465d0
         copt(4) = 0.528d0
         copt(5) = 0.161d0
      else if (poltyp .eq. 'OPT6  ') then
         copt(0) = 0.014d0
         copt(1) = -0.041d0
         copt(2) = -0.172d0
         copt(3) = 0.073d0
         copt(4) = 0.535d0
         copt(5) = 0.467d0
         copt(6) = 0.122d0
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
c
c     set defaults for numbers and lists of polarizable atoms
c
      nlist = 0
      do i = 1, n
         list(i) = 0
      end do
c
c     get keywords containing polarization-related options
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:12) .eq. 'POLARIZABLE ') then
            read (string,*,err=10,end=10)  (list(j),j=nlist+1,n)
   10       continue
            do while (list(nlist+1) .ne. 0)
               nlist = nlist + 1
            end do
         else if (keyword(1:12) .eq. 'POLAR-PRINT ') then
            polprt = .true.
         else if (keyword(1:12) .eq. 'PCG-PRECOND ') then
            pcgprec = .true.
         else if (keyword(1:14) .eq. 'PCG-NOPRECOND ') then
            pcgprec = .false.
         else if (keyword(1:10) .eq. 'PCG-GUESS ') then
            pcgguess = .true.
         else if (keyword(1:12) .eq. 'PCG-NOGUESS ') then
            pcgguess = .false.
         else if (keyword(1:9) .eq. 'PCG-PEEK ') then
            read (string,*,err=20,end=20)  pcgpeek
         else if (keyword(1:10) .eq. 'TCG-GUESS ') then
            tcgguess = .true.
         else if (keyword(1:12) .eq. 'TCG-NOGUESS ') then
            tcgguess = .false.
         else if (keyword(1:9) .eq. 'TCG-PEEK ') then
            read (string,*,err=20,end=20)  tcgpeek
         else if (keyword(1:10) .eq. 'OPT-COEFF ') then
            do j = 0, maxopt
               copt(j) = 0.0d0
            end do
            read (string,*,err=20,end=20)  (copt(j),j=0,maxopt)
         end if
   20    continue
      end do
c
c     get maximum coefficient order for OPT induced dipoles
c
      if (poltyp(1:3) .eq. 'OPT') then
         poltyp = 'OPT   '
         do i = 1, maxopt
            if (copt(i) .ne. 0.0d0)  optorder = max(i,optorder)
         end do
         do i = 0, optorder
            do j = optorder, i, -1
               copm(i) = copm(i) + copt(j)
            end do
         end do
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(ipolar))  deallocate (ipolar)
      if (allocated(polarity))  deallocate (polarity)
      if (allocated(thole))  deallocate (thole)
      if (allocated(tholed))  deallocate (tholed)
      if (allocated(pdamp))  deallocate (pdamp)
      if (allocated(udir))  deallocate (udir)
      if (allocated(udirp))  deallocate (udirp)
      if (allocated(uind))  deallocate (uind)
      if (allocated(uinp))  deallocate (uinp)
      if (allocated(douind))  deallocate (douind)
      allocate (ipolar(n))
      allocate (polarity(n))
      allocate (thole(n))
      allocate (tholed(n))
      allocate (pdamp(n))
      allocate (udir(3,n))
      allocate (udirp(3,n))
      allocate (uind(3,n))
      allocate (uinp(3,n))
      allocate (douind(n))
      if (allocated(uopt))  deallocate (uopt)
      if (allocated(uoptp))  deallocate (uoptp)
      if (allocated(fopt))  deallocate (fopt)
      if (allocated(foptp))  deallocate (foptp)
      if (poltyp .eq. 'OPT') then
         allocate (uopt(0:optorder,3,n))
         allocate (uoptp(0:optorder,3,n))
         allocate (fopt(0:optorder,10,n))
         allocate (foptp(0:optorder,10,n))
      end if
c
c     set the atoms allowed to have nonzero induced dipoles
c
      do i = 1, n
         douind(i) = .true.
      end do
      i = 1
      do while (list(i) .ne. 0)
         if (i .eq. 1) then
            do j = 1, n
               douind(j) = .false.
            end do
         end if
         if (list(i).gt.0 .and. list(i).le.n) then
            j = list(i)
            if (.not. douind(j)) then
               douind(j) = .true.
            end if
         else if (list(i).lt.0 .and. list(i).ge.-n) then
            do j = abs(list(i)), abs(list(i+1))
               if (.not. douind(j)) then
                  douind(j) = .true.
               end if
            end do
            i = i + 1
         end if
         i = i + 1
      end do
c
c     perform dynamic allocation of some local arrays
c
      deallocate (list)
c
c     process keywords containing polarizability parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:9) .eq. 'POLARIZE ') then
            k = 0
            pol = 0.0d0
            thl = -1.0d0
            thd = -1.0d0
            do j = 1, maxval
               pg(j) = 0
            end do
            call getnumb (record,k,next)
            call gettext (record,text,next)
            read (text,*,err=30,end=30)  pol
            call gettext (record,text,next)
            j = 1
            call getnumb (text,pg(1),j)
            if (pg(1) .eq. 0) then
               read (text,*,err=30,end=30)  thl
               call gettext (record,text,next)
               j = 1
               call getnumb (text,pg(1),j)
               string = record(next:240)
               if (pg(1) .eq. 0) then
                  read (text,*,err=30,end=30)  thd
                  read (string,*,err=30,end=30)  (pg(j),j=1,maxval)
               else
                  read (string,*,err=30,end=30)  (pg(j),j=2,maxval)
               end if
            else
               string = record(next:240)
               read (string,*,err=30,end=30)  (pg(j),j=2,maxval)
            end if
   30       continue
            if (k .gt. 0) then
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,40)
   40             format (/,' Additional Atomic Dipole',
     &                       ' Polarizability Parameters :')
                  if (thd .ge. 0.0d0) then
                     write (iout,50)
   50                format (/,5x,'Atom Type',11x,'Alpha',7x,
     &                          'Thole',6x,'TholeD',5x,
     &                          'Group Atom Types',/)
                  else if (thl .ge. 0.0d0) then
                     write (iout,60)
   60                format (/,5x,'Atom Type',11x,'Alpha',7x,
     &                          'Thole',5x,'Group Atom Types',/)
                  else
                     write (iout,70)
   70                format (/,5x,'Atom Type',11x,'Alpha',5x,
     &                          'Group Atom Types',/)
                  end if
               end if
               if (k .le. maxtyp) then
                  polr(k) = pol
                  athl(k) = max(0.0d0,thl)
                  dthl(k) = max(0.0d0,thd)
                  do j = 1, maxval
                     pgrp(j,k) = pg(j)
                     if (pg(j) .eq. 0) then
                        npg = j - 1
                        goto 80
                     end if
                  end do
   80             continue
                  if (.not. silent) then
                     if (thd .ge. 0.0d0) then
                        write (iout,90)  k,pol,thl,thd,(pg(j),j=1,npg)
   90                   format (4x,i8,8x,f10.3,2x,f10.3,2x,f10.3,
     &                             7x,20i5)
                     else if (thl .ge. 0.0d0) then
                        write (iout,100)  k,pol,thl,(pg(j),j=1,npg)
  100                   format (4x,i8,8x,f10.3,2x,f10.3,7x,20i5)
                     else
                        write (iout,110)  k,pol,(pg(j),j=1,npg)
  110                   format (4x,i8,8x,f10.3,7x,20i5)
                     end if
                  end if
               else
                  write (iout,120)
  120             format (/,' KPOLAR  --  Too many Dipole',
     &                       ' Polarizability Parameters')
                  abort = .true.
               end if
            end if
         end if
      end do
c
c     process keywords with specific pair polarization values
c
      blank = '        '
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:8) .eq. 'POLPAIR ') then
            ia = 0
            ib = 0
            thl = -1.0d0
            thd = -1.0d0
            string = record(next:240)
            read (string,*,err=130,end=130)  ia,ib,thl,thd
  130       continue
            if (header .and. .not.silent) then
               header = .false.
               write (iout,140)
  140          format (/,' Additional Polarization Parameters',
     &                    ' for Specific Pairs :')
               if (thd .ge. 0.0d0) then
                  write (iout,150)
  150             format (/,5x,'Atom Types',14x,'Thole',
     &                       9x,'TholeD',/)
               else if (thl .ge. 0.0d0) then
                  write (iout,160)
  160             format (/,5x,'Atom Types',14x,'Thole',/)
               end if
            end if
            if (thd.ge.0.0d0 .and. .not.silent) then
               write (iout,170)  ia,ib,thl,thd
  170          format (6x,2i4,5x,2f15.4)
            else if (thl.ge.0.0d0 .and. .not.silent) then
               write (iout,180)  ia,ib,thl
  180          format (6x,2i4,5x,f15.4)
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            if (ia .le. ib) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            do k = 1, maxnpp
               if (kppr(k).eq.blank .or. kppr(k).eq.pt) then
                  kppr(k) = pt
                  thlpr(k) = max(thl,0.0d0)
                  thdpr(k) = max(thd,0.0d0)
                  goto 200
               end if
            end do
            write (iout,190)
  190       format (/,' KPOLAR  --  Too many Special Pair',
     &                 ' Thole Parameters')
            abort = .true.
  200       continue
         end if
      end do
c
c     find and store the atomic dipole polarizability parameters
c
      sixth = 1.0d0 / 6.0d0
      npolar = n
      do i = 1, n
         polarity(i) = 0.0d0
         thole(i) = 0.0d0
         tholed(i) = 0.0d0
         pdamp(i) = 0.0d0
         it = type(i)
         if (it .ne. 0) then
            polarity(i) = polr(it)
            thole(i) = athl(it)
            tholed(i) = dthl(it)
            pdamp(i) = polarity(i)**sixth
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(jpolar))  deallocate (jpolar)
      allocate (jpolar(n))
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
      allocate (rlist(maxtyp))
c
c     set atom type index into condensed pair Thole matrices
c
      nlist = n
      do i = 1, n
         list(i) = type(i)
         jpolar(i) = list(i)
      end do
      call sort8 (nlist,list)
      do i = 1, maxtyp
         rlist(i) = 0
      end do
      do i = 1, n
         j = jpolar(i)
         if (rlist(j) .eq. 0) then
            do k = 1, nlist
               if (list(k) .eq. j)  rlist(j) = k
            end do
         end if
      end do
      do i = 1, n
         jpolar(i) = rlist(type(i))
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(thlval))  deallocate (thlval)
      if (allocated(thdval))  deallocate (thdval)
      allocate (thlval(nlist,nlist))
      allocate (thdval(nlist,nlist))
c
c     use combination rules for pairwise Thole damping values
c
      do ii = 1, nlist
         i = list(ii)
         do kk = ii, nlist
            k = list(kk)
            thl = min(athl(i),athl(k))
            if (thl .eq. 0.0d0)  thl = max(athl(i),athl(k))
            thd = min(dthl(i),dthl(k))
            if (thd .eq. 0.0d0)  thd = max(dthl(i),dthl(k))
            thlval(ii,kk) = thl
            thlval(kk,ii) = thl
            thdval(ii,kk) = thd
            thdval(kk,ii) = thd
         end do
      end do
c
c     apply Thole damping values for special atom type pairs
c
      do i = 1, maxnpp
         if (kppr(i) .eq. blank)  goto 210
         ia = rlist(number(kppr(i)(1:4)))
         ib = rlist(number(kppr(i)(5:8)))
         if (ia.ne.0 .and. ib.ne.0) then
            thlval(ia,ib) = thlpr(i)
            thlval(ib,ia) = thlpr(i)
            thdval(ia,ib) = thdpr(i)
            thdval(ib,ia) = thdpr(i)
         end if
      end do
  210 continue
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (rlist)
c
c     setup exchange polarization via variable polarizability
c
      call kexpol
c
c     remove zero or undefined electrostatic sites from the list
c
      if ((use_polar .or. use_repel .or. use_solv)
     &       .and. .not.use_chgtrn) then
         npole = 0
         ncp = 0
         npolar = 0
         nexpol = 0
         do i = 1, n
            if (polarity(i) .eq. 0.0d0)  douind(i) = .false.
            if (polsiz(i).ne.0 .or. polarity(i).ne.0.0d0) then
               npole = npole + 1
               ipole(npole) = i
               pollist(i) = npole
               mono0(i) = pole(1,i)
               if (palpha(i) .ne. 0.0d0)  ncp = ncp + 1
               if (polarity(i) .ne. 0.0d0) then
                  npolar = npolar + 1
                  ipolar(npolar) = i
                  douind(i) = .true.
               end if
               if (tholed(i) .ne. 0.0d0)  use_tholed = .true.
               if (kpep(i) .ne. 0.0d0)  nexpol = nexpol + 1
            end if
         end do
      end if
c
c     test multipoles at chiral sites and invert if necessary
c
      if (use_polar .and. .not.use_chgtrn)  call chkpole
c
c     assign polarization group connectivity of each atom
c
      call polargrp
c
c     turn off polarizable multipole potentials if not used
c
      if (npole .eq. 0)  use_mpole = .false.
      if (ncp .ne. 0)  use_chgpen = .true.
      if (npolar .eq. 0)  use_polar = .false.
      if (ncp .ne. 0)  use_thole = .false.
      if (use_tholed)  use_thole = .true.
      if (nexpol .ne. 0)  use_expol = .true.
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine polargrp  --  polarization group connectivity  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "polargrp" generates members of the polarization group of
c     each atom and separate lists of the 1-2, 1-3 and 1-4 group
c     connectivities
c
c
      subroutine polargrp
      use atoms
      use couple
      use iounit
      use kpolr
      use polgrp
      implicit none
      integer i,j,k,m
      integer it,jt
      integer jj,kk
      integer start,stop
      integer nkeep,nlist
      integer maxkeep,maxlist
      integer, allocatable :: keep(:)
      integer, allocatable :: list(:)
      integer, allocatable :: mask(:)
      logical done,abort
c
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(np11))  deallocate (np11)
      if (allocated(np12))  deallocate (np12)
      if (allocated(np13))  deallocate (np13)
      if (allocated(np14))  deallocate (np14)
      if (allocated(ip11))  deallocate (ip11)
      if (allocated(ip12))  deallocate (ip12)
      if (allocated(ip13))  deallocate (ip13)
      if (allocated(ip14))  deallocate (ip14)
      allocate (np11(n))
      allocate (np12(n))
      allocate (np13(n))
      allocate (np14(n))
      allocate (ip11(maxp11,n))
      allocate (ip12(maxp12,n))
      allocate (ip13(maxp13,n))
      allocate (ip14(maxp14,n))
c
c     initialize size and connectivity of polarization groups
c
      do i = 1, n
         np11(i) = 1
         ip11(1,i) = i
         np12(i) = 0
         np13(i) = 0
         np14(i) = 0
      end do
c
c     set termination flag and temporary group storage
c
      abort = .false.
      maxkeep = 100
      maxlist = 10000
c
c     find the directly connected group members for each atom
c
      do i = 1, n
         it = type(i)
         if (it .ne. 0) then
            do j = 1, n12(i)
               jj = i12(j,i)
               jt = type(jj)
               do k = 1, maxval
                  kk = pgrp(k,it)
                  if (kk .eq. 0)  goto 20
                  if (pgrp(k,it) .eq. jt) then
                     if (np11(i) .lt. maxp11) then
                        np11(i) = np11(i) + 1
                        ip11(np11(i),i) = jj
                     else
                        write (iout,10)
   10                   format (/,' POLARGRP  --  Too many Atoms',
     &                             ' in Polarization Group')
                        abort = .true.
                        goto 30
                     end if
                  end if
               end do
   20          continue
            end do
         end if
      end do
   30 continue
c
c     make sure all connected group members are bidirectional
c
      do i = 1, n
         do j = 1, np11(i)
            k = ip11(j,i)
            do m = 1, np11(k)
               if (ip11(m,k) .eq. i)  goto 50
            end do
            write (iout,40)  min(i,k),max(i,k)
   40       format (/,' POLARGRP  --  Check Polarization Groups for',
     &                 ' Atoms',i9,' and',i9)
            abort = .true.
   50       continue
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (keep(maxkeep))
      allocate (list(maxlist))
      allocate (mask(n))
c
c     find any other group members for each atom in turn
c
      do i = 1, n
         mask(i) = 0
      end do
      do i = 1, n
         done = .false.
         start = 1
         stop = np11(i)
         do j = start, stop
            jj = ip11(j,i)
            if (jj .lt. i) then
               done = .true.
               np11(i) = np11(jj)
               do k = 1, np11(i)
                  ip11(k,i) = ip11(k,jj)
               end do
            else
               mask(jj) = i
            end if
         end do
         do while (.not. done)
            done = .true.
            do j = start, stop
               jj = ip11(j,i)
               do k = 1, np11(jj)
                  kk = ip11(k,jj)
                  if (mask(kk) .ne. i) then
                     if (np11(i) .lt. maxp11) then
                        np11(i) = np11(i) + 1
                        ip11(np11(i),i) = kk
                     else
                        write (iout,60)
   60                   format (/,' POLARGRP  --  Too many Atoms',
     &                             ' in Polarization Group')
                        abort = .true.
                        goto 70
                     end if
                     mask(kk) = i
                  end if
               end do
            end do
            if (np11(i) .ne. stop) then
               done = .false.
               start = stop + 1
               stop = np11(i)
            end if
         end do
         call sort (np11(i),ip11(1,i))
      end do
   70 continue
      if (abort)  call fatal
c
c     loop over atoms finding all the 1-2 group relationships
c
      do i = 1, n
         mask(i) = 0
      end do
      do i = 1, n
         do j = 1, np11(i)
            jj = ip11(j,i)
            mask(jj) = i
         end do
         nkeep = 0
         do j = 1, np11(i)
            jj = ip11(j,i)
            do k = 1, n12(jj)
               kk = i12(k,jj)
               if (mask(kk) .ne. i) then
                  nkeep = nkeep + 1
                  keep(nkeep) = kk
               end if
            end do
         end do
         nlist = 0
         do j = 1, nkeep
            jj = keep(j)
            do k = 1, np11(jj)
               kk = ip11(k,jj)
               nlist = nlist + 1
               list(nlist) = kk
            end do
         end do
         call sort8 (nlist,list)
         if (nlist .le. maxp12) then
            np12(i) = nlist
            do j = 1, nlist
               ip12(j,i) = list(j)
            end do
         else
            write (iout,80)
   80       format (/,' POLARGRP  --  Too many Atoms',
     &                 ' in 1-2 Polarization Group')
            abort = .true.
            goto 90
         end if
      end do
   90 continue
c
c     loop over atoms finding all the 1-3 group relationships
c
      do i = 1, n
         mask(i) = 0
      end do
      do i = 1, n
         do j = 1, np11(i)
            jj = ip11(j,i)
            mask(jj) = i
         end do
         do j = 1, np12(i)
            jj = ip12(j,i)
            mask(jj) = i
         end do
         nlist = 0
         do j = 1, np12(i)
            jj = ip12(j,i)
            do k = 1, np12(jj)
               kk = ip12(k,jj)
               if (mask(kk) .ne. i) then
                  nlist = nlist + 1
                  list(nlist) = kk
               end if
            end do
         end do
         call sort8 (nlist,list)
         if (nlist .le. maxp13) then
            np13(i) = nlist
            do j = 1, nlist
               ip13(j,i) = list(j)
            end do
         else
            write (iout,100)
  100       format (/,' POLARGRP  --  Too many Atoms',
     &                 ' in 1-3 Polarization Group')
            abort = .true.
            goto 110
         end if
      end do
  110 continue
c
c     loop over atoms finding all the 1-4 group relationships
c
      do i = 1, n
         mask(i) = 0
      end do
      do i = 1, n
         do j = 1, np11(i)
            jj = ip11(j,i)
            mask(jj) = i
         end do
         do j = 1, np12(i)
            jj = ip12(j,i)
            mask(jj) = i
         end do
         do j = 1, np13(i)
            jj = ip13(j,i)
            mask(jj) = i
         end do
         nlist = 0
         do j = 1, np13(i)
            jj = ip13(j,i)
            do k = 1, np12(jj)
               kk = ip12(k,jj)
               if (mask(kk) .ne. i) then
                  nlist = nlist + 1
                  list(nlist) = kk
               end if
            end do
         end do
         call sort8 (nlist,list)
         if (nlist .le. maxp14) then
            np14(i) = nlist
            do j = 1, nlist
               ip14(j,i) = list(j)
            end do
         else
            write (iout,120)
  120       format (/,' POLARGRP  --  Too many Atoms',
     &                 ' in 1-4 Polarization Group')
            abort = .true.
            goto 130
         end if
      end do
  130 continue
      if (abort)  call fatal
c
c     perform deallocation of some local arrays
c
      deallocate (keep)
      deallocate (list)
      deallocate (mask)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2022  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module kpolpr  --  special Thole forcefield parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     maxnpp   maximum number of special pair polarization entries
c
c     thlpr    Thole damping values for special polarization pairs
c     thdpr    Thole direct damping for special polarization pairs
c     kppr     string of atom types for special polarization pairs
c
c
      module kpolpr
      implicit none
      integer maxnpp
      real*8, allocatable :: thlpr(:)
      real*8, allocatable :: thdpr(:)
      character*8, allocatable :: kppr(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module kpolr  --  polarizability forcefield parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     pgrp   connected types in polarization group of each atom type
c     polr   dipole polarizability parameters for each atom type
c     athl   Thole polarization damping value for each atom type
c     dthl   alternate Thole direct polarization damping values
c
c
      module kpolr
      implicit none
      integer, allocatable :: pgrp(:,:)
      real*8, allocatable :: polr(:)
      real*8, allocatable :: athl(:)
      real*8, allocatable :: dthl(:)
      save
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine krepel  --  Pauli repulsion term assignment  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "krepel" assigns the size values, exponential parameter and
c     number of valence electrons for Pauli repulsion interactions
c     and processes any new or changed values for these parameters
c
c
      subroutine krepel
      use atomid
      use atoms
      use inform
      use iounit
      use krepl
      use keys
      use mpole
      use potent
      use repel
      use reppot
      use sizes
      implicit none
      integer i,j,k
      integer ia,ic,next
      real*8 spr,apr,epr
      logical header
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing Pauli repulsion parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:10) .eq. 'REPULSION ') then
            k = 0
            spr = 0.0d0
            apr = 0.0d0
            epr = 0.0d0
            call getnumb (record,k,next)
            string = record(next:240)
            read (string,*,err=10,end=10)  spr,apr,epr
   10       continue
            if (k .gt. 0) then
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Pauli Repulsion',
     &                       ' Parameters :',
     &                    //,5x,'Atom Class',15x,'Size',11x,'Damp',
     &                       8x,'Valence'/)
               end if
               if (k .le. maxclass) then
                  prsiz(k) = spr
                  prdmp(k) = apr
                  prele(k) = -abs(epr)
                  if (.not. silent) then
                     write (iout,30)  k,spr,apr,epr
   30                format (6x,i6,7x,2f15.4,f15.3)
                  end if
               else
                  write (iout,40)
   40             format (/,' KREPEL  --  Too many Pauli Repulsion',
     &                       ' Parameters')
                  abort = .true.
               end if
            end if
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(irep))  deallocate (irep)
      if (allocated(replist))  deallocate (replist)
      if (allocated(sizpr))  deallocate (sizpr)
      if (allocated(dmppr))  deallocate (dmppr)
      if (allocated(elepr))  deallocate (elepr)
      if (allocated(repole))  deallocate (repole)
      if (allocated(rrepole))  deallocate (rrepole)
      allocate (irep(n))
      allocate (replist(n))
      allocate (sizpr(n))
      allocate (dmppr(n))
      allocate (elepr(n))
      allocate (repole(maxpole,n))
      allocate (rrepole(maxpole,n))
c
c     assign the repulsion size, alpha and valence parameters 
c
      do i = 1, n
         irep(i) = 0
         replist(i) = 0
         sizpr(i) = 0.0d0
         dmppr(i) = 0.0d0
         elepr(i) = 0.0d0
         ic = class(i)
         if (ic .ne. 0) then
            sizpr(i) = prsiz(ic)
            dmppr(i) = prdmp(ic)
            elepr(i) = prele(ic)
         end if
      end do
c
c     process keywords containing atom specific Pauli repulsion
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:10) .eq. 'REPULSION ') then
            ia = 0
            spr = 0.0d0
            apr = 0.0d0
            epr = 0.0d0
            string = record(next:240)
            read (string,*,err=70,end=70)  ia,spr,apr,epr
            if (ia.lt.0 .and. ia.ge.-n) then
               ia = -ia
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,50)
   50             format (/,' Additional Pauli Repulsion Values',
     &                       ' for Specific Atoms :',
     &                    //,8x,'Atom',17x,'Size',12x,'Damp',
     &                       8x,'Valence'/)
               end if
               if (.not. silent) then
                  write (iout,60)  ia,spr,apr,epr
   60             format (6x,i6,7x,2f15.4,f15.3)
               end if
               sizpr(ia) = spr
               dmppr(ia) = apr
               elepr(ia) = -abs(epr)
            end if
   70       continue
         end if
      end do
c
c     condense repulsion sites to the list of multipole sites
c
      nrep = 0
      if (use_repel) then
         do i = 1, n
            if (sizpr(i) .ne. 0.0d0) then
               nrep = nrep + 1
               irep(nrep) = i
               replist(i) = nrep
               do j = 1, maxpole
                  repole(j,i) = pole(j,i)
               end do
            end if
         end do
      end if
c
c     test multipoles at chiral sites and invert if necessary
c
      call chkpole
c
c     turn off the Pauli repulsion potential if not used
c
      if (nrep .eq. 0)  use_repel = .false.
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module krepl  --  Pauli repulsion forcefield parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     prsiz     Pauli repulsion size value for each atom class
c     prdmp     alpha Pauli repulsion parameter for each atom class
c     prele     number of valence electrons for each atom class
c
c
      module krepl
      implicit none
      real*8, allocatable :: prsiz(:)
      real*8, allocatable :: prdmp(:)
      real*8, allocatable :: prele(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2020  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module ksolut  --  solvation term forcefield parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     pbr      Poisson-Boltzmann radius value for each atom type
c     csr      ddCOSMO solvation radius value for each atom type
c     gkr      Generalized Kirkwood radius value for each atom type
c     snk      neck correction scale factor for each atom type
c
c
      module ksolut
      implicit none
      real*8, allocatable :: pbr(:)
      real*8, allocatable :: csr(:)
      real*8, allocatable :: gkr(:)
      real*8, allocatable :: snk(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine ksolv  --  solvation parameter assignment  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "ksolv" assigns implicit solvation energy parameters for
c     the surface area, generalized Born, generalized Kirkwood,
c     Poisson-Boltzmann, cavity-dispersion and HPMF models
c
c
      subroutine ksolv
      use sizes
      use atomid
      use atoms
      use inform
      use iounit
      use keys
      use ksolut
      use potent
      use solpot
      use solute
      implicit none
      integer i,k,next
      real*8 pbrd,csrd
      real*8 gkrd,snek
      logical header
      character*20 keyword
      character*20 value
      character*240 record
      character*240 string
c
c
c     defaults for implicit solvation term and parameters
c
      use_solv = .false.
      use_born = .false.
      solvtyp = '        '
      borntyp = '        '
      doffset = 0.09d0
      onipr = 0.0d0
c
c     search keywords for implicit solvation commands
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:8) .eq. 'SOLVATE ') then
            use_solv = .true.
            use_born = .false.
            solvtyp = 'ASP'
            call getword (record,value,next)
            call upcase (value)
            if (value(1:3) .eq. 'ASP') then
               solvtyp = 'ASP'
            else if (value(1:4) .eq. 'SASA') then
               solvtyp = 'SASA'
            else if (value(1:5) .eq. 'ONION') then
               use_born = .true.
               solvtyp = 'GB'
               borntyp = 'ONION'
            else if (value(1:5) .eq. 'STILL') then
               use_born = .true.
               solvtyp = 'GB'
               borntyp = 'STILL'
            else if (value(1:3) .eq. 'HCT') then
               use_born = .true.
               solvtyp = 'GB'
               borntyp = 'HCT'
            else if (value(1:3) .eq. 'OBC') then
               use_born = .true.
               solvtyp = 'GB'
               borntyp = 'OBC'
            else if (value(1:3) .eq. 'ACE') then
               use_born = .true.
               solvtyp = 'GB'
               borntyp = 'ACE'
            else if (value(1:7) .eq. 'GB-HPMF') then
               use_born = .true.
               solvtyp = 'GB-HPMF'
               borntyp = 'STILL'
            else if (value(1:2) .eq. 'GB') then
               use_born = .true.
               solvtyp = 'GB'
               borntyp = 'STILL'
            else if (value(1:7) .eq. 'GK-HPMF') then
               use_born = .true.
               solvtyp = 'GK-HPMF'
               borntyp = 'GRYCUK'
            else if (value(1:2) .eq. 'GK') then
               use_born = .true.
               solvtyp = 'GK'
               borntyp = 'GRYCUK'
            else if (value(1:7) .eq. 'PB-HPMF') then
               solvtyp = 'PB-HPMF'
            else if (value(1:2) .eq. 'PB') then
               solvtyp = 'PB'
            end if
         else if (keyword(1:12) .eq. 'BORN-RADIUS ') then
            call getword (record,value,next)
            call upcase (value)
            if (value(1:5) .eq. 'ONION') then
               borntyp = 'ONION'
            else if (value(1:5) .eq. 'STILL') then
               borntyp = 'STILL'
            else if (value(1:3) .eq. 'HCT') then
               borntyp = 'HCT'
            else if (value(1:3) .eq. 'OBC') then
               borntyp = 'OBC'
            else if (value(1:3) .eq. 'ACE') then
               borntyp = 'ACE'
            else if (value(1:6) .eq. 'GRYCUK') then
               borntyp = 'GRYCUK'
            else if (value(1:6) .eq. 'GONION') then
               borntyp = 'GONION'
            else if (value(1:7) .eq. 'PERFECT') then
               borntyp = 'PERFECT'
            end if
         else if (keyword(1:12) .eq. 'ONION-PROBE ') then
            read (string,*,err=10,end=10)  onipr 
         else if (keyword(1:18) .eq. 'DIELECTRIC-OFFSET ') then
            read (string,*,err=10,end=10)  doffset
            if (doffset .lt. 0.0d0)  doffset = -doffset
         end if
   10    continue
      end do
c
c     process keywords containing solvation parameters
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. 'SOLUTE ') then
            call getnumb (record,k,next)
            if (k.ge.1 .and. k.le.maxtyp) then
               pbrd = 0.0d0
               csrd = 0.0d0
               gkrd = 0.0d0
               snek = 0.0d0
               string = record(next:240)
               read (string,*,err=20,end=20)  pbrd,csrd,gkrd,snek
   20          continue
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,30)
   30             format (/,' Additional Solvation Parameters :',
     &                    //,5x,'Atom Type',13x,'PB Size',5x,'CS Size',
     &                       5x,'GK Size',6x,'S-Neck',/)
               end if
               pbr(k) = 0.5d0 * pbrd
               csr(k) = 0.5d0 * csrd
               gkr(k) = 0.5d0 * gkrd
               snk(k) = snek
               if (.not. silent) then
                  write (iout,40)  k,pbrd,csrd,gkrd,snek
   40             format (6x,i6,10x,4f12.4)
               end if
            else if (k .gt. maxtyp) then
               write (iout,50)  maxtyp
   50          format (/,' KSOLV  --  Only Atom Types through',i5,
     &                    ' are Allowed')
               abort = .true.
            end if
         end if
      end do
c
c     get keywords with AlphaMol surface area and volume controls
c
      call ksurf
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(rsolv))  deallocate (rsolv)
      allocate (rsolv(n))
c
c     invoke the setup needed for perfect Born radius model
c
      if (borntyp .eq. 'PERFECT')  call kpb
c
c     invoke the setup needed for specific solvation models
c
      if (solvtyp.eq.'ASP' .or. solvtyp.eq.'SASA') then
         call ksa
      else if (solvtyp .eq. 'GB-HPMF') then
         call kgb
         call khpmf
      else if (solvtyp .eq. 'GB') then
         call kgb
      else if (solvtyp .eq. 'GK-HPMF') then
         call kgk
         call khpmf
      else if (solvtyp .eq. 'GK') then
         call kgk
         call knp
      else if (solvtyp .eq. 'PB-HPMF') then
         call kpb
         call khpmf
      else if (solvtyp .eq. 'PB') then
         call kpb
         call knp
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ksa  --  set surface area solvation parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ksa" initializes parameters needed for surface area-based
c     implicit solvation models including ASP and SASA
c
c     literature references:
c
c     L. Wesson and D. Eisenberg, "Atomic Solvation Parameters
c     Applied to Molecular Dynamics of Proteins in Solution",
c     Protein Science, 1, 227-235 (1992)  (Eisenberg-McLachlan ASP)
c
c     T. Ooi, M. Oobatake, G. Nemethy and H. A. Scheraga, "Accessible
c     Surface Areas as a Measure of the Thermodynamic Parameters of
c     Hydration of Peptides", PNAS, 84, 3086-3090 (1987)  (SASA)
c
c
      subroutine ksa
      use sizes
      use atomid
      use atoms
      use couple
      use solpot
      use solute
      implicit none
      integer i,j,k
      integer atmnum
c
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(asolv))  deallocate (asolv)
      allocate (asolv(n))
c
c     assign the Eisenberg-McLachlan ASP solvation parameters;
c     parameters only available for protein-peptide groups
c
      if (solvtyp .eq. 'ASP') then
         do i = 1, n
            atmnum = atomic(i)
            if (atmnum .eq. 6) then
               rsolv(i) = 1.9d0
               asolv(i) = 0.004d0
            else if (atmnum .eq. 7) then
               rsolv(i) = 1.7d0
               asolv(i) = -0.113d0
               if (n12(i) .eq. 4) then
                  asolv(i) = -0.169d0
               end if
            else if (atmnum .eq. 8) then
               rsolv(i) = 1.4d0
               asolv(i) = -0.113d0
               if (n12(i).eq.1 .and. atomic(i12(1,i)).eq.6) then
                  do j = 1, n13(i)
                     k = i13(j,i)
                     if (n12(k).eq.1 .and. atomic(k).eq.8) then
                        asolv(i) = -0.166d0
                     end if
                  end do
               end if
               do j = 1, n12(i)
                  k = i12(j,i)
                  if (atomic(k) .eq. 15)  asolv(i) = -0.140d0
               end do
            else if (atmnum .eq. 15) then
               rsolv(i) = 1.9d0
               asolv(i) = -0.140d0
            else if (atmnum .eq. 16) then
               rsolv(i) = 1.8d0
               asolv(i) = -0.017d0
            else
               rsolv(i) = 0.0d0
               asolv(i) = 0.0d0
            end if
         end do
      end if
c
c     assign the Ooi-Scheraga SASA solvation parameters;
c     parameters only available for protein-peptide groups
c
      if (solvtyp .eq. 'SASA') then
         do i = 1, n
            atmnum = atomic(i)
            if (atmnum .eq. 6) then
               rsolv(i) = 2.0d0
               asolv(i) = 0.008d0
               if (n12(i) .eq. 3) then
                  rsolv(i) = 1.75d0
                  asolv(i) = -0.008d0
                  do j = 1, n12(i)
                     k = i12(j,i)
                     if (atomic(k) .eq. 8) then
                        rsolv(i) = 1.55d0
                        asolv(i) = 0.427d0
                     end if
                  end do
               end if
            else if (atmnum .eq. 7) then
               rsolv(i) = 1.55d0
               asolv(i) = -0.132d0
               if (n12(i) .eq. 4)  asolv(i) = -1.212d0
            else if (atmnum .eq. 8) then
               rsolv(i) = 1.4d0
               if (n12(i) .eq. 1) then
                  asolv(i) = -0.038d0
                  if (atomic(i12(1,i)) .eq. 6) then
                     do j = 1, n13(i)
                        k = i13(j,i)
                        if (n12(k).eq.1 .and. atomic(k).eq.8) then
                           asolv(i) = -0.770d0
                        end if
                     end do
                  end if
               else if (n12(i) .eq. 2) then
                  asolv(i) = -0.172d0
               end if
               do j = 1, n12(i)
                  k = i12(j,i)
                  if (atomic(k) .eq. 15)  asolv(i) = -0.717d0
               end do
            else if (atmnum .eq. 15) then
               rsolv(i) = 2.1d0
               asolv(i) = 0.0d0
            else if (atmnum .eq. 16) then
               rsolv(i) = 2.0d0
               asolv(i) = -0.021d0
            else if (atmnum .eq. 17) then
               rsolv(i) = 2.0d0
               asolv(i) = 0.012d0
            else
               rsolv(i) = 0.0d0
               asolv(i) = 0.0d0
            end if
         end do
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine kgb  --  assign generalized Born parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "kgb" initializes parameters needed for the generalized
c     Born implicit solvation models
c
c     literature references:
c
c     M. Schaefer, C. Bartels, F. Leclerc and M. Karplus, "Effective
c     Atom Volumes for Implicit Solvent Models: Comparison between
c     Voronoi Volumes and Minimum Fluctuations Volumes", Journal of
c     Computational Chemistry, 22, 1857-1879 (2001)  (ACE)
c
c
      subroutine kgb
      use sizes
      use angbnd
      use atmlst
      use atomid
      use atoms
      use bndstr
      use chgpot
      use couple
      use math
      use potent
      use solpot
      use solute
      implicit none
      integer i,j,k,m
      integer mm,nh,kc
      integer ia,ib,ic,id
      integer atmnum,atmmas
      real*8 ri,ri2,rk,rk2
      real*8 c1,c2,c3,pi2
      real*8 r,r2,r4,rab,rbc
      real*8 cosine,factor
      real*8 h,ratio,term
      real*8 width,qterm,temp
      real*8 alpha,alpha2,alpha4
      real*8 vk,prod2,prod4
      real*8 fik,tik2,qik,uik
      real*8 s2ik,s3ik,omgik
      logical amide
c
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(wace))  allocate (wace(maxclass,maxclass))
      if (.not. allocated(s2ace))  allocate (s2ace(maxclass,maxclass))
      if (.not. allocated(uace))  allocate (uace(maxclass,maxclass))
      if (allocated(asolv))  deallocate (asolv)
      if (allocated(rborn))  deallocate (rborn)
      if (allocated(drb))  deallocate (drb)
      if (allocated(drobc))  deallocate (drobc)
      if (allocated(gpol))  deallocate (gpol)
      if (allocated(shct))  deallocate (shct)
      if (allocated(aobc))  deallocate (aobc)
      if (allocated(bobc))  deallocate (bobc)
      if (allocated(gobc))  deallocate (gobc)
      if (allocated(vsolv))  deallocate (vsolv)
      allocate (asolv(n))
      allocate (rborn(n))
      allocate (drb(n))
      allocate (drobc(n))
      allocate (gpol(n))
      allocate (shct(n))
      allocate (aobc(n))
      allocate (bobc(n))
      allocate (gobc(n))
      allocate (vsolv(n))
c
c     set offset and scaling values for analytical Still method
c
      if (borntyp .eq. 'STILL') then
         p1 = 0.073d0
         p2 = 0.921d0
         p3 = 6.211d0
         p4 = 15.236d0
         p5 = 1.254d0
         if (.not. use_bond)  call kbond
         if (.not. use_angle)  call kangle
      end if
c
c     set overlap scale factors for HCT and OBC methods
c
      if (borntyp.eq.'HCT' .or. borntyp.eq.'OBC') then
         do i = 1, n
            shct(i) = 0.80d0
            atmnum = atomic(i)
            if (atmnum .eq. 1)  shct(i) = 0.85d0
            if (atmnum .eq. 6)  shct(i) = 0.72d0
            if (atmnum .eq. 7)  shct(i) = 0.79d0
            if (atmnum .eq. 8)  shct(i) = 0.85d0
            if (atmnum .eq. 9)  shct(i) = 0.88d0
            if (atmnum .eq. 15)  shct(i) = 0.86d0
            if (atmnum .eq. 16)  shct(i) = 0.96d0
            if (atmnum .eq. 26)  shct(i) = 0.88d0
         end do
      end if
c
c     set rescaling coefficients for the OBC method
c
      if (borntyp .eq. 'OBC') then
         do i = 1, n
            aobc(i) = 1.00d0
            bobc(i) = 0.80d0
            gobc(i) = 4.85d0
         end do
      end if
c
c     set the Gaussian width factor for the ACE method
c
      if (borntyp .eq. 'ACE') then
         width = 1.2d0
      end if
c
c     assign surface area factors for nonpolar solvation
c
      if (borntyp .eq. 'ONION') then
         do i = 1, n
            asolv(i) = 0.0072d0
         end do
      else if (borntyp .eq. 'STILL') then
         do i = 1, n
            asolv(i) = 0.0049d0
         end do
      else if (borntyp .eq. 'HCT') then
         do i = 1, n
            asolv(i) = 0.0054d0
         end do
      else if (borntyp .eq. 'OBC') then
         do i = 1, n
            asolv(i) = 0.0054d0
         end do
      else if (borntyp .eq. 'ACE') then
         do i = 1, n
            asolv(i) = 0.0030d0
         end do
      end if
c
c     assign standard radii for GB/SA methods other than ACE;
c     taken from Macromodel and OPLS-AA, except for hydrogens
c
      if (borntyp .ne. 'ACE') then
         do i = 1, n
            atmnum = atomic(i)
            if (atmnum .eq. 1) then
               rsolv(i) = 1.25d0
               k = i12(1,i)
               if (atomic(k) .eq. 7)  rsolv(i) = 1.15d0
               if (atomic(k) .eq. 8)  rsolv(i) = 1.05d0
            else if (atmnum .eq. 3) then
               rsolv(i) = 1.432d0
            else if (atmnum .eq. 6) then
               rsolv(i) = 1.90d0
               if (n12(i) .eq. 3)  rsolv(i) = 1.875d0
               if (n12(i) .eq. 2)  rsolv(i) = 1.825d0
            else if (atmnum .eq. 7) then
               rsolv(i) = 1.7063d0
               if (n12(i) .eq. 4)  rsolv(i) = 1.625d0
               if (n12(i) .eq. 1)  rsolv(i) = 1.60d0
            else if (atmnum .eq. 8) then
               rsolv(i) = 1.535d0
               if (n12(i) .eq. 1)  rsolv(i) = 1.48d0
            else if (atmnum .eq. 9) then
               rsolv(i) = 1.47d0
            else if (atmnum .eq. 10) then
               rsolv(i) = 1.39d0
            else if (atmnum .eq. 11) then
               rsolv(i) = 1.992d0
            else if (atmnum .eq. 12) then
               rsolv(i) = 1.70d0
            else if (atmnum .eq. 14) then
               rsolv(i) = 1.80d0
            else if (atmnum .eq. 15) then
               rsolv(i) = 1.87d0
            else if (atmnum .eq. 16) then
               rsolv(i) = 1.775d0
            else if (atmnum .eq. 17) then
               rsolv(i) = 1.735d0
            else if (atmnum .eq. 18) then
               rsolv(i) = 1.70d0
            else if (atmnum .eq. 19) then
               rsolv(i) = 2.123d0
            else if (atmnum .eq. 20) then
               rsolv(i) = 1.817d0
            else if (atmnum .eq. 35) then
               rsolv(i) = 1.90d0
            else if (atmnum .eq. 36) then
               rsolv(i) = 1.812d0
            else if (atmnum .eq. 37) then
               rsolv(i) = 2.26d0
            else if (atmnum .eq. 53) then
               rsolv(i) = 2.10d0
            else if (atmnum .eq. 54) then
               rsolv(i) = 1.967d0
            else if (atmnum .eq. 55) then
               rsolv(i) = 2.507d0
            else if (atmnum .eq. 56) then
               rsolv(i) = 2.188d0
            else
               rsolv(i) = 2.0d0
            end if
         end do
      end if
c
c     compute the atomic volumes for the analytical Still method
c
      if (borntyp .eq. 'STILL') then
         do i = 1, n
            vsolv(i) = (4.0d0*pi/3.0d0) * rsolv(i)**3
            ri = rsolv(i)
            ri2 = ri * ri
            do j = 1, n12(i)
               k = i12(j,i)
               rk = rsolv(k)
               r = 1.01d0 * bl(bndlist(j,i))
               ratio = (rk*rk-ri2-r*r) / (2.0d0*ri*r)
               h = ri * (1.0d0+ratio)
               term = (pi/3.0d0) * h * h * (3.0d0*ri-h)
               vsolv(i) = vsolv(i) - term
            end do
         end do
c
c     get self-, 1-2 and 1-3 polarization for analytical Still method
c
         do i = 1, n
            gpol(i) = -0.5d0 * electric / (rsolv(i)-doffset+p1)
         end do
         do i = 1, nbond
            ia = ibnd(1,i)
            ib = ibnd(2,i)
            r = bl(i)
            r4 = r**4
            gpol(ia) = gpol(ia) + p2*vsolv(ib)/r4
            gpol(ib) = gpol(ib) + p2*vsolv(ia)/r4
         end do
         do i = 1, nangle
            ia = iang(1,i)
            ib = iang(2,i)
            ic = iang(3,i)
            factor = 1.0d0
            do j = 1, n12(ia)
               id = i12(j,ia)
               if (id .eq. ic) then
                  factor = 0.0d0
               else if (id .ne. ib) then
                  do k = 1, n12(ic)
                     if (i12(k,ic) .eq. id) then
                        factor = 0.5d0
                     end if
                  end do
               end if
            end do
            do j = 1, n12(ib)
               if (i12(j,ib) .eq. ia) then
                  rab = bl(bndlist(j,ib))
               else if (i12(j,ib) .eq. ic) then
                  rbc = bl(bndlist(j,ib))
               end if
            end do
            cosine = cos(anat(i)/radian)
            r2 = rab**2 + rbc**2 - 2.0d0*rab*rbc*cosine
            r4 = r2 * r2
            gpol(ia) = gpol(ia) + factor*p3*vsolv(ic)/r4
            gpol(ic) = gpol(ic) + factor*p3*vsolv(ia)/r4
         end do
      end if
c
c     assign the atomic radii and volumes for the ACE method;
c     volumes taken from average Voronoi values with hydrogens
c
      if (borntyp .eq. 'ACE') then
         do i = 1, n
            atmnum = atomic(i)
            atmmas = nint(mass(i))
            if (atmnum .eq. 1) then
               rsolv(i) = 1.468d0
               vsolv(i) = 11.0d0
               k = i12(1,i)
               if (atomic(k).eq.6 .and. n12(k).eq.4) then
                  vsolv(i) = 11.895d0
               else if (atomic(k).eq.6 .and. n12(k).eq.3) then
                  vsolv(i) = 13.242d0
               else if (atomic(k).eq.7 .and. n12(k).eq.4) then
                  rsolv(i) = 0.60d0
                  vsolv(i) = 9.138d0
               else if (atomic(k).eq.7 .or. atomic(k).eq.8) then
                  rsolv(i) = 0.60d0
                  vsolv(i) = 9.901d0
               else if (atomic(k).ne.16) then
                  rsolv(i) = 1.468d0
                  vsolv(i) = 13.071d0
               end if
            else if (atmnum .eq. 6) then
               rsolv(i) = 2.49d0
               vsolv(i) = 7.0d0
               nh = 0
               do j = 1, n12(i)
                  k = i12(j,i)
                  if (atomic(k) .eq. 1)  nh = nh + 1
               end do
               if (n12(i) .eq. 4) then
                  if (nh .eq. 3) then
                     vsolv(i) = 3.042d0
                  else if (nh .eq. 2) then
                     vsolv(i) = 3.743d0
                  else if (nh .eq. 1) then
                     vsolv(i) = 4.380d0
                  end if
               else if (n12(i) .eq. 3) then
                  if (nh .eq. 1) then
                     rsolv(i) = 2.10d0
                     vsolv(i) = 7.482d0
                  else if (nh .eq. 0) then
                     rsolv(i) = 2.10d0
                     vsolv(i) = 8.288d0
                  end if
                  do j = 1, n12(i)
                     k = i12(1,j)
                     if (atomic(k).eq.8 .and. n12(k).eq.1) then
                        rsolv(i) = 2.10d0
                        vsolv(i) = 7.139d0
                     end if
                  end do
               end if
               if (atmmas .eq. 15) then
                  rsolv(i) = 2.165d0
                  vsolv(i) = 33.175d0
               else if (atmmas .eq. 14) then
                  rsolv(i) = 2.235d0
                  vsolv(i) = 20.862d0
               else if (atmmas.eq.13 .and. n12(i).eq.2) then
                  rsolv(i) = 2.10d0
                  vsolv(i) = 20.329d0
               else if (atmmas .eq. 13) then
                  rsolv(i) = 2.365d0
                  vsolv(i) = 11.784d0
               end if
            else if (atmnum .eq. 7) then
               rsolv(i) = 1.60d0
               vsolv(i) = 6.0d0
               nh = 0
               do j = 1, n12(i)
                  k = i12(j,i)
                  if (atomic(k) .eq. 1)  nh = nh + 1
               end do
               if (n12(i) .eq. 4) then
                  if (nh .eq. 3) then
                     vsolv(i) = 2.549d0
                  else if (nh .eq. 2) then
                     vsolv(i) = 3.304d0
                  end if
               else if (n12(i) .eq. 3) then
                  amide = .false.
                  do j = 1, n12(i)
                     m = i12(j,i)
                     if (atomic(m) .eq. 6) then
                        do k = 1, n12(m)
                           mm = i12(k,m)
                           if (atomic(mm).eq.8 .and. n12(mm).eq.1) then
                              amide = .true.
                           end if
                        end do
                     end if
                  end do
                  if (amide) then
                     if (nh .eq. 0) then
                        vsolv(i) = 7.189d0
                     else if (nh .eq. 1) then
                        vsolv(i) = 6.030d0
                     else if (nh .eq. 2) then
                        vsolv(i) = 5.693d0
                     end if
                  else
                     if (nh .eq. 2) then
                        vsolv(i) = 5.677d0
                     else if (nh .eq. 2) then
                        vsolv(i) = 6.498d0
                     end if
                  end if
               end if
            else if (atmnum .eq. 8) then
               rsolv(i) = 1.60d0
               vsolv(i) = 12.0d0
               if (n12(i) .eq. 1) then
                  vsolv(i) = 13.532d0
                  k = i12(1,i)
                  if (atomic(k) .eq. 15) then
                     vsolv(i) = 17.202d0
                  else
                     do j = 1, n13(i)
                        k = i13(j,i)
                        if (atomic(j).eq.8 .and. n12(j).eq.1) then
                           vsolv(i) = 15.400d0
                        end if
                     end do
                  end if
               else if (n12(i) .eq. 2) then
                  vsolv(i) = 10.642d0
                  do j = 1, n12(i)
                     k = i12(j,i)
                     if (atomic(k) .eq. 15)  vsolv(i) = 11.416d0
                  end do
               end if
            else if (atmnum .eq. 12) then
               rsolv(i) = 1.0d0
               vsolv(i) = 15.235d0
            else if (atmnum .eq. 15) then
               rsolv(i) = 1.89d0
               vsolv(i) = 6.131d0
            else if (atmnum .eq. 16) then
               rsolv(i) = 1.89d0
               vsolv(i) = 17.232d0
               do j = 1, n12(i)
                  k = i12(j,i)
                  if (atomic(k) .eq. 16)  vsolv(i) = 18.465d0
               end do
            else if (atmnum .eq. 26) then
               rsolv(i) = 0.65d0
               vsolv(i) = 9.951d0
            else
               rsolv(i) = 0.0d0
               vsolv(i) = 0.0d0
            end if
         end do
c
c     calculate the pairwise parameters for the ACE method
c
         c1 = 4.0d0 / (3.0d0*pi)
         c2 = 77.0d0 * pi * root2 / 512.0d0
         c3 = 2.0d0 * pi * rootpi
         pi2 = 1.0d0 / (pi*pi)
         do i = 1, n
            ic = class(i)
            ri = rsolv(i)
            ri2 = ri * ri
            do k = 1, n
               kc = class(k)
               rk = rsolv(k)
               vk = vsolv(kc)
               rk2 = rk * rk
               alpha = max(width,ri/rk)
               alpha2 = alpha * alpha
               alpha4 = alpha2 * alpha2
               prod2 = alpha2 * rk2
               prod4 = prod2 * prod2
               ratio = alpha2 * rk2 / ri2
               tik2 = 0.5d0 * pi * ratio
               temp = 1.0d0 / (1.0d0+2.0d0*tik2)
               fik = 2.0d0/(1.0d0+tik2) - temp
               qik = tik2 * sqrt(temp)
               qterm = qik - atan(qik)
               if (k .ne. i) then
                  omgik = vk * qterm * pi2 / prod4
               else
                  omgik = c1 * qterm / (alpha4 * ri)
               end if
               s2ik = 3.0d0 * qterm * prod2
     &                   / ((3.0d0+fik)*qik-4.0d0*atan(qik))
               s3ik = s2ik * sqrt(s2ik)
               uik = c2 * ri / (1.0d0-(c3*s3ik*ri*omgik/vk))
               wace(ic,kc) = omgik
               s2ace(ic,kc) = s2ik
               uace(ic,kc) = uik
            end do
         end do
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine kgk  --  set generalized Kirkwood parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "kgk" initializes parameters needed for the generalized
c     Kirkwood implicit solvation model
c
c
      subroutine kgk
      use sizes
      use atomid
      use atoms
      use couple
      use gkstuf
      use keys
      use kvdws
      use polar
      use polopt
      use polpot
      use ptable
      use solute
      use vdw
      implicit none
      integer i,it,next
      integer atmnum
      real*8 dhct
      logical descreen
      logical omithyd
      logical atomhct
      character*10 radtyp
      character*20 keyword
      character*20 value
      character*240 record
      character*240 string
c
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(rsolv))  deallocate (rsolv)
      if (allocated(rdescr))  deallocate (rdescr)
      if (allocated(rborn))  deallocate (rborn)
      if (allocated(drb))  deallocate (drb)
      if (allocated(drbp))  deallocate (drbp)
      if (allocated(drobc))  deallocate (drobc)
      if (allocated(shct))  deallocate (shct)
      if (allocated(udirs))  deallocate (udirs)
      if (allocated(udirps))  deallocate (udirps)
      if (allocated(uinds))  deallocate (uinds)
      if (allocated(uinps))  deallocate (uinps)
      if (allocated(uopts))  deallocate (uopts)
      if (allocated(uoptps))  deallocate (uoptps)
      if (allocated(sneck))  deallocate (sneck)
      if (allocated(bornint))  deallocate (bornint)
      allocate (rsolv(n))
      allocate (rdescr(n))
      allocate (rborn(n))
      allocate (drb(n))
      allocate (drbp(n))
      allocate (drobc(n))
      allocate (shct(n))
      allocate (udirs(3,n))
      allocate (udirps(3,n))
      allocate (uinds(3,n))
      allocate (uinps(3,n))
      allocate (sneck(n))
      allocate (bornint(n))
      if (poltyp .eq. 'OPT') then
         allocate (uopts(0:optorder,3,n))
         allocate (uoptps(0:optorder,3,n))
      end if
c
c     set default value for exponent in the GB/GK function
c
      gkc = 2.455d0
      dhct = 0.72d0
      descoff = 0.30d0
      radtyp = 'SOLUTE'
      descreen = .true.
      omithyd = .true.
      atomhct = .true.
      useneck = .true.
      usetanh = .true.
c
c     get any altered generalized Kirkwood values from keyfile
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:4) .eq. 'GKC ') then
            read (string,*,err=10,end=10)  gkc
   10       continue
         else if (keyword(1:10) .eq. 'GK-RADIUS ') then
            call getword (record,value,next)
            call upcase (value)
            if (value(1:3) .eq. 'VDW') then
               radtyp = 'VDW'
            else if (value(1:10) .eq. 'MACROMODEL') then
               radtyp = 'MACROMODEL'
            else if (value(1:6) .eq. 'AMOEBA') then
               radtyp = 'AMOEBA'
            else if (value(1:5) .eq. 'BONDI') then
               radtyp = 'BONDI'
            else if (value(1:6) .eq. 'TOMASI') then
               radtyp = 'TOMASI'
            else if (value(1:6) .eq. 'SOLUTE') then
               radtyp = 'SOLUTE'
            end if
         else if (keyword(1:11) .eq. 'NODESCREEN ') then
            descreen = .false.
         else if (keyword(1:18) .eq. 'DESCREEN-HYDROGEN ') then
            omithyd = .false.
         else if (keyword(1:16) .eq. 'DESCREEN-OFFSET ') then
            read (string,*,err=20,end=20)  descoff
   20       continue
         else if (keyword(1:10) .eq. 'HCT-SCALE ') then
            read (string,*,err=30,end=30)  dhct
   30       continue
         else if (keyword(1:12) .eq. 'HCT-ELEMENT ') then
            call getword (record,value,next)
            call upcase (value)
            if (value(1:5) .eq. 'FALSE') then
               atomhct = .false.
            end if
         else if (keyword(1:16) .eq. 'NECK-CORRECTION ') then
            call getword (record,value,next)
            call upcase(value)
            if (value(1:5) .eq. 'FALSE') then
               useneck = .false.
            end if
         else if (keyword(1:16) .eq. 'TANH-CORRECTION ') then
            call getword (record,value,next)
            call upcase(value)
            if (value(1:5) .eq. 'FALSE') then
               usetanh = .false.
            end if
         end if
      end do
c
c     determine the solute atomic radii values to be used
c
      call setrad (radtyp)
c
c     assign generic value for the overlap scale factor
c
      do i = 1, n
         shct(i) = dhct
         rdescr(i) = rsolv(i)
         if (descreen) then
            it = jvdw(i)
            rdescr(i) = 0.5d0 * radmin(it,it)
         end if
c
c     use overlap scale factors for specific elements
c
         if (atomhct) then
            atmnum = atomic(i)
            if (atmnum .eq. 1)  shct(i) = 0.72d0
            if (atmnum .eq. 6)  shct(i) = 0.695d0
            if (atmnum .eq. 7)  shct(i) = 0.7673d0
            if (atmnum .eq. 8)  shct(i) = 0.7965d0
            if (atmnum .eq. 15)  shct(i) = 0.6117d0
            if (atmnum .eq. 16)  shct(i) = 0.7204d0
         end if
c
c     remove hydrogen descreening if it is not to be used
c
         if (omithyd) then
            atmnum = atomic(i)
            if (atmnum .eq. 1) shct(i) = 0.0d0
         end if
      end do
c
c     set optimal overlap scale factors for Macromodel radii
c
      if (radtyp .eq. 'MACROMODEL') then
         do i = 1, n
            shct(i) = 0.80d0
            atmnum = atomic(i)
            if (atmnum .eq. 1)  shct(i) = 0.85d0
            if (atmnum .eq. 6)  shct(i) = 0.72d0
            if (atmnum .eq. 7)  shct(i) = 0.79d0
            if (atmnum .eq. 8)  shct(i) = 0.85d0
            if (atmnum .eq. 9)  shct(i) = 0.88d0
            if (atmnum .eq. 15)  shct(i) = 0.86d0
            if (atmnum .eq. 16)  shct(i) = 0.96d0
            if (atmnum .eq. 26)  shct(i) = 0.88d0
         end do
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine kpb  --  assign Poisson-Boltzmann parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "kpb" assigns parameters needed for the Poisson-Boltzmann
c     implicit solvation model implemented via APBS
c
c
      subroutine kpb
      use sizes
      use atomid
      use atoms
      use bath
      use couple
      use gkstuf
      use inform
      use iounit
      use keys
      use kvdws
      use math
      use nonpol
      use pbstuf
      use polar
      use polopt
      use polpot
      use potent
      use ptable
      use solute
      implicit none
      integer i,j
      integer nx,ny,nz
      integer maxgrd,next
      integer pbtyplen,pbsolnlen
      integer bcfllen,chgmlen
      integer srfmlen,pbionq
      integer trimtext
      real*8 ri,spacing
      real*8 gx,gy,gz
      real*8 xcm,ycm,zcm
      real*8 total,weigh
      real*8 xmin,xmax,ymin
      real*8 ymax,zmin,zmax
      real*8 xlen,ylen,zlen,minlen
      real*8 pbionc,pbionr
      character*10 radtyp
      character*20 keyword
      character*20 value
      character*240 record
      character*240 string
c
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(shct))  deallocate (shct)
      if (allocated(udirs))  deallocate (udirs)
      if (allocated(udirps))  deallocate (udirps)
      if (allocated(uinds))  deallocate (uinds)
      if (allocated(uinps))  deallocate (uinps)
      if (allocated(uopts))  deallocate (uopts)
      if (allocated(uoptps))  deallocate (uoptps)
      allocate (shct(n))
      allocate (udirs(3,n))
      allocate (udirps(3,n))
      allocate (uinds(3,n))
      allocate (uinps(3,n))
      if (poltyp .eq. 'OPT') then
        allocate (uopts(0:optorder,3,n))
        allocate (uoptps(0:optorder,3,n))
      end if
c
c     assign some default APBS configuration parameters
c
      pbtyp = 'LPBE'
      pbsoln = 'MG-MANUAL'
      radtyp = 'SOLUTE'
      chgm = 'SPL4'
      srfm = 'MOL '
      bcfl = 'MDH'
      kelvin = 298.0d0
      pdie = 1.0d0
      sdie = 78.3d0
      srad = 0.0d0
      swin = 0.3d0
      sdens = 10.0d0
      smin = 3.0d0
      ionn = 0
      do i = 1, maxion
         ionc(i) = 0.0d0
         ionq(i) = 1
         ionr(i) = 2.0d0
      end do
      spacing = 0.5d0
      maxgrd = 513
c
c     compute the position of the center of mass
c
      total = 0.0d0
      xcm = 0.0d0
      ycm = 0.0d0
      zcm = 0.0d0
      do i = 1, n
         weigh = mass(i)
         total = total + weigh
         xcm = xcm + x(i)*weigh
         ycm = ycm + y(i)*weigh
         zcm = zcm + z(i)*weigh
      end do
      xcm = xcm / total
      ycm = ycm / total
      zcm = zcm / total
      gcent(1) = xcm
      gcent(2) = ycm
      gcent(3) = zcm
c
c     set default APBS grid dimension based on system extent
c
      xmin = xcm
      ymin = ycm
      zmin = zcm
      xmax = xcm
      ymax = ycm
      zmax = zcm
      do i = 1, n
         ri = 1.0
         xmin = min(xmin,x(i)-ri)
         ymin = min(ymin,y(i)-ri)
         zmin = min(zmin,z(i)-ri)
         xmax = max(xmax,x(i)+ri)
         ymax = max(ymax,y(i)+ri)
         zmax = max(zmax,z(i)+ri)
      end do
      xlen = 2.0d0 * (max(xcm-xmin,xmax-xcm)+smin)
      ylen = 2.0d0 * (max(ycm-ymin,ymax-ycm)+smin)
      zlen = 2.0d0 * (max(zcm-zmin,zmax-zcm)+smin)
      dime(1) = int(xlen/spacing) + 1
      dime(2) = int(ylen/spacing) + 1
      dime(3) = int(zlen/spacing) + 1
c
c     get any altered APBS parameters from the keyfile
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:13) .eq. 'APBS-MG-AUTO ') then
            pbsoln = 'MG-AUTO'
         else if (keyword(1:15) .eq. 'APBS-MG-MANUAL ') then
            pbsoln = 'MG-MANUAL'
         else if (keyword(1:10) .eq. 'APBS-GRID ') then
            nx = dime(1)
            ny = dime(2)
            nz = dime(3)
            read (string,*,err=10,end=10)  nx, ny, nz
   10       continue
            if (nx .ge. 33)  dime(1) = nx
            if (ny .ge. 33)  dime(2) = ny
            if (nz .ge. 33)  dime(3) = nz
         else if (keyword(1:11) .eq. 'APBS-RADII ') then
            call getword (record,value,next)
            call upcase (value)
            if (value(1:3) .eq. 'VDW') then
               radtyp = 'VDW'
            else if (value(1:10) .eq. 'MACROMODEL') then
               radtyp = 'MACROMODEL'
            else if (value(1:5) .eq. 'BONDI') then
               radtyp = 'BONDI'
            else if (value(1:6) .eq. 'TOMASI') then
               radtyp = 'TOMASI'
            else if (value(1:6) .eq. 'SOLUTE') then
               radtyp = 'SOLUTE'
            end if
         else if (keyword(1:11) .eq. 'APBS-SDENS ') then
            read (string,*,err=20,end=20)  sdens
   20       continue
         else if (keyword(1:10) .eq. 'APBS-PDIE ') then
            read (string,*,err=30,end=30)  pdie
   30       continue
         else if (keyword(1:10) .eq. 'APBS-SDIE ') then
            read (string,*,err=40,end=40)  sdie
   40       continue
         else if (keyword(1:10) .eq. 'APBS-SRAD ') then
            read (string,*,err=50,end=50)  srad
   50       continue
         else if (keyword(1:10) .eq. 'APBS-SWIN ') then
            read (string,*,err=60,end=60)  swin
   60       continue
         else if (keyword(1:10) .eq. 'APBS-SMIN ') then
            read (string,*,err=70,end=70)  smin
   70       continue
         else if (keyword(1:7) .eq. 'PBTYPE ') then
            call getword (record,value,next)
            call upcase (value)
            if (value(1:4) .eq. 'LPBE') then
               pbtyp = 'LPBE'
            else if (value(1:4) .eq. 'NPBE') then
               pbtyp = 'NPBE'
            end if
         else if (keyword(1:10) .eq. 'APBS-CHGM ') then
            call getword (record,value,next)
            call upcase (value)
            if (value(1:4) .eq. 'SPL0') then
               chgm = 'SPL0'
            else if (value(1:4) .eq. 'SPL2') then
               chgm = 'SPL2'
            else if (value(1:4) .eq. 'SPL4') then
               chgm = 'SPL4'
            end if
         else if (keyword(1:10) .eq. 'APBS-SRFM ') then
            call getword (record,value,next)
            call upcase (value)
            if (value(1:3) .eq. 'MOL') then
               srfm = 'MOL'
            else if (value(1:4) .eq. 'SMOL') then
               srfm = 'SMOL'
            else if (value(1:4) .eq. 'SPL2') then
               srfm = 'SPL2'
            else if (value(1:4) .eq. 'SPL4') then
               srfm = 'SPL4'
            end if
         else if (keyword(1:10) .eq. 'APBS-BCFL ') then
            call getword (record,value,next)
            call upcase (value)
            if (value(1:3) .eq. 'ZERO') then
               bcfl = 'ZERO'
            else if (value(1:3) .eq. 'MDH') then
               bcfl = 'MDH'
            else if (value(1:3) .eq. 'SDH') then
               bcfl = 'SDH'
            end if
         else if (keyword(1:9) .eq. 'APBS-ION ') then
            pbionc = 0.0d0
            pbionq = 1
            pbionr = 2.0d0
            read (string,*,err=80,end=80)  pbionq,pbionc,pbionr
   80       continue
            if (pbionq.ne.0 .and. pbionc.ge.0.0d0
     &             .and. pbionr.ge.0.0d0) then
               ionn = ionn + 1
               ionc(ionn) = pbionc
               ionq(ionn) = pbionq
               ionr(ionn) = pbionr
            end if
         end if
      end do
c
c     set APBS grid spacing for the chosen grid dimension
c
      xlen = 2.0d0 * (max(xcm-xmin,xmax-xcm)+smin)
      ylen = 2.0d0 * (max(ycm-ymin,ymax-ycm)+smin)
      zlen = 2.0d0 * (max(zcm-zmin,zmax-zcm)+smin)
      grid(1) = xlen / dime(1)
      grid(2) = ylen / dime(2)
      grid(3) = zlen / dime(3)
c
c     grid spacing must be equal to maintain traceless quadrupoles
c
      grid(1) = min(grid(1),grid(2),grid(3))
      grid(2) = grid(1)
      grid(3) = grid(1)
c
c     set the grid dimensions to the smallest multiples of 32
c
      dime(1) = 33
      dime(2) = 33
      dime(3) = 33
c
c     use minimum side length to maintain equal grid spacing
c
      minlen = min(xlen,ylen,zlen)
      do while (grid(1)*dime(1) .lt. minlen)
         dime(1) = dime(1) + 32
      end do
      do while (grid(2)*dime(2) .lt. minlen)
         dime(2) = dime(2) + 32
      end do
      do while (grid(3)*dime(3) .lt. minlen)
         dime(3) = dime(3) + 32
      end do
c
c     limit the grid dimensions and recompute the grid spacing
c
      dime(1) = min(dime(1),maxgrd)
      dime(2) = min(dime(2),maxgrd)
      dime(3) = min(dime(3),maxgrd)
      grid(1) = xlen / dime(1)
      grid(2) = ylen / dime(2)
      grid(3) = zlen / dime(3)
c
c     grid spacing must be equal to maintain traceless quadrupoles
c
      grid(1) = max(grid(1),grid(2),grid(3))
      grid(2) = grid(1)
      grid(3) = grid(1)
c
c     if this is an "mg-auto" (focusing) calculation, set the
c     fine grid to the default size, and the coarse grid to
c     twice its original size; currently, all energies and
c     forces need to be evaluated at the same resolution
c
      if (pbsoln .eq. 'MG-AUTO') then
         fgrid(1) = grid(1)
         fgrid(2) = grid(2)
         fgrid(3) = grid(3)
         fgcent(1) = gcent(1)
         fgcent(2) = gcent(2)
         fgcent(3) = gcent(3)
         cgrid(1) = 2.0d0 * grid(1)
         cgrid(2) = 2.0d0 * grid(2)
         cgrid(3) = 2.0d0 * grid(3)
      end if
c
c     get any custom APBS grid parameters from the keyfile
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:10) .eq. 'APBS-DIME ') then
            read (string,*,err=90,end=90)  nx,ny,nz
            dime(1) = nx
            dime(2) = ny
            dime(3) = nz
   90       continue
            do j = 1, 3
               if (mod(dime(j),32) .ne. 1) then
                  dime(j) = 32*(1+(dime(j)-1)/32) + 1
               end if
            end do
         else if (keyword(1:11) .eq. 'APBS-AGRID ') then
            read (string,*,err=100,end=100)  gx,gy,gz
            grid(1) = gx
            grid(2) = gy
            grid(3) = gz
  100       continue
         else if (keyword(1:11) .eq. 'APBS-CGRID ') then
            read (string,*,err=110,end=110)  gx,gy,gz
            cgrid(1) = gx
            cgrid(2) = gy
            cgrid(3) = gz
  110       continue
         else if (keyword(1:11) .eq. 'APBS-FGRID ') then
            read (string,*,err=120,end=120)  gx,gy,gz
            fgrid(1) = gx
            fgrid(2) = gy
            fgrid(3) = gz
  120       continue
         else if (keyword(1:11) .eq. 'APBS-GCENT ') then
            read (string,*,err=130,end=130)  gx,gy,gz
            gcent(1) = gx
            gcent(2) = gy
            gcent(3) = gz
  130       continue
         else if (keyword(1:12) .eq. 'APBS-CGCENT ') then
            read (string,*,err=140,end=140)  gx,gy,gz
            cgcent(1) = gx
            cgcent(2) = gy
            cgcent(3) = gz
  140       continue
         else if (keyword(1:12) .eq. 'APBS-FGCENT ') then
            read (string,*,err=150,end=150)  gx,gy,gz
            fgcent(1) = gx
            fgcent(2) = gy
            fgcent(3) = gz
  150       continue
         end if
      end do
c
c     determine the solute atomic radii values to be used
c
      call setrad (radtyp)
c
c     assign generic value for the HCT overlap scale factor
c
      do i = 1, n
         shct(i) = 0.69d0
      end do
c
c     determine the length of the character arguments
c
      pbtyplen = trimtext (pbtyp)
      pbsolnlen = trimtext (pbsoln)
      bcfllen = trimtext (bcfl)
      chgmlen = trimtext (chgm)
      srfmlen = trimtext (srfm)
c
c     make call needed to initialize the APBS calculation
c
      call apbsinitial (dime,grid,gcent,cgrid,cgcent,fgrid,fgcent,
     &                  pdie,sdie,srad,swin,sdens,kelvin,ionn,ionc,
     &                  ionq,ionr,pbtyp,pbtyplen,pbsoln,pbsolnlen,
     &                  bcfl,bcfllen,chgm,chgmlen,srfm,srfmlen)
c
c     print out the APBS grid dimensions and spacing
c
      if (verbose) then
         write (iout,160)  (dime(i),i=1,3),grid(1)
  160    format (/,' APBS Grid Dimensions and Spacing :',
     &           //,10x,3i8,10x,f10.4)
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine ksurf  --  find any AlphaMol control values  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "ksurf" reads control values used within the AlphaMol code
c     for determination of molecular surface area and volume
c
c
      subroutine ksurf
      use alfmol
      use keys
      implicit none
      integer i,next
      character*6 word
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     choose algorithms and tolerances for use with AlphaMol
c
      alfmethod = 'SINGLE'
      alfsort = 'NONE'
      alfthread = 1
      alfsosgmp = .false.
      alfhydro = .true.
      delcxeps = 1.0d-10
c
c     get any control parameter values from the keyfile
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:11) .eq. 'ALF-METHOD ') then
            call gettext (record,word,next)
            call upcase (word)
            if (word .eq. 'MULTI ')  alfmethod = 'MULTI'
            if (alfmethod .eq. 'MULTI') then
               string = record(next:240)
               read (string,*,err=10,end=10)  alfthread
            end if
         else if (keyword(1:9) .eq. 'ALF-SORT ') then
            call gettext (record,word,next)
            call upcase (word)
            if (word .eq. 'SORT3D')  alfsort = 'SORT3D'
            if (word .eq. 'BRIO  ')  alfsort = 'BRIO'
            if (word .eq. 'SPLIT ')  alfsort = 'SPLIT'
            if (word .eq. 'KDTREE')  alfsort = 'KDTREE'
         else if (keyword(1:11) .eq. 'ALF-SOSGMP ') then
            alfsosgmp = .true.
         else if (keyword(1:12) .eq. 'ALF-NOHYDRO ') then
            alfhydro = .false.
         else if (keyword(1:10) .eq. 'DELCX-EPS ') then
            read (string,*,err=10,end=10)  delcxeps
         end if
   10    continue
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine knp  --  assign cavity-dispersion parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "knp" initializes parameters needed for the cavity-plus-
c     dispersion nonpolar implicit solvation model
c
c
      subroutine knp
      use sizes
      use atomid
      use atoms
      use couple
      use keys
      use kvdws
      use math
      use nonpol
      use potent
      use solpot
      use solute
      use vdwpot
      implicit none
      integer i,next
      real*8 cross,ah,ao
      real*8 rmini,epsi
      real*8 rmixh,rmixh3
      real*8 rmixh7,emixh
      real*8 rmixo,rmixo3
      real*8 rmixo7,emixo
      real*8 ri,ri3,ri7,ri11
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set probe radius, solvent pressure and surface tension
c
      cavprb = 1.4d0
      solvprs = 0.0334d0
      surften = 0.103d0
c
c     get any altered parameter values from the keyfile
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:13) .eq. 'CAVITY-PROBE ') then
            read (string,*,err=10,end=10)  cavprb
         else if (keyword(1:17) .eq. 'SOLVENT-PRESSURE ') then
            read (string,*,err=10,end=10)  solvprs
         else if (keyword(1:16) .eq. 'SURFACE-TENSION ') then
            read (string,*,err=10,end=10)  surften
         end if
   10    continue
      end do
c
c     set switching function values for pressure and tension
c     cross = 9.251 = 3.0 * 0.103 / 0.0334
c
      cross = 3.0d0 * surften / solvprs
      spcut = cross - 3.5d0
      spoff = cross + 3.5d0
c
c     The SASA term is switched on 0.2 Angtroms after 
c     the cross-over point to give a smooth transition
c
      stcut = cross + 3.5d0 + 0.2d0
      stoff = cross - 3.5d0 + 0.2d0
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(asolv))  deallocate (asolv)
      if (allocated(radcav))  deallocate (radcav)
      if (allocated(raddsp))  deallocate (raddsp)
      if (allocated(epsdsp))  deallocate (epsdsp)
      if (allocated(cdsp))  deallocate (cdsp)
      allocate (asolv(n))
      allocate (radcav(n))
      allocate (raddsp(n))
      allocate (epsdsp(n))
      allocate (cdsp(n))
c
c     assign surface area factors for nonpolar solvation
c
      do i = 1, n
         asolv(i) = surften
      end do
c
c     set cavity and dispersion radii for nonpolar solvation
c
      do i = 1, n
         if (vdwindex .eq. 'CLASS') then
            radcav(i) = rad(class(i))
            raddsp(i) = rad(class(i))
            epsdsp(i) = eps(class(i))
         else
            radcav(i) = rad(type(i))
            raddsp(i) = rad(type(i))
            epsdsp(i) = eps(type(i))
         end if
         if (solvtyp .ne. 'PB')  radcav(i) = radcav(i) + cavprb
      end do
c
c     compute maximum dispersion energies for each atom
c
      do i = 1, n
         epsi = epsdsp(i)
         rmini = raddsp(i)
         if (rmini.gt.0.0d0 .and. epsi.gt.0.0d0) then
            emixo = 4.0d0 * epso * epsi / ((sqrt(epso)+sqrt(epsi))**2)
            rmixo = 2.0d0 * (rmino**3+rmini**3) / (rmino**2+rmini**2)
            rmixo3 = rmixo**3
            rmixo7 = rmixo**7
            ao = emixo * rmixo7
            emixh = 4.0d0 * epsh * epsi / ((sqrt(epsh)+sqrt(epsi))**2)
            rmixh = 2.0d0 * (rminh**3+rmini**3) / (rminh**2+rmini**2)
            rmixh3 = rmixh**3
            rmixh7 = rmixh**7
            ah = emixh * rmixh7
            ri = 0.5d0*rmixh + dspoff
            ri3 = ri**3
            ri7 = ri**7
            ri11 = ri**11
            if (ri .lt. rmixh) then
               cdsp(i) = -4.0d0*pi*emixh*(rmixh3-ri3)/3.0d0
               cdsp(i) = cdsp(i) - emixh*18.0d0/11.0d0*rmixh3*pi
            else
               cdsp(i) = 2.0d0*pi*(2.0d0*rmixh7-11.0d0*ri7)*ah
               cdsp(i) = cdsp(i) / (11.0d0*ri11)
            end if
            cdsp(i) = 2.0d0 * cdsp(i)
            ri = 0.5d0*rmixo + dspoff
            ri3 = ri**3
            ri7 = ri**7
            ri11 = ri**11
            if (ri .lt. rmixo) then
               cdsp(i) = cdsp(i) - 4.0d0*pi*emixo*(rmixo3-ri3)/3.0d0
               cdsp(i) = cdsp(i) - emixo*18.0d0/11.0d0*rmixo3*pi
            else
               cdsp(i) = cdsp(i) + 2.0d0*pi*(2.0d0*rmixo7-11.0d0*ri7)
     &                                  * ao/(11.0d0*ri11)
            end if
         end if
         cdsp(i) = slevy * awater * cdsp(i)
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine khpmf  --  assign hydrophobic PMF parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "khpmf" initializes parameters needed for the hydrophobic
c     potential of mean force nonpolar implicit solvation model
c
c     literature reference:
c
c     M. S. Lin, N. L. Fawzi and T. Head-Gordon, "Hydrophobic
c     Potential of Mean Force as a Solvation Function for Protein
c     Structure Prediction", Structure, 15, 727-740 (2007)
c
c
      subroutine khpmf
      use sizes
      use atomid
      use atoms
      use couple
      use hpmf
      use ptable
      implicit none
      integer i,j,k
      integer nh,atn
      logical keep
c
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(ipmf))  deallocate (ipmf)
      if (allocated(rpmf))  deallocate (rpmf)
      if (allocated(acsa))  deallocate (acsa)
      allocate (ipmf(n))
      allocate (rpmf(n))
      allocate (acsa(n))
c
c     get carbons for PMF and set surface area screening values
c
      npmf = 0
      do i = 1, n
         if (atomic(i) .eq. 6) then
            keep = .true.
            nh = 0
            if (n12(i) .le. 2)  keep = .false.
            do j = 1, n12(i)
               k = i12(j,i)
               if (atomic(k) .eq. 1)  nh = nh + 1
               if (n12(i).eq.3 .and. atomic(k).eq.8)  keep = .false.
            end do
            if (keep) then
               npmf = npmf + 1
               ipmf(npmf) = i
               acsa(i) = 1.0d0
               if (n12(i).eq.3 .and. nh.eq.0)  acsa(i) = 1.554d0
               if (n12(i).eq.3 .and. nh.eq.1)  acsa(i) = 1.073d0
               if (n12(i).eq.4 .and. nh.eq.1)  acsa(i) = 1.276d0
               if (n12(i).eq.4 .and. nh.eq.2)  acsa(i) = 1.045d0
               if (n12(i).eq.4 .and. nh.eq.3)  acsa(i) = 0.880d0
               acsa(i) = acsa(i) * safact/acsurf
            end if
         end if
      end do
c
c     assign HPMF atomic radii from consensus vdw values
c
      do i = 1, n
         rpmf(i) = 1.0d0
         atn = atomic(i)
         if (atn .eq. 0) then
            rpmf(i) = 0.00d0
         else
            rpmf(i) = vdwrad(atn)
         end if
         if (atn .eq. 5)  rpmf(i) = 1.80d0
         if (atn .eq. 8)  rpmf(i) = 1.50d0
         if (atn .eq. 35)  rpmf(i) = 1.85d0
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine setrad  --  assign solute radii for PB and GK  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "setrad" chooses a set of solute atom atomic radii to use
c     during Generalized Kirkwood and Poission-Boltzmann implicit
c     solvation calculations
c
c
      subroutine setrad (radtyp)
      use sizes
      use atomid
      use atoms
      use bath
      use couple
      use inform
      use iounit
      use keys
      use ksolut
      use kvdws
      use math
      use nonpol
      use polar
      use potent
      use ptable
      use vdw
      use solpot
      use solute
      implicit none
      integer i,j,k,l,m
      integer it
      integer atmnum
      integer nheavy
      real*8 rscale
      real*8 offset
      character*10 radtyp
c
c
c     assign default solute radii from consensus vdw values
c
      do i = 1, n
         atmnum = atomic(i)
         if (atmnum .eq. 0)  rsolv(i) = 0.0d0
         rsolv(i) = vdwrad(atmnum)
      end do
c
c     assign solute atomic radii from force field vdw values
c
      if (radtyp .eq. 'VDW') then
         do i = 1, n
            k = jvdw(i)
            rsolv(i) = 2.0d0
            if (k .ne. 0) then
               rsolv(i) = 0.5d0 * radmin(k,k)
            end if
         end do
c
c     assign solute radii from parametrized solvation values
c
      else if (radtyp .eq. 'SOLUTE') then
         if (solvtyp(1:2) .eq. 'GK') then     
            do i = 1, n
               it = type(i)
               if (it .ne. 0) then
                  if (gkr(it) .ne. 0.0d0) then
                     rsolv(i) = gkr(type(i))
                  end if
               end if
            end do
         else if (solvtyp(1:2) .eq. 'PB') then
            do i = 1, n
               it = type(i)
               if (it .ne. 0) then
                  if (pbr(it) .ne. 0.0d0) then
                     rsolv(i) = pbr(type(i))
                  end if
               end if
            end do
         end if
c
c     set and store neck correction ranges and parameters
c
         call initneck
c
c     get neck correction via a bonded connectivity scheme
c
         if (useneck) then
            do i = 1, n
               it = type(i)
               atmnum = atomic(i)
               if (atmnum .gt. 1) then
                  nheavy = 0
                  do j = 1, n12(i)
                     if (atomic(i12(j,i)) .gt. 1) then
                        nheavy = nheavy + 1
                     end if
                  end do
                  if (nheavy .eq. 0) then
                     sneck(i) = 1.0
                  else
                     sneck(i) = snk(it) * (5.0d0-nheavy)/4.0d0
                  end if
               end if
            end do
c
c     hydrogen neck contribution same as bound heavy atom
c
            do i = 1, n
               do k = 1, n12(i)
                  if (atomic(i12(k,i)) .eq. 1) then
                     sneck(i12(k,i)) = sneck(i)
                  end if
               end do
            end do
         end if
c
c     assign solute atomic radii adapted from Macromodel
c
      else if (radtyp .eq. 'MACROMODEL') then
         do i = 1, n
            atmnum = atomic(i)
            if (atmnum .eq. 0)  rsolv(i) = 0.0d0
            rsolv(i) = vdwrad(atmnum)
            if (atmnum .eq. 1) then
               rsolv(i) = 1.25d0
               k = i12(1,i)
               if (atomic(k) .eq. 7)  rsolv(i) = 1.15d0
               if (atomic(k) .eq. 8)  rsolv(i) = 1.05d0
            else if (atmnum .eq. 3) then
               rsolv(i) = 1.432d0
            else if (atmnum .eq. 6) then
               rsolv(i) = 1.90d0
               if (n12(i) .eq. 3)  rsolv(i) = 1.875d0
               if (n12(i) .eq. 2)  rsolv(i) = 1.825d0
            else if (atmnum .eq. 7) then
               rsolv(i) = 1.7063d0
               if (n12(i) .eq. 4)  rsolv(i) = 1.625d0
               if (n12(i) .eq. 1)  rsolv(i) = 1.60d0
            else if (atmnum .eq. 8) then
               rsolv(i) = 1.535d0
               if (n12(i) .eq. 1)  rsolv(i) = 1.48d0
            else if (atmnum .eq. 9) then
               rsolv(i) = 1.47d0
            else if (atmnum .eq. 10) then
               rsolv(i) = 1.39d0
            else if (atmnum .eq. 11) then
               rsolv(i) = 1.992d0
            else if (atmnum .eq. 12) then
               rsolv(i) = 1.70d0
            else if (atmnum .eq. 14) then
               rsolv(i) = 1.80d0
            else if (atmnum .eq. 15) then
               rsolv(i) = 1.87d0
            else if (atmnum .eq. 16) then
               rsolv(i) = 1.775d0
            else if (atmnum .eq. 17) then
               rsolv(i) = 1.735d0
            else if (atmnum .eq. 18) then
               rsolv(i) = 1.70d0
            else if (atmnum .eq. 19) then
               rsolv(i) = 2.123d0
            else if (atmnum .eq. 20) then
               rsolv(i) = 1.817d0
            else if (atmnum .eq. 35) then
               rsolv(i) = 1.90d0
            else if (atmnum .eq. 36) then
               rsolv(i) = 1.812d0
            else if (atmnum .eq. 37) then
               rsolv(i) = 2.26d0
            else if (atmnum .eq. 53) then
               rsolv(i) = 2.10d0
            else if (atmnum .eq. 54) then
               rsolv(i) = 1.967d0
            else if (atmnum .eq. 55) then
               rsolv(i) = 2.507d0
            else if (atmnum .eq. 56) then
               rsolv(i) = 2.188d0
            end if
         end do
c
c     assign solute atomic radii as modified Bondi values
c
      else if (radtyp .eq. 'AMOEBA') then
         do i = 1, n
            atmnum = atomic(i)
            if (atmnum .eq. 0)  rsolv(i) = 0.0d0
            rsolv(i) = vdwrad(atmnum)
            if (atmnum .eq. 1) then
               rsolv(i) = 1.32d0
               k = i12(1,i)
               if (atomic(k) .eq. 7)  rsolv(i) = 1.10d0
               if (atomic(k) .eq. 8)  rsolv(i) = 1.05d0
            end if
            if (atmnum .eq. 3)  rsolv(i) = 1.50d0
            if (atmnum .eq. 6) then
               rsolv(i) = 2.00d0
               if (n12(i) .eq. 3)  rsolv(i) = 2.05d0
               if (n12(i) .eq. 4) then
                  do j = 1, n12(i)
                     k = i12(j,i)
                     if (atomic(k) .eq. 7)  rsolv(i) = 1.75d0
                     if (atomic(k) .eq. 8)  rsolv(i) = 1.75d0
                  end do
               end if
            end if
            if (atmnum .eq. 7) then
               rsolv(i) = 1.60d0
            end if
            if (atmnum .eq. 8) then
               rsolv(i) = 1.55d0
               if (n12(i) .eq. 2)  rsolv(i) = 1.45d0
            end if
         end do
c
c     make Tomasi-style modifications to the solute radii values
c
      else if (radtyp .eq. 'TOMASI') then
         do i = 1, n
            offset = 0.0d0
            atmnum = atomic(i)
            if (atomic(i) .eq. 1) then
               do j = 1, n12(i)
                  k = i12(j,i)
                  if (atomic(k) .eq. 6) then
                     do l = 1, n12(k)
                        m = i12(l,k)
                        if (atomic(m) .eq. 7)  offset = -0.05d0
                        if (atomic(m) .eq. 8)  offset = -0.10d0
                     end do
                  end if
                  if (atomic(k) .eq. 7)  offset = -0.25d0
                  if (atomic(k) .eq. 8)  offset = -0.40d0
                  if (atomic(k) .eq. 16)  offset = -0.10d0
               end do
            else if (atomic(i) .eq. 6) then
               if (n12(i) .eq. 4)  offset = 0.05d0
               if (n12(i) .eq. 3)  offset = 0.02d0
               if (n12(i) .eq. 2)  offset = -0.03d0
               do j = 1, n12(i)
                  k = i12(j,i)
                  if (atomic(k) .eq. 6)  offset = offset - 0.07d0
               end do
               do j = 1, n12(i)
                  k = i12(j,i)
                  if (atomic(k).eq.7 .and. n12(k).eq.4)
     &               offset = -0.20d0
                  if (atomic(k).eq.7 .and. n12(k).eq.3)
     &               offset = -0.25d0
                  if (atomic(k) .eq. 8)  offset = -0.20d0
               end do
            else if (atomic(i) .eq. 7) then
               if (n12(i) .eq. 3) then
                  offset = -0.10d0
                  do j = 1, n12(i)
                     k = i12(j,i)
                     if (atomic(k) .eq. 6)  offset = offset - 0.24d0
                  end do
               else
                  offset = -0.20d0
                  do j = 1, n12(i)
                     k = i12(j,i)
                     if (atomic(k) .eq. 6)  offset = offset - 0.16d0
                  end do
               end if
            else if (atomic(i) .eq. 8) then
               if (n12(i) .eq. 2) then
                  offset = -0.21d0
                  do j = 1, n12(i)
                     k = i12(j,i)
                     if (atomic(k) .eq. 6)  offset = -0.36d0
                  end do
               else
                  offset = -0.25d0
               end if
            else if (atomic(i) .eq. 16) then
               offset = -0.03d0
               do j = 1, n12(i)
                  k = i12(j,i)
                  if (atomic(k) .eq. 6)  offset = offset - 0.10d0
               end do
            end if
            rsolv(i) = rsolv(i) + offset
         end do
      end if
c
c     apply an overall scale factor to the solute atomic radii
c
      rscale = 1.0d0
      if (radtyp .eq. 'MACROMODEL')  rscale = 1.15d0
      if (radtyp .eq. 'BONDI')  rscale = 1.21d0
      if (radtyp .eq. 'TOMASI')  rscale = 1.47d0
      do i = 1, n
         rsolv(i) = rsolv(i) * rscale
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module kstbnd  --  stretch-bend forcefield parameters  ##
c     ##                                                         ##
c     #############################################################
c
c
c     maxnsb   maximum number of stretch-bend parameter entries
c
c     stbn     force constant parameters for stretch-bend terms
c     ksb      string of atom classes for stretch-bend terms
c
c
      module kstbnd
      implicit none
      integer maxnsb
      real*8, allocatable :: stbn(:,:)
      character*12, allocatable :: ksb(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine kstrbnd  --  assign stretch-bend parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "kstrbnd" assigns parameters for stretch-bend interactions
c     and processes new or changed parameter values
c
c
      subroutine kstrbnd
      use angbnd
      use angpot
      use atmlst
      use atomid
      use atoms
      use couple
      use fields
      use inform
      use iounit
      use keys
      use kstbnd
      use potent
      use strbnd
      implicit none
      integer i,j,k,nsb
      integer ia,ib,ic
      integer ita,itb,itc
      integer nba,nbc
      integer size,next
      real*8 sb1,sb2,temp
      logical header
      character*4 pa,pb,pc
      character*12 blank,pt
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing stretch-bend parameters
c
      blank = '            '
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'STRBND ') then
            ia = 0
            ib = 0
            ic = 0
            sb1 = 0.0d0
            sb2 = 0.0d0
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,ic,sb1,sb2
   10       continue
            if (min(ia,ib,ic) .lt. 0)  goto 50
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Stretch-Bend Parameters :',
     &                    //,5x,'Atom Classes',10x,'K(SB)-1',8x,
     &                       'K(SB)-2',/)
               end if
               write (iout,30)  ia,ib,ic,sb1,sb2
   30          format (4x,3i4,3x,2f15.3)
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            if (ia .le. ic) then
               pt = pa//pb//pc
            else
               pt = pc//pb//pa
               temp = sb1
               sb1 = sb2
               sb2 = temp
            end if
            do j = 1, maxnsb
               if (ksb(j).eq.blank .or. ksb(j).eq.pt) then
                  ksb(j) = pt
                  stbn(1,j) = sb1
                  stbn(2,j) = sb2
                  goto 50
               end if
            end do
            write (iout,40)
   40       format (/,' KSTRBND  --  Too many Stretch-Bend',
     &                 ' Interaction Parameters')
            abort = .true.
   50       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      nsb = maxnsb
      do i = maxnsb, 1, -1
         if (ksb(i) .eq. blank)  nsb = i - 1
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(isb))  deallocate (isb)
      if (allocated(sbk))  deallocate (sbk)
      allocate (isb(3,nangle))
      allocate (sbk(2,nangle))
c
c     use special stretch-bend parameter assignment method for MMFF
c
      if (forcefield .eq. 'MMFF94') then
         call kstrbndm
         return
      end if
c
c     assign the stretch-bend parameters for each angle
c
      nstrbnd = 0
      if (nsb .ne. 0) then
         do i = 1, nangle
            ia = iang(1,i)
            ib = iang(2,i)
            ic = iang(3,i)
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            size = 4
            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
            do j = 1, nsb
               if (ksb(j) .eq. pt) then
                  nstrbnd = nstrbnd + 1
                  do k = 1, n12(ib)
                     if (i12(k,ib) .eq. ia)  nba = bndlist(k,ib)
                     if (i12(k,ib) .eq. ic)  nbc = bndlist(k,ib)
                  end do
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nba
                  isb(3,nstrbnd) = nbc
                  if (ita .le. itc) then
                     sbk(1,nstrbnd) = stbn(1,j)
                     sbk(2,nstrbnd) = stbn(2,j)
                  else
                     sbk(1,nstrbnd) = stbn(2,j)
                     sbk(2,nstrbnd) = stbn(1,j)
                  end if
                  goto 60
               end if
            end do
   60       continue
         end do
      end if
c
c     process keywords containing stretch-bend specific parameters
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. 'STRBND ') then
            ia = 0
            ib = 0
            ic = 0
            sb1 = 0.0d0
            sb2 = 0.0d0
            string = record(next:240)
            read (string,*,err=70,end=70)  ia,ib,ic,sb1,sb2
   70       continue
            if (min(ia,ib,ic) .lt. 0) then
               ia = abs(ia)
               ib = abs(ib)
               ic = abs(ic)
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,80)
   80             format (/,' Additional Stretch-Bend Parameters :',
     &                       ' for Specific Angles :',
     &                    //,8x,'Atoms',14x,'K(SB)-1',8x,'K(SB)-2',/)
               end if
               if (.not. silent) then
                  write (iout,90)  ia,ib,ic,sb1,sb2
   90             format (4x,3i4,3x,2f15.3)
               end if
               do j = 1, nstrbnd
                  k = isb(1,j)
                  ita = iang(1,k)
                  itb = iang(2,k)
                  itc = iang(3,k)
                  if (ib .eq. itb) then
                     if ((ia.eq.ita .and. ic.eq.itc) .or.
     &                   (ia.eq.itc .and. ic.eq.ita)) then
                        sbk(1,j) = sb1
                        sbk(2,j) = sb2
                        goto 100
                     end if
                  end if
               end do
            end if
  100       continue
         end if
      end do
c
c     turn off the stretch-bend potential if it is not used
c
      if (nstrbnd .eq. 0)  use_strbnd = .false.
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine kstrbndm  --  assign MMFF str-bnd parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "kstrbndm" assigns parameters for stretch-bend interactions
c     according to the Merck Molecular Force Field (MMFF)
c
c     note "stbnt" is the MMFF stretch-bend type for angle "a-b-c",
c     where atom "a" has a smaller class number than atom "c"
c
c     if the BT of a-b = 1, then stbnt = 1
c     if the BT of b-c = 1, then stbnt = 2
c     if both = 1, then stbnt = 3
c     if 4-membered ring, then stbnt = 4
c     if 3-membered ring, then stbnt = 5
c     if 3-membered ring with BT of a-b = 1, then stbnt = 6
c     if 3-membered ring with BT of b-c = 1, then stbnt = 7
c     if 3-membered ring with BT of both = 1, then stbnt = 8
c     if 4-membered ring with BT of a-b = 1, then stbnt = 9
c     if 4-membered ring with BT of b-c = 1, then stbnt = 10
c     if 4-membered ring with BT of both = 1, then stbnt = 11
c     else, if all BT = 0 and no small ring, then stbnt = 0
c
c     literature references:
c
c     T. A. Halgren, "Merck Molecular Force Field. I. Basis, Form,
c     Scope, Parametrization, and Performance of MMFF94", Journal of
c     Computational Chemistry, 17, 490-519 (1995)
c
c     T. A. Halgren, "Merck Molecular Force Field. V. Extension of
c     MMFF94 Using Experimental Data, Additional Computational Data,
c     and Empirical Rules", Journal of Computational Chemistry, 17,
c     616-641 (1995)
c
c
      subroutine kstrbndm
      use angbnd
      use atmlst
      use atomid
      use couple
      use merck
      use potent
      use ring
      use strbnd
      implicit none
      integer i,j,k,l,m
      integer ia,ib,ic
      integer ita,itb,itc
      integer ina,inb,inc
      integer ira,irb,irc
      integer nb1,nb2
      integer stbnt,ab,bc
      logical ring3,ring4
c
c
c     assign stretch-bend parameters for each angle
c
      nstrbnd = 0
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
c
c     stretch-bend interactions are omitted for linear angles
c
         if (lin(class(ib)) .eq. 0) then
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            ina = atomic(ia)
            inb = atomic(ib)
            inc = atomic(ic)
            sbk(1,nstrbnd+1) = 0.0d0
            sbk(2,nstrbnd+1) = 0.0d0
            do k = 1, n12(ib)
               if (i12(k,ib) .eq. ia)  nb1 = bndlist(k,ib)
               if (i12(k,ib) .eq. ic)  nb2 = bndlist(k,ib)
            end do
            stbnt = 0
            ab = 0
            bc = 0
c
c     check if the atoms belong to a single 3- or 4-membered ring
c
            ring3 = .false.
            ring4 = .false.
            do j = 1, nring3
               do k = 1, 3
                  if (ia .eq. iring3(k,j)) then
                     do l = 1, 3
                        if (ib .eq. iring3(l,j)) then
                           do m = 1, 3
                              if (ic .eq. iring3(m,j))
     &                           ring3 = .true.
                           end do
                        end if
                     end do
                  end if
               end do
            end do
            if (.not. ring3) then
               do j = 1, nring4
                  do k = 1, 4
                     if (ia .eq. iring4(k,j)) then
                        do l = 1, 4
                           if (ib .eq. iring4(l,j)) then
                              do m = 1, 4
                                 if (ic .eq. iring4(m,j))
     &                              ring4 = .true.
                              end do
                           end if
                        end do
                     end if
                  end do
               end do
            end if
c
c     determine the MMFF stretch-bend type for the current angle
c
            if (ita .lt. itc) then
               do j = 1, nligne
                  if (((ia.eq.bt_1(j,1).and.ib.eq.bt_1(j,2)) .or.
     &                 (ib.eq.bt_1(j,1).and.ia.eq.bt_1(j,2)))) then
                     ab = 1
                  end if
                  if (((ic.eq.bt_1(j,1).and.ib.eq.bt_1(j,2)) .or.
     &                 (ib.eq.bt_1(j,1).and.ic.eq.bt_1(j,2)))) then
                     bc = 1
                  end if
               end do
               if (ab.eq.1 .and. bc.eq.0)  stbnt = 1
               if (ab.eq.0 .and. bc.eq.1)  stbnt = 2
               if (ab.eq.1 .and. bc.eq.1)  stbnt = 3
               if (stbnt.eq.0 .AND. ring3) then
                  stbnt = 5
               else if (stbnt.eq.1 .and. ring3) then
                  stbnt = 6
               else if (stbnt.eq.2 .and. ring3) then
                  stbnt = 7
               else if (stbnt.eq.3 .and. ring3) then
                  stbnt = 8
               else if (stbnt.eq.0 .and. ring4) then
                  stbnt = 4
               else if (stbnt.eq.1 .and. ring4) then
                  stbnt = 9
               else if (stbnt.eq.2 .and. ring4) then
                  stbnt = 10
               else if (stbnt.eq.3 .and. ring4) then
                  stbnt = 11
               end if
            else if (ita .gt. itc) then
               do j = 1, nligne
                  if (((ia.eq.bt_1(j,1).and.ib.eq.bt_1(j,2)) .or.
     &                 (ib.eq.bt_1(j,1).and.ia.eq.bt_1(j,2)))) then
                     ab = 1
                  end if
                  if (((ic.eq.bt_1(j,1).and.ib.eq.bt_1(j,2)) .or.
     &                 (ib.eq.bt_1(j,1).and.ic.eq.bt_1(j,2)))) then
                     bc = 1
                  end if
               end do
               if (ab.eq.1 .and. bc.eq.0)  stbnt = 2
               if (ab.eq.0 .and. bc.eq.1)  stbnt = 1
               if (ab.eq.1 .and. bc.eq.1)  stbnt = 3
               if (stbnt.eq.0 .and. ring3) then
                  stbnt = 5
               else if (stbnt.eq.1 .and. ring3) then
                  stbnt = 6
               else if (stbnt.eq.2 .and. ring3) then
                  stbnt = 7
               else if (stbnt.eq.3 .and. ring3) then
                  stbnt = 8
               else if (stbnt.eq.0 .and. ring4) then
                  stbnt = 4
               else if (stbnt.eq.1 .and. ring4) then
                  stbnt = 9
               else if (stbnt.eq.2 .and. ring4) then
                  stbnt = 10
               else if (stbnt.eq.3 .and. ring4) then
                  stbnt = 11
               end if
            else if (ita .eq. itc) then
               do j = 1, nligne
                  if (((ic.eq.bt_1(j,1).and.ib.eq.bt_1(j,2)) .or.
     &                 (ib.eq.bt_1(j,1).and.ic.eq.bt_1(j,2)))) then
                     bc = 1
                  end if
                  if (((ia.eq.bt_1(j,1).and.ib.eq.bt_1(j,2)) .or.
     &                 (ib.eq.bt_1(j,1).and.ia.eq.bt_1(j,2)))) then
                     ab = 1
                  end if
               end do
               if (ab.eq.1 .and. bc.eq.0)  stbnt = 1
               if (ab.eq.0 .and. bc.eq.1)  stbnt = 2
               if (ab.eq.1 .and. bc.eq.1)  stbnt = 3
               if (stbnt.eq.0 .and. ring3) then
                  stbnt = 5
               else if (stbnt.eq.1 .and. ring3) then
                  stbnt = 6
               else if (stbnt.eq.2 .and. ring3) then
                  stbnt = 7
               else if (stbnt.eq.3 .and. ring3) then
                  stbnt = 8
               else if (stbnt.eq.0 .and. ring4) then
                  stbnt = 4
               else if (stbnt.eq.1 .and. ring4) then
                  stbnt = 9
               else if (stbnt.eq.2 .and. ring4) then
                  stbnt = 10
               else if (stbnt.eq.3 .and. ring4) then
                  stbnt = 11
               end if
            end if
c
c     find the periodic table row for the atoms in the angle
c
            if (ina .eq. 1)  ira = 0
            if (ina.ge.3 .and. ina.le.10)  ira = 1
            if (ina.ge.11 .and. ina.le.18)  ira = 2
            if (ina.ge.19 .and. ina.le.36)  ira = 3
            if (ina.ge.37 .and. ina.le.54)  ira = 4
            if (inb .eq. 1)  irb = 0
            if (inb.ge.3 .and. inb.le.10)  irb = 1
            if (inb.ge.11 .and. inb.le.18)  irb = 2
            if (inb.ge.19 .and. inb.le.36)  irb = 3
            if (inb.ge.37 .and. inb.le.54)  irb = 4
            if (inc .eq. 1)  irc = 0
            if (inc.ge.3 .and. inc.le.10)  irc = 1
            if (inc.ge.11 .and. inc.le.18)  irc = 2
            if (inc.ge.19 .and. inc.le.36)  irc = 3
            if (inc.ge.37 .and. inc.le.54)  irc = 4
c
c     assign parameters via explicit values or empirical rules
c
            if (stbnt .eq. 11) then
               if ((stbn_abc11(ita,itb,itc).ne.1000.0d0) .and.
     &             (stbn_cba11(ita,itb,itc).ne.1000.0d0)) then
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = stbn_abc11(ita,itb,itc)
                  sbk(2,nstrbnd) = stbn_cba11(ita,itb,itc)
               else
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc)
                  sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc)
               end if
            else if (stbnt .eq. 10) then
               if ((stbn_abc10(ita,itb,itc).ne.1000.0d0) .and.
     &             (stbn_cba10(ita,itb,itc).ne.1000.0d0)) then
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = stbn_abc10(ita,itb,itc)
                  sbk(2,nstrbnd) = stbn_cba10(ita,itb,itc)
               else
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc)
                  sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc)
               end if
            else if (stbnt .eq. 9) then
               if ((stbn_abc9(ita,itb,itc).ne.1000.0d0) .and.
     &             (stbn_cba9(ita,itb,itc).ne.1000.0d0)) then
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = stbn_abc9(ita,itb,itc)
                  sbk(2,nstrbnd) = stbn_cba9(ita,itb,itc)
               else
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc)
                  sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc)
               end if
            else if (stbnt .eq. 8) then
               if ((stbn_abc8(ita,itb,itc).ne.1000.0d0) .and.
     &             (stbn_cba3(ita,itb,itc).ne.1000.0d0)) then
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = stbn_abc8(ita,itb,itc)
                  sbk(2,nstrbnd) = stbn_cba8(ita,itb,itc)
               else
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc)
                  sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc)
               end if
            else if (stbnt .eq. 7) then
               if ((stbn_abc7(ita,itb,itc).ne.1000.0d0) .and.
     &             (stbn_cba7(ita,itb,itc).ne.1000.0d0)) then
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = stbn_abc7(ita,itb,itc)
                  sbk(2,nstrbnd) = stbn_cba7(ita,itb,itc)
               else
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc)
                  sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc)
               end if
            else if (stbnt .eq. 6) then
               if ((stbn_abc6(ita,itb,itc).ne.1000.0d0) .and.
     &             (stbn_cba3(ita,itb,itc).ne.1000.0d0)) then
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = stbn_abc6(ita,itb,itc)
                  sbk(2,nstrbnd) = stbn_cba6(ita,itb,itc)
               else
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc)
                  sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc)
               end if
            else if (stbnt .eq. 5) then
               if (((stbn_abc5(ita,itb,itc).ne.1000.0d0) .and.
     &              (stbn_cba3(ita,itb,itc).ne.1000.0d0))
     &            .or. (ita.eq.22.and.itb.eq.22.and.itc.eq.22)) then
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = stbn_abc5(ita,itb,itc)
                  sbk(2,nstrbnd) = stbn_cba5(ita,itb,itc)
               else
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc)
                  sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc)
               end if
            else if (stbnt .eq. 4) then
               if ((stbn_abc4(ita,itb,itc).ne.1000.0d0) .and.
     &             (stbn_cba4(ita,itb,itc).ne.1000.0d0)) then
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = stbn_abc4(ita,itb,itc)
                  sbk(2,nstrbnd) = stbn_cba4(ita,itb,itc)
               else
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc)
                  sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc)
               end if
            else if (stbnt .eq. 3) then
               if ((stbn_abc3(ita,itb,itc).ne.1000.0d0) .and.
     &             (stbn_cba3(ita,itb,itc).ne.1000.0d0)) then
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = stbn_abc3(ita,itb,itc)
                  sbk(2,nstrbnd) = stbn_cba3(ita,itb,itc)
               else
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc)
                  sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc)
               end if
            else if (stbnt .eq. 2) then
               if ((stbn_abc2(ita,itb,itc).ne.1000.0d0) .and.
     &            (stbn_cba2(ita,itb,itc).ne.1000.0d0)) then
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = stbn_abc2(ita,itb,itc)
                  sbk(2,nstrbnd) = stbn_cba2(ita,itb,itc)
               else
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc)
                  sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc)
               end if
            else if (stbnt .eq. 1) then
               if ((stbn_abc1(ita,itb,itc).ne.1000.0d0) .and.
     &             (stbn_cba1(ita,itb,itc).ne.1000.0d0)) then
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = stbn_abc1(ita,itb,itc)
                  sbk(2,nstrbnd) = stbn_cba1(ita,itb,itc)
               else
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc)
                  sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc)
               end if
            else if (stbnt .eq. 0) then
               if (((stbn_abc(ita,itb,itc) .ne. 1000.0d0) .and.
     &              (stbn_cba(ita,itb,itc) .ne. 1000.0d0))
     &            .or. (ita.eq.12.AND.itb.eq.20.AND.itc.eq.20)
     &            .or. (ita.eq.20.AND.itb.eq.20.AND.itc.eq.12)) then
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = stbn_abc(ita,itb,itc)
                  sbk(2,nstrbnd) = stbn_cba(ita,itb,itc)
               else
                  nstrbnd = nstrbnd + 1
                  isb(1,nstrbnd) = i
                  isb(2,nstrbnd) = nb1
                  isb(3,nstrbnd) = nb2
                  sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc)
                  sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc)
               end if
            end if
         end if
      end do
c
c     turn off the stretch-bend potential if it is not used
c
      if (nstrbnd .eq. 0)  use_strbnd = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine kstrtor  --  find stretch-torsion parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "kstrtor" assigns stretch-torsion parameters to torsions
c     needing them, and processes any new or changed values
c
c
      subroutine kstrtor
      use atmlst
      use atomid
      use atoms
      use couple
      use inform
      use iounit
      use keys
      use ksttor
      use potent
      use strtor
      use tors
      implicit none
      integer i,j,k,nbt
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer size,next
      real*8 bt1,bt2,bt3
      real*8 bt4,bt5,bt6
      real*8 bt7,bt8,bt9
      logical header,swap
      character*4 pa,pb,pc,pd
      character*4 zeros
      character*16 blank
      character*16 pt,pt0
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing stretch-torsion parameters
c
      blank = '                '
      zeros = '0000'
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:8) .eq. 'STRTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            bt1 = 0.0d0
            bt2 = 0.0d0
            bt3 = 0.0d0
            bt4 = 0.0d0
            bt5 = 0.0d0
            bt6 = 0.0d0
            bt7 = 0.0d0
            bt8 = 0.0d0
            bt9 = 0.0d0
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,ic,id,bt1,bt2,bt3,
     &                                     bt4,bt5,bt6,bt7,bt8,bt9
   10       continue
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            if (ib .lt. ic) then
               pt = pa//pb//pc//pd
               swap = .false.
            else if (ic .lt. ib) then
               pt = pd//pc//pb//pa
               swap = .true.
            else if (ia .le. id) then
               pt = pa//pb//pc//pd
               swap = .false.
            else if (id .lt. ia) then
               pt = pd//pc//pb//pa
               swap = .true.
            end if
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Stretch-Torsion Parameters :',
     &                    //,5x,'Atom Classes',10x,'Stretch',
     &                       9x,'1-Fold',6x,'2-Fold',6x,'3-Fold',/)
               end if
               write (iout,30)  ia,ib,ic,id,bt1,bt2,bt3,
     &                          bt4,bt5,bt6,bt7,bt8,bt9
   30          format (2x,4i4,8x,'1st Bond',3x,3f12.3,
     &                 /,26x,'2nd Bond',3x,3f12.3,
     &                 /,26x,'3rd Bond',3x,3f12.3)
            end if
            do j = 1, maxnbt
               if (kbt(j).eq.blank .or. kbt(j).eq.pt) then
                  kbt(j) = pt
                  btcon(4,j) = bt4
                  btcon(5,j) = bt5
                  btcon(6,j) = bt6
                  if (swap) then
                     btcon(1,j) = bt7
                     btcon(2,j) = bt8
                     btcon(3,j) = bt9
                     btcon(7,j) = bt1
                     btcon(8,j) = bt2
                     btcon(9,j) = bt3
                  else
                     btcon(1,j) = bt1
                     btcon(2,j) = bt2
                     btcon(3,j) = bt3
                     btcon(7,j) = bt7
                     btcon(8,j) = bt8
                     btcon(9,j) = bt9
                  end if
                  goto 50
               end if
            end do
            write (iout,40)
   40       format (/,' KSTRTOR  --  Too many Stretch-Torsion',
     &                 ' Parameters')
            abort = .true.
   50       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      nbt = maxnbt
      do i = maxnbt, 1, -1
         if (kbt(i) .eq. blank)  nbt = i - 1
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(ist))  deallocate (ist)
      if (allocated(kst))  deallocate (kst)
      allocate (ist(4,ntors))
      allocate (kst(9,ntors))
c
c     assign the stretch-torsion parameters for each torsion
c
      nstrtor = 0
      if (nbt .ne. 0) then
         do i = 1, ntors
            ia = itors(1,i)
            ib = itors(2,i)
            ic = itors(3,i)
            id = itors(4,i)
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            itd = class(id)
            size = 4
            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
               swap = .false.
            else if (itc .lt. itb) then
               pt = pd//pc//pb//pa
               swap = .true.
            else if (ita .le. itd) then
               pt = pa//pb//pc//pd
               swap = .false.
            else if (itd .lt. ita) then
               pt = pd//pc//pb//pa
               swap = .true.
            end if
            pt0 = zeros//pt(5:12)//zeros
            do j = 1, nbt
               if (kbt(j) .eq. pt) then
                  nstrtor = nstrtor + 1
                  kst(4,nstrtor) = btcon(4,j)
                  kst(5,nstrtor) = btcon(5,j)
                  kst(6,nstrtor) = btcon(6,j)
                  if (swap) then
                     kst(1,nstrtor) = btcon(7,j)
                     kst(2,nstrtor) = btcon(8,j)
                     kst(3,nstrtor) = btcon(9,j)
                     kst(7,nstrtor) = btcon(1,j)
                     kst(8,nstrtor) = btcon(2,j)
                     kst(9,nstrtor) = btcon(3,j)
                  else
                     kst(1,nstrtor) = btcon(1,j)
                     kst(2,nstrtor) = btcon(2,j)
                     kst(3,nstrtor) = btcon(3,j)
                     kst(7,nstrtor) = btcon(7,j)
                     kst(8,nstrtor) = btcon(8,j)
                     kst(9,nstrtor) = btcon(9,j)
                  end if
                  ist(1,nstrtor) = i
                  do k = 1, n12(ia)
                     if (i12(k,ia) .eq. ib) then
                        ist(2,nstrtor) = bndlist(k,ia)
                        goto 60
                     endif
                  end do
   60             continue
                  do k = 1, n12(ib)
                     if (i12(k,ib) .eq. ic) then
                        ist(3,nstrtor) = bndlist(k,ib)
                        goto 70
                     end if
                  end do
   70             continue
                  do k = 1, n12(ic)
                     if (i12(k,ic) .eq. id) then
                        ist(4,nstrtor) = bndlist(k,ic)
                        goto 100
                     end if
                  end do
               end if
            end do
            do j = 1, nbt
               if (kbt(j) .eq. pt0) then
                  nstrtor = nstrtor + 1
                  kst(4,nstrtor) = btcon(4,j)
                  kst(5,nstrtor) = btcon(5,j)
                  kst(6,nstrtor) = btcon(6,j)
                  if (swap) then
                     kst(1,nstrtor) = btcon(7,j)
                     kst(2,nstrtor) = btcon(8,j)
                     kst(3,nstrtor) = btcon(9,j)
                     kst(7,nstrtor) = btcon(1,j)
                     kst(8,nstrtor) = btcon(2,j)
                     kst(9,nstrtor) = btcon(3,j)
                  else
                     kst(1,nstrtor) = btcon(1,j)
                     kst(2,nstrtor) = btcon(2,j)
                     kst(3,nstrtor) = btcon(3,j)
                     kst(7,nstrtor) = btcon(7,j)
                     kst(8,nstrtor) = btcon(8,j)
                     kst(9,nstrtor) = btcon(9,j)
                  end if
                  ist(1,nstrtor) = i
                  do k = 1, n12(ia)
                     if (i12(k,ia) .eq. ib) then
                        ist(2,nstrtor) = bndlist(k,ia)
                        goto 80
                     endif
                  end do
   80             continue
                  do k = 1, n12(ib)
                     if (i12(k,ib) .eq. ic) then
                        ist(3,nstrtor) = bndlist(k,ib)
                        goto 90
                     end if
                  end do
   90             continue
                  do k = 1, n12(ic)
                     if (i12(k,ic) .eq. id) then
                        ist(4,nstrtor) = bndlist(k,ic)
                        goto 100
                     end if
                  end do
               end if
            end do
  100       continue
         end do
      end if
c
c     turn off the stretch-torsion potential if it is not used
c
      if (nstrtor .eq. 0)  use_strtor = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module ksttor  --  stretch-torsion forcefield parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     maxnbt   maximum number of stretch-torsion parameter entries
c
c     btcon    torsional amplitude parameters for stretch-torsion
c     kbt      string of atom classes for stretch-torsion terms
c
c
      module ksttor
      implicit none
      integer maxnbt
      real*8, allocatable :: btcon(:,:)
      character*16, allocatable :: kbt(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine ktors  --  torsional parameter assignment  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "ktors" assigns torsional parameters to each torsion in
c     the structure and processes any new or changed values
c
c
      subroutine ktors
      use atomid
      use atoms
      use couple
      use fields
      use inform
      use iounit
      use keys
      use ktorsn
      use math
      use potent
      use tors
      use usage
      implicit none
      integer i,j
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer nt,nt5,nt4
      integer size,next
      integer iring,minat
      integer nlist,ilist
      integer, allocatable :: kindex(:)
      integer ft(6)
      real*8 angle
      real*8 vt(6),st(6)
      logical header,done
      logical use_ring
      character*4 pa,pb,pc,pd
      character*4 zeros
      character*7 label
      character*16 blank
      character*16 pt,pt0
      character*16 pt1,pt2
      character*16, allocatable :: klist(:)
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing torsional angle parameters
c
      blank = '                '
      zeros = '0000'
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         iring = -1
         if (keyword(1:8) .eq. 'TORSION ')  iring = 0
         if (keyword(1:9) .eq. 'TORSION5 ')  iring = 5
         if (keyword(1:9) .eq. 'TORSION4 ')  iring = 4
         if (iring .ge. 0) then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do j = 1, 6
               vt(j) = 0.0d0
               st(j) = 0.0d0
               ft(j) = 0
            end do
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,ic,id,
     &                                     (vt(j),st(j),ft(j),j=1,6)
   10       continue
            if (min(ia,ib,ic,id) .lt. 0)  goto 110
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            if (ib .lt. ic) then
               pt = pa//pb//pc//pd
            else if (ic .lt. ib) then
               pt = pd//pc//pb//pa
            else if (ia .le. id) then
               pt = pa//pb//pc//pd
            else if (id .lt. ia) then
               pt = pd//pc//pb//pa
            end if
            call torphase (ft,vt,st)
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Torsional Parameters :',
     &                    //,5x,'Atom Classes',5x,'1-Fold',4x,'2-Fold',
     &                       4x,'3-Fold',4x,'4-Fold',4x,'5-Fold',
     &                       4x,'6-Fold',/)
               end if
               if (iring .eq. 0) then
                  write (iout,30)  ia,ib,ic,id,
     &                             (vt(j),nint(st(j)),j=1,6)
   30             format (2x,4i4,1x,6(f6.2,i4))
               else
                  if (iring .eq. 5)  label = '5-Ring '
                  if (iring .eq. 4)  label = '4-Ring '
                  write (iout,40)  ia,ib,ic,id,
     &                             (vt(j),nint(st(j)),j=1,6),label(1:6)
   40             format (2x,4i4,1x,6(f6.2,i4),3x,a6)
               end if
            end if
            if (iring .eq. 0) then
               do j = 1, maxnt
                  if (kt(j).eq.blank .or. kt(j).eq.pt) then
                     kt(j) = pt
                     t1(1,j) = vt(1)
                     t1(2,j) = st(1)
                     t2(1,j) = vt(2)
                     t2(2,j) = st(2)
                     t3(1,j) = vt(3)
                     t3(2,j) = st(3)
                     t4(1,j) = vt(4)
                     t4(2,j) = st(4)
                     t5(1,j) = vt(5)
                     t5(2,j) = st(5)
                     t6(1,j) = vt(6)
                     t6(2,j) = st(6)
                     goto 60
                  end if
               end do
               write (iout,50)
   50          format (/,' KTORS  --  Too many Torsional Angle',
     &                    ' Parameters')
               abort = .true.
   60          continue
            else if (iring .eq. 5) then
               do j = 1, maxnt5
                  if (kt5(j).eq.blank .or. kt5(j).eq.pt) then
                     kt5(j) = pt
                     t15(1,j) = vt(1)
                     t15(2,j) = st(1)
                     t25(1,j) = vt(2)
                     t25(2,j) = st(2)
                     t35(1,j) = vt(3)
                     t35(2,j) = st(3)
                     t45(1,j) = vt(4)
                     t45(2,j) = st(4)
                     t55(1,j) = vt(5)
                     t55(2,j) = st(5)
                     t65(1,j) = vt(6)
                     t65(2,j) = st(6)
                     goto 80
                  end if
               end do
               write (iout,70)
   70          format (/,' KTORS  --  Too many 5-Ring Torsional',
     &                    ' Parameters')
               abort = .true.
   80          continue
            else if (iring .eq. 4) then
               do j = 1, maxnt4
                  if (kt4(j).eq.blank .or. kt4(j).eq.pt) then
                     kt4(j) = pt
                     t14(1,j) = vt(1)
                     t14(2,j) = st(1)
                     t24(1,j) = vt(2)
                     t24(2,j) = st(2)
                     t34(1,j) = vt(3)
                     t34(2,j) = st(3)
                     t44(1,j) = vt(4)
                     t44(2,j) = st(4)
                     t54(1,j) = vt(5)
                     t54(2,j) = st(5)
                     t64(1,j) = vt(6)
                     t64(2,j) = st(6)
                     goto 100
                  end if
               end do
               write (iout,90)
   90          format (/,' KTORS  --  Too many 4-Ring Torsional',
     &                    ' Parameters')
               abort = .true.
  100          continue
            end if
  110       continue
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(tors1))  deallocate (tors1)
      if (allocated(tors2))  deallocate (tors2)
      if (allocated(tors3))  deallocate (tors3)
      if (allocated(tors4))  deallocate (tors4)
      if (allocated(tors5))  deallocate (tors5)
      if (allocated(tors6))  deallocate (tors6)
      allocate (tors1(4,ntors))
      allocate (tors2(4,ntors))
      allocate (tors3(4,ntors))
      allocate (tors4(4,ntors))
      allocate (tors5(4,ntors))
      allocate (tors6(4,ntors))
c
c     use special torsional parameter assignment method for MMFF
c
      if (forcefield .eq. 'MMFF94') then
         call ktorsm
         return
      end if
c
c     determine the total number of forcefield parameters
c
      nt = maxnt
      nt5 = maxnt5
      nt4 = maxnt4
      do i = maxnt, 1, -1
         if (kt(i) .eq. blank)  nt = i - 1
      end do
      do i = maxnt5, 1, -1
         if (kt5(i) .eq. blank)  nt5 = i - 1
      end do
      do i = maxnt4, 1, -1
         if (kt4(i) .eq. blank)  nt4 = i - 1
      end do
      use_ring = .false.
      if (min(nt5,nt4) .ne. 0)  use_ring = .true.
c
c     perform dynamic allocation of some local arrays
c
      allocate (kindex(maxnt))
      allocate (klist(maxnt))
c
c     assign torsional parameters for each torsional angle
c     by putting the parameter values into the "tors" arrays
c
      header = .true.
      nlist = 0
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         size = 4
         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
         pt2 = zeros//pt(5:16)
         pt1 = pt(1:12)//zeros
         pt0 = zeros//pt(5:12)//zeros
         tors1(1,i) = 0.0d0
         tors1(2,i) = 0.0d0
         tors2(1,i) = 0.0d0
         tors2(2,i) = 0.0d0
         tors3(1,i) = 0.0d0
         tors3(2,i) = 0.0d0
         tors4(1,i) = 0.0d0
         tors4(2,i) = 0.0d0
         tors5(1,i) = 0.0d0
         tors5(2,i) = 0.0d0
         tors6(1,i) = 0.0d0
         tors6(2,i) = 0.0d0
         done = .false.
c
c     make a check for torsions inside small rings
c
         iring = 0
         if (use_ring) then
            call chkring (iring,ia,ib,ic,id)
            if (iring .eq. 6)  iring = 0
            if (iring.eq.5 .and. nt5.eq.0)  iring = 0
            if (iring.eq.4 .and. nt4.eq.0)  iring = 0
         end if
c
c     find parameters for this torsion; first check "klist"
c     to save time for angle types already located
c
         if (iring .eq. 0) then
            do j = 1, nlist
               if (klist(j) .eq. pt) then
                  ilist = kindex(j)
                  tors1(1,i) = tors1(1,ilist)
                  tors1(2,i) = tors1(2,ilist)
                  tors2(1,i) = tors2(1,ilist)
                  tors2(2,i) = tors2(2,ilist)
                  tors3(1,i) = tors3(1,ilist)
                  tors3(2,i) = tors3(2,ilist)
                  tors4(1,i) = tors4(1,ilist)
                  tors4(2,i) = tors4(2,ilist)
                  tors5(1,i) = tors5(1,ilist)
                  tors5(2,i) = tors5(2,ilist)
                  tors6(1,i) = tors6(1,ilist)
                  tors6(2,i) = tors6(2,ilist)
                  done = .true.
                  goto 120
               end if
            end do
            do j = 1, nt
               if (kt(j) .eq. pt) then
                  nlist = nlist + 1
                  klist(nlist) = pt
                  kindex(nlist) = i
                  tors1(1,i) = t1(1,j)
                  tors1(2,i) = t1(2,j)
                  tors2(1,i) = t2(1,j)
                  tors2(2,i) = t2(2,j)
                  tors3(1,i) = t3(1,j)
                  tors3(2,i) = t3(2,j)
                  tors4(1,i) = t4(1,j)
                  tors4(2,i) = t4(2,j)
                  tors5(1,i) = t5(1,j)
                  tors5(2,i) = t5(2,j)
                  tors6(1,i) = t6(1,j)
                  tors6(2,i) = t6(2,j)
                  done = .true.
                  goto 120
               end if
            end do
            do j = 1, nt
               if (kt(j).eq.pt1 .or. kt(j).eq.pt2) then
                  tors1(1,i) = t1(1,j)
                  tors1(2,i) = t1(2,j)
                  tors2(1,i) = t2(1,j)
                  tors2(2,i) = t2(2,j)
                  tors3(1,i) = t3(1,j)
                  tors3(2,i) = t3(2,j)
                  tors4(1,i) = t4(1,j)
                  tors4(2,i) = t4(2,j)
                  tors5(1,i) = t5(1,j)
                  tors5(2,i) = t5(2,j)
                  tors6(1,i) = t6(1,j)
                  tors6(2,i) = t6(2,j)
                  done = .true.
                  goto 120
               end if
            end do
            do j = 1, nt
               if (kt(j) .eq. pt0) then
                  tors1(1,i) = t1(1,j)
                  tors1(2,i) = t1(2,j)
                  tors2(1,i) = t2(1,j)
                  tors2(2,i) = t2(2,j)
                  tors3(1,i) = t3(1,j)
                  tors3(2,i) = t3(2,j)
                  tors4(1,i) = t4(1,j)
                  tors4(2,i) = t4(2,j)
                  tors5(1,i) = t5(1,j)
                  tors5(2,i) = t5(2,j)
                  tors6(1,i) = t6(1,j)
                  tors6(2,i) = t6(2,j)
                  done = .true.
                  goto 120
               end if
            end do
c
c     find the parameters for a 5-ring torsion
c
         else if (iring .eq. 5) then
            do j = 1, nt5
               if (kt5(j) .eq. pt) then
                  tors1(1,i) = t15(1,j)
                  tors1(2,i) = t15(2,j)
                  tors2(1,i) = t25(1,j)
                  tors2(2,i) = t25(2,j)
                  tors3(1,i) = t35(1,j)
                  tors3(2,i) = t35(2,j)
                  tors4(1,i) = t45(1,j)
                  tors4(2,i) = t45(2,j)
                  tors5(1,i) = t55(1,j)
                  tors5(2,i) = t55(2,j)
                  tors6(1,i) = t65(1,j)
                  tors6(2,i) = t65(2,j)
                  done = .true.
                  goto 120
               end if
            end do
            do j = 1, nt5
               if (kt5(j).eq.pt1 .or. kt5(j).eq.pt2) then
                  tors1(1,i) = t15(1,j)
                  tors1(2,i) = t15(2,j)
                  tors2(1,i) = t25(1,j)
                  tors2(2,i) = t25(2,j)
                  tors3(1,i) = t35(1,j)
                  tors3(2,i) = t35(2,j)
                  tors4(1,i) = t45(1,j)
                  tors4(2,i) = t45(2,j)
                  tors5(1,i) = t55(1,j)
                  tors5(2,i) = t55(2,j)
                  tors6(1,i) = t65(1,j)
                  tors6(2,i) = t65(2,j)
                  done = .true.
                  goto 120
               end if
            end do
            do j = 1, nt5
               if (kt5(j) .eq. pt0) then
                  tors1(1,i) = t15(1,j)
                  tors1(2,i) = t15(2,j)
                  tors2(1,i) = t25(1,j)
                  tors2(2,i) = t25(2,j)
                  tors3(1,i) = t35(1,j)
                  tors3(2,i) = t35(2,j)
                  tors4(1,i) = t45(1,j)
                  tors4(2,i) = t45(2,j)
                  tors5(1,i) = t55(1,j)
                  tors5(2,i) = t55(2,j)
                  tors6(1,i) = t65(1,j)
                  tors6(2,i) = t65(2,j)
                  done = .true.
                  goto 120
               end if
            end do
c
c     find the parameters for a 4-ring torsion
c
         else if (iring .eq. 4) then
            do j = 1, nt4
               if (kt4(j) .eq. pt) then
                  tors1(1,i) = t14(1,j)
                  tors1(2,i) = t14(2,j)
                  tors2(1,i) = t24(1,j)
                  tors2(2,i) = t24(2,j)
                  tors3(1,i) = t34(1,j)
                  tors3(2,i) = t34(2,j)
                  tors4(1,i) = t44(1,j)
                  tors4(2,i) = t44(2,j)
                  tors5(1,i) = t54(1,j)
                  tors5(2,i) = t54(2,j)
                  tors6(1,i) = t64(1,j)
                  tors6(2,i) = t64(2,j)
                  done = .true.
                  goto 120
               end if
            end do
            do j = 1, nt4
               if (kt4(j).eq.pt1 .or. kt4(j).eq.pt2) then
                  tors1(1,i) = t14(1,j)
                  tors1(2,i) = t14(2,j)
                  tors2(1,i) = t24(1,j)
                  tors2(2,i) = t24(2,j)
                  tors3(1,i) = t34(1,j)
                  tors3(2,i) = t34(2,j)
                  tors4(1,i) = t44(1,j)
                  tors4(2,i) = t44(2,j)
                  tors5(1,i) = t54(1,j)
                  tors5(2,i) = t54(2,j)
                  tors6(1,i) = t64(1,j)
                  tors6(2,i) = t64(2,j)
                  done = .true.
                  goto 120
               end if
            end do
            do j = 1, nt4
               if (kt4(j) .eq. pt0) then
                  tors1(1,i) = t14(1,j)
                  tors1(2,i) = t14(2,j)
                  tors2(1,i) = t24(1,j)
                  tors2(2,i) = t24(2,j)
                  tors3(1,i) = t34(1,j)
                  tors3(2,i) = t34(2,j)
                  tors4(1,i) = t44(1,j)
                  tors4(2,i) = t44(2,j)
                  tors5(1,i) = t54(1,j)
                  tors5(2,i) = t54(2,j)
                  tors6(1,i) = t64(1,j)
                  tors6(2,i) = t64(2,j)
                  done = .true.
                  goto 120
               end if
            end do
         end if
c
c     warning if suitable torsional parameter not found
c
  120    continue
         minat = min(atomic(ia),atomic(ib),atomic(ic),atomic(id))
         if (minat .eq. 0)  done = .true.
         if (use_tors .and. .not.done) then
            if (use(ia) .or. use(ib) .or. use(ic) .or. use(id))
     &         abort = .true.
            if (header) then
               header = .false.
               write (iout,130)
  130          format (/,' Undefined Torsional Parameters :',
     &                 //,' Type',24x,'Atom Names',24x,
     &                    'Atom Classes',/)
            end if
            label = 'Torsion'
            if (iring .eq. 5)  label = '5-Ring '
            if (iring .eq. 4)  label = '4-Ring '
            write (iout,140)  label,ia,name(ia),ib,name(ib),ic,
     &                        name(ic),id,name(id),ita,itb,itc,itd
  140       format (1x,a7,4x,4(i6,'-',a3),5x,4i5)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (kindex)
      deallocate (klist)
c
c     process keywords containing torsion specific 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:8) .eq. 'TORSION ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do j = 1, 6
               vt(j) = 0.0d0
               st(j) = 0.0d0
               ft(j) = 0
            end do
            string = record(next:240)
            read (string,*,err=150,end=150)  ia,ib,ic,id,
     &                                       (vt(j),st(j),ft(j),j=1,6)
  150       continue
            if (min(ia,ib,ic,id) .lt. 0) then
               ia = abs(ia)
               ib = abs(ib)
               ic = abs(ic)
               id = abs(id)
               call torphase (ft,vt,st)
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,160)
  160             format (/,' Additional Torsion Specific Parameters :',
     &                    //,8x,'Atoms',9x,'1-Fold',4x,'2-Fold',
     &                       4x,'3-Fold',4x,'4-Fold',4x,'5-Fold',
     &                       4x,'6-Fold',/)
               end if
               if (.not. silent) then
                  write (iout,170)  ia,ib,ic,id,
     &                              (vt(j),nint(st(j)),j=1,6)
  170             format (2x,4i4,1x,6(f6.2,i4))
               end if
               do j = 1, ntors
                  ita = itors(1,j)
                  itb = itors(2,j)
                  itc = itors(3,j)
                  itd = itors(4,j)
                  if ((ia.eq.ita .and. ib.eq.itb .and.
     &                 ic.eq.itc .and. id.eq.itd) .or.
     &                (ia.eq.itd .and. ib.eq.itc .and.
     &                 ic.eq.itb .and. id.eq.ita)) then
                     tors1(1,j) = vt(1)
                     tors1(2,j) = st(1)
                     tors2(1,j) = vt(2)
                     tors2(2,j) = st(2)
                     tors3(1,j) = vt(3)
                     tors3(2,j) = st(3)
                     tors4(1,j) = vt(4)
                     tors4(2,j) = st(4)
                     tors5(1,j) = vt(5)
                     tors5(2,j) = st(5)
                     tors6(1,j) = vt(6)
                     tors6(2,j) = st(6)
                     goto 180
                  end if
               end do
            end if
  180       continue
         end if
      end do
c
c     find the cosine and sine of phase angle for each torsion
c
      do i = 1, ntors
         angle = tors1(2,i) / radian
         tors1(3,i) = cos(angle)
         tors1(4,i) = sin(angle)
         angle = tors2(2,i) / radian
         tors2(3,i) = cos(angle)
         tors2(4,i) = sin(angle)
         angle = tors3(2,i) / radian
         tors3(3,i) = cos(angle)
         tors3(4,i) = sin(angle)
         angle = tors4(2,i) / radian
         tors4(3,i) = cos(angle)
         tors4(4,i) = sin(angle)
         angle = tors5(2,i) / radian
         tors5(3,i) = cos(angle)
         tors5(4,i) = sin(angle)
         angle = tors6(2,i) / radian
         tors6(3,i) = cos(angle)
         tors6(4,i) = sin(angle)
      end do
c
c     turn off the torsional potential if it is not used
c
      if (ntors .eq. 0)  use_tors = .false.
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ktorsm  --  assign MMFF torsional parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ktorsm" assigns torsional parameters to each torsion according
c     to the Merck Molecular Force Field (MMFF)
c
c     literature references:
c
c     T. A. Halgren, "Merck Molecular Force Field. I. Basis, Form,
c     Scope, Parametrization, and Performance of MMFF94", Journal of
c     Computational Chemistry, 17, 490-519 (1995)
c
c     T. A. Halgren, "Merck Molecular Force Field. V. Extension of
c     MMFF94 Using Experimental Data, Additional Computational Data,
c     and Empirical Rules", Journal of Computational Chemistry, 17,
c     616-641 (1995)
c
c
      subroutine ktorsm
      use atomid
      use atoms
      use ktorsn
      use math
      use merck
      use potent
      use ring
      use tors
      implicit none
      integer i,j,k,l,m,o
      integer size,tt
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer inb,inc,irb,irc
      integer itta,ittb
      integer ittc,ittd
      integer nt4,nt5
      integer ab,bc,cd
      integer mclass
      real*8 angle
      real*8 beta,pi_bc,n_bc
      real*8 ub,vb,wb
      real*8 uc,vc,wc
      logical done,skipring
      logical ring4,ring5
      character*4 pa,pb,pc,pd
      character*16 pt,blank
c
c
c     determine the total number of forcefield parameters
c
      blank = '                '
      nt5 = maxnt5
      nt4 = maxnt4
      do i = maxnt5, 1, -1
         if (kt5(i) .eq. blank)  nt5 = i - 1
      end do
      do i = maxnt4, 1, -1
         if (kt4(i) .eq. blank)  nt4 = i - 1
      end do
c
c     assign MMFF torsional parameters for each torsional angle
c
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         itta = type(ia)
         ittb = type(ib)
         ittc = type(ic)
         ittd = type(id)
         done = .false.
         mclass = 0
         skipring = .false.
   10    continue
c
c     determine the atom class equivalency assignments
c
         mclass = mclass + 1
         if (mclass .eq. 1) then
            ita = eqclass(itta,mclass)
            itb = eqclass(ittb,mclass)
            itc = eqclass(ittc,mclass)
            itd = eqclass(ittd,mclass)
         else if (mclass.eq.2) then
            ita = eqclass(itta,mclass)
            itb = eqclass(ittb,mclass)
            itc = eqclass(ittc,mclass)
            itd = eqclass(ittd,mclass)
         else if (mclass.eq.3) then
            ita = eqclass(itta,3)
            itb = eqclass(ittb,2)
            itc = eqclass(ittc,2)
            itd = eqclass(ittd,5)
         else if (mclass.eq.4) then
            ita = eqclass(itta,5)
            itb = eqclass(ittb,2)
            itc = eqclass(ittc,2)
            itd = eqclass(ittd,3)
         else if (mclass.eq.5) then
            ita = eqclass(itta,5)
            itb = eqclass(ittb,2)
            itc = eqclass(ittc,2)
            itd = eqclass(ittd,5)
         end if
c
c     construct search string and zero out parameters
c
         size = 4
         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
         tors1(1,i) = 0.0d0
         tors1(2,i) = 0.0d0
         tors2(1,i) = 0.0d0
         tors2(2,i) = 0.0d0
         tors3(1,i) = 0.0d0
         tors3(2,i) = 0.0d0
         tors4(1,i) = 0.0d0
         tors4(2,i) = 0.0d0
         tors5(1,i) = 0.0d0
         tors5(2,i) = 0.0d0
         tors6(1,i) = 0.0d0
         tors6(2,i) = 0.0d0
         done = .false.
c
c     set the MMFF torsion type attribution
c
         ab = 0
         if (ia .le. ib) then
            do j = 1, nligne
               if (ia.eq.bt_1(j,1) .and. ib.eq.bt_1(j,2)) then
                  ab = 1
               end if
            end do
         else if (ib .le. ia) then
            do j = 1, nligne
               if (ib.eq.bt_1(j,1) .and. ia.eq.bt_1(j,2)) then
                  ab = 1
               end if
            end do
         end if
         bc = 0
         if (ib .le. ic) then
            do j = 1, nligne
               if (ib.eq.bt_1(j,1) .and. ic.eq.bt_1(j,2)) then
                  bc = 1
               end if
            end do
         else if (ic .le. ib) then
            do j = 1, nligne
               if (ic.eq.bt_1(j,1) .and. ib.eq.bt_1(j,2)) then
                  bc = 1
               end if
            end do
         end if
         cd = 0
         if (ic .le. id) then
            do j = 1, nligne
               if (ic.eq.bt_1(j,1) .and. id.eq.bt_1(j,2)) then
                  cd = 1
               end if
            end do
         else if (id .le. ic) then
            do j = 1, nligne
               if (id.eq.bt_1(j,1) .and. ic.eq.bt_1(j,2)) then
                  cd = 1
               end if
            end do
         end if
c
c     make a check for torsions inside small rings
c
         ring4 = .false.
         ring5 = .false.
         do j = 1, nring4
            do k = 1, 4
               if (ia .eq. iring4(k,j)) then
                  do l = 1, 4
                     if (ib .eq. iring4(l,j)) then
                        do m = 1, 4
                           if (ic .eq. iring4(m,j)) then
                              do o = 1, 4
                                 if (id .eq. iring4(o,j))
     &                              ring4 = .true.
                              end do
                           end if
                        end do
                     end if
                  end do
               end if
            end do
         end do
         do j = 1, nring5
            do k = 1, 5
               if (ia .eq. iring5(k,j)) then
                  do l = 1, 5
                     if (ib .eq. iring5(l,j)) then
                        do m = 1, 5
                           if (ic .eq. iring5(m,j)) then
                              do o = 1, 5
                                 if (id .eq. iring5(o,j))
     &                              ring5 = .true.
                              end do
                           end if
                        end do
                     end if
                  end do
               end if
            end do
         end do
         if (skipring) then
            ring4 = .false.
            ring5 = .false.
         end if
         if (ring4) then
            tt = 4
            do j = 1, nt4
               if (kt4(j) .eq. pt) then
                  tors1(1,i) = t14(1,j)
                  tors1(2,i) = t14(2,j)
                  tors2(1,i) = t24(1,j)
                  tors2(2,i) = t24(2,j)
                  tors3(1,i) = t34(1,j)
                  tors3(2,i) = t34(2,j)
                  done = .true.
                  goto 20
               end if
            end do
            if (.not.done .and. mclass.lt.5) then
               goto 10
            end if
         end if
         if (ring5 .and. (class(ia).eq.1.or.class(ib).eq.1.or.
     &                    class(ic).eq.1.or.class(id).eq.1)) then
            tt = 5
            do j = 1, nt5
               if (kt5(j) .eq. pt) then
                  tors1(1,i) = t15(1,j)
                  tors1(2,i) = t15(2,j)
                  tors2(1,i) = t25(1,j)
                  tors2(2,i) = t25(2,j)
                  tors3(1,i) = t35(1,j)
                  tors3(2,i) = t35(2,j)
                  done = .true.
               end if
            end do
            if (.not.done .and. mclass.lt.5) then
               goto 10
            else if (.not.done .and. mclass.eq.5) then
               mclass = 0
               skipring = .true.
               goto 10
            end if
         end if
c
c     condition below deduced from validation suite comparison
c
         if ((ab.eq.1 .and. (mltb(class(ic)).eq.0.or.
     &                       sbmb(class(ic)).eq.0)) .or.
     &       (cd.eq.1 .and. (mltb(class(ib)).eq.0.or.
     &                       sbmb(class(ib)).eq.0))) then
            tt = 2
            do j = 1, maxnt
               if (kt_2(j) .eq. pt) then
                  tors1(1,i) = t1_2(1,j)
                  tors1(2,i) = t1_2(2,j)
                  tors2(1,i) = t2_2(1,j)
                  tors2(2,i) = t2_2(2,j)
                  tors3(1,i) = t3_2(1,j)
                  tors3(2,i) = t3_2(2,j)
                  done = .true.
                  goto 20
               end if
            end do
            if (.not.done .and. mclass.lt.5) then
               goto 10
            end if
            if (.not.done .and. mclass.eq.5) then
               tt = 0
               do j = 1, maxnt
                  if (kt(j) .eq. pt) then
                     tors1(1,i) = t1(1,j)
                     tors1(2,i) = t1(2,j)
                     tors2(1,i) = t2(1,j)
                     tors2(2,i) = t2(2,j)
                     tors3(1,i) = t3(1,j)
                     tors3(2,i) = t3(2,j)
                     done = .true.
                     goto 20
                  end if
               end do
               if (.not.done .and. mclass.lt.5) then
                  goto 10
               end if
            end if
            if (tors1(1,i) .eq. 1000.0d0)  done = .false.
            if (tors1(2,i) .eq. 1000.0d0)  done = .false.
            if (tors2(1,i) .eq. 1000.0d0)  done = .false.
            if (tors2(2,i) .eq. 1000.0d0)  done = .false.
            if (tors3(1,i) .eq. 1000.0d0)  done = .false.
            if (tors3(2,i) .eq. 1000.0d0)  done = .false.
            goto 20
         else if (bc .eq. 1) then
            tt = 1
            do j = 1, maxnt
               if (kt_1(j) .eq. pt) then
                  tors1(1,i) = t1_1(1,j)
                  tors1(2,i) = t1_1(2,j)
                  tors2(1,i) = t2_1(1,j)
                  tors2(2,i) = t2_1(2,j)
                  tors3(1,i) = t3_1(1,j)
                  tors3(2,i) = t3_1(2,j)
                  done = .true.
                  goto 20
               end if
            end do
            if (.not.done .and. mclass.lt.5) then
               goto 10
            end if
            if (tors1(1,i) .eq. 1000.0d0)  done = .false.
            if (tors1(2,i) .eq. 1000.0d0)  done = .false.
            if (tors2(1,i) .eq. 1000.0d0)  done = .false.
            if (tors2(2,i) .eq. 1000.0d0)  done = .false.
            if (tors3(1,i) .eq. 1000.0d0)  done = .false.
            if (tors3(2,i) .eq. 1000.0d0)  done = .false.
            goto 20
         else if (.not. done) then
            tt = 0
            do j = 1, maxnt
               if (kt(j) .eq. pt) then
                  tors1(1,i) = t1(1,j)
                  tors1(2,i) = t1(2,j)
                  tors2(1,i) = t2(1,j)
                  tors2(2,i) = t2(2,j)
                  tors3(1,i) = t3(1,j)
                  tors3(2,i) = t3(2,j)
                  done = .true.
                  goto 20
               end if
            end do
            if (.not.done .and. mclass.lt.5) then
               goto 10
            end if
            if (tors1(1,i) .eq. 1000.0d0)  done = .false.
            if (tors1(2,i) .eq. 1000.0d0)  done = .false.
            if (tors2(1,i) .eq. 1000.0d0)  done = .false.
            if (tors2(2,i) .eq. 1000.0d0)  done = .false.
            if (tors3(1,i) .eq. 1000.0d0)  done = .false.
            if (tors3(2,i) .eq. 1000.0d0)  done = .false.
            goto 20
         end if
   20    continue
c
c     use the empirical rules for parameter not located
c
         if (.not. done) then
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            itd = class(id)
            inb = atomic(ib)
            inc = atomic(ic)
            if (inb .eq. 6) then
               ub = 2.0d0
               vb = 2.12d0
            else if (inb .eq. 7) then
               ub = 2.0d0
               vb = 1.5d0
            else if (inb .eq. 8) then
               ub = 2.0d0
               vb = 0.2d0
            else if (inb .eq. 14) then
               ub = 1.25d0
               vb = 1.22d0
            else if (inb .eq. 15) then
               ub = 1.25d0
               vb = 2.4d0
            else if (inb .eq. 16) then
               ub = 1.25d0
               vb = 0.49d0
            end if
            if (inc .eq. 6) then
               uc = 2.0d0
               vc = 2.12d0
            else if (inc .eq. 7) then
               uc = 2.0d0
               vc = 1.5d0
            else if (inc .eq. 8) then
               uc = 2.0d0
               vc = 0.2d0
            else if (inc .eq. 14) then
               uc = 1.25d0
               vc = 1.22d0
            else if (inc .eq. 15) then
               uc = 1.25d0
               vc = 2.4d0
            else if (inc .eq. 16) then
               uc = 1.25d0
               vc = 0.49d0
            end if
            n_bc = (crd(itb)-1) * (crd(itc)-1)
            if (inb.eq.1)  irb = 0
            if (inb.ge.3 .and. inb.le.10)  irb = 1
            if (inb.ge.11 .and. inb.le.18)  irb = 2
            if (inb.ge.19 .and. inb.le.36)  irb = 3
            if (inb.ge.37 .and. inb.le.54)  irb = 4
            if (inc.eq.1)  irc = 0
            if (inc.ge.3 .and. inc.le.10)  irc = 1
            if (inc.ge.11 .and. inc.le.18)  irc = 2
            if (inc.ge.19 .and. inc.le.36)  irc = 3
            if (inc.ge.37 .and. inc.le.54)  irc = 4
            if (lin(itb).eq.1 .or. lin(itc).eq.1) then
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = 0.0d0
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if (arom(itb).eq.1 .and. arom(itc).eq.1) then
               if (pilp(itb).eq.0 .and. pilp(itc).eq.0) then
                  pi_bc = 0.5d0
               else
                  pi_bc = 0.3d0
               end if
               if ((val(itb).eq.3.and.val(itc).eq.4) .or.
     &             (val(itb).eq.4.and.val(itc).eq.3) .or.
     &             (val(itb).eq.4.and.val(itc).eq.34) .or.
     &             (val(itb).eq.34.and.val(itc).eq.4) .or.
     &             (val(itb).eq.34.and.val(itc).eq.3) .or.
     &             (val(itb).eq.3.and.val(itc).eq.34) .or.
     &             (val(itb).eq.34.and.val(itc).eq.34)) then
                  beta = 3.0d0
               else
                  beta = 6.0d0
               end if
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = beta * pi_bc * sqrt(ub*uc)
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if ((mltb(itb).eq.2 .and. mltb(itc).eq.2) .or.
     &               (mltb(itc).eq.2 .and. mltb(itb).eq.2)) then
               beta = 6.0d0
               pi_bc = 1.0d0
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = beta * pi_bc * sqrt(ub*uc)
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if (mltb(itb).eq.2 .or. mltb(itc).eq.2) then
               beta = 6.0d0
               pi_bc = 0.4d0
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = beta * pi_bc * sqrt(ub*uc)
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if (crd(itb).eq.4 .and. crd(itc).eq.4) then
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = 0.0d0
               tors2(2,i) = 180.0d0
               tors3(1,i) = sqrt(vb*vc) / n_bc
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if ((crd(itb).eq.4.and.crd(itc).eq.3.and.
     &              ((val(itc).eq.4.or.val(itc).eq.34).or.
     &                 mltb(itc).ne.0)) .or.
     &              (crd(itc).eq.4.and.crd(itb).eq.3.and.
     &              ((val(itb).eq.4.or.val(itb).eq.34).or.
     &                 mltb(itb).ne.0))) then
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = 0.0d0
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if ((crd(itb).eq.4.and.crd(itc).eq.2.and.
     &               (val(itc).eq.3.or.mltb(itc).ne.0)) .or.
     &               (crd(itb).eq.4.and.crd(itc).eq.2.and.
     &               (val(itc).eq.3.or.mltb(itc).ne.0))) then
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = 0.0d0
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if (crd(itb).eq.4 .or. crd(itc).eq.4) then
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = 0.0d0
               tors2(2,i) = 180.0d0
               tors3(1,i) = sqrt(vb*vc) / n_bc
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if (pilp(itb).eq.1 .and. pilp(itc).eq.1) then
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = 0.0d0
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if (pilp(itb).ne.0 .and. mltb(itc).ne.0) then
               beta = 6.0d0
               if (mltb(itb) .eq. 1) then
                  pi_bc = 0.5d0
               else if (irb.eq.1 .and. irc.eq.1) then
                  pi_bc = 0.3d0
               else if (irb.ne.1 .or. irc.ne.1) then
                  pi_bc = 0.15d0
               end if
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = beta * pi_bc * sqrt(ub*uc)
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if (pilp(itc).ne.0 .and. mltb(itb).ne.0) then
               beta = 6.0d0
               if (mltb(itc) .eq. 1) then
                  pi_bc = 0.5d0
               else if (irb.eq.1 .and. irc.eq.1) then
                  pi_bc = 0.3d0
               else if (irb.ne.1 .or. irc.ne.1) then
                  pi_bc = 0.15d0
               end if
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = beta * pi_bc * sqrt(ub*uc)
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if ((mltb(itb).eq.1.or.mltb(itc).eq.1) .and.
     &               (inb.ne.6.or.inc.ne.6)) then
               beta = 6.0d0
               pi_bc = 0.4d0
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = beta * pi_bc * sqrt(ub*uc)
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if (mltb(itb).ne.0 .and. mltb(itc).ne.0) then
               beta = 6.0d0
               pi_bc = 0.15d0
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = beta * pi_bc * sqrt(ub*uc)
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if (inb.eq.8 .and. inc.eq.8) then
               wb = 2.0d0
               wc = 2.0d0
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = -sqrt(wb*wc)
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if ((inb.eq.8.and.inc.eq.16) .or.
     &               (inb.eq.16.and.inc.eq.8)) then
               wb = 2.0d0
               wc = 8.0d0
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = -sqrt(wb*wc)
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else if (inb.eq.16 .and. inc.eq.16) then
               wb = 8.0d0
               wc = 8.0d0
               tors1(1,i) = 0.0d0
               tors1(2,i) = 0.0d0
               tors2(1,i) = -sqrt(wb*wc)
               tors2(2,i) = 180.0d0
               tors3(1,i) = 0.0d0
               tors3(2,i) = 0.0d0
               done = .true.
               goto 20
            else
               tors1(1,i) = 0.0
               tors1(2,i) = 0.0
               tors2(1,i) = 0.0
               tors2(2,i) = 180.0
               tors3(1,i) = sqrt(vb*vc) / n_bc
               tors3(2,i) = 0.0
               done = .true.
               goto 20
            end if
         end if
      end do
c
c     find the cosine and sine of phase angle for each torsion
c
      do i = 1, ntors
         angle = tors1(2,i) / radian
         tors1(3,i) = cos(angle)
         tors1(4,i) = sin(angle)
         angle = tors2(2,i) / radian
         tors2(3,i) = cos(angle)
         tors2(4,i) = sin(angle)
         angle = tors3(2,i) / radian
         tors3(3,i) = cos(angle)
         tors3(4,i) = sin(angle)
         angle = tors4(2,i) / radian
         tors4(3,i) = cos(angle)
         tors4(4,i) = sin(angle)
         angle = tors5(2,i) / radian
         tors5(3,i) = cos(angle)
         tors5(4,i) = sin(angle)
         angle = tors6(2,i) / radian
         tors6(3,i) = cos(angle)
         tors6(4,i) = sin(angle)
      end do
c
c     turn off the torsional potential if it is not used
c
      if (ntors .eq. 0)  use_tors = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module ktorsn  --  torsional angle forcefield parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     maxnt    maximum number of torsional angle parameter entries
c     maxnt5   maximum number of 5-membered ring torsion entries
c     maxnt4   maximum number of 4-membered ring torsion entries
c
c     t1       torsional parameters for standard 1-fold rotation
c     t2       torsional parameters for standard 2-fold rotation
c     t3       torsional parameters for standard 3-fold rotation
c     t4       torsional parameters for standard 4-fold rotation
c     t5       torsional parameters for standard 5-fold rotation
c     t6       torsional parameters for standard 6-fold rotation
c     t15      torsional parameters for 1-fold rotation in 5-ring
c     t25      torsional parameters for 2-fold rotation in 5-ring
c     t35      torsional parameters for 3-fold rotation in 5-ring
c     t45      torsional parameters for 4-fold rotation in 5-ring
c     t55      torsional parameters for 5-fold rotation in 5-ring
c     t65      torsional parameters for 6-fold rotation in 5-ring
c     t14      torsional parameters for 1-fold rotation in 4-ring
c     t24      torsional parameters for 2-fold rotation in 4-ring
c     t34      torsional parameters for 3-fold rotation in 4-ring
c     t44      torsional parameters for 4-fold rotation in 4-ring
c     t54      torsional parameters for 5-fold rotation in 4-ring
c     t64      torsional parameters for 6-fold rotation in 4-ring
c     kt       string of atom classes for torsional angles
c     kt5      string of atom classes for 5-ring torsions
c     kt4      string of atom classes for 4-ring torsions
c
c
      module ktorsn
      implicit none
      integer maxnt
      integer maxnt5
      integer maxnt4
      real*8, allocatable :: t1(:,:)
      real*8, allocatable :: t2(:,:)
      real*8, allocatable :: t3(:,:)
      real*8, allocatable :: t4(:,:)
      real*8, allocatable :: t5(:,:)
      real*8, allocatable :: t6(:,:)
      real*8, allocatable :: t15(:,:)
      real*8, allocatable :: t25(:,:)
      real*8, allocatable :: t35(:,:)
      real*8, allocatable :: t45(:,:)
      real*8, allocatable :: t55(:,:)
      real*8, allocatable :: t65(:,:)
      real*8, allocatable :: t14(:,:)
      real*8, allocatable :: t24(:,:)
      real*8, allocatable :: t34(:,:)
      real*8, allocatable :: t44(:,:)
      real*8, allocatable :: t54(:,:)
      real*8, allocatable :: t64(:,:)
      character*16, allocatable :: kt(:)
      character*16, allocatable :: kt5(:)
      character*16, allocatable :: kt4(:)
      save
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 2003 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine ktortor  --  tors-tors parameter assignment  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "ktortor" assigns torsion-torsion parameters to adjacent
c     torsion pairs and processes any new or changed values
c
c
      subroutine ktortor
      use atomid
      use atoms
      use bitor
      use inform
      use iounit
      use keys
      use ktrtor
      use potent
      use tortor
      implicit none
      integer i,j,k,m
      integer ia,ib,ic,id,ie
      integer ita,itb,itc,itd,ite
      integer size,next,ntt
      integer nx,ny,nxy
      integer tkey(maxtgrd2)
      real*8 eps
      real*8 tx(maxtgrd2)
      real*8 ty(maxtgrd2)
      real*8 tf(maxtgrd2)
      real*8 tind(maxtgrd2)
      real*8 bs(0:maxtgrd)
      real*8 cs(0:maxtgrd)
      real*8 ds(0:maxtgrd)
      real*8 tmp1(0:maxtgrd)
      real*8 tmp2(0:maxtgrd)
      real*8 tmp3(0:maxtgrd)
      real*8 tmp4(0:maxtgrd)
      real*8 tmp5(0:maxtgrd)
      real*8 tmp6(0:maxtgrd)
      real*8 tmp7(0:maxtgrd)
      logical header,cyclic
      character*3 ttag
      character*4 pa,pb,pc,pd,pe
      character*20 blank,pt
      character*20 pt1,pt2
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing torsion-torsion parameters
c
      blank = '                    '
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:8) .eq. 'TORTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            ie = 0
            nx = 0
            ny = 0
            nxy = 0
            ttag = '   '
            do j = 1, maxtgrd2
               tx(j) = 0.0d0
               ty(j) = 0.0d0
               tf(j) = 0.0d0
            end do
            string = record(next:240)
            read (string,*,err=40,end=40)  ia,ib,ic,id,ie,nx,ny
            nxy = nx * ny
            call getword (record,ttag,next)
            m = i
            j = 0
            dowhile (j .lt. nxy)
               m = m + 1
               record = keyline(m)
               read (record,*,err=10,end=10)  tx(j+1),ty(j+1),tf(j+1),
     &                                        tx(j+2),ty(j+2),tf(j+2),
     &                                        tx(j+3),ty(j+3),tf(j+3)
               j = j + 3
               goto 30
   10          continue
               read (record,*,err=20,end=20)  tx(j+1),ty(j+1),tf(j+1),
     &                                        tx(j+2),ty(j+2),tf(j+2)
               j = j + 2
               goto 30
   20          continue
               read (record,*,err=40,end=40)  tx(j+1),ty(j+1),tf(j+1)
               j = j + 1
   30          continue
            end do
   40       continue
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,50)
   50             format (/,' Additional Torsion-Torsion Parameters :',
     &                    //,5x,'Atom Classes',12x,'Grid-1',
     &                       6x,'Grid-2',6x,'Tier',/)
               end if
               write (iout,60)  ia,ib,ic,id,ie,nx,ny,ttag
   60          format (1x,5i4,5x,i8,4x,i8,8x,a3)
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            call numeral (ie,pe,size)
            pt = pa//pb//pc//pd//pe
            do j = 1, maxntt
               if (ktt(j).eq.blank .or. ktt(j).eq.pt) then
                  ktt(j) = pt
                  ttier(j) = ttag
                  do k = 1, nxy
                     tind(k) = 360.0d0*ty(k) + tx(k)
                     tkey(k) = k
                  end do
                  call sort2 (nxy,tind,tkey)
                  do k = 1, nxy
                     tbf(k,j) = tf(tkey(k))
                  end do
                  nx = nxy
                  call sort9 (nx,tx)
                  tnx(j) = nx
                  do k = 1, nx
                     ttx(k,j) = tx(k)
                  end do
                  ny = nxy
                  call sort9 (ny,ty)
                  tny(j) = ny
                  do k = 1, ny
                     tty(k,j) = ty(k)
                  end do
                  goto 80
               end if
            end do
            write (iout,70)
   70       format (/,' KTORTOR  --  Too many Torsion-Torsion',
     &                 ' Parameters')
            abort = .true.
   80       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      ntt = maxntt
      do i = maxntt, 1, -1
         if (ktt(i) .eq. blank)  ntt = i - 1
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(itt))  deallocate (itt)
      allocate (itt(3,nbitor))
c
c     check whether each torsion-torsion parameter is periodic;
c     assumes the "tbf" array is sorted with both indices in
c     increasing order and the first index changing most rapidly
c
      do i = 1, ntt
         cyclic = .true.
         eps = 0.000001d0
         nx = tnx(i) - 1
         ny = tny(i) - 1
         if (abs(abs(ttx(1,i)-ttx(tnx(i),i))-360.0d0) .gt. eps)
     &      cyclic = .false.
         if (abs(abs(tty(1,i)-tty(tny(i),i))-360.0d0) .gt. eps)
     &      cyclic = .false.
         if (cyclic) then
            do j = 1, tny(i)
               k = (j-1)*tnx(i) + 1
               if (abs(tbf(k,i)-tbf(k+nx,i)) .gt. eps) then
                  write (iout,90)  tbf(k,i),tbf(k+nx,i)
   90             format (/,' KTORTOR  --  Warning, Unequal Tor-Tor',
     &                        ' Values',3x,2f12.5)
                  abort = .true.
               end if
            end do
            k = ny * tnx(i)
            do j = 1, tnx(i)
               if (abs(tbf(j,i)-tbf(j+k,i)) .gt. eps) then
                  write (iout,100)  tbf(j,i),tbf(j+k,i)
  100             format (/,' KTORTOR  --  Warning, Unequal Tor-Tor',
     &                        ' Values',3x,2f12.5)
                  abort = .true.
               end if
            end do
         end if
c
c     spline fit the derivatives about the first torsion
c
         do j = 1, tnx(i)
            tmp1(j-1) = ttx(j,i)
         end do
         m = 0
         do j = 1, tny(i)
            do k = 1, tnx(i)
               tmp2(k-1) = tbf(m+k,i)
            end do
            if (cyclic) then
               call cspline (nx,tmp1,tmp2,bs,cs,ds,tmp3,
     &                         tmp4,tmp5,tmp6,tmp7)
            else
               call nspline (nx,tmp1,tmp2,bs,cs,tmp3,
     &                         tmp4,tmp5,tmp6,tmp7)
            end if
            do k = 1, tnx(i)
               tbx(m+k,i) = bs(k-1)
            end do
            m = m + tnx(i)
         end do
c
c     spline fit the derivatives about the second torsion
c
         do j = 1, tny(i)
            tmp1(j-1) = tty(j,i)
         end do
         m = 1
         do j = 1, tnx(i)
            do k = 1, tny(i)
               tmp2(k-1) = tbf(m+(k-1)*tnx(i),i)
            end do
            if (cyclic) then
               call cspline (ny,tmp1,tmp2,bs,cs,ds,tmp3,
     &                         tmp4,tmp5,tmp6,tmp7)
            else
               call nspline (ny,tmp1,tmp2,bs,cs,tmp3,
     &                         tmp4,tmp5,tmp6,tmp7)
            end if
            do k = 1, tny(i)
               tby(m+(k-1)*tnx(i),i) = bs(k-1)
            end do
            m = m + 1
         end do
c
c     spline fit the cross derivatives about both torsions
c
         m = 1
         do j = 1, tnx(i)
            do k = 1, tny(i)
               tmp2(k-1) = tbx(m+(k-1)*tnx(i),i)
            end do
            if (cyclic) then
               call cspline (ny,tmp1,tmp2,bs,cs,ds,tmp3,
     &                          tmp4,tmp5,tmp6,tmp7)
            else
               call nspline (ny,tmp1,tmp2,bs,cs,tmp3,
     &                         tmp4,tmp5,tmp6,tmp7)
            end if
            do k = 1, tny(i)
               tbxy(m+(k-1)*tnx(i),i) = bs(k-1)
            end do
            m = m + 1
         end do
      end do
c
c     assign torsion-torsion parameters for each bitorsion
c
      ntortor = 0
      do i = 1, nbitor
         ia = ibitor(1,i)
         ib = ibitor(2,i)
         ic = ibitor(3,i)
         id = ibitor(4,i)
         ie = ibitor(5,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         ite = class(ie)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         call numeral (ite,pe,size)
         pt1 = pa//pb//pc//pd//pe
         pt2 = pe//pd//pc//pb//pa
c
c     assign tier-specific parameters for this torsion-torsion
c
         do j = 1, ntt
            if (ttier(j) .eq. tier(ic)) then
               if (ktt(j) .eq. pt1) then
                  ntortor = ntortor + 1
                  itt(1,ntortor) = i
                  itt(2,ntortor) = j
                  itt(3,ntortor) = 1
                  goto 110
               else if (ktt(j) .eq. pt2) then
                  ntortor = ntortor + 1
                  itt(1,ntortor) = i
                  itt(2,ntortor) = j
                  itt(3,ntortor) = -1
                  goto 110
               end if
            end if
         end do
c
c     assign nonspecific parameters for this torsion-torsion
c
         do j = 1, ntt
            if (ttier(j) .eq. '   ') then
               if (ktt(j) .eq. pt1) then
                  ntortor = ntortor + 1
                  itt(1,ntortor) = i
                  itt(2,ntortor) = j
                  itt(3,ntortor) = 1
                  goto 110
               else if (ktt(j) .eq. pt2) then
                  ntortor = ntortor + 1
                  itt(1,ntortor) = i
                  itt(2,ntortor) = j
                  itt(3,ntortor) = -1
                  goto 110
               end if
            end if
         end do
  110    continue
      end do
c
c     turn off the torsion-torsion potential if it is not used
c
      if (ntortor .eq. 0)  use_tortor = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module ktrtor  --  torsion-torsion forcefield parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     maxntt    maximum number of torsion-torsion parameter entries
c     maxtgrd   maximum dimension of torsion-torsion spline grid
c     maxtgrd2  maximum number of torsion-torsion spline grid points
c
c     tnx       number of columns in torsion-torsion spline grid
c     tny       number of rows in torsion-torsion spline grid
c     ttx       angle values for first torsion of spline grid
c     tty       angle values for second torsion of spline grid
c     tbf       function values at points on spline grid
c     tbx       gradient over first torsion of spline grid
c     tby       gradient over second torsion of spline grid
c     tbxy      Hessian cross components over spline grid
c     ttier     tier name for each torsion-torsion parameter
c     ktt       string of torsion-torsion atom classes
c
c
      module ktrtor
      implicit none
      integer maxntt
      integer maxtgrd
      integer maxtgrd2
      parameter (maxtgrd=30)
      parameter (maxtgrd2=maxtgrd*maxtgrd)
      integer, allocatable :: tnx(:)
      integer, allocatable :: tny(:)
      real*8, allocatable :: ttx(:,:)
      real*8, allocatable :: tty(:,:)
      real*8, allocatable :: tbf(:,:)
      real*8, allocatable :: tbx(:,:)
      real*8, allocatable :: tby(:,:)
      real*8, allocatable :: tbxy(:,:)
      character*3, allocatable :: ttier(:)
      character*20, allocatable :: ktt(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine kundrot1  --  Cartesian excluded volume derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "kundrot1" calculates first derivatives of the total excluded
c     volume with respect to the Cartesian coordinates of each atom
c     using a numerical method due to Craig Kundrot
c
c     literature reference:
c
c     C. E. Kundrot, J. W. Ponder and F. M. Richards, "Algorithms for
c     Calculating Excluded Volume and Its Derivatives as a Function
c     of Molecular Conformation and Their Use in Energy Minimization",
c     Journal of Computational Chemistry, 12, 402-409 (1991)
c
c
      subroutine kundrot1 (n,x,y,z,rad,probe,dex)
      use iounit
      use math
      implicit none
      integer maxcube,maxarc
      parameter (maxcube=30)
      parameter (maxarc=1000)
      integer i,j,k,m,n
      integer io,ir,in
      integer narc,nx,ny,nz
      integer istart,istop
      integer jstart,jstop
      integer kstart,kstop
      integer mstart,mstop
      integer isum,icube,itemp
      integer inov(maxarc)
      integer, allocatable :: itab(:)
      integer cube(2,maxcube,maxcube,maxcube)
      real*8 xr,yr,zr
      real*8 xmin,ymin,zmin
      real*8 xmax,ymax,zmax
      real*8 aa,bb,temp,phi_term
      real*8 theta1,theta2,dtheta
      real*8 seg_dx,seg_dy,seg_dz
      real*8 pre_dx,pre_dy,pre_dz
      real*8 rinsq,rdiff
      real*8 rsecn,rsec2n
      real*8 cosine,ti,tf
      real*8 alpha,beta
      real*8 ztop,zstart
      real*8 ztopshave
      real*8 phi1,cos_phi1
      real*8 phi2,cos_phi2
      real*8 zgrid,pix2
      real*8 rsec2r,rsecr
      real*8 rr,rrx2,rrsq
      real*8 rmax,edge
      real*8 dist2,vdwsum
      real*8 probe,zstep
      real*8 arci(maxarc)
      real*8 arcf(maxarc)
      real*8 dx(maxarc)
      real*8 dy(maxarc)
      real*8 dsq(maxarc)
      real*8 d(maxarc)
      real*8 x(*)
      real*8 y(*)
      real*8 z(*)
      real*8 rad(*)
      real*8, allocatable :: volrad(:)
      real*8 dex(3,*)
      logical, allocatable :: skip(:)
c
c
c     set the step size in z-direction, which controls derivative
c     accuracy; step of 0.06 balances compute time and accuracy
c     for large systems, while step of 0.01 gives higher accuracy
c
c     zstep = 0.0601d0
      zstep = 0.0101d0
c
c     initialize minimum and maximum ranges of atoms
c
      pix2 = 2.0d0 * pi
      rmax = 0.0d0
      xmin = x(1)
      xmax = x(1)
      ymin = y(1)
      ymax = y(1)
      zmin = z(1)
      zmax = z(1)
c
c     perform dynamic allocation of some local arrays
c
      allocate (itab(n))
      allocate (volrad(n))
      allocate (skip(n))
c
c     assign van der Waals radii to the atoms; note that
c     the radii are incremented by the size of the probe;
c     then get the maximum and minimum ranges of atoms
c
      do i = 1, n
         volrad(i) = rad(i)
         if (volrad(i) .eq. 0.0d0) then
            skip(i) = .true.
         else
            skip(i) = .false.
            volrad(i) = volrad(i) + probe
            if (volrad(i) .gt. rmax)  rmax = volrad(i)
            if (x(i) .lt. xmin)  xmin = x(i)
            if (x(i) .gt. xmax)  xmax = x(i)
            if (y(i) .lt. ymin)  ymin = y(i)
            if (y(i) .gt. ymax)  ymax = y(i)
            if (z(i) .lt. zmin)  zmin = z(i)
            if (z(i) .gt. zmax)  zmax = z(i)
         end if
      end do
c
c     load the cubes based on coarse lattice; first of all
c     set edge length to the maximum diameter of any atom
c
      edge = 2.0d0 * rmax
      nx = int((xmax-xmin)/edge) + 1
      ny = int((ymax-ymin)/edge) + 1
      nz = int((zmax-zmin)/edge) + 1
      if (max(nx,ny,nz) .gt. maxcube) then
         write (iout,10)
   10    format (/,' KUNDROT1  --  Increase the Value of MAXCUBE')
         call fatal
      end if
c
c     initialize the coarse lattice of cubes
c
      do i = 1, nx
         do j = 1, ny
            do k = 1, nz
               cube(1,i,j,k) = 0
               cube(2,i,j,k) = 0
            end do
         end do
      end do
c
c     find the number of atoms in each cube
c
      do m = 1, n
         if (.not. skip(m)) then
            i = int((x(m)-xmin)/edge) + 1
            j = int((y(m)-ymin)/edge) + 1
            k = int((z(m)-zmin)/edge) + 1
            cube(1,i,j,k) = cube(1,i,j,k) + 1
         end if
      end do
c
c     determine the highest index in the array "itab" for the
c     atoms that fall into each cube; the first cube that has
c     atoms defines the first index for "itab"; the final index
c     for the atoms in the present cube is the final index of
c     the last cube plus the number of atoms in the present cube
c
      isum = 0
      do i = 1, nx
         do j = 1, ny
            do k = 1, nz
               icube = cube(1,i,j,k)
               if (icube .ne. 0) then
                  isum = isum + icube
                  cube(2,i,j,k) = isum
               end if
            end do
         end do
      end do
c
c     "cube(2,,,)" now contains a pointer to the array "itab"
c     giving the position of the last entry for the list of
c     atoms in that cube of total number equal to "cube(1,,,)"
c
      do m = 1, n
         if (.not. skip(m)) then
            i = int((x(m)-xmin)/edge) + 1
            j = int((y(m)-ymin)/edge) + 1
            k = int((z(m)-zmin)/edge) + 1
            icube = cube(2,i,j,k)
            itab(icube) = m
            cube(2,i,j,k) = icube - 1
         end if
      end do
c
c     set "cube(2,,,)" to be the starting index in "itab"
c     for atom list of that cube; and "cube(1,,,)" to be
c     the stop index
c
      isum = 0
      do i = 1, nx
         do j = 1, ny
            do k = 1, nz
               icube = cube(1,i,j,k)
               if (icube .ne. 0) then
                  isum = isum + icube
                  cube(1,i,j,k) = isum
                  cube(2,i,j,k) = cube(2,i,j,k) + 1
               end if
            end do
         end do
      end do
c
c     process in turn each atom from the coordinate list;
c     first select the potential intersecting atoms
c
      do ir = 1, n
         pre_dx = 0.0d0
         pre_dy = 0.0d0
         pre_dz = 0.0d0
         if (skip(ir))  goto 50
         rr = volrad(ir)
         rrx2 = 2.0d0 * rr
         rrsq = rr * rr
         xr = x(ir)
         yr = y(ir)
         zr = z(ir)
c
c     find cubes to search for overlaps of current atom
c
         istart = int((xr-xmin)/edge)
         istop = min(istart+2,nx)
         istart = max(istart,1)
         jstart = int((yr-ymin)/edge)
         jstop = min(jstart+2,ny)
         jstart = max(jstart,1)
         kstart = int((zr-zmin)/edge)
         kstop = min(kstart+2,nz)
         kstart = max(kstart,1)
c
c     load all overlapping atoms into "inov"
c
         io = 0
         do i = istart, istop
            do j = jstart, jstop
               do k = kstart, kstop
                  mstart = cube(2,i,j,k)
                  if (mstart .ne. 0) then
                     mstop = cube(1,i,j,k)
                     do m = mstart, mstop
                        in = itab(m)
                        if (in .ne. ir) then
                           io = io + 1
                           if (io .gt. maxarc) then
                              write (iout,20)
   20                         format (/,' KUNDROT1  --  Increase ',
     &                                   ' the Value of MAXARC')
                              call fatal
                           end if
                           dx(io) = x(in) - xr
                           dy(io) = y(in) - yr
                           dsq(io) = dx(io)**2 + dy(io)**2
                           dist2 = dsq(io) + (z(in)-zr)**2
                           vdwsum = (rr+volrad(in))**2
                           if (dist2.gt.vdwsum .or. dist2.eq.0.0d0) then
                              io = io - 1
                           else
                              d(io) = sqrt(dsq(io))
                              inov(io) = in
                           end if
                        end if
                     end do
                  end if
               end do
            end do
         end do
c
c     determine resolution along the z-axis
c
         if (io .ne. 0) then
            ztop = zr + rr
            ztopshave = ztop - zstep
            zgrid = zr - rr
c
c     half of the part not covered by the planes
c
            zgrid = zgrid + 0.5d0*(rrx2-(int(rrx2/zstep)*zstep))
            zstart = zgrid
c
c     section atom spheres perpendicular to the z axis
c
            do while (zgrid .le. ztop)
c
c     "rsecr" is radius of circle of intersection
c     of "ir" sphere on the current sphere
c
               rsec2r = rrsq - (zgrid-zr)**2
               if (rsec2r .lt. 0.0d0)  rsec2r = 0.000001d0
               rsecr = sqrt(rsec2r)
               if (zgrid .ge. ztopshave) then
                  cos_phi1 = 1.0d0
                  phi1 = 0.0d0
               else
                  cos_phi1 = (zgrid + 0.5d0*zstep - zr) / rr
                  phi1 = acos(cos_phi1)
               end if
               if (zgrid .eq. zstart) then
                  cos_phi2 = -1.0d0
                  phi2 = pi
               else
                  cos_phi2 = (zgrid - 0.5d0*zstep - zr) / rr
                  phi2 = acos(cos_phi2)
               end if
c
c     check intersections of neighbor circles
c
               narc = 0
               do k = 1, io
                  in = inov(k)
                  rinsq = volrad(in)**2
                  rsec2n = rinsq - (zgrid-z(in))**2
                  if (rsec2n .gt. 0.0d0) then
                     rsecn = sqrt(rsec2n)
                     if (d(k) .lt. rsecr+rsecn) then
                        rdiff = rsecr - rsecn
                        if (d(k) .le. abs(rdiff)) then
                           if (rdiff .lt. 0.0d0) then
                              narc = 1
                              arci(narc) = 0.0d0
                              arcf(narc) = pix2
                           end if
                           goto 40
                        end if
                        narc = narc + 1
                        if (narc .gt. maxarc) then
                           write (iout,30)
   30                      format (/,' KUNDROT1  --  Increase',
     &                                ' the Value of MAXARC')
                           call fatal
                        end if
c
c     initial and final arc endpoints are found for intersection
c     of "ir" circle with another circle contained in same plane;
c     the initial endpoint of the enclosed arc is stored in "arci",
c     the final endpoint in "arcf"; get "cosine" via law of cosines
c
                        cosine = (dsq(k)+rsec2r-rsec2n)
     &                                     / (2.0d0*d(k)*rsecr)
                        cosine = min(1.0d0,max(-1.0d0,cosine))
c
c     "alpha" is the angle between a line containing either point
c     of intersection and the reference circle center and the
c     line containing both circle centers; "beta" is the angle
c     between the line containing both circle centers and x-axis
c
                        alpha = acos(cosine)
                        beta = atan2(dy(k),dx(k))
                        if (dy(k) .lt. 0.0d0)  beta = beta + pix2
                        ti = beta - alpha
                        tf = beta + alpha
                        if (ti .lt. 0.0d0)  ti = ti + pix2
                        if (tf .gt. pix2)  tf = tf - pix2
                        arci(narc) = ti
c
c     if the arc crosses zero, then it is broken into two segments;
c     the first ends at two pi and the second begins at zero
c
                        if (tf .lt. ti) then
                           arcf(narc) = pix2
                           narc = narc + 1
                           arci(narc) = 0.0d0
                        end if
                        arcf(narc) = tf
   40                   continue
                     end if
                  end if
               end do
c
c     find the pre-area and pre-forces on this section (band),
c     "pre-" means a multiplicative factor is yet to be applied
c
               if (narc .eq. 0) then
                  seg_dz = pix2 * (cos_phi1**2 - cos_phi2**2)
                  pre_dz = pre_dz + seg_dz
               else
c
c     sort the arc endpoint arrays, each with "narc" entries,
c     in order of increasing values of the arguments in "arci"
c
                  k = 1
                  do while (k .lt. narc)
                     aa = arci(k)
                     bb = arcf(k)
                     temp = 1000000.0d0
                     do i = k, narc
                        if (arci(i) .le. temp) then
                           temp = arci(i)
                           itemp = i
                        end if
                     end do
                     arci(k) = arci(itemp)
                     arcf(k) = arcf(itemp)
                     arci(itemp) = aa
                     arcf(itemp) = bb
                     k = k + 1
                  end do
c
c     consolidate arcs by removing overlapping arc endpoints
c
                  temp = arcf(1)
                  j = 1
                  do k = 2, narc
                     if (temp .lt. arci(k)) then
                        arcf(j) = temp
                        j = j + 1
                        arci(j) = arci(k)
                        temp = arcf(k)
                     else if (temp .lt. arcf(k)) then
                        temp = arcf(k)
                     end if
                  end do
                  arcf(j) = temp
                  narc = j
                  if (narc .eq. 1) then
                     narc = 2
                     arcf(2) = pix2
                     arci(2) = arcf(1)
                     arcf(1) = arci(1)
                     arci(1) = 0.0d0
                  else
                     temp = arci(1)
                     do k = 1, narc-1
                        arci(k) = arcf(k)
                        arcf(k) = arci(k+1)
                     end do
                     if (temp.eq.0.0d0 .and. arcf(narc).eq.pix2) then
                        narc = narc - 1
                     else
                        arci(narc) = arcf(narc)
                        arcf(narc) = temp
                     end if
                  end if
c
c     compute the numerical pre-derivative values
c
                  do k = 1, narc
                     theta1 = arci(k)
                     theta2 = arcf(k)
                     if (theta2 .ge. theta1) then
                        dtheta = theta2 - theta1
                     else
                        dtheta = (theta2+pix2) - theta1
                     end if
                     phi_term = phi2 - phi1 - 0.5d0*(sin(2.0d0*phi2)
     &                                              -sin(2.0d0*phi1))
                     seg_dx = (sin(theta2)-sin(theta1)) * phi_term
                     seg_dy = (cos(theta1)-cos(theta2)) * phi_term
                     seg_dz = dtheta * (cos_phi1**2 - cos_phi2**2)
                     pre_dx = pre_dx + seg_dx
                     pre_dy = pre_dy + seg_dy
                     pre_dz = pre_dz + seg_dz
                  end do
               end if
               zgrid = zgrid + zstep
            end do
         end if
   50    continue
         dex(1,ir) = 0.5d0 * rrsq * pre_dx
         dex(2,ir) = 0.5d0 * rrsq * pre_dy
         dex(3,ir) = 0.5d0 * rrsq * pre_dz
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (itab)
      deallocate (volrad)
      deallocate (skip)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine kundrot2  --  Cartesian excluded volume Hessian  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "kundrot2" calculates second derivatives of the total excluded
c     volume with respect to the Cartesian coordinates of the atoms
c     using a numerical method due to Craig Kundrot
c
c     literature reference:
c
c     C. E. Kundrot, J. W. Ponder and F. M. Richards, "Algorithms for
c     Calculating Excluded Volume and Its Derivatives as a Function
c     of Molecular Conformation and Their Use in Energy Minimization",
c     Journal of Computational Chemistry, 12, 402-409 (1991)
c
c
      subroutine kundrot2 (iatom,n,x,y,z,rad,probe,xhess,yhess,zhess)
      use iounit
      use math
      implicit none
      integer maxarc
      parameter (maxarc=1000)
      integer i,j,k,m,n
      integer in,iaa,ibb
      integer iatom,narc
      integer iblock,itemp
      integer idtemp,idfirst
      integer nnear,id(0:2)
      integer inear(maxarc)
      integer arciatom(maxarc)
      integer arcfatom(maxarc)
      real*8 xr,yr,zr
      real*8 probe,zstep
      real*8 ztop,ztopshave,zstart
      real*8 aa,bb,temp,tempf
      real*8 phi1,phi2,phiold
      real*8 theta1,theta2,firsti
      real*8 zgrid,rsec2r,rsecr
      real*8 pix2,dist2,rcut2
      real*8 rr,rrx2,rrsq
      real*8 alpha,beta,gamma
      real*8 ti,tf,ri,s2,b,cosine
      real*8 rinsq,rsecn,rsec2n
      real*8 cos1,cos2,sin1,sin2
      real*8 phi_xy,phi_z
      real*8 delx(2),dely(2),delz(2)
      real*8 r_s(2),r_s2(2),u(2)
      real*8 r(0:2),r_r(0:2)
      real*8 duds(2),dudr(2)
      real*8 u_term(2)
      real*8 dfdtheta(3,2)
      real*8 dthetadx(2,3,0:2)
      real*8 dalphdx(2,3,0:2)
      real*8 dbetadx(2,2,0:2)
      real*8 dudx(2,3,0:2)
      real*8 dsdx(2,2,0:2)
      real*8 drdz(2,0:2)
      real*8 arci(maxarc)
      real*8 arcf(maxarc)
      real*8 dx(maxarc)
      real*8 dy(maxarc)
      real*8 dsq(maxarc)
      real*8 d(maxarc)
      real*8 x(*)
      real*8 y(*)
      real*8 z(*)
      real*8 rad(*)
      real*8, allocatable :: volrad(:)
      real*8 xhess(3,*)
      real*8 yhess(3,*)
      real*8 zhess(3,*)
      logical covered
c
c
c     set the step size in z-direction, which controls derivative
c     accuracy; step of 0.06 balances compute time and accuracy
c     for large systems, while step of 0.01 gives higher accuracy
c
c     zstep = 0.0601d0
      zstep = 0.0101d0
c
c     zero out the Hessian elements for current atom
c
      do i = 1, n
         do j = 1, 3
            xhess(j,i) = 0.0d0
            yhess(j,i) = 0.0d0
            zhess(j,i) = 0.0d0
         end do
      end do
      if (rad(iatom) .eq. 0.0d0)  return
      pix2 = 2.0d0 * pi
c
c     perform dynamic allocation of some local arrays
c
      allocate (volrad(n))
c
c     assign van der Waals radii to the atoms; note that
c     the radii are incremented by the size of the probe
c
      do i = 1, n
         volrad(i) = rad(i)
         if (volrad(i) .ne. 0.0d0)  volrad(i) = volrad(i) + probe
      end do
c
c     set the radius and coordinates for current atom
c
      rr = volrad(iatom)
      rrx2 = 2.0d0 * rr
      rrsq = rr**2
      xr = x(iatom)
      yr = y(iatom)
      zr = z(iatom)
c
c     select potential intersecting atoms
c
      nnear = 1
      do j = 1, n
         if (j.ne.iatom .and. volrad(j).ne.0.0d0) then
            dx(nnear) = x(j) - xr
            dy(nnear) = y(j) - yr
            dsq(nnear) = dx(nnear)**2 + dy(nnear)**2
            dist2 = dsq(nnear) + (z(j)-zr)**2
            rcut2 = (volrad(j) + rr)**2
            if (dist2 .lt. rcut2) then
               d(nnear) = sqrt(dsq(nnear))
               inear(nnear) = j
               nnear = nnear + 1
               if (nnear .gt. maxarc) then
                  write (iout,10)
   10             format (/,' KUNDROT2  --  Increase',
     &                       ' the Value of MAXARC')
                  call fatal
               end if
            end if
         end if
      end do
      nnear = nnear - 1
c
c     determine the z resolution
c
      if (nnear .ne. 0) then
         ztop = zr + rr
         ztopshave = ztop - zstep
         zgrid = zr - rr
c
c     half of the part not covered by the planes
c
         zgrid = zgrid + (0.5d0*(rrx2-(int(rrx2/zstep)*zstep)))
         zstart = zgrid
c
c     section atom spheres perpendicular to the z axis
c
         do while (zgrid .le. ztop)
c
c     "rsecr" is radius of current atom sphere on the z-plane
c
            rsec2r = rrsq - (zgrid-zr)**2
            if (rsec2r .lt. 0.0d0) then
               rsec2r = 0.000001d0
            end if
            rsecr = sqrt(rsec2r)
            if (zgrid .ge. ztopshave) then
               phi1 = 0.0d0
            else
               phi1 = acos(((zgrid+0.5d0*zstep)-zr) / rr)
            end if
            if (zgrid .eq. zstart) then
               phi2 = pi
            else
               phi2 = phiold
            end if
c
c     check intersections of neighbor circles
c
            k = 0
            narc = 0
            covered = .false.
            do while (.not.covered .and. k.lt.nnear
     &                   .and. narc.lt.maxarc)
               k = k + 1
               in = inear(k)
               rinsq = volrad(in)**2
               rsec2n = rinsq - (zgrid-z(in))**2
               if (rsec2n .gt. 0.0d0) then
                  rsecn = sqrt(rsec2n)
                  if (d(k) .lt. rsecr+rsecn) then
                     b = rsecr - rsecn
                     if (d(k) .le. abs(b)) then
                        if (b .lt. 0.0d0) then
                           narc = 1
                           arci(narc) = 0.0d0
                           arcf(narc) = pix2
                           arciatom(narc) = in
                           arcfatom(narc) = in
                           covered = .true.
                        end if
                     else
                        narc = narc + 1
                        if (narc .gt. maxarc) then
                           write (iout,20)
   20                      format (/,' KUNDROT2  -- Increase',
     &                                ' the Value of MAXARC')
                           call fatal
                        else
c
c     initial and final arc endpoints are found for intersection
c     of "ir" circle with another circle contained in same plane;
c     the initial endpoint of the enclosed arc is stored in "arci",
c     the final endpoint in "arcf"; get "cosine" via law of cosines
c
                           cosine = (dsq(k)+rsec2r-rsec2n) /
     &                                      (2.0d0*d(k)*rsecr)
                           cosine = min(1.0d0,max(-1.0d0,cosine))
c
c     "alpha" is the angle between a line containing either point
c     of intersection and the reference circle center and the
c     line containing both circle centers; "beta" is the angle
c     between the line containing both circle centers and x-axis
c
                           alpha = acos(cosine)
                           if (dx(k) .eq. 0.0d0) then
                              gamma = 0.5d0 * pi
                           else
                              gamma = atan(abs(dy(k)/dx(k)))
                           end if
                           if (dy(k) .gt. 0.0d0) then
                              if (dx(k) .gt. 0.0d0) then
                                 beta = gamma
                              else
                                 beta = pi - gamma
                              end if
                           else
                              if (dx(k) .gt. 0.0d0) then
                                 beta = pix2 - gamma
                              else
                                 beta = pi + gamma
                              end if
                           end if
c
c     finally, the arc endpoints
c
                           ti = beta - alpha
                           tf = beta + alpha
                           if (ti .lt. 0.0d0)  ti = ti + pix2
                           if (tf .gt. pix2)  tf = tf - pix2
                           arci(narc) = ti
                           arciatom(narc) = in
                           arcfatom(narc) = in
                           if (tf .lt. ti) then
                              arcf(narc) = pix2
                              narc = narc + 1
                              arci(narc) = 0.0d0
                              arciatom(narc) = in
                              arcfatom(narc) = in
                           end if
                           arcf(narc) = tf
                        end if
                     end if
                  end if
               end if
            end do
c
c     find the pre-area and pre-forces on this section (band)
c     through sphere "ir"; the "pre-" means a multiplicative
c     factor is yet to be applied
c
            if (narc .ne. 0) then
c
c     general case; sort arc endpoints
c
               k = 1
               do while (k .lt. narc)
                  aa = arci(k)
                  bb = arcf(k)
                  iaa = arciatom(k)
                  ibb = arcfatom(k)
                  temp = 10000000.0d0
                  do i = k, narc
                     if (arci(i) .le. temp) then
                        temp = arci(i)
                        itemp = i
                     end if
                  end do
                  arci(k) = arci(itemp)
                  arcf(k) = arcf(itemp)
                  arciatom(k) = arciatom(itemp)
                  arcfatom(k) = arcfatom(itemp)
                  arci(itemp) = aa
                  arcf(itemp) = bb
                  arciatom(itemp) = iaa
                  arcfatom(itemp) = ibb
                  k = k + 1
               end do
c
c     eliminate overlapping arc endpoints;
c     first, consolidate the occluded arcs
c
               m = 1
               tempf = arcf(1)
               idtemp = arcfatom(1)
               do k = 2, narc
                  if (tempf .lt. arci(k)) then
                     arcf(m) = tempf
                     arcfatom(m) = idtemp
                     m = m + 1
                     arci(m) = arci(k)
                     arciatom(m) = arciatom(k)
                     tempf = arcf(k)
                     idtemp = arcfatom(k)
                  else if (tempf .lt. arcf(k)) then
                     tempf = arcf(k)
                     idtemp = arcfatom(k)
                  end if
               end do
               arcf(m) = tempf
               arcfatom(m) = idtemp
               narc = m
c
c     change occluded arcs to accessible arcs
c
               if (narc .eq. 1) then
                  if (arci(1).eq.0.0d0 .and. arcf(1).eq.pix2) then
                     narc = 0
                  else
                     firsti = arci(1)
                     idfirst = arciatom(1)
                     arci(1) = arcf(1)
                     arciatom(1) = arcfatom(1)
                     arcf(1) = firsti + pix2
                     arcfatom(1) = idfirst
                  end if
               else
                  firsti = arci(1)
                  idfirst = arciatom(1)
                  do k = 1, narc-1
                     arci(k) = arcf(k)
                     arciatom(k) = arcfatom(k)
                     arcf(k) = arci(k+1)
                     arcfatom(k) = arciatom(k+1)
                  end do
c
c     check gap between first and last arcs; if the
c     occluded arc crossed zero, then no accessible arc
c
                  if (firsti.eq.0.0d0 .and. arcf(narc).eq.pix2) then
                     narc = narc - 1
                  else
                     arci(narc) = arcf(narc)
                     arciatom(narc) = arcfatom(narc)
                     arcf(narc) = firsti
                     arcfatom(narc) = idfirst
                  end if
               end if
c
c     setup prior to application of chain rule
c
               do k = 1, narc
                  ri = sqrt(rrsq - (zgrid-zr)**2)
                  do i = 1, 2
                     if (i .eq. 1) then
                        id(1) = arciatom(k)
                     else
                        id(2) = arcfatom(k)
                     end if
                     delx(i) = x(id(i)) - xr
                     dely(i) = y(id(i)) - yr
                     delz(i) = zgrid - z(id(i))
                     s2 = delx(i)**2 + dely(i)**2
                     r_s(i) = 1.0d0 / sqrt(s2)
                     r_s2(i) = r_s(i)**2
                     r(i) = sqrt(volrad(id(i))**2 - delz(i)**2)
                     r_r(i) = 1.0d0 / r(i)
                     u(i) = (ri**2+s2-r(i)**2) * (0.5d0*r_s(i)/ri)
                  end do
c
c     apply the chain rule repeatedly
c
                  theta1 = arci(k)
                  theta2 = arcf(k)
                  cos1 = cos(theta1)
                  cos2 = cos(theta2)
                  sin1 = sin(theta1)
                  sin2 = sin(theta2)
                  phi_xy = phi2 - phi1 - 0.5d0*(sin(2.0d0*phi2)
     &                                         -sin(2.0d0*phi1))
                  phi_z = sin(phi2)**2 - sin(phi1)**2
                  phi_xy = 0.5d0 * rrsq * phi_xy
                  phi_z = 0.5d0 * rrsq * phi_z
                  dfdtheta(1,1) = -cos1 * phi_xy
                  dfdtheta(2,1) = -sin1 * phi_xy
                  dfdtheta(3,1) = -phi_z
                  dfdtheta(1,2) = cos2 * phi_xy
                  dfdtheta(2,2) = sin2 * phi_xy
                  dfdtheta(3,2) = phi_z
                  do i = 1, 2
                     dbetadx(i,1,0) = dely(i) * r_s2(i)
                     dbetadx(i,2,0) = -delx(i) * r_s2(i)
                     dbetadx(i,1,i) = -dbetadx(i,1,0)
                     dbetadx(i,2,i) = -dbetadx(i,2,0)
                  end do
                  do i = 1, 2
                     duds(i) = (1.0d0/ri) - (u(i)*r_s(i))
                     dsdx(i,1,i) = delx(i) * r_s(i)
                     dsdx(i,2,i) = dely(i) * r_s(i)
                     dsdx(i,1,0) = -dsdx(i,1,i)
                     dsdx(i,2,0) = -dsdx(i,2,i)
                     dudr(i) = -r(i) * r_s(i) / ri
                     drdz(i,i) = delz(i) * r_r(i)
                     drdz(i,0) = -drdz(i,i)
                  end do
                  do m = 0, 2
                     do i = 1, 2
                        dudx(i,1,m) = duds(i) * dsdx(i,1,m)
                        dudx(i,2,m) = duds(i) * dsdx(i,2,m)
                        dudx(i,3,m) = dudr(i) * drdz(i,m)
                     end do
                  end do
                  do i = 1, 2
                     u_term(i) = -1.0d0 / sqrt(1.0d0-u(i)**2)
                  end do
                  do j = 1, 3
                     do m = 0, 2
                        do i = 1, 2
                           dalphdx(i,j,m) = u_term(i) * dudx(i,j,m)
                        end do
                     end do
                  end do
                  do j = 1, 2
                     do m = 0, 2
                        dthetadx(1,j,m) = dbetadx(1,j,m)
     &                                       + dalphdx(1,j,m)
                        dthetadx(2,j,m) = dbetadx(2,j,m)
     &                                       - dalphdx(2,j,m)
                     end do
                  end do
                  do m = 0, 2
                     dthetadx(1,3,m) = dalphdx(1,3,m)
                     dthetadx(2,3,m) = -dalphdx(2,3,m)
                  end do
c
c     partials with respect to coordinates of serial atom id(m)
c
                  id(0) = iatom
                  do m = 0, 2
                     iblock = id(m)
                     do j = 1, 3
                        xhess(j,iblock) = xhess(j,iblock)
     &                     + dfdtheta(1,1)*dthetadx(1,j,m)
     &                     + dfdtheta(1,2)*dthetadx(2,j,m)
                        yhess(j,iblock) = yhess(j,iblock)
     &                     + dfdtheta(2,1)*dthetadx(1,j,m)
     &                     + dfdtheta(2,2)*dthetadx(2,j,m)
                        zhess(j,iblock) = zhess(j,iblock)
     &                     + dfdtheta(3,1)*dthetadx(1,j,m)
     &                     + dfdtheta(3,2)*dthetadx(2,j,m)
                     end do
                  end do
               end do
            end if
            zgrid = zgrid + zstep
            phiold = phi1
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (volrad)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine kurey  --  Urey-Bradley parameter assignment  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "kurey" assigns the force constants and ideal distances
c     for the Urey-Bradley 1-3 interactions; also processes any
c     new or changed parameter values
c
c
      subroutine kurey
      use angbnd
      use atomid
      use atoms
      use inform
      use iounit
      use keys
      use kurybr
      use potent
      use urey
      implicit none
      integer i,j,nu
      integer ia,ib,ic
      integer ita,itb,itc
      integer size,next
      real*8 bb,tt
      logical header
      character*4 pa,pb,pc
      character*12 blank,pt
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing Urey-Bradley parameters
c
      blank = '            '
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:9) .eq. 'UREYBRAD ') then
            ia = 0
            ib = 0
            ic = 0
            bb = 0.0d0
            tt = 0.0d0
            string = record(next:240)
            read (string,*,err=10,end=10)  ia,ib,ic,bb,tt
   10       continue
            if (min(ia,ib,ic) .lt. 0)  goto 50
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Urey-Bradley Parameters :',
     &                    //,5x,'Atom Classes',12x,'K(UB)',
     &                       7x,'Distance',/)
               end if
               write (iout,30)  ia,ib,ic,bb,tt
   30          format (4x,3i4,3x,f15.3,f15.4)
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            if (ia .le. ic) then
               pt = pa//pb//pc
            else
               pt = pc//pb//pa
            end if
            do j = 1, maxnu
               if (ku(j).eq.blank .or. ku(j).eq.pt) then
                  ku(j) = pt
                  ucon(j) = bb
                  dst13(j) = tt
                  goto 50
               end if
            end do
            write (iout,40)
   40       format (/,' KUREY  --  Too many Urey-Bradley',
     &                 ' Interaction Parameters')
            abort = .true.
   50       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      nu = maxnu
      do i = maxnu, 1, -1
         if (ku(i) .eq. blank)  nu = i - 1
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(iury))  deallocate (iury)
      if (allocated(uk))  deallocate (uk)
      if (allocated(ul))  deallocate (ul)
      allocate (iury(3,nangle))
      allocate (uk(nangle))
      allocate (ul(nangle))
c
c     assign the Urey-Bradley parameters for each angle
c
      nurey = 0
      if (nu .ne. 0) then
         do i = 1, nangle
            ia = iang(1,i)
            ib = iang(2,i)
            ic = iang(3,i)
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            size = 4
            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
            do j = 1, nu
               if (ku(j) .eq. pt) then
                  nurey = nurey + 1
                  iury(1,nurey) = ia
                  iury(2,nurey) = ib
                  iury(3,nurey) = ic
                  uk(nurey) = ucon(j)
                  ul(nurey) = dst13(j)
                  goto 60
               end if
            end do
   60       continue
         end do
      end if
c
c     process keywords containing Urey-Bradley specific parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:9) .eq. 'UREYBRAD ') then
            ia = 0
            ib = 0
            ic = 0
            bb = 0.0d0
            tt = 0.0d0
            string = record(next:240)
            read (string,*,err=70,end=70)  ia,ib,ic,bb,tt
   70       continue
            if (min(ia,ib,ic) .lt. 0) then
               ia = abs(ia)
               ib = abs(ib)
               ic = abs(ic)
               if (header .and. .not.silent) then
                  header = .false.
                  write (iout,80)
   80             format (/,' Additional Urey-Bradley Parameters',
     &                       ' for Specific Angles :',
     &                    //,8x,'Atoms',16x,'K(UB)',7x,'Distance',/)
               end if
               if (.not. silent) then
                  write (iout,90)  ia,ib,ic,bb,tt
   90             format (4x,3i4,3x,f15.3,f15.4)
               end if
               do j = 1, nurey
                  ita = iury(1,j)
                  itb = iury(2,j)
                  itc = iury(3,j)
                  if (ib .eq. itb) then
                     if ((ia.eq.ita .and. ic.eq.itc) .or.
     &                   (ia.eq.itc .and. ic.eq.ita)) then
                        uk(j) = bb
                        ul(j) = tt
                        goto 100
                     end if
                  end if
               end do
            end if
  100       continue
         end if
      end do
c
c     turn off the Urey-Bradley potential if it is not used
c
      if (nurey .eq. 0)  use_urey = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module kurybr  --  Urey-Bradley term forcefield parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     maxnu   maximum number of Urey-Bradley parameter entries
c
c     ucon    force constant parameters for Urey-Bradley terms
c     dst13   ideal 1-3 distance parameters for Urey-Bradley terms
c     ku      string of atom classes for Urey-Bradley terms
c
c
      module kurybr
      implicit none
      integer maxnu
      real*8, allocatable :: ucon(:)
      real*8, allocatable :: dst13(:)
      character*12, allocatable :: ku(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine kvdw  --  van der Waals parameter assignment  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "kvdw" assigns the parameters to be used in computing the
c     van der Waals interactions and processes any new or changed
c     values for these parameters
c
c
      subroutine kvdw
      use atomid
      use atoms
      use couple
      use fields
      use inform
      use iounit
      use keys
      use khbond
      use kvdws
      use kvdwpr
      use math
      use merck
      use potent
      use vdw
      use vdwpot
      implicit none
      integer i,j,k
      integer ii,kk
      integer ia,ib
      integer next,size
      integer maxdim
      integer nlist,number
      integer, allocatable :: list(:)
      real*8 rd,ep,rdn,gik
      real*8, allocatable :: srad(:)
      real*8, allocatable :: srad4(:)
      real*8, allocatable :: seps(:)
      real*8, allocatable :: seps4(:)
      logical header
      character*4 pa,pb
      character*8 blank,pt
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     process keywords containing van der Waals parameters
c
      maxdim = maxclass
      if (vdwindex .eq. 'TYPE')  maxdim = maxtyp
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:4) .eq. 'VDW ') then
            call getnumb (record,k,next)
            if (k.gt.0 .and. k.le.maxdim) then
               rd = 0.0d0
               ep = 0.0d0
               rdn = 0.0d0
               string = record(next:240)
               read (string,*,err=10,end=10)  rd,ep,rdn
   10          continue
               if (header .and. .not.silent) then
                  header = .false.
                  if (vdwindex .eq. 'CLASS') then
                     write (iout,20)
   20                format (/,' Additional van der Waals Parameters :',
     &                       //,5x,'Atom Class',15x,'Size',
     &                          8x,'Epsilon',8x,'Reduction',/)
                  else
                     write (iout,30)
   30                format (/,' Additional van der Waals Parameters :',
     &                       //,5x,'Atom Type',16x,'Size',
     &                          8x,'Epsilon',8x,'Reduction',/)
                  end if
               end if
               rad(k) = rd
               eps(k) = ep
               reduct(k) = rdn
               if (.not. silent) then
                  write (iout,40)  k,rd,ep,rdn
   40             format (6x,i6,7x,2f15.4,f15.3)
               end if
            else if (k .gt. maxclass) then
               write (iout,50)  maxclass
   50          format (/,' KVDW  --  Only Atom Classes through',i4,
     &                    ' are Allowed')
               abort = .true.
            end if
         end if
      end do
c
c     process keywords containing 1-4 van der Waals parameters
c
      maxdim = maxclass
      if (vdwindex .eq. 'TYPE')  maxdim = maxtyp
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:6) .eq. 'VDW14 ') then
            call getnumb (record,k,next)
            if (k.gt.0 .and. k.le.maxdim) then
               rd = 0.0d0
               ep = 0.0d0
               string = record(next:240)
               read (string,*,err=60,end=60)  rd,ep
   60          continue
               if (header .and. .not.silent) then
                  header = .false.
                  if (vdwindex .eq. 'CLASS') then
                     write (iout,70)
   70                format (/,' Additional 1-4 van der Waals',
     &                          ' Parameters :',
     &                       //,5x,'Atom Class',15x,'Size',
     &                          8x,'Epsilon',/)
                  else
                     write (iout,80)
   80                format (/,' Additional 1-4 van der Waals',
     &                          ' Parameters :',
     &                       //,5x,'Atom Type',16x,'Size',
     &                          8x,'Epsilon',/)
                  end if
               end if
               rad4(k) = rd
               eps4(k) = ep
               if (.not. silent) then
                  write (iout,90)  k,rd,ep
   90             format (6x,i6,7x,2f15.4)
               end if
            else if (k .gt. maxclass) then
               write (iout,100)  maxclass
  100          format (/,' KVDW  --  Only Atom Classes through',i4,
     &                    ' are Allowed')
               abort = .true.
            end if
         end if
      end do
c
c     process keywords containing specific pair vdw parameters
c
      blank = '        '
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:8) .eq. 'VDWPAIR ' .or.
     &       keyword(1:6) .eq. 'VDWPR ') then
            ia = 0
            ib = 0
            rd = 0.0d0
            ep = 0.0d0
            string = record(next:240)
            read (string,*,err=150,end=150)  ia,ib,rd,ep
            if (header .and. .not.silent) then
               header = .false.
               if (vdwindex .eq. 'CLASS') then
                  write (iout,110)
  110             format (/,' Additional van der Waals Parameters',
     &                       ' for Specific Pairs :',
     &                    //,5x,'Atom Classes',9x,'Size Sum',
     &                       8x,'Epsilon',/)
               else
                  write (iout,120)
  120             format (/,' Additional van der Waals Parameters',
     &                       ' for Specific Pairs :',
     &                    //,5x,'Atom Types',11x,'Size Sum',
     &                       8x,'Epsilon',/)
               end if
            end if
            if (.not. silent) then
               write (iout,130)  ia,ib,rd,ep
  130          format (6x,2i4,5x,2f15.4)
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            if (ia .le. ib) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            do k = 1, maxnvp
               if (kvpr(k).eq.blank .or. kvpr(k).eq.pt) then
                  kvpr(k) = pt
                  radpr(k) = rd
                  epspr(k) = ep
                  goto 150
               end if
            end do
            write (iout,140)
  140       format (/,' KVDW  --  Too many Special Pair VDW',
     &                 ' Parameters')
            abort = .true.
  150       continue
         end if
      end do
c
c     process keywords containing hydrogen bonding vdw parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:6) .eq. 'HBOND ') then
            ia = 0
            ib = 0
            rd = 0.0d0
            ep = 0.0d0
            string = record(next:240)
            read (string,*,err=200,end=200)  ia,ib,rd,ep
            if (header .and. .not.silent) then
               header = .false.
               if (vdwindex .eq. 'CLASS') then
                  write (iout,160)
  160             format (/,' Additional van der Waals Hydrogen',
     &                       ' Bonding Parameters :',
     &                    //,5x,'Atom Classes',9x,'Size Sum',
     &                       8x,'Epsilon',/)
               else
                  write (iout,170)
  170             format (/,' Additional van der Waals Hydrogen',
     &                       ' Bonding Parameters :',
     &                    //,5x,'Atom Types',11x,'Size Sum',
     &                       8x,'Epsilon',/)
               end if
            end if
            if (.not. silent) then
               write (iout,180)  ia,ib,rd,ep
  180          format (6x,2i4,5x,2f15.4)
            end if
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            if (ia .le. ib) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            do k = 1, maxnvp
               if (khb(k).eq.blank .or. khb(k).eq.pt) then
                  khb(k) = pt
                  radhb(k) = rd
                  epshb(k) = ep
                  goto 200
               end if
            end do
            write (iout,190)
  190       format (/,' KVDW  --  Too many Hydrogen Bonding Pair',
     &                 ' Parameters')
            abort = .true.
  200       continue
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(ivdw))  deallocate (ivdw)
      if (allocated(jvdw))  deallocate (jvdw)
      if (allocated(mvdw))  deallocate (mvdw)
      if (allocated(ired))  deallocate (ired)
      if (allocated(kred))  deallocate (kred)
      if (allocated(xred))  deallocate (xred)
      if (allocated(yred))  deallocate (yred)
      if (allocated(zred))  deallocate (zred)
      allocate (ivdw(n))
      allocate (jvdw(n))
      allocate (mvdw(maxtyp))
      allocate (ired(n))
      allocate (kred(n))
      allocate (xred(n))
      allocate (yred(n))
      allocate (zred(n))
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
      allocate (srad(maxtyp))
      allocate (srad4(maxtyp))
      allocate (seps(maxtyp))
      allocate (seps4(maxtyp))
c
c     set type or class index into condensed pair matrices
c
      nlist = n
      do i = 1, n
         list(i) = 0
         if (vdwindex .eq. 'TYPE') then
            list(i) = type(i)
         else
            list(i) = class(i)
         end if
         jvdw(i) = list(i)
      end do
      call sort8 (nlist,list)
      do i = 1, maxtyp
         mvdw(i) = 0
      end do
      do i = 1, n
         j = jvdw(i)
         if (mvdw(j) .eq. 0) then
            do k = 1, nlist
               if (list(k) .eq. j)  mvdw(j) = k
            end do
         end if
      end do
      do i = 1, n
         if (vdwindex .eq. 'TYPE') then
            k = type(i)
            jvdw(i) = mvdw(k)
         else
            k = class(i)
            jvdw(i) = mvdw(k)
         end if
      end do
c
c     get the vdw radii and well depths for each atom type
c
      maxdim = maxclass
      if (vdwindex .eq. 'TYPE')  maxdim = maxtyp
      do i = 1, maxdim
         if (rad4(i) .eq. 0.0d0)  rad4(i) = rad(i)
         if (eps4(i) .eq. 0.0d0)  eps4(i) = eps(i)
         if (radtyp .eq. 'SIGMA') then
            rad(i) = twosix * rad(i)
            rad4(i) = twosix * rad4(i)
         end if
         if (radsiz .eq. 'DIAMETER') then
            rad(i) = 0.5d0 * rad(i)
            rad4(i) = 0.5d0 * rad4(i)
         end if
         srad(i) = sqrt(rad(i))
         eps(i) = abs(eps(i))
         seps(i) = sqrt(eps(i))
         srad4(i) = sqrt(rad4(i))
         eps4(i) = abs(eps4(i))
         seps4(i) = sqrt(eps4(i))
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(radmin))  deallocate (radmin)
      if (allocated(epsilon))  deallocate (epsilon)
      if (allocated(radmin4))  deallocate (radmin4)
      if (allocated(epsilon4))  deallocate (epsilon4)
      if (allocated(radhbnd))  deallocate (radhbnd)
      if (allocated(epshbnd))  deallocate (epshbnd)
      allocate (radmin(nlist,nlist))
      allocate (epsilon(nlist,nlist))
      allocate (radmin4(nlist,nlist))
      allocate (epsilon4(nlist,nlist))
      allocate (radhbnd(nlist,nlist))
      allocate (epshbnd(nlist,nlist))
c
c     use combination rules to set pairwise vdw radii sums
c
      do ii = 1, nlist
         i = list(ii)
         do kk = ii, nlist
            k = list(kk)
            if (radrule(1:6) .eq. 'MMFF94') then
               if (i .ne. k) then
                  rd = 0.5d0 * (rad(i)+rad(k))
                  if (DA(i).ne.'D' .and. DA(k).ne.'D') then
                     if (rd .ne. 0.0d0) then
                        gik = (rad(i)-rad(k))/(rad(i)+rad(k))
                        rd = (1.0d0+0.2d0*(1.0d0-exp(-12.0d0*gik*gik)))
     &                           * rd
                     end if
                  end if
               else
                  rd = rad(i)
               end if
            else if (rad(i).eq.0.0d0 .and. rad(k).eq.0.0d0) then
               rd = 0.0d0
            else if (radrule(1:10) .eq. 'ARITHMETIC') then
               rd = rad(i) + rad(k)
            else if (radrule(1:9) .eq. 'GEOMETRIC') then
               rd = 2.0d0 * (srad(i) * srad(k))
            else if (radrule(1:10) .eq. 'CUBIC-MEAN') then
               rd = 2.0d0 * (rad(i)**3+rad(k)**3)/(rad(i)**2+rad(k)**2)
            else
               rd = rad(i) + rad(k)
            end if
            radmin(ii,kk) = rd
            radmin(kk,ii) = rd
         end do
      end do
c
c     use combination rules to set pairwise well depths
c
      do ii = 1, nlist
         i = list(ii)
         do kk = ii, nlist
            k = list(kk)
            if (epsrule(1:6) .eq. 'MMFF94') then
               ep = 0.0d0
               if (nn(i).ne.0.0d0 .and. nn(k).ne.0.0d0
     &                .and. radmin(ii,kk).ne.0.0d0) then
                  ep = 181.16d0*g(i)*g(k)*alph(i)*alph(k)
     &                    / ((sqrt(alph(i)/nn(i))+sqrt(alph(k)/nn(k)))
     &                                 *radmin(ii,kk)**6)
               end if
               if (i .eq. k)  eps(i) = ep
            else if (eps(i).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(i) + eps(k))
            else if (epsrule(1:9) .eq. 'GEOMETRIC') then
               ep = seps(i) * seps(k)
            else if (epsrule(1:8) .eq. 'HARMONIC') then
               ep = 2.0d0 * (eps(i)*eps(k)) / (eps(i)+eps(k))
            else if (epsrule(1:3) .eq. 'HHG') then
               ep = 4.0d0 * (eps(i)*eps(k)) / (seps(i)+seps(k))**2
            else if (epsrule(1:3) .eq. 'W-H') then
               ep = 2.0d0 * (seps(i)*seps(k)) * (rad(i)*rad(k))**3
     &                 / (rad(i)**6+rad(k)**6)
            else
               ep = seps(i) * seps(k)
            end if
            epsilon(ii,kk) = ep
            epsilon(kk,ii) = ep
         end do
      end do
c
c     use combination rules to set pairwise 1-4 vdw radii sums
c
      do ii = 1, nlist
         i = list(ii)
         do kk = ii, nlist
            k = list(kk)
            if (radrule(1:6) .eq. 'MMFF94') then
               if (i .ne. k) then
                  rd = 0.5d0 * (rad(i)+rad(k))
                  if (DA(i).ne.'D' .and. DA(k).ne.'D') then
                     if (rd .ne. 0.0d0) then
                        gik = (rad(i)-rad(k))/(rad(i)+rad(k))
                        rd = (1.0d0+0.2d0*(1.0d0-exp(-12.0d0*gik*gik)))
     &                           * rd
                     end if
                  end if
               else
                  rd = rad(i)
               end if
            else if (rad4(i).eq.0.0d0 .and. rad4(k).eq.0.0d0) then
               rd = 0.0d0
            else if (radrule(1:10) .eq. 'ARITHMETIC') then
               rd = rad4(i) + rad4(k)
            else if (radrule(1:9) .eq. 'GEOMETRIC') then
               rd = 2.0d0 * (srad4(i) * srad4(k))
            else if (radrule(1:10) .eq. 'CUBIC-MEAN') then
               rd = 2.0d0 * (rad4(i)**3+rad4(k)**3)
     &                         / (rad4(i)**2+rad4(k)**2)
            else
               rd = rad4(i) + rad4(k)
            end if
            radmin4(ii,kk) = rd
            radmin4(kk,ii) = rd
         end do
      end do
c
c     use combination rules to set pairwise 1-4 well depths
c
      do ii = 1, nlist
         i = list(ii)
         do kk = ii, nlist
            k = list(kk)
            if (epsrule(1:6) .eq. 'MMFF94') then
               ep = 0.0d0
               if (nn(i).ne.0.0d0 .and. nn(k).ne.0.0d0
     &                .and. radmin4(ii,kk).ne.0.0d0) then
                  ep = 181.16d0*G(i)*G(k)*alph(i)*alph(k)
     &                    / ((sqrt(alph(i)/nn(i))+sqrt(alph(k)/nn(k)))
     &                                 *radmin4(ii,kk)**6)
               end if
               if (i .eq. k)  eps4(i) = ep
            else if (eps4(i).eq.0.0d0 .and. eps4(k).eq.0.0d0) then
               ep = 0.0d0
            else if (epsrule(1:10) .eq. 'ARITHMETIC') then
               ep = 0.5d0 * (eps4(i) + eps4(k))
            else if (epsrule(1:9) .eq. 'GEOMETRIC') then
               ep = seps4(i) * seps4(k)
            else if (epsrule(1:8) .eq. 'HARMONIC') then
               ep = 2.0d0 * (eps4(i)*eps4(k)) / (eps4(i)+eps4(k))
            else if (epsrule(1:3) .eq. 'HHG') then
               ep = 4.0d0 * (eps4(i)*eps4(k)) / (seps4(i)+seps4(k))**2
            else if (epsrule(1:3) .eq. 'W-H') then
               ep = 2.0d0 * (seps4(i)*seps4(k)) * (rad4(i)*rad4(k))**3
     &                 / (rad4(i)**6+rad4(k)**6)
            else
               ep = seps4(i) * seps4(k)
            end if
            epsilon4(ii,kk) = ep
            epsilon4(kk,ii) = ep
         end do
      end do
c
c     use reduced values for MMFF donor-acceptor pairs
c
      if (forcefield .eq. 'MMFF94') then
         do ii = 1, nlist
            i = list(ii)
            do kk = ii, nlist
               k = list(kk)
               if ((da(i).eq.'D' .and. da(k).eq.'A') .or.
     &             (da(i).eq.'A' .and. da(k).eq.'D')) then
                  epsilon(ii,kk) = epsilon(ii,kk) * 0.5d0
                  epsilon(kk,ii) = epsilon(kk,ii) * 0.5d0
                  radmin(ii,kk) = radmin(ii,kk) * 0.8d0
                  radmin(kk,ii) = radmin(kk,ii) * 0.8d0
                  epsilon4(ii,kk) = epsilon4(ii,kk) * 0.5d0
                  epsilon4(kk,ii) = epsilon4(kk,ii) * 0.5d0
                  radmin4(ii,kk) = radmin4(ii,kk) * 0.8d0
                  radmin4(kk,ii) = radmin4(kk,ii) * 0.8d0
               end if
            end do
         end do
      end if
c
c     vdw reduction factor information for each individual atom
c
      do i = 1, n
         ired(i) = i
         kred(i) = 0.0d0
         if (vdwindex .eq. 'TYPE') then
            kred(i) = reduct(type(i))
         else
            kred(i) = reduct(class(i))
         end if
         if (n12(i).eq.1 .and. kred(i).ne.0.0d0) then
            ired(i) = i12(1,i)
         end if
      end do
c
c     apply radii and well depths for special atom class pairs
c
      do i = 1, maxnvp
         if (kvpr(i) .eq. blank)  goto 230
         ia = number(kvpr(i)(1:4))
         ib = number(kvpr(i)(5:8))
         if (rad(ia) .eq. 0.0d0)  rad(ia) = 0.001d0
         if (rad(ib) .eq. 0.0d0)  rad(ib) = 0.001d0
         ia = mvdw(ia)
         ib = mvdw(ib)
         if (ia.ne.0 .and. ib.ne.0) then
            if (radtyp .eq. 'SIGMA')  radpr(i) = twosix * radpr(i)
            radmin(ia,ib) = radpr(i)
            radmin(ib,ia) = radpr(i)
            epsilon(ia,ib) = abs(epspr(i))
            epsilon(ib,ia) = abs(epspr(i))
            radmin4(ia,ib) = radpr(i)
            radmin4(ib,ia) = radpr(i)
            epsilon4(ia,ib) = abs(epspr(i))
            epsilon4(ib,ia) = abs(epspr(i))
         end if
      end do
  230 continue
c
c     set radii and well depths for hydrogen bonding pairs
c
      if (vdwtyp .eq. 'MM3-HBOND') then
         do i = 1, nlist
            do k = 1, nlist
               radhbnd(k,i) = 0.0d0
               epshbnd(k,i) = 0.0d0
            end do
         end do
         do i = 1, maxnhb
            if (khb(i) .eq. blank)  goto 240
            ia = number(khb(i)(1:4))
            ib = number(khb(i)(5:8))
            if (rad(ia) .eq. 0.0d0)  rad(ia) = 0.001d0
            if (rad(ib) .eq. 0.0d0)  rad(ib) = 0.001d0
            ia = mvdw(ia)
            ib = mvdw(ib)
            if (ia.ne.0 .and. ib.ne.0) then
               if (radtyp .eq. 'SIGMA')  radhb(i) = twosix * radhb(i)
               radhbnd(ia,ib) = radhb(i)
               radhbnd(ib,ia) = radhb(i)
               epshbnd(ia,ib) = abs(epshb(i))
               epshbnd(ib,ia) = abs(epshb(i))
            end if
         end do
  240    continue
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (srad)
      deallocate (srad4)
      deallocate (seps)
      deallocate (seps4)
c
c     set coefficients for Gaussian fit to eps=1 and radmin=1
c
      if (vdwtyp .eq. 'GAUSSIAN') then
         if (gausstyp .eq. 'LJ-4') then
            ngauss = 4
            igauss(1,1) = 846706.7d0
            igauss(2,1) = 15.464405d0 * twosix**2
            igauss(1,2) = 2713.651d0
            igauss(2,2) = 7.346875d0 * twosix**2
            igauss(1,3) = -9.699172d0
            igauss(2,3) = 1.8503725d0 * twosix**2
            igauss(1,4) = -0.7154420d0
            igauss(2,4) = 0.639621d0 * twosix**2
         else if (gausstyp .eq. 'LJ-2') then
            ngauss = 2
            igauss(1,1) = 14487.1d0
            igauss(2,1) = 9.05148d0 * twosix**2
            igauss(1,2) = -5.55338d0
            igauss(2,2) = 1.22536d0 * twosix**2
         else if (gausstyp .eq. 'MM3-2') then
            ngauss = 2
            igauss(1,1) = 2438.886d0
            igauss(2,1) = 9.342616d0
            igauss(1,2) = -6.197368d0
            igauss(2,2) = 1.564486d0
         else if (gausstyp .eq. 'MM2-2') then
            ngauss = 2
            igauss(1,1) = 3423.562d0
            igauss(2,1) = 9.692821d0
            igauss(1,2) = -6.503760d0
            igauss(2,2) = 1.585344d0
         else if (gausstyp .eq. 'IN-PLACE') then
            ngauss = 2
            igauss(1,1) = 500.0d0
            igauss(2,1) = 6.143d0
            igauss(1,2) = -18.831d0
            igauss(2,2) = 2.209d0
         end if
      end if
c
c     remove zero-sized atoms from the list of vdw sites
c
      nvdw = 0
      do i = 1, n
         if (jvdw(i) .ne. 0) then
            k = class(i)
            if (vdwindex .eq. 'TYPE')  k = type(i)
            if (rad(k) .ne. 0.0d0) then
               nvdw = nvdw + 1
               ivdw(nvdw) = i
            end if
         end if
      end do
c
c     turn off the van der Waals potential if it is not used
c
      if (nvdw .eq. 0)  use_vdw = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module kvdwpr  --  special pair vdw forcefield parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     maxnvp   maximum number of special pair van der Waals entries
c
c     radpr    radius parameter for special van der Waals pairs
c     epspr    well depth parameter for special van der Waals pairs
c     kvpr     string of atom classes for special van der Waals pairs
c
c
      module kvdwpr
      implicit none
      integer maxnvp
      real*8, allocatable :: radpr(:)
      real*8, allocatable :: epspr(:)
      character*8, allocatable :: kvpr(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module kvdws  --  van der Waals term forcefield parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     rad      van der Waals radius parameter for each atom class
c     eps      van der Waals well depth parameter for each atom class
c     rad4     van der Waals radius parameter in 1-4 interactions
c     eps4     van der Waals well depth parameter in 1-4 interactions
c     reduct   van der Waals reduction factor for each atom class
c
c
      module kvdws
      implicit none
      real*8, allocatable :: rad(:)
      real*8, allocatable :: eps(:)
      real*8, allocatable :: rad4(:)
      real*8, allocatable :: eps4(:)
      real*8, allocatable :: reduct(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine lattice  --  setup periodic boundary conditions  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "lattice" stores the periodic box dimensions and sets angle
c     values to be used in computing fractional coordinates
c
c
      subroutine lattice
      use bound
      use boxes
      use cell
      use inform
      use iounit
      use math
      implicit none
      real*8 boxmax
      real*8 ar1,ar2,ar3
      real*8 br1,br2,br3
      real*8 cr1,cr2,cr3
c
c
c     use periodic boundary conditions if a cell was defined
c
      boxmax = max(xbox,ybox,zbox)
      if (boxmax .ne. 0.0d0)  use_bounds = .true.
c
c     set unspecified periodic boundary box lengths and angles
c
      if (use_bounds) then
         if (xbox .eq. 0.0d0)  xbox = boxmax
         if (ybox .eq. 0.0d0)  ybox = boxmax
         if (zbox .eq. 0.0d0)  zbox = boxmax
         if (alpha .eq. 0.0d0)  alpha = 90.0d0
         if (beta .eq. 0.0d0)  beta = 90.0d0
         if (gamma .eq. 0.0d0)  gamma = 90.0d0
c
c     determine the general periodic boundary lattice type
c
         orthogonal = .false.
         monoclinic = .false.
         triclinic = .false.
         if (nosymm) then
            triclinic = .true.
         else if (alpha.eq.90.0d0 .and. beta.eq.90.0d0
     &               .and. gamma.eq.90.0d0) then
            orthogonal = .true.
         else if (alpha.eq.90.0d0 .and. gamma.eq.90.0d0) then
            monoclinic = .true.
         else
            triclinic = .true.
         end if
      end if
c
c     set lattice values for non-prism periodic boundaries
c
      if (octahedron .or. dodecadron) then
         orthogonal = .false.
         monoclinic = .false.
         triclinic = .false.
         nonprism = .true.
      end if
c
c     compute and store half box lengths and other lengths
c
      xbox2 = 0.5d0 * xbox
      ybox2 = 0.5d0 * ybox
      zbox2 = 0.5d0 * zbox
      if (octahedron)  box34 = 0.75d0 * xbox
c
c     set replicated cell dimensions equal to the unit cell
c
      xcell = xbox
      ycell = ybox
      zcell = zbox
      xcell2 = xbox2
      ycell2 = ybox2
      zcell2 = zbox2
c
c     get values needed for fractional coordinate computations
c
      if (triclinic) then
         alpha_sin = sin(alpha/radian)
         alpha_cos = cos(alpha/radian)
         beta_sin = sin(beta/radian)
         beta_cos = cos(beta/radian)
         gamma_sin = sin(gamma/radian)
         gamma_cos = cos(gamma/radian)
         beta_term = (alpha_cos - beta_cos*gamma_cos) / gamma_sin
         gamma_term = sqrt(beta_sin**2 - beta_term**2)
      else if (monoclinic) then
         alpha_sin = 1.0d0
         alpha_cos = 0.0d0
         beta_sin = sin(beta/radian)
         beta_cos = cos(beta/radian)
         gamma_sin = 1.0d0
         gamma_cos = 0.0d0
         beta_term = 0.0d0
         gamma_term = beta_sin
      else
         alpha_sin = 1.0d0
         alpha_cos = 0.0d0
         beta_sin = 1.0d0
         beta_cos = 0.0d0
         gamma_sin = 1.0d0
         gamma_cos = 0.0d0
         beta_term = 0.0d0
         gamma_term = 1.0d0
      end if
c
c     determine the volume of the parent periodic box
c
      volbox = 0.0d0
      if (triclinic) then
         volbox = (gamma_sin*gamma_term) * xbox * ybox * zbox
      else if (monoclinic) then
         volbox = beta_sin * xbox * ybox * zbox
      else
         volbox = xbox * ybox * zbox
      end if
c
c     compute and store real space lattice vectors as rows
c
      ar1 = xbox
      ar2 = 0.0d0
      ar3 = 0.0d0
      br1 = ybox * gamma_cos
      br2 = ybox * gamma_sin
      br3 = 0.0d0
      cr1 = zbox * beta_cos
      cr2 = zbox * beta_term
      cr3 = zbox * gamma_term
      lvec(1,1) = ar1
      lvec(1,2) = ar2
      lvec(1,3) = ar3
      lvec(2,1) = br1
      lvec(2,2) = br2
      lvec(2,3) = br3
      lvec(3,1) = cr1
      lvec(3,2) = cr2
      lvec(3,3) = cr3
c
c     compute and store reciprocal lattice vectors as columns
c
      if (volbox .ne. 0.0d0) then
         recip(1,1) = (br2*cr3 - cr2*br3) / volbox
         recip(2,1) = (br3*cr1 - cr3*br1) / volbox
         recip(3,1) = (br1*cr2 - cr1*br2) / volbox
         recip(1,2) = (cr2*ar3 - ar2*cr3) / volbox
         recip(2,2) = (cr3*ar1 - ar3*cr1) / volbox
         recip(3,2) = (cr1*ar2 - ar1*cr2) / volbox
         recip(1,3) = (ar2*br3 - br2*ar3) / volbox
         recip(2,3) = (ar3*br1 - br3*ar1) / volbox
         recip(3,3) = (ar1*br2 - br1*ar2) / volbox
      end if
c
c     correct volume of non-parallelepiped periodic cells
c
      if (nonprism)  volbox = 0.5d0 * volbox
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine lbfgs  --  limited memory BFGS optimization  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "lbfgs" implements a limited memory BFGS quasi-newton nonlinear
c     optimization routine
c
c     literature references:
c
c     J. Nocedal, "Updating Quasi-Newton Matrices with Limited
c     Storage", Mathematics of Computation, 35, 773-782 (1980)
c
c     D. C. Lui and J. Nocedal, "On the Limited Memory BFGS Method
c     for Large Scale Optimization", Mathematical Programming,
c     45, 503-528 (1989)
c
c     J. Nocedal and S. J. Wright, "Numerical Optimization",
c     Springer-Verlag, New York, 1999, Section 9.1
c
c     variables and parameters:
c
c     nvar      number of parameters in the objective function
c     x0        contains starting point upon input, upon return
c                 contains the best point found
c     minimum   during optimization contains best current function
c                 value; returns final best function value
c     grdmin    normal exit if rms gradient gets below this value
c     ncalls    total number of function/gradient evaluations
c
c     required external routines:
c
c     fgvalue    function to evaluate function and gradient values
c     optsave    subroutine to write out info about current status
c
c
      subroutine lbfgs (nvar,x0,minimum,grdmin,fgvalue,optsave)
      use inform
      use iounit
      use keys
      use linmin
      use math
      use minima
      use output
      use scales
      implicit none
      integer i,j,k,m
      integer nvar,next
      integer msav,muse
      integer niter,ncalls
      integer nerr,maxerr
      real*8 f,f_old,fgvalue
      real*8 f_move,x_move
      real*8 g_norm,g_rms
      real*8 minimum,grdmin
      real*8 angle,rms,beta
      real*8 ys,yy,gamma
      real*8 x0(*)
      real*8, allocatable :: rho(:)
      real*8, allocatable :: alpha(:)
      real*8, allocatable :: x_old(:)
      real*8, allocatable :: g(:)
      real*8, allocatable :: g_old(:)
      real*8, allocatable :: p(:)
      real*8, allocatable :: q(:)
      real*8, allocatable :: r(:)
      real*8, allocatable :: h0(:)
      real*8, allocatable :: s(:,:)
      real*8, allocatable :: y(:,:)
      logical done
      character*9 blank,status
      character*20 keyword
      character*240 record
      character*240 string
      external fgvalue,optsave
c
c
c     initialize some values to be used below
c
      ncalls = 0
      rms = sqrt(dble(nvar))
      if (coordtype .eq. 'CARTESIAN') then
         rms = rms / sqrt(3.0d0)
      else if (coordtype .eq. 'RIGIDBODY') then
         rms = rms / sqrt(6.0d0)
      end if
      blank = '         '
      done = .false.
      nerr = 0
      maxerr = 2
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(scale))  allocate (scale(nvar))
c
c     set default values for variable scale factors
c
      if (.not. set_scale) then
         do i = 1, nvar
            if (scale(i) .eq. 0.0d0)  scale(i) = 1.0d0
         end do
      end if
c
c     set default parameters for the optimization
c
      msav = min(nvar,20)
      if (fctmin .eq. 0.0d0)  fctmin = -100000000.0d0
      if (maxiter .eq. 0)  maxiter = 1000000
      if (nextiter .eq. 0)  nextiter = 1
      if (iprint .lt. 0)  iprint = 1
      if (iwrite .lt. 0)  iwrite = 1
c
c     set default parameters for the line search
c
      if (stpmax .eq. 0.0d0)  stpmax = 5.0d0
      stpmin = 1.0d-16
      cappa = 0.9d0
      slpmax = 10000.0d0
      angmax = 180.0d0
      intmax = 5
c
c     search the keywords for optimization parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:14) .eq. 'LBFGS-VECTORS ') then
            read (string,*,err=10,end=10)  msav
            msav = max(0,min(msav,nvar))
         else if (keyword(1:17) .eq. 'STEEPEST-DESCENT ') then
            msav = 0
         else if (keyword(1:7) .eq. 'FCTMIN ') then
            read (string,*,err=10,end=10)  fctmin
         else if (keyword(1:8) .eq. 'MAXITER ') then
            read (string,*,err=10,end=10)  maxiter
         else if (keyword(1:8) .eq. 'STEPMAX ') then
            read (string,*,err=10,end=10)  stpmax
         else if (keyword(1:8) .eq. 'STEPMIN ') then
            read (string,*,err=10,end=10)  stpmin
         else if (keyword(1:6) .eq. 'CAPPA ') then
            read (string,*,err=10,end=10)  cappa
         else if (keyword(1:9) .eq. 'SLOPEMAX ') then
            read (string,*,err=10,end=10)  slpmax
         else if (keyword(1:7) .eq. 'ANGMAX ') then
            read (string,*,err=10,end=10)  angmax
         else if (keyword(1:7) .eq. 'INTMAX ') then
            read (string,*,err=10,end=10)  intmax
         end if
   10    continue
      end do
c
c     print header information about the optimization method
c
      if (iprint .gt. 0) then
         if (msav .eq. 0) then
            write (iout,20)
   20       format (/,' Steepest Descent Gradient Optimization :')
            write (iout,30)
   30       format (/,' SD Iter     F Value      G RMS      F Move',
     &                 '   X Move   Angle  FG Call  Comment')
         else
            write (iout,40)
   40       format (/,' Limited Memory BFGS Quasi-Newton',
     &                 ' Optimization :')
            write (iout,50)
   50       format (/,' QN Iter     F Value      G RMS      F Move',
     &                 '   X Move   Angle  FG Call  Comment')
         end if
         flush (iout)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (x_old(nvar))
      allocate (g(nvar))
      allocate (g_old(nvar))
      allocate (p(nvar))
      allocate (q(nvar))
      allocate (r(nvar))
      allocate (h0(nvar))
      if (msav .ne. 0) then
         allocate (rho(msav))
         allocate (alpha(msav))
         allocate (s(nvar,msav))
         allocate (y(nvar,msav))
      end if
c
c     evaluate the function and get the initial gradient
c
      niter = nextiter - 1
      maxiter = niter + maxiter
      ncalls = ncalls + 1
      f = fgvalue (x0,g)
      f_old = f
      m = 0
      gamma = 1.0d0
      g_norm = 0.0d0
      g_rms = 0.0d0
      do i = 1, nvar
         g_norm = g_norm + g(i)*g(i)
         g_rms = g_rms + (g(i)*scale(i))**2
      end do
      g_norm = sqrt(g_norm)
      g_rms = sqrt(g_rms) / rms
      f_move = 0.5d0 * stpmax * g_norm
c
c     print initial information prior to first iteration
c
      if (iprint .gt. 0) then
         if (f.lt.1.0d8 .and. f.gt.-1.0d7 .and. g_rms.lt.1.0d5) then
            write (iout,60)  niter,f,g_rms,ncalls
   60       format (/,i6,f14.4,f11.4,29x,i7)
         else
            write (iout,70)  niter,f,g_rms,ncalls
   70       format (/,i6,d14.4,d11.4,29x,i7)
         end if
         flush (iout)
      end if
c
c     write initial intermediate prior to first iteration
c
      if (iwrite .gt. 0)  call optsave (niter,f,x0)
c
c     tests of the various termination criteria
c
      if (niter .ge. maxiter) then
         status = 'IterLimit'
         done = .true.
      end if
      if (f .le. fctmin) then
         status = 'SmallFct '
         done = .true.
      end if
      if (g_rms .le. grdmin) then
         status = 'SmallGrad'
         done = .true.
      end if
c
c     start of a new limited memory BFGS iteration
c
      do while (.not. done)
         niter = niter + 1
         muse = min(niter-1,msav)
         m = m + 1
         if (m .gt. msav)  m = 1
c
c     estimate Hessian diagonal and compute the Hg product
c
         do i = 1, nvar
            h0(i) = gamma
            q(i) = g(i)
         end do
         k = m
         do j = 1, muse
            k = k - 1
            if (k .eq. 0)  k = msav
            alpha(k) = 0.0d0
            do i = 1, nvar
               alpha(k) = alpha(k) + s(i,k)*q(i)
            end do
            alpha(k) = alpha(k) * rho(k)
            do i = 1, nvar
               q(i) = q(i) - alpha(k)*y(i,k)
            end do
         end do
         do i = 1, nvar
            r(i) = h0(i) * q(i)
         end do
         do j = 1, muse
            beta = 0.0d0
            do i = 1, nvar
               beta = beta + y(i,k)*r(i)
            end do
            beta = beta * rho(k)
            do i = 1, nvar
               r(i) = r(i) + s(i,k)*(alpha(k)-beta)
            end do
            k = k + 1
            if (k .gt. msav)  k = 1
         end do
c
c     set search direction and store current point and gradient
c
         do i = 1, nvar
            p(i) = -r(i)
            x_old(i) = x0(i)
            g_old(i) = g(i)
         end do
c
c     perform line search along the new conjugate direction
c
         status = blank
         call search (nvar,f,g,x0,p,f_move,angle,ncalls,fgvalue,status)
c
c     update variables based on results of this iteration
c
         if (msav .ne. 0) then
            ys = 0.0d0
            yy = 0.0d0
            do i = 1, nvar
               s(i,m) = x0(i) - x_old(i)
               y(i,m) = g(i) - g_old(i)
               ys = ys + y(i,m)*s(i,m)
               yy = yy + y(i,m)*y(i,m)
            end do
            gamma = abs(ys/yy)
            rho(m) = 1.0d0 / ys
         end if
c
c     get the sizes of the moves made during this iteration
c
         f_move = f_old - f
         f_old = f
         x_move = 0.0d0
         do i = 1, nvar
            x_move = x_move + ((x0(i)-x_old(i))/scale(i))**2
         end do
         x_move = sqrt(x_move) / rms
         if (coordtype .eq. 'INTERNAL') then
            x_move = radian * x_move
         end if
c
c     compute the rms gradient per optimization parameter
c
         g_rms = 0.0d0
         do i = 1, nvar
            g_rms = g_rms + (g(i)*scale(i))**2
         end do
         g_rms = sqrt(g_rms) / rms
c
c     test for error due to line search problems
c
         if (status.eq.'BadIntpln' .or. status.eq.'IntplnErr') then
            nerr = nerr + 1
            if (nerr .ge. maxerr)  done = .true.
         else
            nerr = 0
         end if
c
c     test for too many total iterations
c
         if (niter .ge. maxiter) then
            status = 'IterLimit'
            done = .true.
         end if
c
c     test the normal termination criteria
c
         if (f .le. fctmin) then
            status = 'SmallFct '
            done = .true.
         end if
         if (g_rms .le. grdmin) then
            status = 'SmallGrad'
            done = .true.
         end if
c
c     print intermediate results for the current iteration
c
         if (iprint .gt. 0) then
            if (done .or. mod(niter,iprint).eq.0) then
               if (f.lt.1.0d8 .and. f.gt.-1.0d7 .and.
     &             g_rms.lt.1.0d5 .and. f_move.lt.1.0d6 .and.
     &             f_move.gt.-1.0d5) then
                  write (iout,80)  niter,f,g_rms,f_move,x_move,
     &                             angle,ncalls,status
   80             format (i6,f14.4,f11.4,f12.4,f9.4,f8.2,i7,3x,a9)
               else
                  write (iout,90)  niter,f,g_rms,f_move,x_move,
     &                             angle,ncalls,status
   90             format (i6,d14.4,d11.4,d12.4,f9.4,f8.2,i7,3x,a9)
               end if
            end if
            flush (iout)
         end if
c
c     write intermediate results for the current iteration
c
         if (iwrite .gt. 0) then
            if (done .or. mod(niter,iwrite).eq.0) then
               call optsave (niter,f,x0)
            end if
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (x_old)
      deallocate (g)
      deallocate (g_old)
      deallocate (p)
      deallocate (q)
      deallocate (r)
      deallocate (h0)
      if (msav .ne. 0) then
         deallocate (rho)
         deallocate (alpha)
         deallocate (s)
         deallocate (y)
      end if
c
c     set final value of the objective function
c
      minimum = f
      if (iprint .gt. 0) then
         if (status.eq.'SmallGrad' .or. status.eq.'SmallFct ') then
            write (iout,100)  status
  100       format (/,' LBFGS  --  Normal Termination due to ',a9)
         else
            write (iout,110)  status
  110       format (/,' LBFGS  --  Incomplete Convergence due to ',a9)
         end if
         flush (iout)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module light  --  method of lights pair neighbors indices  ##
c     ##                                                             ##
c     #################################################################
c
c
c     nlight  total number of sites for method of lights calculation
c     kbx     low index of neighbors of each site in the x-sorted list
c     kby     low index of neighbors of each site in the y-sorted list
c     kbz     low index of neighbors of each site in the z-sorted list
c     kex     high index of neighbors of each site in the x-sorted list
c     key     high index of neighbors of each site in the y-sorted list
c     kez     high index of neighbors of each site in the z-sorted list
c     locx    maps the x-sorted list into original interaction list
c     locy    maps the y-sorted list into original interaction list
c     locz    maps the z-sorted list into original interaction list
c     rgx     maps the original interaction list into x-sorted list
c     rgy     maps the original interaction list into y-sorted list
c     rgz     maps the original interaction list into z-sorted list
c
c
      module light
      implicit none
      integer nlight
      integer, allocatable :: kbx(:)
      integer, allocatable :: kby(:)
      integer, allocatable :: kbz(:)
      integer, allocatable :: kex(:)
      integer, allocatable :: key(:)
      integer, allocatable :: kez(:)
      integer, allocatable :: locx(:)
      integer, allocatable :: locy(:)
      integer, allocatable :: locz(:)
      integer, allocatable :: rgx(:)
      integer, allocatable :: rgy(:)
      integer, allocatable :: rgz(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine lights  --  get neighbors via method of lights  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "lights" computes the set of nearest neighbor interactions
c     using the method of lights algorithm
c
c     note this routine can include each pair only once via setting
c     of the negative x-coordinate boundaries, or it can optionally
c     include each pair in both directions, ie, both (A,B) and (B,A);
c     inclusion of one or both directions is controlled by "unique"
c
c     literature references:
c
c     F. Sullivan, R. D. Mountain and J. O'Connell, "Molecular
c     Dynamics on Vector Computers", Journal of Computational
c     Physics, 61, 138-153 (1985)
c
c     W. Dzwinel, M. Bargiel, J. Kitowski and J. Moscinski, "Linked
c     Lists and the Method of Lights in Molecular Dynamics Simulation-
c     Search for the Best Method of Forces Evaluation in Sequential
c     MD Codes", Molecular Simulation, 4, 229-239 (1989)
c
c
      subroutine lights (cutoff,nsite,xsort,ysort,zsort,unique)
      use bound
      use boxes
      use cell
      use iounit
      use light
      implicit none
      integer i,j,k
      integer nsite
      integer extent
      real*8 cutoff,term,box
      real*8 xcut,ycut,zcut
      real*8 xmove,ymove,zmove
      real*8 xsort(*)
      real*8 ysort(*)
      real*8 zsort(*)
      real*8, allocatable :: xfrac(:)
      real*8, allocatable :: yfrac(:)
      real*8, allocatable :: zfrac(:)
      logical unique
c
c
c     check that maximum number of replicates is not exceeded
c
      if (use_replica) then
         if (xcell2.gt.xbox .or. ycell2.gt.ybox
     &           .or. zcell2.gt.zbox) then
            write (iout,10)
   10       format (/,' LIGHTS  --  Number of Replicas is Too',
     &                 ' Large for Method of Lights')
            call fatal
         end if
      end if
c
c     non-prism periodic cell is not handled at present
c
      if (use_bounds) then
         if (nonprism) then
            write (iout,20)
   20       format (/,' LIGHTS  --  Non-Prism Cell is not',
     &                 ' Supported by Method of Lights')
            call fatal
         end if
      end if
c
c     set the light width based on input distance cutoff
c
      xcut = cutoff
      ycut = cutoff
      zcut = cutoff
      if (use_bounds) then
         if (monoclinic) then
            xcut = xcut / beta_sin
            zcut = zcut / beta_sin
         else if (triclinic) then
            term = xbox * ybox * zbox / volbox
            xcut = xcut * term * alpha_sin
            ycut = ycut * term * beta_sin
            zcut = zcut * term * gamma_sin
         end if
      end if
c
c     perform dynamic allocation of some local arrays
c
      if (use_bounds) then
         allocate (xfrac(nsite))
         allocate (yfrac(nsite))
         allocate (zfrac(nsite))
      end if
c
c     find fractional coordinates for the unit cell atoms
c
      if (use_bounds) then
         if (orthogonal) then
            do i = 1, nsite
               zfrac(i) = zsort(i)
               yfrac(i) = ysort(i)
               xfrac(i) = xsort(i)
            end do
         else if (monoclinic) then
            do i = 1, nsite
               zfrac(i) = zsort(i) / beta_sin
               yfrac(i) = ysort(i)
               xfrac(i) = xsort(i) - zfrac(i)*beta_cos
            end do
         else if (triclinic) then
            do i = 1, nsite
               zfrac(i) = zsort(i) / gamma_term
               yfrac(i) = (ysort(i) - zfrac(i)*beta_term) / gamma_sin
               xfrac(i) = xsort(i) - yfrac(i)*gamma_cos
     &                       - zfrac(i)*beta_cos
            end do
         end if
      end if
c
c     use images to move coordinates into periodic cell
c
      if (use_bounds) then
         do i = 1, nsite
            xsort(i) = xfrac(i)
            ysort(i) = yfrac(i)
            zsort(i) = zfrac(i)
            do while (abs(xsort(i)) .gt. xcell2)
               xsort(i) = xsort(i) - sign(xcell,xsort(i))
            end do
            do while (abs(ysort(i)) .gt. ycell2)
               ysort(i) = ysort(i) - sign(ycell,ysort(i))
            end do
            do while (abs(zsort(i)) .gt. zcell2)
               zsort(i) = zsort(i) - sign(zcell,zsort(i))
            end do
         end do
      end if
c
c     generate the replica coordinates for the sort arrays
c
      if (use_replica) then
         k = nsite
         do j = 2, ncell
            xmove = icell(1,j) * xbox
            ymove = icell(2,j) * ybox
            zmove = icell(3,j) * zbox
            do i = 1, nsite
               k = k + 1
               xsort(k) = xfrac(i) + xmove
               ysort(k) = yfrac(i) + ymove
               zsort(k) = zfrac(i) + zmove
               do while (abs(xsort(k)) .gt. xcell2)
                  xsort(k) = xsort(k) - sign(xcell,xsort(k))
               end do
               do while (abs(ysort(k)) .gt. ycell2)
                  ysort(k) = ysort(k) - sign(ycell,ysort(k))
               end do
               do while (abs(zsort(k)) .gt. zcell2)
                  zsort(k) = zsort(k) - sign(zcell,zsort(k))
               end do
            end do
         end do
      end if
c
c     perform deallocation of some local arrays
c
      if (use_bounds) then
         deallocate (xfrac)
         deallocate (yfrac)
         deallocate (zfrac)
      end if
c
c     perform dynamic allocation of some global arrays
c
      nlight = ncell * nsite
      extent = 0
      if (allocated(rgx))  extent = size(rgx)
      if (extent .lt. nlight) then
         if (allocated(kbx))  deallocate (kbx)
         if (allocated(kby))  deallocate (kby)
         if (allocated(kbz))  deallocate (kbz)
         if (allocated(kex))  deallocate (kex)
         if (allocated(key))  deallocate (key)
         if (allocated(kez))  deallocate (kez)
         if (allocated(locx))  deallocate (locx)
         if (allocated(locy))  deallocate (locy)
         if (allocated(locz))  deallocate (locz)
         if (allocated(rgx))  deallocate (rgx)
         if (allocated(rgy))  deallocate (rgy)
         if (allocated(rgz))  deallocate (rgz)
         allocate (kbx(nsite))
         allocate (kby(nsite))
         allocate (kbz(nsite))
         allocate (kex(nsite))
         allocate (key(nsite))
         allocate (kez(nsite))
         allocate (locx(nlight))
         allocate (locy(nlight))
         allocate (locz(nlight))
         allocate (rgx(nlight))
         allocate (rgy(nlight))
         allocate (rgz(nlight))
      end if
c
c     sort the coordinate components into ascending order
c
      call sort2 (nlight,xsort,locx)
      call sort2 (nlight,ysort,locy)
      call sort2 (nlight,zsort,locz)
c
c     use of replicates requires secondary sorting along x-axis
c
      if (use_replica) then
         j = 1
         do i = 1, nlight-1
            if (xsort(i+1) .ne. xsort(i)) then
               call sort5 (i-j+1,locx(j),nsite)
               j = i + 1
            end if
         end do
         call sort5 (nlight-j+1,locx(j),nsite)
      end if
c
c     index the position of each atom in the sorted coordinates
c
      do i = 1, nlight
         rgx(locx(i)) = i
         rgy(locy(i)) = i
         rgz(locz(i)) = i
      end do
c
c     find the negative x-coordinate boundary for each atom
c
      if (unique) then
         do i = nlight, 1, -1
            k = locx(i)
            if (k .le. nsite) then
               kbx(k) = i
            end if
         end do
      else
         j = nlight
         box = 0.0d0
         do i = nlight, 1, -1
            k = locx(i)
            do while (xsort(i)-xsort(j)+box .le. xcut)
               if (j .eq. 1) then
                  if (use_bounds) then
                     j = nlight + 1
                     box = xcell
                  end if
               end if
               j = j - 1
               if (j .lt. 1)  goto 30
            end do
   30       continue
            j = j + 1
            if (j .gt. nlight) then
               j = 1
               box = 0.0d0
            end if
            kbx(k) = j
         end do
      end if
c
c     find the positive x-coordinate boundary for each atom
c
      j = 1
      box = 0.0d0
      do i = 1, nlight
         k = locx(i)
         if (k .le. nsite) then
            do while (xsort(j)-xsort(i)+box .lt. xcut)
               if (j .eq. nlight) then
                  if (use_bounds) then
                     j = 0
                     box = xcell
                  end if
               end if
               j = j + 1
               if (j .gt. nlight)  goto 40
            end do
   40       continue
            j = j - 1
            if (j .lt. 1) then
               j = nlight
               box = 0.0d0
            end if
            kex(k) = j
         end if
      end do
c
c     find the negative y-coordinate boundary for each atom
c
      j = nlight
      box = 0.0d0
      do i = nlight, 1, -1
         k = locy(i)
         if (k .le. nsite) then
            do while (ysort(i)-ysort(j)+box .le. ycut)
               if (j .eq. 1) then
                  if (use_bounds) then
                     j = nlight + 1
                     box = ycell
                  end if
               end if
               j = j - 1
               if (j .lt. 1)  goto 50
            end do
   50       continue
            j = j + 1
            if (j .gt. nlight) then
               j = 1
               box = 0.0d0
            end if
            kby(k) = j
         end if
      end do
c
c     find the positive y-coordinate boundary for each atom
c
      j = 1
      box = 0.0d0
      do i = 1, nlight
         k = locy(i)
         if (k .le. nsite) then
            do while (ysort(j)-ysort(i)+box .lt. ycut)
               if (j .eq. nlight) then
                  if (use_bounds) then
                     j = 0
                     box = ycell
                  end if
               end if
               j = j + 1
               if (j .gt. nlight)  goto 60
            end do
   60       continue
            j = j - 1
            if (j .lt. 1) then
               j = nlight
               box = 0.0d0
            end if
            key(k) = j
         end if
      end do
c
c     find the negative z-coordinate boundary for each atom
c
      j = nlight
      box = 0.0d0
      do i = nlight, 1, -1
         k = locz(i)
         if (k .le. nsite) then
            do while (zsort(i)-zsort(j)+box .le. zcut)
               if (j .eq. 1) then
                  if (use_bounds) then
                     j = nlight + 1
                     box = zcell
                  end if
               end if
               j = j - 1
               if (j .lt. 1)  goto 70
            end do
   70       continue
            j = j + 1
            if (j .gt. nlight) then
               j = 1
               box = 0.0d0
            end if
            kbz(k) = j
         end if
      end do
c
c     find the positive z-coordinate boundary for each atom
c
      j = 1
      box = 0.0d0
      do i = 1, nlight
         k = locz(i)
         if (k .le. nsite) then
            do while (zsort(j)-zsort(i)+box .lt. zcut)
               if (j .eq. nlight) then
                  if (use_bounds) then
                     j = 0
                     box = zcell
                  end if
               end if
               j = j + 1
               if (j .gt. nlight)  goto 80
            end do
   80       continue
            j = j - 1
            if (j .lt. 1) then
               j = nlight
               box = 0.0d0
            end if
            kez(k) = j
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module limits  --  interaction taper & cutoff distances  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     vdwcut      cutoff distance for van der Waals interactions
c     repcut      cutoff distance for Pauli repulsion interactions
c     dispcut     cutoff distance for dispersion interactions
c     chgcut      cutoff distance for charge-charge interactions
c     dplcut      cutoff distance for dipole-dipole interactions
c     mpolecut    cutoff distance for atomic multipole interactions
c     ctrncut     cutoff distance for charge transfer interactions
c     vdwtaper    distance at which van der Waals switching begins
c     reptaper    distance at which Pauli repulsion switching begins
c     disptaper   distance at which dispersion switching begins
c     chgtaper    distance at which charge-charge switching begins
c     dpltaper    distance at which dipole-dipole switching begins
c     mpoletaper  distance at which atomic multipole switching begins
c     ctrntaper   distance at which charge transfer switching begins
c     ewaldcut    cutoff distance for real space Ewald electrostatics
c     dewaldcut   cutoff distance for real space Ewald dispersion
c     usolvcut    cutoff distance for dipole solver preconditioner
c     use_ewald   logical flag governing use of electrostatic Ewald
c     use_dewald  logical flag governing use of dispersion Ewald
c     use_lights  logical flag governing use of method of lights
c     use_list    logical flag governing use of any neighbor lists
c     use_vlist   logical flag governing use of van der Waals list
c     use_dlist   logical flag governing use of dispersion list
c     use_clist   logical flag governing use of charge list
c     use_mlist   logical flag governing use of multipole list
c     use_ulist   logical flag governing use of preconditioner list
c
c
      module limits
      implicit none
      real*8 vdwcut,repcut
      real*8 dispcut,chgcut
      real*8 dplcut,mpolecut
      real*8 ctrncut
      real*8 vdwtaper,reptaper
      real*8 disptaper,chgtaper
      real*8 dpltaper,mpoletaper
      real*8 ctrntaper
      real*8 ewaldcut,dewaldcut
      real*8 usolvcut
      logical use_ewald,use_dewald
      logical use_lights,use_list
      logical use_vlist,use_dlist
      logical use_clist,use_mlist
      logical use_ulist
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module linmin  --  line search minimization parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     intmax   maximum number of interpolations during line search
c     stpmin   minimum step length in current line search direction
c     stpmax   maximum step length in current line search direction
c     cappa    stringency of line search (0=tight < cappa < 1=loose)
c     slpmax   projected gradient above which stepsize is reduced
c     angmax   maximum angle between search direction and -gradient
c
c
      module linmin
      implicit none
      integer intmax
      real*8 stpmin
      real*8 stpmax
      real*8 cappa
      real*8 slpmax
      real*8 angmax
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2020  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine lusolve  --  LU factorization as linear solver  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "lusolve" uses a LU factorization with partial pivoting to solve
c     the linear system Ax = b, returning "x" in "b"; "A" is the upper
c     triangle and diagonal of a symmetric matrix stored by rows
c
c     literature reference:
c
c     W. H. Press, B. P. Flannery, S. A. Teukolsky and W. T. Vetterling,
c     "Numerical Recipes: The Art of Scientific Computing, 2nd Edition",
c     Cambridge University Press, 1992, Section 2.3
c
c
      subroutine lusolve (nvar,a,b)
      use iounit
      implicit none
      integer i,j,k,m
      integer nvar,imax
      integer, allocatable :: indx(:)
      real*8 amax,sum
      real*8 eps,temp
      real*8 a(*)
      real*8 b(*)
      real*8, allocatable :: vv(:)
      real*8, allocatable :: af(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (indx(nvar))
      allocate (vv(nvar))
      allocate (af(nvar,nvar))
c
c     copy input upper triangle into the full matrix
c
      k = 0
      do i = 1, nvar
         do j = i, nvar
            k = k + 1
            af(j,i) = a(k)
            af(i,j) = af(j,i)
         end do
      end do
c
c     perform LU factorization of the input matrix
c
      do i = 1, nvar
         amax = 0.0d0
         do j = 1, nvar
            if (abs(af(i,j)) .gt. amax)  amax = abs(af(i,j))
         end do
         if (amax .eq. 0.0d0) then
            write (iout,10)
   10       format (/,' LUSOLVE  --  Input Matrix Singular during',
     &                 ' LU Factorization')
            call fatal
         end if
         vv(i) = 1.0d0 / amax
      end do
      eps = 1.0d-10
      do j = 1, nvar
         do i = 1, j-1
            sum = af(i,j)
            do k = 1, i-1
               sum = sum - af(i,k)*af(k,j)
            end do
            af(i,j) = sum
         end do
         amax = 0.0d0
         do i = j, nvar
            sum = af(i,j)
            do k = 1, j-1
               sum = sum - af(i,k)*af(k,j)
            end do
            af(i,j) = sum
            temp = vv(i) * abs(sum)
            if (temp .ge. amax) then
               imax = i
               amax = temp
            end if
         end do
         if (j .ne. imax) then
            do k = 1, nvar
               temp = af(imax,k)
               af(imax,k) = af(j,k)
               af(j,k) = temp
            end do
            vv(imax) = vv(j)
         end if
         indx(j) = imax
         if (af(j,j) .eq. 0.0d0)  af(j,j) = eps
         if (j .ne. nvar) then
            temp = 1.0d0 / af(j,j)
            do i = j+1, nvar
               af(i,j) = af(i,j) * temp
            end do
         end if
      end do
c
c     use factored matrix to solve the linear equations
c
      m = 0
      do i = 1, nvar
         k = indx(i)
         sum = b(k)
         b(k) = b(i)
         if (m .ne. 0) then
            do j = m, i-1
               sum = sum - af(i,j)*b(j)
            end do
         else if (sum .ne. 0.0d0) then
            m = i
         end if
         b(i) = sum
      end do
      do i = nvar, 1, -1
         sum = b(i)
         do j = i+1, nvar
            sum = sum - af(i,j)*b(j)
         end do
         b(i) = sum / af(i,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (indx)
      deallocate (vv)
      deallocate (af)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine makeint  --  convert Cartesian to internal  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "makeint" converts Cartesian to internal coordinates where
c     selection of internal coordinates is controlled by "mode"
c
c        mode = 0     automatic internal coordinates
c        mode = 1     manual selection of coordinates
c        mode = 2     use existing structure as a template
c        mode = 3     use dihedral angles in all cases
c
c
      subroutine makeint (mode)
      use atoms
      use couple
      use iounit
      use math
      use zclose
      use zcoord
      implicit none
      integer i,j
      integer i1,i2,i3,i4,i5
      integer adjacent,trial
      integer mode,next
      integer, allocatable :: iz0(:)
      integer, allocatable :: iz1(:)
      real*8 geometry,sign
      logical more
      character*1 answer
      character*1 default
      character*8 phrase
      character*240 record
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (iz0(0:n))
      allocate (iz1(n))
c
c     zero out local values used for the defining atoms
c
      i1 = 0
      i2 = 0
      i3 = 0
      i4 = 0
      i5 = 0
      iz0(0) = 0
      do i = 1, n
         iz0(i) = 0
         iz1(i) = 0
      end do
c
c     zero out the coordinates, defining atoms and closures
c
      do i = 1, n
         zbond(i) = 0.0d0
         zang(i) = 0.0d0
         ztors(i) = 0.0d0
      end do
      if (mode .ne. 2) then
         do i = 1, n
            do j = 1, 4
               iz(j,i) = 0
            end do
         end do
         nadd = 0
         ndel = 0
      end if
c
c     first, decide which of the atoms to define next
c
      do i = 1, n
         if (mode .eq. 1) then
            trial = i1 + 1
   10       continue
            write (iout,20)  trial
   20       format (/,' Atom Number to be Defined [',i5,'] :  ',$)
            read (input,30,err=10)  i1
   30       format (i10)
            if (i1 .eq. 0)  i1 = trial
            if (iz0(i1) .ne. 0) then
               write (iout,40)
   40          format (/,' Already Defined that Atom; Choose Another')
               if (i1 .eq. trial)  trial = trial + 1
               goto 10
            end if
         else
            i1 = i
         end if
c
c     define the bond length for the current atom
c
         if (i .ge. 2) then
            if (mode .eq. 2) then
               i2 = iz(1,i1)
            else
               i2 = adjacent (i1,0,mode,more,iz0,iz1)
               if (i2 .eq. 0) then
                  write (iout,50)  i1
   50             format (/,' MAKEINT  --  Connectivity Error',
     &                       ' in defining Atom',i6)
                  call fatal
               end if
            end if
            zbond(i1) = geometry (i1,i2,0,0)
         end if
c
c     define the bond angle for the current atom
c
         if (i .ge. 3) then
            if (mode .eq. 2) then
               i3 = iz(2,i1)
            else
               i3 = adjacent (i2,i1,mode,more,iz0,iz1)
               if (i3 .eq. 0) then
                  write (iout,60)  i1
   60             format (/,' MAKEINT  --  Connectivity Error',
     &                       ' in defining Atom',i6)
                  call fatal
               end if
            end if
            zang(i1) = geometry (i1,i2,i3,0)
         end if
c
c     decide whether to use a dihedral or second bond angle;
c     then find the value of the angle
c
         if (i .ge. 4) then
            if (mode .eq. 3) then
               answer = 'D'
            else if (mode .eq. 2) then
               if (iz(4,i1) .eq. 0) then
                  answer = 'D'
               else
                  answer = 'B'
               end if
            else if (mode .eq. 1) then
               if (more) then
                  phrase = 'D or [B]'
                  default = 'B'
               else
                  phrase = '[D] or B'
                  default = 'D'
               end if
               write (iout,70)  phrase
   70          format (/,' Specify with Dihedral Angle or Second',
     &                    ' Bond Angle (',a8,') :  ',$)
               read (input,80)  record
   80          format (a240)
               next = 1
               call gettext (record,answer,next)
               call upcase (answer)
               if (answer.ne.'B' .and. answer.ne.'D')  answer = default
            else if (mode .eq. 0) then
               if (more) then
                  answer = 'B'
               else
                  answer = 'D'
               end if
            end if
            if (answer .eq. 'B') then
               if (mode .eq. 2) then
                  i4 = iz(3,i1)
               else
                  i4 = adjacent (i2,i3,mode,more,iz0,iz1)
                  if (i4 .eq. 0) then
                     write (iout,90)  i1
   90                format (/,' MAKEINT  --  Connectivity Error',
     &                          ' in defining Atom',i6)
                     call fatal
                  end if
               end if
               ztors(i1) = geometry (i1,i2,i4,0)
               i5 = 1
               sign = geometry (i1,i2,i3,i4)
               if (sign .gt. 0.0d0)  i5 = -1
            else if (answer .eq. 'D') then
               if (mode .eq. 2) then
                  i4 = iz(3,i1)
               else
                  i4 = adjacent (i3,i2,mode,more,iz0,iz1)
                  if (i4 .eq. 0) then
                     write (iout,100)  i1
  100                format (/,' MAKEINT  --  Connectivity Error',
     &                          ' in defining Atom',i6)
                     call fatal
                  end if
               end if
               i5 = 0
               ztors(i1) = geometry (i1,i2,i3,i4)
            end if
         end if
c
c     transfer defining atoms to permanent array;
c     mark the current atom as finished
c
         iz(1,i1) = iz0(i2)
         iz(2,i1) = iz0(i3)
         iz(3,i1) = iz0(i4)
         iz(4,i1) = i5
         iz0(i1) = i
         iz1(i1) = i2
      end do
c
c     add any bonds needed to make ring closures
c
      nadd = 0
      do i = 1, n
         do j = 1, n12(i)
            if (iz0(i) .lt. iz0(i12(j,i)) .and.
     &          iz1(i12(j,i)) .ne. i) then
               nadd = nadd + 1
               iadd(1,nadd) = iz0(i)
               iadd(2,nadd) = iz0(i12(j,i))
            end if
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iz0)
      deallocate (iz1)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function adjacent  --  atom adjacent to specified atom  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "adjacent" finds an atom connected to atom "i1" other than
c     atom "i2"; if no such atom exists, then the closest atom
c     in space is returned
c
c     variables and parameters:
c
c     mode   whether "makeint" is in manual mode, automatic, etc.
c     more   returned true if there is more than one previously
c              defined atom other than "i2" which is directly
c              connected (adjacent) to atom "i1"
c     iz0    line number of the Z-matrix on which an atom is
c              defined, 0 if not yet defined
c     iz1    line number of the Z-matrix on which the atom used
c              defining the bond length to a given atom is defined
c
c
      function adjacent (i1,i2,mode,more,iz0,iz1)
      use atoms
      use couple
      use inform
      use iounit
      use sizes
      use zclose
      implicit none
      integer i,j,k,i1,i2
      integer nc,adjacent,mode
      integer ic(maxval)
      integer iz0(0:*)
      integer iz1(*)
      real*8 dist2,short
      logical more
c
c
c     get a list of eligible atoms bonded to the atom of interest
c
      nc = 0
      more = .false.
      do j = 1, n12(i1)
         i = i12(j,i1)
         if (iz0(i).ne.0 .and. i.ne.i2) then
            if (i2 .eq. 0) then
               nc = nc + 1
               ic(nc) = i
            else
               if (iz1(i).eq.i1 .or. iz1(i1).eq.i) then
                  nc = nc + 1
                  ic(nc) = i
               end if
            end if
         end if
      end do
      if (nc .gt. 1)  more = .true.
c
c     if no bonded atom is eligible, use the nearest neighbor
c
      if (nc .eq. 0) then
         adjacent = 0
         if (mode .eq. 1) then
            write (iout,10)  i1
   10       format (/,' ADJACENT  --  Atom',i6,' not Attached',
     &                 ' to any Prior Atom')
         else
            short = 100000000.0d0
            do i = 1, n
               if (iz0(i).ne.0 .and. i.ne.i1 .and. i.ne.i2) then
                  dist2 = (x(i)-x(i1))**2 + (y(i)-y(i1))**2
     &                           + (z(i)-z(i1))**2
                  if (dist2 .lt. short) then
                     short = dist2
                     adjacent = i
                  end if
               end if
            end do
            if (i2 .eq. 0) then
               ndel = ndel + 1
               idel(1,ndel) = adjacent
               idel(2,ndel) = i1
               if (debug) then
                  write (iout,20)  i1
   20             format (/,' ADJACENT  --  Atom',i6,' not Attached',
     &                       ' to any Prior Atom')
               end if
            end if
         end if
c
c     for automatic mode, always use the first eligible bonded atom
c
      else if (mode .eq. 0) then
         adjacent = ic(1)
c
c     for torsion mode, use an adjacent atom bonded to undefined atoms
c
      else if (mode .eq. 3) then
         adjacent = ic(1)
         do k = 1, nc
            do j = 1, n12(ic(k))
               i = i12(j,ic(k))
               if (iz0(i).ne.0 .and. i.ne.i1) then
                  adjacent = ic(k)
                  goto 30
               end if
            end do
         end do
   30    continue
c
c     if only one directly bonded atom is eligible, then use it
c
      else if (nc .eq. 1) then
         adjacent = ic(1)
         if (mode.eq.1 .or. debug) then
            write (iout,40)  ic(1)
   40       format (/,' ADJACENT  --  Atom',i6,' is the only',
     &                 ' Connected Atom')
         end if
c
c     ask the user which eligible bonded atom to use as adjacent
c
      else
   50    continue
         if (nc .eq. 2) then
            write (iout,60)  (ic(j),j=1,nc)
   60       format (' Choose a Connected Atom (',2i6,') :  ',$)
         else if (nc .eq. 3) then
            write (iout,70)  (ic(j),j=1,nc)
   70       format (' Choose a Connected Atom (',3i6,') :  ',$)
         else if (nc .eq. 4) then
            write (iout,80)  (ic(j),j=1,nc)
   80       format (' Choose a Connected Atom (',4i6,') :  ',$)
         else if (nc .eq. 5) then
            write (iout,90)  (ic(j),j=1,nc)
   90       format (' Choose a Connected Atom (',5i6,') :  ',$)
         else if (nc .eq. 6) then
            write (iout,100)  (ic(j),j=1,nc)
  100       format (' Choose a Connected Atom (',6i6,') :  ',$)
         else if (nc .eq. 7) then
            write (iout,110)  (ic(j),j=1,nc)
  110       format (' Choose a Connected Atom (',7i6,') :  ',$)
         else if (nc .eq. 8) then
            write (iout,120)  (ic(j),j=1,nc)
  120       format (' Choose a Connected Atom (',8i6,') :  ',$)
         end if
         read (input,130,err=50)  adjacent
  130    format (i10)
         if (adjacent .eq. 0) then
            adjacent = ic(1)
         else
            do j = 1, nc
               if (ic(j) .eq. adjacent)  goto 140
            end do
            goto 50
  140       continue
         end if
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine makeref  --  copy structure to reference area  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "makeref" copies the information contained in the "xyz" file
c     of the current structure into corresponding reference areas
c
c
      subroutine makeref (iref)
      use atomid
      use atoms
      use boxes
      use couple
      use files
      use refer
      use titles
      implicit none
      integer i,j,iref
      logical first
      save first
      data first  / .true. /
c
c
c     perform dynamic allocation of some global arrays
c
      if (first) then
         first = .false.
         if (.not. allocated(reftyp))  allocate (reftyp(maxatm,maxref))
         if (.not. allocated(n12ref))  allocate (n12ref(maxatm,maxref))
         if (.not. allocated(i12ref))
     &      allocate (i12ref(maxval,maxatm,maxref))
         if (.not. allocated(xref))  allocate (xref(maxatm,maxref))
         if (.not. allocated(yref))  allocate (yref(maxatm,maxref))
         if (.not. allocated(zref))  allocate (zref(maxatm,maxref))
         if (.not. allocated(refnam))  allocate (refnam(maxatm,maxref))
      end if
c
c     copy the filename and title line for the structure
c
      reffile(iref) = filename
      refleng(iref) = leng
      reftitle(iref) = title
      refltitle(iref) = ltitle
c
c     copy the coordinates, type and connectivity of each atom
c
      nref(iref) = n
      do i = 1, n
         refnam(i,iref) = name(i)
         xref(i,iref) = x(i)
         yref(i,iref) = y(i)
         zref(i,iref) = z(i)
         reftyp(i,iref) = type(i)
         n12ref(i,iref) = n12(i)
         do j = 1, n12(i)
            i12ref(j,i,iref) = i12(j,i)
         end do
      end do
c
c     copy any unit cell parameters from the coordinates file
c
      xboxref(iref) = xbox
      yboxref(iref) = ybox
      zboxref(iref) = zbox
      alpharef(iref) = alpha
      betaref(iref) = beta
      gammaref(iref) = gamma
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine makexyz  --  convert internal to Cartesian  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "makexyz" generates a complete set of Cartesian coordinates
c     for a full structure from the internal coordinate values
c
c
      subroutine makexyz
      use atoms
      use zcoord
      implicit none
      integer i,chiral
      integer ia,ib,ic
      real*8 bond
      real*8 angle1
      real*8 angle2
c
c
c     loop over each atom in turn, finding its coordinates
c
      do i = 1, n
         ia = iz(1,i)
         ib = iz(2,i)
         ic = iz(3,i)
         chiral = iz(4,i)
         bond = zbond(i)
         angle1 = zang(i)
         angle2 = ztors(i)
         call xyzatm (i,ia,bond,ib,angle1,ic,angle2,chiral)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module math  --  mathematical and geometrical constants  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     pi         numerical value of the geometric constant Pi
c     twopi      numerical value of two times Pi
c     rootpi     numerical value of the square root of Pi
c     radian     conversion factor from radians to degrees
c     elog       numerical value of the natural logarithm base
c     logten     numerical value of the natural log of ten
c     twosix     numerical value of the sixth root of two
c     root2      numerical value of the square root of two
c     root3      numerical value of the square root of three
c     third      numerical value of one-third (1/3)
c     third2     numerical value of two-thirds (2/3)
c
c
      module math
      implicit none
      real*8 pi,twopi,rootpi
      real*8 radian,elog,logten
      real*8 twosix,root2,root3
      real*8 third,third2
      parameter (pi=3.141592653589793238d0)
      parameter (twopi=6.283185307179586476d0)
      parameter (rootpi=1.772453850905516027d0)
      parameter (radian=57.29577951308232088d0)
      parameter (elog=2.718281828459045235d0)
      parameter (logten=2.302585092994045684d0)
      parameter (twosix=1.122462048309372981d0)
      parameter (root2=1.414213562373095049d0)
      parameter (root3=1.732050807568877294d0)
      parameter (third=0.333333333333333333d0)
      parameter (third2=0.666666666666666667d0)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  function maxwell  --  Maxwell-Boltzmann distribution value  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "maxwell" returns a speed in Angstroms/picosecond randomly
c     selected from a 3-D Maxwell-Boltzmann distribution for the
c     specified particle mass (amu) and system temperature (K)
c
c     literature reference:
c
c     P. W. Atkins, "Physical Chemistry, 4th Edition", W. H. Freeman,
c     New York, 1990; see section 24.2 for general discussion
c
c
      function maxwell (mass,temper)
      use units
      implicit none
      real*8 maxwell
      real*8 mass,temper
      real*8 rho,beta
      real*8 random,erfinv
      real*8 xspeed,yspeed
      real*8 zspeed
      external random,erfinv
c
c
c     initialize the speed magnitude of the particle to zero
c
      maxwell = 0.0d0
c
c     set normalization factor for cumulative velocity distribution
c
      if (mass.gt.0.0d0 .and. temper.gt.0.0d0) then
         beta = sqrt(mass / (2.0d0*boltzmann*temper))
c
c     pick a randomly distributed velocity along each of three axes
c
         rho = random ()
         xspeed = erfinv(rho) / beta
         rho = random ()
         yspeed = erfinv(rho) / beta
         rho = random ()
         zspeed = erfinv(rho) / beta
c
c     set the final value of the particle speed in 3-dimensions
c
         maxwell = sqrt(xspeed**2 + yspeed**2 + zspeed**2)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2025  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program mdavg  --  statistics from molecular dynamics log  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "mdavg" is a simple utility to read the output from a Tinker
c     dynamics simulation and compute average and standard deviation
c     for quantities such as total energy, potential energy, kinetic
c     energy, temperature, pressure and density
c
c
      program mdavg
      use inform
      use iounit
      implicit none
      integer i,ilog
      integer nask,nread
      integer nstep,nblock
      integer maxblock
      integer start,stop
      integer freeunit
      real*8 block,time
      real*8 val,var
      real*8 etot,vtot
      real*8 epot,vpot
      real*8 ekin,vkin
      real*8 temp,vtemp
      real*8 pres,vpres
      real*8 dens,vdens
      logical exist,query
      logical doinfo,proceed
      character*240 logfile
      character*240 record
      character*240 string
c
c
c     default unit numbers for I/O and command line arguments
c
      input = 5
      iout = 6
      call command
c
c     zero out the individual average and variance values
c
      doinfo = .false.
      proceed = .false.
      maxblock = 1000000
      nread = 0
      nstep = 0
      nblock = 0
      time = 10000000.0d0
      etot = 0.0d0
      vtot = 0.0d0
      epot = 0.0d0
      vpot = 0.0d0
      ekin = 0.0d0
      vkin = 0.0d0
      temp = 0.0d0
      vtemp = 0.0d0
      pres = 0.0d0
      vpres = 0.0d0
      dens = 0.0d0
      vdens = 0.0d0
c
c     try to get a filename from the command line arguments
c
      call nextarg (logfile,exist)
      if (exist) then
         call basefile (logfile)
         call suffix (logfile,'log','old')
         inquire (file=logfile,exist=exist)
      end if
c
c     ask for the user specified dynamics log filename
c
      if (.not. exist)  call promo
      nask = 0
      do while (.not.exist .and. nask.lt.maxask)
         doinfo = .true.
         nask = nask + 1
         write (iout,10)
   10    format (/,' Enter Molecular Dynamics Log File Name :  ',$)
         read (input,20)  logfile
   20    format (a240)
         call basefile (logfile)
         call suffix (logfile,'log','old')
         inquire (file=logfile,exist=exist)
      end do
      if (.not. exist)  call fatal
c
c     find the first and last block to use in the analysis
c
      start = 1
      stop = maxblock
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=30,end=30)  start
         query = .false.
      end if
      call nextarg (string,exist)
      if (exist)  read (string,*,err=30,end=30)  stop
   30 continue
c
c     make interactive query for the range of blocks to use
c
      if (doinfo) then
         write (iout,40)
   40    format (/,' Numbers of First & Last Block of Steps :  ',$)
         read (input,50)  record
   50    format (a240)
         read (record,*,err=60,end=60)  start,stop
   60    continue
      end if
c
c     open the input molecular dynamics log file
c
      ilog = freeunit ()
      open (unit=ilog,file=logfile,status='old')
      rewind (unit=ilog)
c
c     get block average values from the dynamics log file
c
      do i = 1, maxblock
         read (ilog,70,err=80,end=80)  record
   70    format (a240)
         if (record(2:15) .eq. 'Average Values') then
            nread = nread + 1
            string = record(29:34)
            read (string,*)  nstep
            proceed = .false.
            if (nread.ge.start .and. nread.le.stop) then
               proceed = .true.
               nblock = nblock + 1
            end if
         else if (record(2:16) .eq. 'Simulation Time') then
            string = record(21:36)
            read (string,*)  val
            time = val / dble(nread)
         end if
         if (proceed) then
            if (record(2:13) .eq. 'Total Energy') then
               string = record(21:36)
               read (string,*)  val
               string = record(54:62)
               read (string,*)  var
               etot = etot + val
               vtot = vtot + var*var
            else if (record(2:17) .eq. 'Potential Energy') then
               string = record(21:36)
               read (string,*)  val
               string = record(54:62)
               read (string,*)  var
               epot = epot + val
               vpot = vpot + var*var
            else if (record(2:15) .eq. 'Kinetic Energy') then
               string = record(21:36)
               read (string,*)  val
               string = record(54:62)
               read (string,*)  var
               ekin = ekin + val
               vkin = vkin + var*var
            else if (record(2:12) .eq. 'Temperature') then
               string = record(21:36)
               read (string,*)  val
               string = record(54:62)
               read (string,*)  var
               temp = temp + val
               vtemp = vtemp + var*var
            else if (record(2:9) .eq. 'Pressure') then
               string = record(21:36)
               read (string,*)  val
               string = record(54:62)
               read (string,*)  var
               pres = pres + val
               vpres = vpres + var*var
            else if (record(2:8) .eq. 'Density') then
               string = record(21:36)
               read (string,*)  val
               string = record(54:62)
               read (string,*)  var
               dens = dens + val
               vdens = vdens + var*var
            end if
         end if
      end do
   80 continue
      block = dble(nblock)
      time = time * block
c
c     convert sums to average and standard deviation values
c
      if (nblock .ne. 0) then
         etot = etot / block
         vtot = sqrt(vtot/block)
         epot = epot / block
         vpot = sqrt(vpot/block)
         ekin = ekin / block
         vkin = sqrt(vkin/block)
         temp = temp / block
         vtemp = sqrt(vtemp/block)
         pres = pres / block
         vpres = sqrt(vpres/block)
         dens = dens / block
         vdens = sqrt(vdens/block)
      end if
c
c     print the averages and overall standard deviations
c
      if (nblock .ne. 0) then
         if (doinfo) then
            write (iout,90)
   90       format ()
         end if
         write (iout,100)  nblock
  100    format (' Total MD Blocks',8x,i12,' Blocks')
         if (doinfo) then
            write (iout,110)  nstep
  110       format (' Steps per Block',8x,i12,' Steps')
            if (time .ge. 1000000.0d0) then
               write (iout,120)  time/1000000.0d0
  120          format (' Simulation Time',8x,f12.4,' Microseconds',/)
            else if (time .ge. 1000.0d0) then
               write (iout,130)  time/1000.0d0
  130          format (' Simulation Time',8x,f12.4,' Nanoseconds',/)
            else
               write (iout,140)  time
  140          format (' Simulation Time',8x,f12.2,' Picoseconds',/)
            end if
         end if
         write (iout,150)  etot,vtot
  150    format (' Total Energy',7x,f16.4,' Kcal/mole   (+/-',
     &              f9.4,')')
         write (iout,160)  epot,vpot
  160    format (' Potential Energy',3x,f16.4,' Kcal/mole   (+/-',
     &              f9.4,')')
         write (iout,170)  ekin,vkin
  170    format (' Kinetic Energy',5x,f16.4,' Kcal/mole   (+/-',
     &              f9.4,')')
         write (iout,180)  temp,vtemp
  180    format (' Temperature',8x,f16.2,' Kelvin      (+/-',f9.2,')')
         write (iout,190)  pres,vpres
  190    format (' Pressure',11x,f16.2,' Atmosphere  (+/-',f9.2,')')
         write (iout,200)  dens,vdens
  200    format (' Density',12x,f16.4,' Grams/cc    (+/-',f9.4,')')
      else
         write (iout,210)
  210    format (/,' MDAVG  --  Input File Contains No Dynamics',
     &              ' Log Information')
      end if
      close (unit=ilog)
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine mdinit  --  initialize a dynamics trajectory  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "mdinit" initializes the velocities and accelerations
c     for a molecular dynamics trajectory, including restarts
c
c
      subroutine mdinit (dt)
      use atomid
      use atoms
      use bath
      use bound
      use couple
      use extfld
      use files
      use freeze
      use group
      use inform
      use iounit
      use keys
      use mdstuf
      use molcul
      use moldyn
      use mpole
      use output
      use potent
      use rgddyn
      use rigid
      use stodyn
      use units
      use usage
      implicit none
      integer i,j,istep
      integer idyn,lext
      integer size,next
      integer ndummy
      integer freeunit
      integer trimtext
      real*8 dt,e,ekt,qterm
      real*8 maxwell,speed
      real*8 amass,gmass
      real*8 vec(3)
      real*8, allocatable :: derivs(:,:)
      logical exist
      character*7 ext
      character*20 keyword
      character*20 text
      character*240 dynfile
      character*240 record
      character*240 string
c
c
c     set default parameters for the dynamics trajectory
c
      integrate = 'BEEMAN'
      bmnmix = 8
      nrespa = max(1,nint(dt/0.0005d0))
      nfree = 0
      ndummy = 0
      irest = -1
      iprint = 100
      use_wrap = .true.
      velsave = .false.
      frcsave = .false.
      uindsave = .false.
      friction = 0.5d0
      if (use_solv)  friction = 91.0d0
      use_sdarea = .false.
c
c     set default values for temperature and pressure control
c
      thermostat = 'BUSSI'
      tautemp = -1.0d0
      collide = 0.1d0
      do i = 1, maxnose
         vnh(i) = 0.0d0
         qnh(i) = 0.0d0
         gnh(i) = 0.0d0
      end do
      barostat = 'BUSSI'
      prestyp = 'ISOTROPIC'
      taupres = -1.0d0
      compress = 0.000046d0
      vbar = 0.0d0
      qbar = 0.0d0
      gbar = 0.0d0
      voltrial = 25
      volmove = 100.0d0
      volscale = 'MOLECULAR'
c
c     check for keywords containing any altered parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:11) .eq. 'INTEGRATOR ') then
            call getword (record,integrate,next)
            call upcase (integrate)
            if (integrate .eq. 'RESPA')  integrate = 'BRESPA'
         else if (keyword(1:14) .eq. 'BEEMAN-MIXING ') then
            read (string,*,err=10,end=10)  bmnmix
         else if (keyword(1:12) .eq. 'RESPA-INNER ') then
            read (string,*,err=10,end=10)  nrespa
         else if (keyword(1:16) .eq. 'DEGREES-FREEDOM ') then
            read (string,*,err=10,end=10)  nfree
         else if (keyword(1:15) .eq. 'REMOVE-INERTIA ') then
            read (string,*,err=10,end=10)  irest
         else if (keyword(1:12) .eq. 'UNWRAP-COORDS ') then
            use_wrap = .false.
         else if (keyword(1:14) .eq. 'SAVE-VELOCITY ') then
            velsave = .true.
         else if (keyword(1:11) .eq. 'SAVE-FORCE ') then
            frcsave = .true.
         else if (keyword(1:13) .eq. 'SAVE-INDUCED ') then
            uindsave = .true.
         else if (keyword(1:9) .eq. 'FRICTION ') then
            read (string,*,err=10,end=10)  friction
         else if (keyword(1:17) .eq. 'FRICTION-SCALING ') then
            use_sdarea = .true.
         else if (keyword(1:11) .eq. 'THERMOSTAT ') then
            call getword (record,text,next)
            call upcase (text)
            if (text(1:5) .eq. 'BUSSI')  thermostat = 'BUSSI'
            if (text(1:9) .eq. 'BERENDSEN')  thermostat = 'BERENDSEN'
            if (text(1:4) .eq. 'NOSE')  thermostat = 'NOSE-HOOVER'
            if (text(1:8) .eq. 'ANDERSEN')  thermostat = 'ANDERSEN'
         else if (keyword(1:16) .eq. 'TAU-TEMPERATURE ') then
            read (string,*,err=10,end=10)  tautemp
         else if (keyword(1:10) .eq. 'COLLISION ') then
            read (string,*,err=10,end=10)  collide
         else if (keyword(1:9) .eq. 'BAROSTAT ') then
            call getword (record,text,next)
            call upcase (text)
            if (text(1:5) .eq. 'BUSSI')  barostat = 'BUSSI'
            if (text(1:9) .eq. 'BERENDSEN')  barostat = 'BERENDSEN'
            if (text(1:4) .eq. 'NOSE')  barostat = 'NOSE-HOOVER'
            if (text(1:10) .eq. 'MONTECARLO')  barostat = 'MONTECARLO'
         else if (keyword(1:13) .eq. 'TAU-PRESSURE ') then
            read (string,*,err=10,end=10)  taupres
         else if (keyword(1:9) .eq. 'PRESSURE ') then
            call getword (record,text,next)
            call upcase (text)
            if (text(1:3) .eq. 'ISO')  prestyp = 'ISOTROPIC'
            if (text(1:5) .eq. 'ANISO')  prestyp = 'ANISO'
            if (text(1:4) .eq. 'SEMI')  prestyp = 'SEMIISO'
         else if (keyword(1:9) .eq. 'COMPRESS ') then
            read (string,*,err=10,end=10)  compress
         else if (keyword(1:13) .eq. 'VOLUME-TRIAL ') then
            read (string,*,err=10,end=10)  voltrial
         else if (keyword(1:12) .eq. 'VOLUME-MOVE ') then
            read (string,*,err=10,end=10)  volmove
         else if (keyword(1:13) .eq. 'VOLUME-SCALE ') then
            call getword (record,text,next)
            call upcase (text)
            if (text(1:9) .eq. 'MOLECULAR')  volscale = 'MOLECULAR'
            if (text(1:6) .eq. 'ATOMIC')  volscale = 'ATOMIC'
         else if (keyword(1:9) .eq. 'PRINTOUT ') then
            read (string,*,err=10,end=10)  iprint
         end if
   10    continue
      end do
c
c     check for use of induced dipole prediction methods
c
      if (use_polar)  call predict
c
c     make sure all atoms or groups have a nonzero mass
c
      if (integrate .eq. 'RIGIDBODY') then
         do i = 1, ngrp
            if (grpmass(i) .le. 0.0d0) then
               grpmass(i) = 1.0d0
               if (igrp(1,i) .le. igrp(2,i)) then
                  totmass = totmass + 1.0d0
                  if (verbose) then
                     write (iout,20)  i
   20                format (/,' MDINIT  --  Warning, Mass of Group',
     &                          i6,' Set to 1.0 for Dynamics')
                  end if
               end if
            end if
         end do
      else
         do i = 1, n
            if (atomic(i) .le. 0)  ndummy = ndummy + 1
            if (use(i) .and. mass(i).le.0.0d0) then
               mass(i) = 1.0d0
               if (atomic(i) .gt. 0)  totmass = totmass + 1.0d0
               if (verbose) then
                  write (iout,30)  i
   30             format (/,' MDINIT  --  Warning, Mass of Atom',
     &                       i6,' Set to 1.0 for Dynamics')
               end if
            end if
         end do
      end if
c
c     decide whether to remove center of mass motion; note
c     should be applied by default to stochastic dynamics
c
      dorest = .true.
      if (irest .eq. 0) then
         dorest = .false.
      else if (irest .lt. 0) then
         if (nuse .ne. n)  dorest = .false.
c        if (integrate .eq. 'BAOAB')  dorest = .false.
c        if (integrate .eq. 'OBABO')  dorest = .false.
c        if (integrate .eq. 'SRESPA')  dorest = .false.
c        if (integrate .eq. 'STOCHASTIC')  dorest = .false.
         if (integrate .eq. 'GHMC')  dorest = .false.
         if (isothermal .and. thermostat.eq.'ANDERSEN')
     &      dorest = .false.
      end if
      if (dorest) then
         if (irest .lt. 0)  irest = 100
      else
         irest = 0
      end if
c
c     enforce use of velocity Verlet with Andersen thermostat
c
      if (thermostat .eq. 'ANDERSEN') then
         if (integrate .eq. 'BEEMAN')  integrate = 'VERLET'
         if (integrate .eq. 'BRESPA')  integrate = 'VRESPA'
      end if
c
c     couple Nose-Hoover thermostat and barostat with integrator
c
      if (integrate .eq. 'NOSE-HOOVER') then
         thermostat = 'NOSE-HOOVER'
         barostat = 'NOSE-HOOVER'
      else if (thermostat.eq.'NOSE-HOOVER' .and.
     &         barostat.eq.'NOSE-HOOVER') then
         integrate = 'NOSE-HOOVER'
      end if
c
c     apply default values for thermostat and barostat coupling
c
      if (tautemp .lt. 0.0d0) then
         tautemp = 0.2d0
         if (thermostat .eq. 'NOSE-HOOVER')  tautemp = 1.0d0
      end if
      if (taupres .lt. 0.0d0) then
         taupres = 2.0d0
         if (barostat .eq. 'NOSE-HOOVER')  taupres = 10.0d0
         if (prestyp .eq. 'ANISO')  taupres = 10.0d0
      end if
c
c     check for options not allowed with Monte Carlo barostat
c
      if (barostat .eq. 'MONTECARLO') then
         if (use_freeze .and. volscale.eq.'ATOMIC') then
            write (iout,40)
   40       format (/,' MDINIT  --  No Atom-Based Monte Carlo',
     &                 ' Barostat with Constraints')
            call fatal
         else if (prestyp .eq. 'SEMIISO') then 
            write (iout,50)
   50       format (/,' MDINIT  --  No Monte Carlo Barostat',
     &                 ' with Semi-Isotropic Pressure')
            call fatal
         end if
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (integrate .eq. 'RIGIDBODY') then
         if (.not. allocated(xcmo))  allocate (xcmo(n))
         if (.not. allocated(ycmo))  allocate (ycmo(n))
         if (.not. allocated(zcmo))  allocate (zcmo(n))
         if (.not. allocated(vcm))  allocate (vcm(3,ngrp))
         if (.not. allocated(wcm))  allocate (wcm(3,ngrp))
         if (.not. allocated(lm))  allocate (lm(3,ngrp))
         if (.not. allocated(vc))  allocate (vc(3,ngrp))
         if (.not. allocated(wc))  allocate (wc(3,ngrp))
         if (.not. allocated(linear))  allocate (linear(ngrp))
      else
         if (.not. allocated(v))  allocate (v(3,n))
         if (.not. allocated(a))  allocate (a(3,n))
         if (.not. allocated(aalt))  allocate (aalt(3,n))
         if (.not. allocated(aslow))  allocate (aslow(3,n))
         if (.not. allocated(afast))  allocate (afast(3,n))
      end if
c
c     set the number of degrees of freedom for the system
c
      if (nfree .eq. 0) then
         if (integrate .eq. 'RIGIDBODY') then
            call grpline
            nfree = 6 * ngrp
            do i = 1, ngrp
               size = igrp(2,i) - igrp(1,i) + 1
               if (size .eq. 1)  nfree = nfree - 3
               if (linear(i))  nfree = nfree - 1
            end do
         else
            nfree = 3 * (nuse-ndummy)
         end if
         if (use_freeze) then
            nfree = nfree - nrat
            do i = 1, nratx
               nfree = nfree - kratx(i)
            end do
            nfree = nfree - 3*nwat
         end if
         if (isothermal .and. thermostat.ne.'ANDERSEN'
     &         .and. integrate.ne.'BAOAB'
     &         .and. integrate.ne.'OBABO'
     &         .and. integrate.ne.'SRESPA'
     &         .and. integrate.ne.'STOCHASTIC'
     &         .and. integrate.ne.'GHMC') then
            if (.not. use_exfld) then
               if (use_bounds) then
                  if (integrate.ne.'RIGIDBODY' .and. ngrp.ne.0) then
                     nfree = nfree - 6*(ngrp+1)
                  else
                     nfree = nfree - 3
                  end if
               else
                  nfree = nfree - 6
               end if
            end if
         end if
      end if
c
c     check for a nonzero number of degrees of freedom
c
      if (nfree .lt. 0)  nfree = 0
      if (debug) then
         write (iout,60)  nfree
   60    format (/,' Number of Degrees of Freedom for Dynamics :',i10)
      end if
      if (nfree .eq. 0) then
         write (iout,70)
   70    format (/,' MDINIT  --  No Degrees of Freedom for Dynamics')
         call fatal
      end if
c
c     set masses for Nose-Hoover thermostat and barostat
c
      if (thermostat .eq. 'NOSE-HOOVER') then
         ekt = gasconst * kelvin
         qterm = ekt * tautemp * tautemp
         do j = 1, maxnose
            if (qnh(j) .eq. 0.0d0)  qnh(j) = qterm
         end do
         qnh(1) = dble(nfree) * qnh(1)
      end if
      if (barostat .eq. 'NOSE-HOOVER') then
         ekt = gasconst * kelvin
         qterm = ekt * taupres * taupres
         qbar = dble(nfree+1) * qterm
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     try to restart using prior velocities and accelerations
c
      dynfile = filename(1:leng)//'.dyn'
      call version (dynfile,'old')
      inquire (file=dynfile,exist=exist)
      if (exist) then
         call gradient (e,derivs)
         idyn = freeunit ()
         open (unit=idyn,file=dynfile,status='old')
         rewind (unit=idyn)
         call readdyn (idyn)
         close (unit=idyn)
         write (iout,80)  dynfile(1:trimtext(dynfile))
   80    format (/,' Restarting Molecular Dynamics Using :  ',a)
c
c     set translational velocities for rigid body dynamics
c
      else if (integrate .eq. 'RIGIDBODY') then
         call gradient (e,derivs)
         do i = 1, ngrp
            gmass = grpmass(i)
            speed = maxwell (gmass,kelvin)
            call ranvec (vec)
            do j = 1, 3
               vcm(j,i) = speed * vec(j)
               wcm(j,i) = 0.0d0
               lm(j,i) = 0.0d0
            end do
         end do
         if (nuse .eq. n) then
            istep = 0
            call mdrest (istep)
         end if
c
c     set velocities and fast/slow accelerations for RESPA methods
c
      else if (integrate.eq.'VRESPA' .or. integrate.eq.'BRESPA'
     &            .or. integrate.eq.'SRESPA') then
         call gradslow (e,derivs)
         do i = 1, n
            amass = mass(i)
            if (use(i) .and. amass.ne.0.0d0) then
               speed = maxwell (amass,kelvin)
               call ranvec (vec)
               do j = 1, 3
                  v(j,i) = speed * vec(j)
                  a(j,i) = -ekcal * derivs(j,i) / mass(i)
                  aslow(j,i) = a(j,i)
               end do
            else
               do j = 1, 3
                  v(j,i) = 0.0d0
                  a(j,i) = 0.0d0
                  aslow(j,i) = 0.0d0
               end do
            end if
         end do
         call gradfast (e,derivs)
         do i = 1, n
            amass = mass(i)
            if (use(i) .and. amass.ne.0.0d0) then
               do j = 1, 3
                  aalt(j,i) = -ekcal * derivs(j,i) / amass
                  afast(j,i) = aalt(j,i)
               end do
            else
               do j = 1, 3
                  aalt(j,i) = 0.0d0
                  afast(j,i) = aalt(j,i)
               end do
            end if
         end do
         if (nuse .eq. n) then
            istep = 0
            call mdrest (istep)
         end if
c
c     set velocities and accelerations for Cartesian dynamics
c
      else
         call gradient (e,derivs)
         do i = 1, n
            amass = mass(i)
            if (use(i) .and. amass.ne.0.0d0) then
               speed = maxwell (amass,kelvin)
               call ranvec (vec)
               do j = 1, 3
                  v(j,i) = speed * vec(j)
                  a(j,i) = -ekcal * derivs(j,i) / amass
                  aalt(j,i) = a(j,i)
               end do
            else
               do j = 1, 3
                  v(j,i) = 0.0d0
                  a(j,i) = 0.0d0
                  aalt(j,i) = 0.0d0
               end do
            end if
         end do
         if (nuse .eq. n) then
            istep = 0
            call mdrest (istep)
         end if
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
c
c     check for any prior dynamics coordinate sets
c
      i = 0
      exist = .true.
      do while (exist)
         i = i + 1
         lext = 3
         call numeral (i,ext,lext)
         dynfile = filename(1:leng)//'.'//ext(1:lext)
         inquire (file=dynfile,exist=exist)
         if (.not.exist .and. i.lt.100) then
            lext = 2
            call numeral (i,ext,lext)
            dynfile = filename(1:leng)//'.'//ext(1:lext)
            inquire (file=dynfile,exist=exist)
         end if
         if (.not.exist .and. i.lt.10) then
            lext = 1
            call numeral (i,ext,lext)
            dynfile = filename(1:leng)//'.'//ext(1:lext)
            inquire (file=dynfile,exist=exist)
         end if
      end do
      nprior = i - 1
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine mdrest  --  stop system translation & rotation  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "mdrest" finds and removes any translational or rotational
c     kinetic energy of the center of mass of the overall system,
c     of rigid bodies or of user-defined atom groups
c
c
      subroutine mdrest (istep)
      use mdstuf
      implicit none
      integer istep
c
c
c     check steps between center of mass motion removal
c
c     if (.not. dorest)  return
c     if (mod(istep,irest) .ne. 0)  return
c
c     eliminate system translational and rotational motion
c
      if (integrate .eq. 'RIGIDBODY') then
         call rgdrest
      else
         call xyzrest
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine xyzrest  --  remove Cartesian system inertia  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "xyzrest" removes any translational or rotational inertia
c     during dynamics for the overall system or atom groups
c
c
      subroutine xyzrest
      use atomid
      use atoms
      use bound
      use group
      use inform
      use iounit
      use moldyn
      use units
      implicit none
      integer i,j,k,m
      real*8 weigh,eps
      real*8 xx,yy,zz,xy,xz,yz
      real*8 xdel,ydel,zdel
      real*8 mang(3),tensor(3,3)
      real*8, allocatable :: totmass(:)
      real*8, allocatable :: etrans(:)
      real*8, allocatable :: erot(:)
      real*8, allocatable :: xtot(:)
      real*8, allocatable :: ytot(:)
      real*8, allocatable :: ztot(:)
      real*8, allocatable :: vtot(:,:)
      real*8, allocatable :: vang(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (totmass(0:ngrp))
      allocate (etrans(0:ngrp))
      allocate (vtot(3,0:ngrp))
      if (.not.use_bounds .or. ngrp.ne.0) then
         allocate (erot(0:ngrp))
         allocate (xtot(0:ngrp))
         allocate (ytot(0:ngrp))
         allocate (ztot(0:ngrp))
         allocate (vang(3,0:ngrp))
      end if
c
c     zero out total mass and linear velocity of each group
c
      do i = 0, ngrp
         totmass(i) = 0.0d0
         do j = 1, 3
            vtot(j,i) = 0.0d0
         end do
      end do
c
c     compute linear velocity of each group center of mass
c
      do i = 0, ngrp
         do k = igrp(1,i), igrp(2,i)
            m = kgrp(k)
            weigh = mass(m)
            totmass = totmass + weigh
            do j = 1, 3
               vtot(j,i) = vtot(j,i) + v(j,m)*weigh
            end do
         end do
      end do
c
c     compute translational kinetic energy of each group
c
      do i = 0, ngrp
         etrans(i) = 0.0d0
         do j = 1, 3
            vtot(j,i) = vtot(j,i) / totmass(i)
            etrans(i) = etrans(i) + vtot(j,i)**2
         end do
         etrans(i) = 0.5d0 * etrans(i) * totmass(i) / ekcal
      end do
c
c     find the center of mass coordinates of each atom group
c
      if (.not.use_bounds .or. ngrp.ne.0) then
         do i = 0, ngrp
            xtot(i) = 0.0d0
            ytot(i) = 0.0d0
            ztot(i) = 0.0d0
            do k = igrp(1,i), igrp(2,i)
               m = kgrp(k)
               weigh = mass(m)
               xtot(i) = xtot(i) + x(m)*weigh
               ytot(i) = ytot(i) + y(m)*weigh
               ztot(i) = ztot(i) + z(m)*weigh
            end do
            xtot(i) = xtot(i) / totmass(i)
            ytot(i) = ytot(i) / totmass(i)
            ztot(i) = ztot(i) / totmass(i)
c
c     compute the angular momentum of each atom group
c
            do j = 1, 3
               mang(j) = 0.0d0
            end do
            do k = igrp(1,i), igrp(2,i)
               m = kgrp(k)
               weigh = mass(m)
               mang(1) = mang(1) + (y(m)*v(3,m)-z(m)*v(2,m))*weigh
               mang(2) = mang(2) + (z(m)*v(1,m)-x(m)*v(3,m))*weigh
               mang(3) = mang(3) + (x(m)*v(2,m)-y(m)*v(1,m))*weigh
            end do
            mang(1) = mang(1) - (ytot(i)*vtot(3,i)-ztot(i)*vtot(2,i))
     &                             *totmass(i)
            mang(2) = mang(2) - (ztot(i)*vtot(1,i)-xtot(i)*vtot(3,i))
     &                             *totmass(i)
            mang(3) = mang(3) - (xtot(i)*vtot(2,i)-ytot(i)*vtot(1,i))
     &                             *totmass(i)
c
c     calculate the moment of inertia tensor
c
            xx = 0.0d0
            xy = 0.0d0
            xz = 0.0d0
            yy = 0.0d0
            yz = 0.0d0
            zz = 0.0d0
            do k = igrp(1,i), igrp(2,i)
               m = kgrp(k)
               weigh = mass(m)
               xdel = x(m) - xtot(i)
               ydel = y(m) - ytot(i)
               zdel = z(m) - ztot(i)
               xx = xx + xdel*xdel*weigh
               xy = xy + xdel*ydel*weigh
               xz = xz + xdel*zdel*weigh
               yy = yy + ydel*ydel*weigh
               yz = yz + ydel*zdel*weigh
               zz = zz + zdel*zdel*weigh
            end do
            tensor(1,1) = yy + zz
            tensor(2,1) = -xy
            tensor(3,1) = -xz
            tensor(1,2) = -xy
            tensor(2,2) = xx + zz
            tensor(3,2) = -yz
            tensor(1,3) = -xz
            tensor(2,3) = -yz
            tensor(3,3) = xx + yy
c
c     fix to avoid singularity for one- or two-body groups
c
            if (igrp(2,i)-igrp(1,i) .le. 2) then
               eps = 0.000001d0
               tensor(1,1) = tensor(1,1) + eps
               tensor(2,2) = tensor(2,2) + eps
               tensor(3,3) = tensor(3,3) + eps
            end if
c
c     diagonalize the moment of inertia tensor
c
            call invert (3,tensor)
c
c     compute angular velocity and rotational kinetic energy
c
            erot(i) = 0.0d0
            do k = 1, 3
               vang(k,i) = 0.0d0
               do j = 1, 3
                  vang(k,i) = vang(k,i) + tensor(k,j)*mang(j)
               end do
               erot(i) = erot(i) + vang(k,i)*mang(k)
            end do
            erot(i) = 0.5d0 * erot(i) / ekcal
         end do
      end if
c
c     eliminate any translation of each atom group
c
      do i = 0, ngrp
         do k = igrp(1,i), igrp(2,i)
            m = kgrp(k)
            do j = 1, 3
               v(j,m) = v(j,m) - vtot(j,i)
            end do
         end do
      end do
c
c     print the translational velocity of each atom group
c
      if (debug) then
         write (iout,10)
   10    format ()
         if (ngrp .eq. 0) then
            write (iout,20)  (vtot(i,0),i=1,3),etrans(0)
   20       format (' System Linear Velocity :  ',3d12.2,
     &              /,' Translational Kinetic Energy :',10x,f12.4,
     &                 ' Kcal/mole')
         else
            do i = 0, ngrp
               write (iout,30)  i,(vtot(j,i),j=1,3),etrans(i)
   30          format (' Group',i4,' Linear Velocity :  ',3d12.2,
     &                 /,' Translational Kinetic Energy :',10x,f12.4,
     &                    ' Kcal/mole')
            end do
         end if
      end if
c
c     eliminate any rotation about each group center of mass
c
      if (.not.use_bounds .or. ngrp.ne.0) then
         do i = 0, ngrp
            do k = igrp(1,i), igrp(2,i)
               m = kgrp(k)
               xdel = x(m) - xtot(i)
               ydel = y(m) - ytot(i)
               zdel = z(m) - ztot(i)
               v(1,m) = v(1,m) - vang(2,i)*zdel + vang(3,i)*ydel
               v(2,m) = v(2,m) - vang(3,i)*xdel + vang(1,i)*zdel
               v(3,m) = v(3,m) - vang(1,i)*ydel + vang(2,i)*xdel
            end do
         end do
c
c     print the angular velocity of each atom group
c
         if (debug) then
            if (ngrp .eq. 0) then
               write (iout,40)  (vang(j,0),j=1,3),erot(0)
   40          format (' System Angular Velocity : ',3d12.2,
     &                 /,' Rotational Kinetic Energy :',13x,f12.4,
     &                    ' Kcal/mole')
            else
               do i = 0, ngrp
                  write (iout,50)  i,(vang(j,i),j=1,3),erot(i)
   50             format (' Group',i4,' Angular Velocity : ',3d12.2,
     &                    /,' Rotational Kinetic Energy :',13x,f12.4,
     &                       ' Kcal/mole')
               end do
            end if
         end if
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (totmass)
      deallocate (etrans)
      deallocate (vtot)
      if (.not.use_bounds .or. ngrp.ne.0) then
         deallocate (erot)
         deallocate (xtot)
         deallocate (ytot)
         deallocate (ztot)
         deallocate (vang)
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine rgdrest  --  remove rigidbody system inertia  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "rgdrest" removes any translational or rotational inertia
c     during dynamics over rigid body coordinates
c
c
      subroutine rgdrest
      use atomid
      use atoms
      use bound
      use group
      use inform
      use iounit
      use rgddyn
      use units
      implicit none
      integer i,j,k
      real*8 etrans,erot
      real*8 weigh,totmass,eps
      real*8 xx,yy,zz,xy,xz,yz
      real*8 xtot,ytot,ztot
      real*8 xdel,ydel,zdel
      real*8 mang(3),vang(3)
      real*8 vtot(3),tensor(3,3)
      real*8, allocatable :: xcm(:)
      real*8, allocatable :: ycm(:)
      real*8, allocatable :: zcm(:)
c
c
c     zero out the total mass and overall linear velocity
c
      totmass = 0.0d0
      do j = 1, 3
         vtot(j) = 0.0d0
      end do
c
c     compute linear velocity of the system center of mass
c
      do i = 1, ngrp
         weigh = grpmass(i)
         totmass = totmass + weigh
         do j = 1, 3
            vtot(j) = vtot(j) + vcm(j,i)*weigh
         end do
      end do
c
c     compute translational kinetic energy of overall system
c
      etrans = 0.0d0
      do j = 1, 3
         vtot(j) = vtot(j) / totmass
         etrans = etrans + vtot(j)**2
      end do
      etrans = 0.5d0 * etrans * totmass / ekcal
c
c     perform dynamic allocation of some local arrays
c
      if (.not. use_bounds) then
         allocate (xcm(ngrp))
         allocate (ycm(ngrp))
         allocate (zcm(ngrp))
      end if
c
c     find the center of mass coordinates of the overall system
c
      if (.not. use_bounds) then
         xtot = 0.0d0
         ytot = 0.0d0
         ztot = 0.0d0
         do i = 1, ngrp
            xcm(i) = 0.0d0
            ycm(i) = 0.0d0
            zcm(i) = 0.0d0
            do j = igrp(1,i), igrp(2,i)
               k = kgrp(j)
               weigh = mass(k)
               xcm(i) = xcm(i) + x(k)*weigh
               ycm(i) = ycm(i) + y(k)*weigh
               zcm(i) = zcm(i) + z(k)*weigh
            end do
            xtot = xtot + xcm(i)
            ytot = ytot + ycm(i)
            ztot = ztot + zcm(i)
            weigh = max(1.0d0,grpmass(i))
            xcm(i) = xcm(i) / weigh
            ycm(i) = ycm(i) / weigh
            zcm(i) = zcm(i) / weigh
         end do
         xtot = xtot / totmass
         ytot = ytot / totmass
         ztot = ztot / totmass
c
c     compute the angular momentum of the overall system
c
         do j = 1, 3
            mang(j) = 0.0d0
         end do
         do i = 1, ngrp
            weigh = grpmass(i)
            mang(1) = mang(1) + (ycm(i)*vcm(3,i)
     &                          -zcm(i)*vcm(2,i))*weigh
            mang(2) = mang(2) + (zcm(i)*vcm(1,i)
     &                          -xcm(i)*vcm(3,i))*weigh
            mang(3) = mang(3) + (xcm(i)*vcm(2,i)
     &                          -ycm(i)*vcm(1,i))*weigh
         end do
         mang(1) = mang(1) - (ytot*vtot(3)-ztot*vtot(2))*totmass
         mang(2) = mang(2) - (ztot*vtot(1)-xtot*vtot(3))*totmass
         mang(3) = mang(3) - (xtot*vtot(2)-ytot*vtot(1))*totmass
c
c     calculate the moment of inertia tensor
c
         xx = 0.0d0
         xy = 0.0d0
         xz = 0.0d0
         yy = 0.0d0
         yz = 0.0d0
         zz = 0.0d0
         do i = 1, ngrp
            weigh = grpmass(i)
            xdel = xcm(i) - xtot
            ydel = ycm(i) - ytot
            zdel = zcm(i) - ztot
            xx = xx + xdel*xdel*weigh
            xy = xy + xdel*ydel*weigh
            xz = xz + xdel*zdel*weigh
            yy = yy + ydel*ydel*weigh
            yz = yz + ydel*zdel*weigh
            zz = zz + zdel*zdel*weigh
         end do
         tensor(1,1) = yy + zz
         tensor(2,1) = -xy
         tensor(3,1) = -xz
         tensor(1,2) = -xy
         tensor(2,2) = xx + zz
         tensor(3,2) = -yz
         tensor(1,3) = -xz
         tensor(2,3) = -yz
         tensor(3,3) = xx + yy
c
c     fix to avoid singularity for one- or two-body systems
c
         if (ngrp .le. 2) then
            eps = 0.000001d0
            tensor(1,1) = tensor(1,1) + eps
            tensor(2,2) = tensor(2,2) + eps
            tensor(3,3) = tensor(3,3) + eps
         end if
c
c     diagonalize the moment of inertia tensor
c
         call invert (3,tensor)
c
c     compute angular velocity and rotational kinetic energy
c
         erot = 0.0d0
         do i = 1, 3
            vang(i) = 0.0d0
            do j = 1, 3
               vang(i) = vang(i) + tensor(i,j)*mang(j)
            end do
            erot = erot + vang(i)*mang(i)
         end do
         erot = 0.5d0 * erot / ekcal
      end if
c
c     eliminate any translation of the overall system
c
      do i = 1, ngrp
         do j = 1, 3
            vcm(j,i) = vcm(j,i) - vtot(j)
         end do
      end do
c
c     print the translational velocity of the overall system
c
      if (debug) then
         write (iout,10)  (vtot(j),j=1,3),etrans
   10    format (' System Linear Velocity :  ',3d12.2,
     &           /,' Translational Kinetic Energy :',10x,f12.4,
     &              ' Kcal/mole')
      end if
c
c     eliminate any rotation about the system center of mass
c
      if (.not. use_bounds) then
         do i = 1, ngrp
            xdel = xcm(i) - xtot
            ydel = ycm(i) - ytot
            zdel = zcm(i) - ztot
            vcm(1,i) = vcm(1,i) - vang(2)*zdel + vang(3)*ydel
            vcm(2,i) = vcm(2,i) - vang(3)*xdel + vang(1)*zdel
            vcm(3,i) = vcm(3,i) - vang(1)*ydel + vang(2)*xdel
         end do
c
c     print the angular velocity of the overall system
c
         if (debug) then
            write (iout,20)  (vang(j),j=1,3),erot
   20       format (' System Angular Velocity : ',3d12.2,
     &              /,' Rotational Kinetic Energy :',13x,f12.4,
     &                 ' Kcal/mole')
         end if
      end if
c
c     perform deallocation of some local arrays
c
      if (.not. use_bounds) then
         deallocate (xcm)
         deallocate (ycm)
         deallocate (zcm)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine mdsave  --  save trajectory and restart files  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "mdsave" writes molecular dynamics trajectory snapshots and
c     auxiliary files with velocity, force or induced dipole data;
c     also checks for user requested termination of a simulation
c
c
      subroutine mdsave (istep,dt,epot,eksum)
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use files
      use group
      use inform
      use iounit
      use mdstuf
      use mpole
      use output
      use polar
      use potent
      use rgddyn
      use socket
      use titles
      implicit none
      integer i,j,lext
      integer istep
      integer ixyz,iind
      integer ivel,ifrc
      integer iend,isave
      integer freeunit
      integer trimtext
      integer modsave
      real*8 dt,pico
      real*8 epot,eksum
      logical exist,first
      character*7 ext
      character*240 endfile
      character*240 xyzfile
      character*240 velfile
      character*240 frcfile
      character*240 indfile
c
c
c     send data via external socket communication if desired
c
      if (.not.sktstart .or. use_socket)  call sktdyn (istep,dt,epot)
c
c     check number of steps between trajectory file saves
c
      modsave = mod(istep,iwrite)
      if (modsave .ne. 0)  return
c
c     get the sequence number of the current trajectory frame
c
      isave = nprior + istep/iwrite
      lext = 3
      call numeral (isave,ext,lext)
c
c     print header for the instantaneous values at current step
c
      pico = dble(istep) * dt
      write (iout,10)  istep
   10 format (/,' Instantaneous Values for Frame Saved at',
     &           i10,' Dynamics Steps')
c
c     print the current time, potential and kinetic energies
c
      if (digits .ge. 8) then
         write (iout,20)  pico
   20    format (/,' Current Time',8x,f19.8,' Picosecond')
         write (iout,30)  epot
   30    format (' Current Potential',3x,f19.8,' Kcal/mole')
         write (iout,40)  eksum
   40    format (' Current Kinetic',5x,f19.8,' Kcal/mole')
      else if (digits .ge. 6) then
         write (iout,50)  pico
   50    format (/,' Current Time',8x,f17.6,' Picosecond')
         write (iout,60)  epot
   60    format (' Current Potential',3x,f17.6,' Kcal/mole')
         write (iout,70)  eksum
   70    format (' Current Kinetic',5x,f17.6,' Kcal/mole')
      else
         write (iout,80)  pico
   80    format (/,' Current Time',8x,f15.4,' Picosecond')
         write (iout,90)  epot
   90    format (' Current Potential',3x,f15.4,' Kcal/mole')
         write (iout,100)  eksum
  100    format (' Current Kinetic',5x,f15.4,' Kcal/mole')
      end if
c
c     print the values of the lattice lengths and angles
c
      if (use_bounds) then
         if (digits .le. 6) then
            write (iout,110)  xbox,ybox,zbox
  110       format (' Lattice Lengths',6x,3f14.6)
            write (iout,120)  alpha,beta,gamma
  120       format (' Lattice Angles',7x,3f14.6)
         else if (digits .le. 8) then
            write (iout,130)  xbox,ybox,zbox
  130       format (' Lattice Lengths',6x,3f16.8)
            write (iout,140)  alpha,beta,gamma
  140       format (' Lattice Angles',7x,3f16.8)
         else
            write (iout,150)  xbox,ybox,zbox
  150       format (' Lattice Lengths',6x,3f18.10)
            write (iout,160)  alpha,beta,gamma
  160       format (' Lattice Angles',7x,3f18.10)
         end if
      end if
c
c     move stray molecules into periodic box if desired
c
      if (use_wrap)  call bounds
c
c     save coordinates to archive or numbered structure file
c
      ixyz = freeunit ()
      if (cyclesave) then
         xyzfile = filename(1:leng)//'.'//ext(1:lext)
         call version (xyzfile,'new')
         open (unit=ixyz,file=xyzfile,status='new')
         call prtxyz (ixyz)
      else if (dcdsave) then
         xyzfile = filename(1:leng)
         call suffix (xyzfile,'dcd','old')
         inquire (file=xyzfile,exist=exist)
         if (exist) then
            first = .false.
            open (unit=ixyz,file=xyzfile,form='unformatted',
     &               status='old',position='append')
         else
            first = .true.
            open (unit=ixyz,file=xyzfile,form='unformatted',
     &               status='new')
         end if
         call prtdcd (ixyz,first)
      else
         xyzfile = filename(1:leng)
         call suffix (xyzfile,'arc','old')
         inquire (file=xyzfile,exist=exist)
         if (exist) then
            call openend (ixyz,xyzfile)
         else
            open (unit=ixyz,file=xyzfile,status='new')
         end if
         call prtxyz (ixyz)
      end if
      close (unit=ixyz)
      write (iout,170)  isave
  170 format (' Frame Number',13x,i10)
      write (iout,180)  xyzfile(1:trimtext(xyzfile))
  180 format (' Coordinate File',13x,a)
c
c     update the information needed to restart the trajectory
c
      call prtdyn
c
c     save the velocity vector components at the current step
c
      if (velsave) then
         ivel = freeunit ()
         if (cyclesave) then
            velfile = filename(1:leng)//'.'//ext(1:lext)//'v'
            call version (velfile,'new')
            open (unit=ivel,file=velfile,status='new')
         else if (dcdsave) then
            velfile = filename(1:leng)
            call suffix (velfile,'dcdv','old')
            inquire (file=velfile,exist=exist)
            if (exist) then
               first = .false.
               open (unit=ivel,file=velfile,form='unformatted',
     &                  status='old',position='append')
            else
               first = .true.
               open (unit=ivel,file=velfile,form='unformatted',
     &                  status='new')
            end if
         else
            velfile = filename(1:leng)
            call suffix (velfile,'vel','old')
            inquire (file=velfile,exist=exist)
            if (exist) then
               call openend (ivel,velfile)
            else
               open (unit=ivel,file=velfile,status='new')
            end if
         end if
         if (integrate .eq. 'RIGIDBODY') then
            write (ivel,190)  ngrp,title(1:ltitle)
  190       format (i6,2x,a)
            do i = 1, ngrp
               write (ivel,200)  i,(vcm(j,i),j=1,3)
  200          format (i6,3x,d13.6,3x,d13.6,3x,d13.6)
               write (ivel,210)  i,(wcm(j,i),j=1,3)
  210          format (i6,3x,d13.6,3x,d13.6,3x,d13.6)
            end do
         else if (dcdsave) then
            call prtdcdv (ivel,first)
         else
            call prtvel (ivel)
         end if
         close (unit=ivel)
         write (iout,240)  velfile(1:trimtext(velfile))
  240    format (' Velocity File',15x,a)
      end if
c
c     save the force vector components for the current step; not
c     available for rigid body or multiple time step integrators
c
      if (frcsave .and. integrate.ne.'RIGIDBODY'
     &       .and. integrate.ne.'VRESPA'
     &       .and. integrate.ne.'BRESPA'
     &       .and. integrate.ne.'SRESPA') then
         ifrc = freeunit ()
         if (cyclesave) then
            frcfile = filename(1:leng)//'.'//ext(1:lext)//'f'
            call version (frcfile,'new')
            open (unit=ifrc,file=frcfile,status='new')
         else if (dcdsave) then
            frcfile = filename(1:leng)
            call suffix (frcfile,'dcdf','old')
            inquire (file=frcfile,exist=exist)
            if (exist) then
               first = .false.
               open (unit=ifrc,file=frcfile,form='unformatted',
     &                  status='old',position='append')
            else
               first = .true.
               open (unit=ifrc,file=frcfile,form='unformatted',
     &                  status='new')
            end if
            call prtdcdf (ifrc,first)
         else
            frcfile = filename(1:leng)
            call suffix (frcfile,'frc','old')
            inquire (file=frcfile,exist=exist)
            if (exist) then
               call openend (ifrc,frcfile)
            else
               open (unit=ifrc,file=frcfile,status='new')
            end if
            call prtfrc (ifrc)
         end if
         close (unit=ifrc)
         write (iout,270)  frcfile(1:trimtext(frcfile))
  270    format (' Force Vector File',11x,a)
      end if
c
c     save the induced dipole components for the current step
c
      if (uindsave .and. use_polar) then
         iind = freeunit ()
         if (cyclesave) then
            indfile = filename(1:leng)//'.'//ext(1:lext)//'u'
            call version (indfile,'new')
            open (unit=iind,file=indfile,status='new')
         else if (dcdsave) then
            indfile = filename(1:leng)
            call suffix (indfile,'dcdu','old')
            inquire (file=indfile,exist=exist)
            if (exist) then
               first = .false.
               open (unit=iind,file=indfile,form='unformatted',
     &                  status='old',position='append')
            else
               first = .true.
               open (unit=iind,file=indfile,form='unformatted',
     &                  status='new')
            end if
            call prtdcdu (iind,first)
         else
            indfile = filename(1:leng)
            call suffix (indfile,'uind','old')
            inquire (file=indfile,exist=exist)
            if (exist) then
               call openend (iind,indfile)
            else
               open (unit=iind,file=indfile,status='new')
            end if
            call prtuind (iind)
         end if
         close (unit=iind)
         write (iout,300)  indfile(1:trimtext(indfile))
  300    format (' Induced Dipole File',9x,a)
      end if
c
c     test for requested termination of the dynamics calculation
c
      endfile = 'tinker.end'
      inquire (file=endfile,exist=exist)
      if (.not. exist) then
         endfile = filename(1:leng)//'.end'
         inquire (file=endfile,exist=exist)
         if (exist) then
            iend = freeunit ()
            open (unit=iend,file=endfile,status='old')
            close (unit=iend,status='delete')
         end if
      end if
      if (exist) then
         write (iout,310)
  310    format (/,' MDSAVE  --  Dynamics Calculation Ending',
     &              ' due to User Request')
         call fatal
      end if
c
c     skip an extra line to keep the output formating neat
c
      modsave = mod(istep,iprint)
      if (verbose .and. modsave.ne.0) then
         write (iout,320)
  320    format ()
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine mdstat  --  compute averages over a trajectory  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "mdstat" is called at each molecular dynamics time step to
c     form statistics on various average values and fluctuations,
c     and to periodically save the state of the trajectory
c
c
      subroutine mdstat (istep,dt,etot,epot,ekin,temp,pres)
      use atoms
      use bath
      use bound
      use boxes
      use inform
      use iounit
      use limits
      use mdstuf
      use molcul
      use units
      use usage
      use warp
      implicit none
      integer istep
      integer modstep
      real*8 dt,temp,pres
      real*8 etot,epot,ekin
      real*8 pico,dens
      real*8 fluctuate,fluctuate2
      real*8 potfluct,potfluct2
      real*8 kinfluct,kinfluct2
      real*8 tfluct,pfluct,dfluct
      real*8 tfluct2,pfluct2,dfluct2
      real*8 etot_sum,etot2_sum
      real*8 etot_ave,etot2_ave
      real*8 epot_sum,epot2_sum
      real*8 epot_ave,epot2_ave
      real*8 ekin_sum,ekin2_sum
      real*8 ekin_ave,ekin2_ave
      real*8 temp_sum,temp2_sum
      real*8 temp_ave,temp2_ave
      real*8 pres_sum,pres2_sum
      real*8 pres_ave,pres2_ave
      real*8 dens_sum,dens2_sum
      real*8 dens_ave,dens2_ave
      save etot_sum,etot2_sum
      save epot_sum,epot2_sum
      save ekin_sum,ekin2_sum
      save temp_sum,temp2_sum
      save pres_sum,pres2_sum
      save dens_sum,dens2_sum
c
c
c     set number of steps for block averages of properties
c
      modstep = mod(istep,iprint)
c
c     zero out summation variables for new averaging period
c
      if (modstep.eq.1 .or. iprint.eq.1) then
         etot_sum = 0.0d0
         etot2_sum = 0.0d0
         epot_sum = 0.0d0
         epot2_sum = 0.0d0
         ekin_sum = 0.0d0
         ekin2_sum = 0.0d0
         temp_sum = 0.0d0
         temp2_sum = 0.0d0
         pres_sum = 0.0d0
         pres2_sum = 0.0d0
         dens_sum = 0.0d0
         dens2_sum = 0.0d0
      end if
c
c     print energy, temperature and pressure for current step
c
      if (verbose) then
         if (modstep .eq. 1) then
            if (use_bounds .and. integrate.ne.'STOCHASTIC') then
               write (iout,10)
   10          format (/,4x,'MD Step',7x,'E Total',4x,'E Potential',
     &                    6x,'E Kinetic',7x,'Temp',7x,'Pres',/)
            else
               write (iout,20)
   20          format (/,4x,'MD Step',7x,'E Total',4x,'E Potential',
     &                    6x,'E Kinetic',7x,'Temp',/)
            end if
         end if
         if (use_bounds .and. integrate.ne.'STOCHASTIC') then
            write (iout,30)  istep,etot,epot,ekin,temp,pres
   30       format (i10,3f15.4,2f11.2)
         else
            write (iout,40)  istep,etot,epot,ekin,temp
   40       format (i10,3f15.4,f11.2)
         end if
         flush (iout)
      end if
c
c     print header for the averages over a group of recent steps
c
      if (modstep .eq. 0) then
         pico = dble(istep) * dt
         write (iout,50)  iprint,istep
   50    format (/,' Average Values for the Last',i6,' Out of',
     &              i9,' Dynamics Steps')
         if (digits .ge. 8) then
            write (iout,60)  pico
   60       format (/,' Simulation Time',5x,f19.8,' Picosecond')
         else if (digits .ge. 6) then
            write (iout,70)  pico
   70       format (/,' Simulation Time',5x,f17.6,' Picosecond')
         else
            write (iout,80)  pico
   80       format (/,' Simulation Time',5x,f15.4,' Picosecond')
         end if
      end if
c
c     compute total energy and fluctuation for recent steps
c
      etot_sum = etot_sum + etot
      etot2_sum = etot2_sum + etot**2
      if (modstep .eq. 0) then
         etot_ave = etot_sum / dble(iprint)
         etot2_ave = etot2_sum / dble(iprint)
         fluctuate2 = etot2_ave - etot_ave**2
         if (fluctuate2 .gt. 0.0d0) then
            fluctuate = sqrt(fluctuate2)
         else
            fluctuate = 0.0d0
         end if
         if (digits .ge. 8) then
            write (iout,90)  etot_ave,fluctuate
   90       format (' Total Energy',8x,f19.8,' Kcal/mole',3x,
     &                 '(+/-',f13.8,')')
         else if (digits .ge. 6) then
            write (iout,100)  etot_ave,fluctuate
  100       format (' Total Energy',8x,f17.6,' Kcal/mole',3x,
     &                 '(+/-',f11.6,')')
         else
            write (iout,110)  etot_ave,fluctuate
  110       format (' Total Energy',8x,f15.4,' Kcal/mole',3x,
     &                 '(+/-',f9.4,')')
         end if
      end if
c
c     compute average potential energy and its fluctuation
c
      epot_sum = epot_sum + epot
      epot2_sum = epot2_sum + epot**2
      if (modstep .eq. 0) then
         epot_ave = epot_sum / dble(iprint)
         epot2_ave = epot2_sum / dble(iprint)
         potfluct2 = epot2_ave - epot_ave**2
         if (potfluct2 .gt. 0.0d0) then
            potfluct = sqrt(potfluct2)
         else
            potfluct = 0.0d0
         end if
         if (digits .ge. 8) then
            write (iout,120)  epot_ave,potfluct
  120       format (' Potential Energy',4x,f19.8,' Kcal/mole',3x,
     &                 '(+/-',f13.8,')')
         else if (digits .ge. 6) then
            write (iout,130)  epot_ave,potfluct
  130       format (' Potential Energy',4x,f17.6,' Kcal/mole',3x,
     &                 '(+/-',f11.6,')')
         else
            write (iout,140)  epot_ave,potfluct
  140       format (' Potential Energy',4x,f15.4,' Kcal/mole',3x,
     &                 '(+/-',f9.4,')')
         end if
      end if
c
c     compute average kinetic energy and its fluctuation
c
      ekin_sum = ekin_sum + ekin
      ekin2_sum = ekin2_sum + ekin**2
      if (modstep .eq. 0) then
         ekin_ave = ekin_sum / dble(iprint)
         ekin2_ave = ekin2_sum / dble(iprint)
         kinfluct2 = ekin2_ave - ekin_ave**2
         if (kinfluct2 .gt. 0.0d0) then
            kinfluct = sqrt(kinfluct2)
         else
            kinfluct = 0.0d0
         end if
         if (digits .ge. 8) then
            write (iout,150)  ekin_ave,kinfluct
  150       format (' Kinetic Energy',6x,f19.8,' Kcal/mole',3x,
     &                 '(+/-',f13.8,')')
         else if (digits .ge. 6) then
            write (iout,160)  ekin_ave,kinfluct
  160       format (' Kinetic Energy',6x,f17.6,' Kcal/mole',3x,
     &                 '(+/-',f11.6,')')
         else
            write (iout,170)  ekin_ave,kinfluct
  170       format (' Kinetic Energy',6x,f15.4,' Kcal/mole',3x,
     &                 '(+/-',f9.4,')')
         end if
      end if
c
c     compute the average temperature and its fluctuation
c
      temp_sum = temp_sum + temp
      temp2_sum = temp2_sum + temp**2
      if (modstep .eq. 0) then
         temp_ave = temp_sum / dble(iprint)
         temp2_ave = temp2_sum / dble(iprint)
         tfluct2 = temp2_ave - temp_ave**2
         if (tfluct2 .gt. 0.0d0) then
            tfluct = sqrt(tfluct2)
         else
            tfluct = 0.0d0
         end if
         if (digits .ge. 8) then
            write (iout,210)  temp_ave,tfluct
  210       format (' Temperature',9x,f19.6,' Kelvin',6x,
     &                 '(+/-',f13.6,')')
         else if (digits .ge. 6) then
            write (iout,220)  temp_ave,tfluct
  220       format (' Temperature',9x,f17.4,' Kelvin',6x,
     &                 '(+/-',f11.4,')')
         else
            write (iout,230)  temp_ave,tfluct
  230       format (' Temperature',9x,f15.2,' Kelvin',6x,
     &                 '(+/-',f9.2,')')
         end if
      end if
c
c     compute the average pressure and its fluctuation
c
      if (use_bounds) then
         pres_sum = pres_sum + pres
         pres2_sum = pres2_sum + pres**2
         if (modstep .eq. 0) then
            pres_ave = pres_sum / dble(iprint)
            pres2_ave = pres2_sum / dble(iprint)
            pfluct2 = pres2_ave - pres_ave**2
            if (pfluct2 .gt. 0.0d0) then
               pfluct = sqrt(pfluct2)
            else
               pfluct = 0.0d0
            end if
            if (digits .ge. 8) then
               write (iout,240)  pres_ave,pfluct
  240          format (' Pressure',12x,f19.6,' Atmosphere',2x,
     &                    '(+/-',f13.6,')')
            else if (digits .ge. 6) then
               write (iout,250)  pres_ave,pfluct
  250          format (' Pressure',12x,f17.4,' Atmosphere',2x,
     &                    '(+/-',f11.4,')')
            else
               write (iout,260)  pres_ave,pfluct
  260          format (' Pressure',12x,f15.2,' Atmosphere',2x,
     &                    '(+/-',f9.2,')')
            end if
         end if
c
c     compute the average density and its fluctuation
c
         dens = (1.0d24/volbox) * (totmass/avogadro)
         dens_sum = dens_sum + dens
         dens2_sum = dens2_sum + dens**2
         if (modstep .eq. 0) then
            dens_ave = dens_sum / dble(iprint)
            dens2_ave = dens2_sum / dble(iprint)
            dfluct2 = dens2_ave - dens_ave**2
            if (dfluct2 .gt. 0.0d0) then
               dfluct = sqrt(dfluct2)
            else
               dfluct = 0.0d0
            end if
            if (digits .ge. 8) then
               write (iout,270)  dens_ave,dfluct
  270          format (' Density',13x,f19.8,' Grams/cc',4x,
     &                    '(+/-',f13.8,')')
            else if (digits .ge. 6) then
               write (iout,280)  dens_ave,dfluct
  280          format (' Density',13x,f17.6,' Grams/cc',4x,
     &                    '(+/-',f11.6,')')
            else
               write (iout,290)  dens_ave,dfluct
  290          format (' Density',13x,f15.4,' Grams/cc',4x,
     &                    '(+/-',f9.4,')')
            end if
         end if
      end if
c
c     declare deformation value for potential energy smoothing
c
      if (use_smooth) then
         if (modstep .eq. 0) then
            if (digits .ge. 8) then
               write (iout,300)  deform
  300          format (' Deformation',9x,f19.8,' Sqr Angs')
            else if (digits .ge. 6) then
               write (iout,310)  deform
  310          format (' Deformation',9x,f17.6,' Sqr Angs')
            else
               write (iout,320)  deform
  320          format (' Deformation',9x,f15.4,' Sqr Angs')
            end if
         end if
      end if
c
c     ensure any output is written to the storage device
c
      if (modstep .eq. 0)  flush (iout)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2000  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module mdstuf  --  molecular dynamics trajectory controls  ##
c     ##                                                             ##
c     #################################################################
c
c
c     nfree       total number of degrees of freedom for a system
c     irest       steps between removal of COM motion (0=no removal)
c     bmnmix      mixing coefficient for use with Beeman integrator
c     nrespa      inner steps per outer step for RESPA integrators
c     dorest      logical flag to remove center of mass motion
c     integrate   type of molecular dynamics integration algorithm
c
c
      module mdstuf
      implicit none
      integer nfree
      integer irest
      integer bmnmix
      integer nrespa
      logical dorest
      character*11 integrate
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine mechanic  --  initialize molecular mechanics  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "mechanic" sets up needed parameters for the potential energy
c     calculation and reads in many of the user selectable options
c
c
      subroutine mechanic
      use inform
      use iounit
      implicit none
c
c
c     set the bonded connectivity lists and active atoms
c
      call attach
      call active
c
c     find bonds, angles, torsions, extensions and small rings
c
      call bonds
      call angles
      call torsions
      call bitors
      call tritors
      call tettors
      call rings
c
c     get the base force field from parameter file and keyfile
c
      call field
c
c     find unit cell type, lattice parameters and cutoff values
c
      call unitcell
      call lattice
      call polymer
      call cutoffs
c
c     setup needed for potential energy smoothing methods
c
      call flatten
c
c     assign atom types, classes and other atomic information
c
      call katom
c
c     assign atoms to molecules and set the atom groups
c
      call molecule
      call cluster
c
c     search for and store biomolecule residues and sequences
c
      call findpro
      call findnuc
      call findseq
c
c     find any pisystem atoms, bonds and torsional angles
c
      call orbital
c
c     assign bond, angle and cross term potential parameters
c
      call kbond
      call kangle
      call kstrbnd
      call kurey
      call kangang
c
c     assign out-of-plane deformation potential parameters
c
      call kopbend
      call kopdist
      call kimprop
      call kimptor
c
c     assign torsion and torsion cross term potential parameters
c
      call ktors
      call kpitors
      call kstrtor
      call kangtor
      call ktortor
c
c     assign electrostatic interaction potential parameters
c
      call kcharge
      call kdipole
      call kmpole
      call kpolar
      call kchgtrn
      call kchgflx
c
c     assign van der Waals, repulsion and dispersion parameters
c
      call kvdw
      call krepel
      call kdisp
c
c     assign solvation, metal, pisystem and restraint parameters
c
      call ksolv
      call kmetal
      call korbit
      call kgeom
      call kextra
c
c     assign electrostatic and dispersion Ewald sum parameters
c
      call kewald
c
c     set any holonomic interatomic distance constraints
c
      call kfreeze
c
c     set hybrid parameter values for free energy perturbation
c
      call mutate
c
c     quit if essential parameter information is missing
c
      if (abort) then
         write (iout,10)
   10    format (/,' MECHANIC  --  Some Required Potential Energy',
     &              ' Parameters are Undefined')
         call fatal
      end if
      return
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 2007 by Nicolas Staelens & Jay W. Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module merck  --  MMFF-specific force field parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     nligne     number of atom pairs having MMFF Bond Type 1
c     bt_1       atom pairs having MMFF Bond Type 1
c     eqclass    table of atom class equivalencies used to find
c                default parameters if explicit values are missing
c                (see J. Comput. Chem., 17, 490-519, '95, Table IV)
c     crd        number of attached neighbors    |
c     val        valency value                   |  see T. A. Halgren,
c     pilp       if 0, no lone pair              |  J. Comput. Chem.,
c                if 1, one or more lone pair(s)  |  17, 616-645 (1995)
c     mltb       multibond indicator             |
c     arom       aromaticity indicator           |
c     lin        linearity indicator             |
c     sbmb       single- vs multiple-bond flag   |
c     mmffarom   aromatic rings parameters
c     mmffaromc  cationic aromatic rings parameters
c     mmffaroma  anionic aromatic rings parameters
c
c
      module merck
      use sizes
      implicit none
      integer nligne 
      integer bt_1(500,2)
      integer eqclass(500,5)
      integer crd(100)
      integer val(100)
      integer pilp(100)
      integer mltb(100)
      integer arom(100)
      integer lin(100)
      integer sbmb(100)
      integer mmffarom(maxtyp,6)
      integer mmffaromc(maxtyp,6)
      integer mmffaroma(maxtyp,6)
c
c
c     rad0      covalent atomic radius for empirical bond rules
c     paulel    Pauling electronegativities for empirical bond rules
c     r0ref     reference bond length for empirical bond rules
c     kbref     reference force constant for empirical bond rules
c     mmff_kb   bond force constant for pairs of atom classes
c     mmff_kb1  bond force constant for class pairs with Bond Type 1
c     mmff_b0   bond length value for pairs of atom classes
c     mmff_b1   bond length value for class pairs with Bond Type 1
c
c
      real*8 rad0(100)
      real*8 paulel(100)
      real*8 r0ref(100,100)
      real*8 kbref(100,100)
      real*8 mmff_kb(100,100)
      real*8 mmff_kb1(100,100)
      real*8 mmff_b0(100,100)
      real*8 mmff_b1(100,100)
c
c
c     mmff_ka     angle force constant for triples of atom classes
c     mmff_ka1    angle force constant with one bond of Type 1
c     mmff_ka2    angle force constant with both bonds of Type 1
c     mmff_ka3    angle force constant for 3-membered ring
c     mmff_ka4    angle force constant for 4-membered ring
c     mmff_ka5    angle force constant for 3-ring and one Bond Type 1
c     mmff_ka6    angle force constant for 3-ring and both Bond Type 1
c     mmff_ka7    angle force constant for 4-ring and one Bond Type 1
c     mmff_ka8    angle force constant for 4-ring and both Bond Type 1
c     mmff_ang0   ideal bond angle for triples of atom classes
c     mmff_ang1   ideal bond angle with one bond of Type 1
c     mmff_ang2   ideal bond angle with both bonds of Type 1
c     mmff_ang3   ideal bond angle for 3-membered ring
c     mmff_ang4   ideal bond angle for 4-membered ring
c     mmff_ang5   ideal bond angle for 3-ring and one Bond Type 1
c     mmff_ang6   ideal bond angle for 3-ring and both Bond Type 1
c     mmff_ang7   ideal bond angle for 4-ring and one Bond Type 1
c     mmff_ang8   ideal bond angle for 4-ring and both Bond Type 1
c
c
      real*8, allocatable :: mmff_ka(:,:,:)
      real*8, allocatable :: mmff_ka1(:,:,:)
      real*8, allocatable :: mmff_ka2(:,:,:)
      real*8, allocatable :: mmff_ka3(:,:,:)
      real*8, allocatable :: mmff_ka4(:,:,:)
      real*8, allocatable :: mmff_ka5(:,:,:)
      real*8, allocatable :: mmff_ka6(:,:,:)
      real*8, allocatable :: mmff_ka7(:,:,:)
      real*8, allocatable :: mmff_ka8(:,:,:)
      real*8, allocatable :: mmff_ang0(:,:,:)
      real*8, allocatable :: mmff_ang1(:,:,:)
      real*8, allocatable :: mmff_ang2(:,:,:)
      real*8, allocatable :: mmff_ang3(:,:,:)
      real*8, allocatable :: mmff_ang4(:,:,:)
      real*8, allocatable :: mmff_ang5(:,:,:)
      real*8, allocatable :: mmff_ang6(:,:,:)
      real*8, allocatable :: mmff_ang7(:,:,:)
      real*8, allocatable :: mmff_ang8(:,:,:)
c
c
c     Stretch-Bend Type 0
c     stbn_abc     stretch-bend parameters for A-B-C atom classes
c     stbn_cba     stretch-bend parameters for C-B-A atom classes
c     Stretch-Bend Type 1  (A-B is Bond Type 1)
c     stbn_abc1    stretch-bend parameters for A-B-C atom classes
c     stbn_cba1    stretch-bend parameters for C-B-A atom classes
c     Stretch-Bend Type 2  (B-C is Bond Type 1) 
c     stbn_abc2    stretch-bend parameters for A-B-C atom classes
c     stbn_cba2    stretch-bend parameters for C-B-A atom classes
c     Stretch-Bend Type = 3  (A-B and B-C are Bond Type 1) 
c     stbn_abc3    stretch-bend parameters for A-B-C atom classes
c     stbn_cba3    stretch-bend parameters for C-B-A atom classes
c     Stretch-Bend Type 4  (both Bond Types 0, 4-membered ring)
c     stbn_abc4    stretch-bend parameters for A-B-C atom classes
c     stbn_cba4    stretch-bend parameters for C-B-A atom classes
c     Stretch-Bend Type 5  (both Bond Types 0, 3-membered ring)
c     stbn_abc5    stretch-bend parameters for A-B-C atom classes
c     stbn_cba5    stretch-bend parameters for C-B-A atom classes
c     Stretch-Bend Type 6  (A-B is Bond Type 1, 3-membered ring)
c     stbn_abc6    stretch-bend parameters for A-B-C atom classes
c     stbn_cba6    stretch-bend parameters for C-B-A atom classes
c     Stretch-Bend Type 7  (B-C is Bond Type 1, 3-membered ring)
c     stbn_abc7    stretch-bend parameters for A-B-C atom classes
c     stbn_cba7    stretch-bend parameters for C-B-A atom classes
c     Stretch-Bend Type 8  (both Bond Types 1, 3-membered ring)
c     stbn_abc8    stretch-bend parameters for A-B-C atom classes
c     stbn_cba8    stretch-bend parameters for C-B-A atom classes
c     Stretch-Bend Type 9  (A-B is Bond Type 1, 4-membered ring)
c     stbn_abc9    stretch-bend parameters for A-B-C atom classes
c     stbn_cba9    stretch-bend parameters for C-B-A atom classes
c     Stretch-Bend Type 10  (B-C is Bond Type 1, 4-membered ring)
c     stbn_abc10   stretch-bend parameters for A-B-C atom classes
c     stbn_cba10   stretch-bend parameters for C-B-A atom classes
c     Stretch-Bend Type 11  (both Bond Types 1, 4-membered ring)
c     stbn_abc11   stretch-bend parameters for A-B-C atom classes
c     stbn_cba11   stretch-bend parameters for C-B-A atom classes
c     defstbn_abc  default stretch-bend parameters for A-B-C classes
c     defstbn_cba  default stretch-bend parameters for C-B-A classes
c
c
      real*8, allocatable :: stbn_abc(:,:,:)
      real*8, allocatable :: stbn_cba(:,:,:)
      real*8, allocatable :: stbn_abc1(:,:,:)
      real*8, allocatable :: stbn_cba1(:,:,:)
      real*8, allocatable :: stbn_abc2(:,:,:)
      real*8, allocatable :: stbn_cba2(:,:,:)
      real*8, allocatable :: stbn_abc3(:,:,:)
      real*8, allocatable :: stbn_cba3(:,:,:)
      real*8, allocatable :: stbn_abc4(:,:,:)
      real*8, allocatable :: stbn_cba4(:,:,:)
      real*8, allocatable :: stbn_abc5(:,:,:)
      real*8, allocatable :: stbn_cba5(:,:,:)
      real*8, allocatable :: stbn_abc6(:,:,:)
      real*8, allocatable :: stbn_cba6(:,:,:)
      real*8, allocatable :: stbn_abc7(:,:,:)
      real*8, allocatable :: stbn_cba7(:,:,:)
      real*8, allocatable :: stbn_abc8(:,:,:)
      real*8, allocatable :: stbn_cba8(:,:,:)
      real*8, allocatable :: stbn_abc9(:,:,:)
      real*8, allocatable :: stbn_cba9(:,:,:)
      real*8, allocatable :: stbn_abc10(:,:,:)
      real*8, allocatable :: stbn_cba10(:,:,:)
      real*8, allocatable :: stbn_abc11(:,:,:)
      real*8, allocatable :: stbn_cba11(:,:,:)
      real*8 defstbn_abc(0:4,0:4,0:4)
      real*8 defstbn_cba(0:4,0:4,0:4)
c
c
c     t1_1     torsional parameters for 1-fold, MMFF Torsion Type 1
c     t1_2     torsional parameters for 1-fold, MMFF Torsion Type 2
c     t2_1     torsional parameters for 2-fold, MMFF Torsion Type 1
c     t2_2     torsional parameters for 2-fold, MMFF Torsion Type 2
c     t3_1     torsional parameters for 3-fold, MMFF Torsion Type 1
c     t3_2     torsional parameters for 3-fold, MMFF Torsion Type 2
c     kt_1     string of classes for torsions, MMFF Torsion Type 1
c     kt_2     string of classes for torsions, MMFF Torsion Type 2
c
c
      real*8 t1_1(2,0:2000)
      real*8 t2_1(2,0:2000)
      real*8 t3_1(2,0:2000)
      real*8 t1_2(2,0:2000)
      real*8 t2_2(2,0:2000)
      real*8 t3_2(2,0:2000)
      character*16 kt_1(0:2000)
      character*16 kt_2(0:2000)
c
c
c     g        scale factors for calculation of MMFF eps
c     alph     atomic polarizabilities for calculation of MMFF eps
c     nn       effective number of valence electrons for MMFF eps
c     da       donor/acceptor atom classes
c
c
      real*8 g(maxclass)
      real*8 alph(maxclass)
      real*8 nn(maxclass)
      character*1 da(maxclass)
c
c
c     bci      bond charge increments for building atom charges
c     bci_1    bond charge increments for MMFF Bond Type 1   
c     pbci     partial BCI for building missing BCI's
c     fcadj    formal charge adjustment factor
c
c
      real*8 bci(100,100)
      real*8 bci_1(100,100)
      real*8 pbci(maxclass)
      real*8 fcadj(maxclass)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine merge  --  merge reference & current systems  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "merge" combines the reference and current structures into
c     a single new "current" structure containing the reference
c     atoms followed by the atoms of the current structure
c
c
      subroutine merge (iref)
      use atomid
      use atoms
      use couple
      use iounit
      use refer
      implicit none
      integer i,j,k
      integer iref
      integer ntotal
c
c
c     check for too many total atoms in the combined system
c
      ntotal = n + nref(iref)
      if (ntotal .gt. maxatm) then
         write (iout,10)  maxatm
   10    format (/,' MERGE  --  The Maximum of',i9,' Atoms',
     &              ' has been Exceeded')
         call fatal
      end if
c
c     move the current structure to higher atom numbers
c
      do i = n, 1, -1
         k = i + nref(iref)
         x(k) = x(i)
         y(k) = y(i)
         z(k) = z(i)
         type(k) = type(i)
         name(k) = name(i)
         n12(k) = n12(i)
         do j = 1, n12(i)
            i12(j,k) = i12(j,i) + nref(iref)
         end do
      end do
c
c     place reference structure in the current structure
c
      call getref (iref)
      n = ntotal
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module minima  --  general parameters for minimizations  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     maxiter   maximum number of iterations during optimization
c     nextiter  iteration number to use for the first iteration
c     fctmin    value below which function is deemed optimized
c     hguess    initial value for the H-matrix diagonal elements
c
c
      module minima
      implicit none
      integer maxiter
      integer nextiter
      real*8 fctmin
      real*8 hguess
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  program minimize  --  low storage BFGS Cartesian optimizer  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "minimize" performs energy minimization in Cartesian coordinate
c     space using a low storage BFGS nonlinear optimization
c
c
      program minimize
      use atoms
      use bound
      use files
      use freeze
      use inform
      use iounit
      use scales
      use usage
      implicit none
      integer i,j,k
      integer imin,nvar
      integer freeunit
      real*8 minimum,minimiz1
      real*8 grdmin,gnorm,grms
      real*8 energy,eps
      real*8, allocatable :: xx(:)
      real*8, allocatable :: derivs(:,:)
      logical exist,analytic
      character*240 minfile
      character*240 string
      external energy
      external minimiz1
      external optsave
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     perform the setup functions needed for optimization
c
      call optinit
c
c     use either analytical or numerical gradients
c
      analytic = .true.
      eps = 0.00001d0
c
c     get termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  grdmin
   10 continue
      if (grdmin .le. 0.0d0) then
         write (iout,20)
   20    format (/,' Enter RMS Gradient per Atom Criterion',
     &              ' [0.01] :  ',$)
         read (input,30)  grdmin
   30    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.01d0
c
c     write out a copy of coordinates for later update
c
      imin = freeunit ()
      minfile = filename(1:leng)//'.xyz'
      call version (minfile,'new')
      open (unit=imin,file=minfile,status='new')
      call prtxyz (imin)
      close (unit=imin)
      outfile = minfile
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(scale))  allocate (scale(3*n))
c
c     set scaling parameter for function and derivative values;
c     use square root of median eigenvalue of typical Hessian
c
      set_scale = .true.
      nvar = 0
      do i = 1, nuse
         do j = 1, 3
            nvar = nvar + 1
            scale(nvar) = 12.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nvar))
      allocate (derivs(3,n))
c
c     convert atomic coordinates to optimization parameters
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         xx(nvar) = x(k) * scale(nvar)
         nvar = nvar + 1
         xx(nvar) = y(k) * scale(nvar)
         nvar = nvar + 1
         xx(nvar) = z(k) * scale(nvar)
      end do
c
c     make the call to the optimization routine
c
      call lbfgs (nvar,xx,minimum,grdmin,minimiz1,optsave)
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         x(k) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         y(k) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         z(k) = xx(nvar) / scale(nvar)
      end do
c
c     compute the final function and RMS gradient values
c
      if (analytic) then
         call gradient (minimum,derivs)
      else
         minimum = energy ()
         call numgrad (energy,derivs,eps)
      end if
      if (use_freeze)  call shakeg (derivs)
      gnorm = 0.0d0
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            gnorm = gnorm + derivs(j,k)**2
         end do
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(nvar/3))
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      deallocate (derivs)
c
c     write out the final function and gradient values
c
      if (digits .ge. 8) then
         if (grms .gt. 1.0d-8) then
            write (iout,40)  minimum,grms,gnorm
   40       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,f20.8,
     &              /,' Final Gradient Norm :',3x,f20.8)
         else
            write (iout,50)  minimum,grms,gnorm
   50       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,d20.8,
     &              /,' Final Gradient Norm :',3x,d20.8)
         end if
      else if (digits .ge. 6) then
         if (grms .gt. 1.0d-6) then
            write (iout,60)  minimum,grms,gnorm
   60       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,f18.6,
     &              /,' Final Gradient Norm :',3x,f18.6)
         else
            write (iout,70)  minimum,grms,gnorm
   70       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,d18.6,
     &              /,' Final Gradient Norm :',3x,d18.6)
         end if
      else
         if (grms .gt. 1.0d-4) then
            write (iout,80)  minimum,grms,gnorm
   80       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,f16.4,
     &              /,' Final Gradient Norm :',3x,f16.4)
         else
            write (iout,90)  minimum,grms,gnorm
   90       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,d16.4,
     &              /,' Final Gradient Norm :',3x,d16.4)
         end if
      end if
c
c     move stray molecules into periodic box if desired
c
      if (use_wrap)  call bounds
c
c     write the final coordinates into a file
c
      imin = freeunit ()
      open (unit=imin,file=minfile,status='old')
      rewind (unit=imin)
      call prtxyz (imin)
      close (unit=imin)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  function minimiz1  --  energy and gradient for minimize  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "minimiz1" is a service routine that computes the energy and
c     gradient for a low storage BFGS optimization in Cartesian
c     coordinate space
c
c
      function minimiz1 (xx,g)
      use atoms
      use freeze
      use scales
      use usage
      implicit none
      integer i,k,nvar
      real*8 minimiz1,e
      real*8 energy,eps
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
      logical analytic
      external energy
c
c
c     use either analytical or numerical gradients
c
      analytic = .true.
      eps = 0.00001d0
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         x(k) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         y(k) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         z(k) = xx(nvar) / scale(nvar)
      end do
c
c     adjust atomic coordinates to satisfy distance constraints
c
      if (use_freeze)  call shake (x,y,z)
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the energy and gradient
c
      if (analytic) then
         call gradient (e,derivs)
      else
         e = energy ()
         call numgrad (energy,derivs,eps)
      end if
      minimiz1 = e
c
c     adjust gradient to remove components along constraints
c
      if (use_freeze)  call shakeg (derivs)
c
c     convert coordinates and gradient to optimization parameters
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         xx(nvar) = x(k) * scale(nvar)
         g(nvar) = derivs(1,k) / scale(nvar)
         nvar = nvar + 1
         xx(nvar) = y(k) * scale(nvar)
         g(nvar) = derivs(2,k) / scale(nvar)
         nvar = nvar + 1
         xx(nvar) = z(k) * scale(nvar)
         g(nvar) = derivs(3,k) / scale(nvar)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program minirot  --  low storage BFGS torsional optimizer  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "minirot" performs an energy minimization in torsional
c     angle space using a low storage BFGS nonlinear optimization
c
c
      program minirot
      use files
      use inform
      use iounit
      use math
      use omega
      use scales
      use zcoord
      implicit none
      integer i,imin
      integer freeunit
      real*8 minimum,minirot1
      real*8 grdmin,grms,gnorm
      real*8, allocatable :: xx(:)
      real*8, allocatable :: derivs(:)
      logical exist
      character*240 minfile
      character*240 string
      external minirot1
      external optsave
c
c
c     set up the molecular mechanics calculation
c
      call initial
      call getint
      call mechanic
c
c     perform the setup functions needed for optimization
c
      call optinit
      call initrot
c
c     get termination criterion as RMS torsional gradient
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  grdmin
   10 continue
      if (grdmin .le. 0.0d0) then
         write (iout,20)
   20    format (/,' Enter RMS Gradient per Torsion Criterion',
     &              ' [0.01] :  ',$)
         read (input,30)  grdmin
   30    format (f20.0)
      end if
      if (grdmin .eq. 0.0d0)  grdmin = 0.01d0
c
c     write out a copy of coordinates for later update
c
      imin = freeunit ()
      minfile = filename(1:leng)//'.int'
      call version (minfile,'new')
      open (unit=imin,file=minfile,status='new')
      call prtint (imin)
      close (unit=imin)
      outfile = minfile
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(scale))  allocate (scale(nomega))
c
c     set scaling parameter for function and derivative values;
c     use square root of median eigenvalue of typical Hessian
c
      set_scale = .true.
      do i = 1, nomega
         scale(i) = 5.0d0
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nomega))
c
c     convert dihedral angles to optimization parameters
c
      do i = 1, nomega
         xx(i) = dihed(i) * scale(i)
      end do
c
c     make the call to the optimization routine
c
      call lbfgs (nomega,xx,minimum,grdmin,minirot1,optsave)
c
c     convert optimization parameters to dihedral angles
c
      do i = 1, nomega
         dihed(i) = xx(i) / scale(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(nomega))
c
c     compute the final function and RMS gradient values
c
      call gradrot (minimum,derivs)
      gnorm = 0.0d0
      do i = 1, nomega
         gnorm = gnorm + derivs(i)**2
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(nomega))
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
c
c     write out the final function and gradient values
c
      if (digits .ge. 8) then
         if (grms .gt. 1.0d-8) then
            write (iout,40)  minimum,grms,gnorm
   40       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,f20.8,
     &              /,' Final Gradient Norm :',3x,f20.8)
         else
            write (iout,50)  minimum,grms,gnorm
   50       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,d20.8,
     &              /,' Final Gradient Norm :',3x,d20.8)
         end if
      else if (digits .ge. 6) then
         if (grms .gt. 1.0d-6) then
            write (iout,60)  minimum,grms,gnorm
   60       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,f18.6,
     &              /,' Final Gradient Norm :',3x,f18.6)
         else
            write (iout,70)  minimum,grms,gnorm
   70       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,d18.6,
     &              /,' Final Gradient Norm :',3x,d18.6)
         end if
      else
         if (grms .gt. 1.0d-4) then
            write (iout,80)  minimum,grms,gnorm
   80       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,f16.4,
     &              /,' Final Gradient Norm :',3x,f16.4)
         else
            write (iout,90)  minimum,grms,gnorm
   90       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,d16.4,
     &              /,' Final Gradient Norm :',3x,d16.4)
         end if
      end if
c
c     write the final coordinates into a file
c
      imin = freeunit ()
      open (unit=imin,file=minfile,status='old')
      rewind (unit=imin)
      call prtint (imin)
      close (unit=imin)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function minirot1  --  energy and gradient for minirot  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "minirot1" is a service routine that computes the energy
c     and gradient for a low storage BFGS nonlinear optimization
c     in torsional angle space
c
c
      function minirot1 (xx,g)
      use math
      use omega
      use scales
      use zcoord
      implicit none
      integer i
      real*8 minirot1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:)
c
c
c     convert optimization parameters to dihedral angles
c
      do i = 1, nomega
         dihed(i) = xx(i) / scale(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(nomega))
c
c     get coordinates, then compute energy and gradient
c
      call makexyz
      call gradrot (e,derivs)
      minirot1 = e
c
c     convert gradient components to optimization parameters
c
      do i = 1, nomega
         g(i) = derivs(i) / scale(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program minrigid  --  low store BFGS rigid body optimizer  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "minrigid" performs an energy minimization of rigid body atom
c     groups using a low storage BFGS nonlinear optimization
c
c
      program minrigid
      use files
      use group
      use inform
      use iounit
      use output
      use rigid
      implicit none
      integer i,j
      integer imin,nvar
      integer freeunit
      real*8 minimum,minrigid1
      real*8 grdmin,grms,gnorm
      real*8, allocatable :: xx(:)
      real*8, allocatable :: derivs(:,:)
      logical exist
      character*240 minfile
      character*240 string
      external minrigid1
      external optsave
c
c
c     set up the molecular mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     set up the use of rigid body coordinate system
c
      coordtype = 'RIGIDBODY'
      use_rigid = .true.
      call orient
c
c     perform the setup functions needed for optimization
c
      call optinit
c
c     get termination criterion as RMS rigid body gradient
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  grdmin
   10 continue
      if (grdmin .le. 0.0d0) then
         write (iout,20)
   20    format (/,' Enter RMS Gradient per Rigid Body Criterion',
     &              ' [0.01] :  ',$)
         read (input,30)  grdmin
   30    format (f20.0)
      end if
      if (grdmin .eq. 0.0d0)  grdmin = 0.01d0
c
c     write out a copy of coordinates for later update
c
      imin = freeunit ()
      minfile = filename(1:leng)//'.xyz'
      call version (minfile,'new')
      open (unit=imin,file=minfile,status='new')
      call prtxyz (imin)
      close (unit=imin)
      outfile = minfile
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(6*ngrp))
c
c     convert rigid body coordinates to optimization parameters
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            xx(nvar) = rbc(j,i)
         end do
      end do
c
c     make the call to the optimization routine
c
      call lbfgs (nvar,xx,minimum,grdmin,minrigid1,optsave)
c
c     convert optimization parameters to rigid body coordinates
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            rbc(j,i) = xx(nvar)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(6,ngrp))
c
c     compute the final function and RMS gradient values
c
      call gradrgd (minimum,derivs)
      gnorm = 0.0d0
      do i = 1, ngrp
         do j = 1, 6
            gnorm = gnorm + derivs(j,i)**2
         end do
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(ngrp))
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
c
c     write out the final function and gradient values
c
      if (digits .ge. 8) then
         if (grms .gt. 1.0d-8) then
            write (iout,40)  minimum,grms,gnorm
   40       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,f20.8,
     &              /,' Final Gradient Norm :',3x,f20.8)
         else
            write (iout,50)  minimum,grms,gnorm
   50       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,d20.8,
     &              /,' Final Gradient Norm :',3x,d20.8)
         end if
      else if (digits .ge. 6) then
         if (grms .gt. 1.0d-6) then
            write (iout,60)  minimum,grms,gnorm
   60       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,f18.6,
     &              /,' Final Gradient Norm :',3x,f18.6)
         else
            write (iout,70)  minimum,grms,gnorm
   70       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,d18.6,
     &              /,' Final Gradient Norm :',3x,d18.6)
         end if
      else
         if (grms .gt. 1.0d-4) then
            write (iout,80)  minimum,grms,gnorm
   80       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,f16.4,
     &              /,' Final Gradient Norm :',3x,f16.4)
         else
            write (iout,90)  minimum,grms,gnorm
   90       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,d16.4,
     &              /,' Final Gradient Norm :',3x,d16.4)
         end if
      end if
c
c     write the final coordinates into a file
c
      imin = freeunit ()
      open (unit=imin,file=minfile,status='old')
      rewind (unit=imin)
      call prtxyz (imin)
      close (unit=imin)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function minrigid1  --  energy and gradient for minrigid  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "minrigid1" is a service routine that computes the energy
c     and gradient for a low storage BFGS nonlinear optimization
c     of rigid bodies
c
c
      function minrigid1 (xx,g)
      use group
      use math
      use rigid
      implicit none
      integer i,j,nvar
      real*8 minrigid1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to rigid body coordinates
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            rbc(j,i) = xx(nvar)
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(6,ngrp))
c
c     compute and store the energy and gradient
c
      call rigidxyz
      call gradrgd (e,derivs)
      minrigid1 = e
c
c     convert rigid body gradient to optimization parameters
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            g(nvar) = derivs(j,i)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program mol2xyz  --  Tripos MOL2 to Cartesian coordinates  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "mol2xyz" takes as input a Tripos MOL2 coordinates file,
c     converts to and then writes out Cartesian coordinates
c
c
      program mol2xyz
      use files
      use iounit
      use titles
      implicit none
      integer ixyz,freeunit
      character*240 xyzfile
c
c
c     get and read the Tripos MOL2 format file
c
      call initial
      call getmol2
      write (iout,10)  title(1:ltitle)
   10 format (/,' Title :  ',a)
c
c     write out the Cartesian coordinates file
c
      ixyz = freeunit ()
      xyzfile = filename(1:leng)//'.xyz'
      call version (xyzfile,'new')
      open (unit=ixyz,file=xyzfile,status='new')
      call prtxyz (ixyz)
      close (unit=ixyz)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module molcul  --  individual molecules in current system  ##
c     ##                                                             ##
c     #################################################################
c
c
c     nmol      total number of separate molecules in the system
c     imol      first and last atom of each molecule in the list
c     kmol      contiguous list of the atoms in each molecule
c     molcule   number of the molecule to which each atom belongs
c     totmass   total weight of all the molecules in the system
c     molmass   molecular weight for each molecule in the system
c
c
      module molcul
      implicit none
      integer nmol
      integer, allocatable :: imol(:,:)
      integer, allocatable :: kmol(:)
      integer, allocatable :: molcule(:)
      real*8 totmass
      real*8, allocatable :: molmass(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module moldyn  --  MD trajectory velocity & acceleration  ##
c     ##                                                            ##
c     ################################################################
c
c
c     v       current velocity of each atom along the x,y,z-axes
c     a       current acceleration of each atom along x,y,z-axes
c     aalt    alternate acceleration of each atom along x,y,z-axes
c     aslow   RESPA secondary slow acceleration of each atom
c     afast   RESPA secondary fast acceleration of each atom
c
c
      module moldyn
      implicit none
      real*8, allocatable :: v(:,:)
      real*8, allocatable :: a(:,:)
      real*8, allocatable :: aalt(:,:)
      real*8, allocatable :: aslow(:,:)
      real*8, allocatable :: afast(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine molecule  --  assign atoms to molecules  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "molecule" counts the molecules, assigns each atom to
c     its molecule and computes the mass of each molecule
c
c
      subroutine molecule
      use atomid
      use atoms
      use couple
      use molcul
      implicit none
      integer i,j,k,ii
      integer mi,mj,mk
      integer, allocatable :: list(:)
c
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(imol))  deallocate (imol)
      if (allocated(kmol))  deallocate (kmol)
      if (allocated(molcule))  deallocate (molcule)
      if (allocated(molmass))  deallocate (molmass)
      allocate (imol(2,n))
      allocate (kmol(n))
      allocate (molcule(n))
      allocate (molmass(n))
c
c     zero number of molecules and molecule membership list
c
      nmol = 0
      do i = 1, n
         molcule(i) = 0
      end do
c
c     assign each atom to its respective molecule
c
      do i = 1, n
         if (molcule(i) .eq. 0) then
            nmol = nmol + 1
            molcule(i) = nmol
         end if
         mi = molcule(i)
         do ii = 1, n12(i)
            j = i12(ii,i)
            mj = molcule(j)
            if (mj .eq. 0) then
               molcule(j) = mi
            else if (mi .lt. mj) then
               nmol = nmol - 1
               do k = 1, n
                  mk = molcule(k)
                  if (mk .eq. mj) then
                     molcule(k) = mi
                  else if (mk .gt. mj) then
                     molcule(k) = mk - 1
                  end if
               end do
            else if (mi .gt. mj) then
               nmol = nmol - 1
               do k = 1, n
                  mk = molcule(k)
                  if (mk .eq. mi) then
                     molcule(k) = mj
                  else if (mk .gt. mi) then
                     molcule(k) = mk - 1
                  end if
               end do
               mi = mj
            end if
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
c
c     pack atoms of each molecule into a contiguous indexed list
c
      do i = 1, n
         list(i) = molcule(i)
      end do
      call sort3 (n,list,kmol)
c
c     find the first and last atom in each molecule
c
      k = 1
      imol(1,1) = 1
      do i = 2, n
         j = list(i)
         if (j .ne. k) then
            imol(2,k) = i - 1
            k = j
            imol(1,k) = i
         end if
      end do
      imol(2,nmol) = n
c
c     perform deallocation of some local arrays
c
      deallocate (list)
c
c     sort the list of atoms in each molecule by atom number
c
      do i = 1, nmol
         k = imol(2,i) - imol(1,i) + 1
         call sort (k,kmol(imol(1,i)))
      end do
c
c     if all atomic masses are zero, set them all to unity
c
      do i = 1, n
         if (mass(i) .ne. 0.0d0)  goto 10
      end do
      do i = 1, n
         mass(i) = 1.0d0
      end do
   10 continue
c
c     compute the mass of each molecule and the total mass
c
      totmass = 0.0d0
      do i = 1, nmol
         molmass(i) = 0.0d0
         do k = imol(1,i), imol(2,i)
            molmass(i) = molmass(i) + mass(kmol(k))
         end do
         totmass = totmass + molmass(i)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2012  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program molxyz  --  MDL MOL file to Cartesian coordinates  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "molxyz" takes as input a MDL MOL coordinates file,
c     converts to and then writes out Cartesian coordinates
c
c
      program molxyz
      use files
      use iounit
      use titles
      implicit none
      integer ixyz,freeunit
      character*240 xyzfile
c
c
c     get and read the MDL MOL format file
c
      call initial
      call getmol
      write (iout,10)  title(1:ltitle)
   10 format (/,' Title :  ',a)
c
c     write out the Cartesian coordinates file
c
      ixyz = freeunit ()
      xyzfile = filename(1:leng)//'.xyz'
      call version (xyzfile,'new')
      open (unit=ixyz,file=xyzfile,status='new')
      call prtxyz (ixyz)
      close (unit=ixyz)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module moment  --  electric multipole moment components  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     netchg   net electric charge for the total system
c     netdpl   dipole moment magnitude for the total system
c     netqpl   diagonal quadrupole (Qxx, Qyy, Qzz) for total system
c     xdpl     total dipole vector x-component in the global frame
c     ydpl     total dipole vector y-component in the global frame
c     zdpl     total dipole vector z-component in the global frame
c     xxqpl    total quadrupole tensor xx-component in global frame
c     xyqpl    total quadrupole tensor xy-component in global frame
c     xzqpl    total quadrupole tensor xz-component in global frame
c     yxqpl    total quadrupole tensor yx-component in global frame
c     yyqpl    total quadrupole tensor yy-component in global frame
c     yzqpl    total quadrupole tensor yz-component in global frame
c     zxqpl    total quadrupole tensor zx-component in global frame
c     zyqpl    total quadrupole tensor zy-component in global frame
c     zzqpl    total quadrupole tensor zz-component in global frame
c
c
      module moment
      implicit none
      real*8 netchg,netdpl
      real*8 netqpl(3)
      real*8 xdpl,ydpl,zdpl
      real*8 xxqpl,xyqpl,xzqpl
      real*8 yxqpl,yyqpl,yzqpl
      real*8 zxqpl,zyqpl,zzqpl
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2000  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine moments  --  total electric multipole moments  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "moments" computes the total electric charge, dipole components
c     and quadrupole components as a sum over the partial charges,
c     bond dipoles and atomic multipole moments over active atoms or
c     the full system
c
c     literature reference:
c
c     C. Gray and K. E. Gubbins, "Theory of Molecular Fluids, Volume 1:
c     Fundamentals", Oxford University Press, (1984)  [factor of 3/2 in
c     conversion of traced to traceless quadrupoles; pages 50-51]
c
c
      subroutine moments (mode)
      use atomid
      use atoms
      use bound
      use charge
      use dipole
      use limits
      use moment
      use mpole
      use polar
      use potent
      use rigid
      use solpot
      use units
      use usage
      implicit none
      integer i,j,k
      real*8 xc,yc,zc
      real*8 xi,yi,zi,ri
      real*8 weigh,trace
      real*8 xmid,ymid,zmid
      real*8 xbnd,ybnd,zbnd
      real*8, allocatable :: xcm(:)
      real*8, allocatable :: ycm(:)
      real*8, allocatable :: zcm(:)
      real*8 a(3,3),b(3,3)
      logical, allocatable :: temp(:)
      character*6 mode
c
c
c     zero out total charge, dipole and quadrupole components
c
      netchg = 0.0d0
      netdpl = 0.0d0
      netqpl(1) = 0.0d0
      netqpl(2) = 0.0d0
      netqpl(3) = 0.0d0
      xdpl = 0.0d0
      ydpl = 0.0d0
      zdpl = 0.0d0
      xxqpl = 0.0d0
      xyqpl = 0.0d0
      xzqpl = 0.0d0
      yxqpl = 0.0d0
      yyqpl = 0.0d0
      yzqpl = 0.0d0
      zxqpl = 0.0d0
      zyqpl = 0.0d0
      zzqpl = 0.0d0
c
c     perform dynamic allocation of some local arrays
c
      if (mode .eq. 'FULL')  allocate (temp(n))
c
c     store active atom list, and make all atoms active
c
      if (mode.eq.'FULL' .and. nuse.ne.n) then
         do i = 1, n
            temp(i) = use(i)
            use(i) = .true.
         end do
      end if
c
c     maintain periodic boundaries and neighbor lists
c
      if (use_bounds .and. .not.use_rigid)  call bounds
      if (use_clist .or. use_mlist)  call nblist
c
c     perform dynamic allocation of some local arrays
c
      allocate (xcm(n))
      allocate (ycm(n))
      allocate (zcm(n))
c
c     find the center of mass of the set of active atoms
c
      weigh = 0.0d0
      xmid = 0.0d0
      ymid = 0.0d0
      zmid = 0.0d0
      do i = 1, n
         if (use(i)) then
            weigh = weigh + mass(i)
            xmid = xmid + x(i)*mass(i)
            ymid = ymid + y(i)*mass(i)
            zmid = zmid + z(i)*mass(i)
         end if
      end do
      if (weigh .ne. 0.0d0) then
         xmid = xmid / weigh
         ymid = ymid / weigh
         zmid = zmid / weigh
      end if
      do i = 1, n
         xcm(i) = x(i) - xmid
         ycm(i) = y(i) - ymid
         zcm(i) = z(i) - zmid
      end do
c
c     alter partial charges and monopoles via charge flux
c
      if (use_chgflx)  call alterchg
c
c     set the multipole moment components due to partial charges
c
      do i = 1, nion
         k = iion(i)
         if (use(k)) then
            netchg = netchg + pchg(k)
            xdpl = xdpl + xcm(k)*pchg(k)
            ydpl = ydpl + ycm(k)*pchg(k)
            zdpl = zdpl + zcm(k)*pchg(k)
            xxqpl = xxqpl + xcm(k)*xcm(k)*pchg(k)
            xyqpl = xyqpl + xcm(k)*ycm(k)*pchg(k)
            xzqpl = xzqpl + xcm(k)*zcm(k)*pchg(k)
            yxqpl = yxqpl + ycm(k)*xcm(k)*pchg(k)
            yyqpl = yyqpl + ycm(k)*ycm(k)*pchg(k)
            yzqpl = yzqpl + ycm(k)*zcm(k)*pchg(k)
            zxqpl = zxqpl + zcm(k)*xcm(k)*pchg(k)
            zyqpl = zyqpl + zcm(k)*ycm(k)*pchg(k)
            zzqpl = zzqpl + zcm(k)*zcm(k)*pchg(k)
         end if
      end do
c
c     set the multipole moment components due to bond dipoles
c
      do i = 1, ndipole
         j = idpl(1,i)
         k = idpl(2,i)
         if (use(j) .or. use(k)) then
            xi = x(j) - x(k)
            yi = y(j) - y(k)
            zi = z(j) - z(k)
            ri = sqrt(xi*xi + yi*yi + zi*zi)
            xbnd = bdpl(i) * (xi/ri) / debye
            ybnd = bdpl(i) * (yi/ri) / debye
            zbnd = bdpl(i) * (zi/ri) / debye
            xc = x(j) - xi*sdpl(i)
            yc = y(j) - yi*sdpl(i)
            zc = z(j) - zi*sdpl(i)
            xdpl = xdpl + xbnd
            ydpl = ydpl + ybnd
            zdpl = zdpl + zbnd
            xxqpl = xxqpl + 2.0d0*xc*xbnd
            xyqpl = xyqpl + xc*ybnd + yc*xbnd
            xzqpl = xzqpl + xc*zbnd + zc*xbnd
            yxqpl = yxqpl + yc*xbnd + xc*ybnd
            yyqpl = yyqpl + 2.0d0*yc*ybnd
            yzqpl = yzqpl + yc*zbnd + zc*ybnd
            zxqpl = zxqpl + zc*xbnd + xc*zbnd
            zyqpl = zyqpl + zc*ybnd + yc*zbnd
            zzqpl = zzqpl + 2.0d0*zc*zbnd
         end if
      end do
c
c     find atomic multipoles and induced dipoles in global frame
c
      if (use_born)  call born
      call chkpole
      call rotpole ('MPOLE')
      call induce
      if (solvtyp.eq.'GK' .or. solvtyp.eq.'PB') then
         do i = 1, npole
            k = ipole(i)
            rpole(2,k) = rpole(2,k) + uinds(1,k)
            rpole(3,k) = rpole(3,k) + uinds(2,k)
            rpole(4,k) = rpole(4,k) + uinds(3,k)
         end do
      else
         do i = 1, npole
            k = ipole(i)
            rpole(2,k) = rpole(2,k) + uind(1,k)
            rpole(3,k) = rpole(3,k) + uind(2,k)
            rpole(4,k) = rpole(4,k) + uind(3,k)
         end do
      end if
c
c     set the moment components due to atomic monopoles and dipoles
c
      do i = 1, npole
         k = ipole(i)
         if (use(k)) then
            netchg = netchg + rpole(1,k)
            xdpl = xdpl + xcm(k)*rpole(1,k) + rpole(2,k)
            ydpl = ydpl + ycm(k)*rpole(1,k) + rpole(3,k)
            zdpl = zdpl + zcm(k)*rpole(1,k) + rpole(4,k)
            xxqpl = xxqpl + xcm(k)*xcm(k)*rpole(1,k)
     &                 + 2.0d0*xcm(k)*rpole(2,k)
            xyqpl = xyqpl + xcm(k)*ycm(k)*rpole(1,k)
     &                 + xcm(k)*rpole(3,k) + ycm(k)*rpole(2,k)
            xzqpl = xzqpl + xcm(k)*zcm(k)*rpole(1,k)
     &                 + xcm(k)*rpole(4,k) + zcm(k)*rpole(2,k)
            yxqpl = yxqpl + ycm(k)*xcm(k)*rpole(1,k)
     &                 + ycm(k)*rpole(2,k) + xcm(k)*rpole(3,k)
            yyqpl = yyqpl + ycm(k)*ycm(k)*rpole(1,k)
     &                 + 2.0d0*ycm(k)*rpole(3,k)
            yzqpl = yzqpl + ycm(k)*zcm(k)*rpole(1,k)
     &                 + ycm(k)*rpole(4,k) + zcm(k)*rpole(3,k)
            zxqpl = zxqpl + zcm(k)*xcm(k)*rpole(1,k)
     &                 + zcm(k)*rpole(2,k) + xcm(k)*rpole(4,k)
            zyqpl = zyqpl + zcm(k)*ycm(k)*rpole(1,k)
     &                 + zcm(k)*rpole(3,k) + ycm(k)*rpole(4,k)
            zzqpl = zzqpl + zcm(k)*zcm(k)*rpole(1,k)
     &                 + 2.0d0*zcm(k)*rpole(4,k)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xcm)
      deallocate (ycm)
      deallocate (zcm)
c
c     convert the quadrupole from traced to traceless form
c
      trace = (xxqpl + yyqpl + zzqpl) / 3.0d0
      xxqpl = 1.5d0 * (xxqpl-trace)
      xyqpl = 1.5d0 * xyqpl
      xzqpl = 1.5d0 * xzqpl
      yxqpl = 1.5d0 * yxqpl
      yyqpl = 1.5d0 * (yyqpl-trace)
      yzqpl = 1.5d0 * yzqpl
      zxqpl = 1.5d0 * zxqpl
      zyqpl = 1.5d0 * zyqpl
      zzqpl = 1.5d0 * (zzqpl-trace)
c
c     add the traceless atomic quadrupoles to total quadrupole
c
      do i = 1, npole
         k = ipole(i)
         if (use(k)) then
            xxqpl = xxqpl + 3.0d0*rpole(5,k)
            xyqpl = xyqpl + 3.0d0*rpole(6,k)
            xzqpl = xzqpl + 3.0d0*rpole(7,k)
            yxqpl = yxqpl + 3.0d0*rpole(8,k)
            yyqpl = yyqpl + 3.0d0*rpole(9,k)
            yzqpl = yzqpl + 3.0d0*rpole(10,k)
            zxqpl = zxqpl + 3.0d0*rpole(11,k)
            zyqpl = zyqpl + 3.0d0*rpole(12,k)
            zzqpl = zzqpl + 3.0d0*rpole(13,k)
         end if
      end do
c
c     revert to the original set of active atoms
c
      if (mode.eq.'FULL' .and. nuse.ne.n) then
         do i = 1, n
            use(i) = temp(i)
         end do
      end if
c
c     perform deallocation of some local arrays
c
      if (mode .eq. 'FULL')  deallocate (temp)
c
c     convert dipole to Debye and quadrupole to Buckingham
c
      xdpl = xdpl * debye
      ydpl = ydpl * debye
      zdpl = zdpl * debye
      xxqpl = xxqpl * debye
      xyqpl = xyqpl * debye
      xzqpl = xzqpl * debye
      yxqpl = yxqpl * debye
      yyqpl = yyqpl * debye
      yzqpl = yzqpl * debye
      zxqpl = zxqpl * debye
      zyqpl = zyqpl * debye
      zzqpl = zzqpl * debye
c
c     get dipole magnitude and diagonalize quadrupole tensor
c
      netdpl = sqrt(xdpl*xdpl + ydpl*ydpl + zdpl*zdpl)
      a(1,1) = xxqpl
      a(1,2) = xyqpl
      a(1,3) = xzqpl
      a(2,1) = yxqpl
      a(2,2) = yyqpl
      a(2,3) = yzqpl
      a(3,1) = zxqpl
      a(3,2) = zyqpl
      a(3,3) = zzqpl
      call jacobi (3,a,netqpl,b)
      return
      end
c
c
c     ################################################################
c     ##                   COPYRIGHT (C) 2001 by                    ##
c     ##  Michael Schnieders, Alan Grossfield & Jay William Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program monte  --  Monte Carlo-Minimization search method  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "monte" performs a Monte Carlo-Minimization conformational
c     search using Cartesian single atom or torsional move sets
c
c     literature references:
c
c     Z. Li and H. A. Scheraga, "Monte Carlo-Minimization Approach
c     to the Multiple-Minima Problem in Protein Folding", Proc. Natl.
c     Acad. Sci. USA, 84, 6611-6615 (1987)
c
c     D. J. Wales, "Energy Landscapes with Applications to Clusters,
c     Biomolecules and Glasses", Cambridge University Press, 2003,
c     Section 6.7.4
c
c
      program monte
      use atoms
      use files
      use inform
      use iounit
      use omega
      use output
      use units
      use usage
      use zcoord
      implicit none
      integer i,k,m,next
      integer keep,nbig
      integer nmap,lext
      integer istep,nstep
      integer ixyz,freeunit
      real*8 global,ratio
      real*8 big,eps,size
      real*8 grdmin,temper
      real*8 minimum,pminimum
      real*8 tsize,factor
      real*8 beta,boltz
      real*8 random,trial
      real*8 converge,delta
      real*8 efficient
      real*8 vector(3)
      real*8, allocatable :: xg(:)
      real*8, allocatable :: yg(:)
      real*8, allocatable :: zg(:)
      real*8, allocatable :: xi(:)
      real*8, allocatable :: yi(:)
      real*8, allocatable :: zi(:)
      real*8, allocatable :: xp(:)
      real*8, allocatable :: yp(:)
      real*8, allocatable :: zp(:)
      logical exist,reset,done
      logical torsmove
      character*1 answer
      character*6 status
      character*7 ext
      character*240 xyzfile
      character*240 record
      character*240 string
      external random
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     initialize values of some counters and parameters
c
      istep = 0
      keep = 0
      nbig = 0
      nmap = 0
      delta = 0.00001d0
      eps = 0.0001d0
      big = 100000.0d0
      reset = .false.
c
c     get the desired number of Monte Carlo steps
c
      nstep = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  nstep
   10 continue
      if (nstep .le. 0) then
         write (iout,20)
   20    format (/,' Maximum Number of Monte Carlo Steps [1000] :  ', $)
         read (input,30)  nstep
   30    format (i10)
         if (nstep .le. 0)  nstep = 1000
      end if
c
c     get the search efficiency criterion for convergence
c
      converge = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=40,end=40)  converge
   40 continue
      if (converge .lt. 0.0d0) then
         write (iout,50)
   50    format (/,' Enter Search Efficiency Termination Criterion',
     &              ' [0.01] :  ', $)
         read (input,60)  string
   60    format (a240)
         read (string,*,err=70,end=70)  converge
   70    continue
         if (converge .lt. 0.0d0)  converge = 0.01
      end if
      converge = converge + delta
c
c     choose either the torsional or single atom move set
c
      torsmove = .false.
      call nextarg (answer, exist)
      if (.not. exist) then
         write (iout,80)
   80    format (/,' Use [C]artesian or [T]orsional Moves [C] :  ',$)
         read (input,90)  record
   90    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'T')  torsmove = .true.
c
c     for torsional moves, generate the internal coordinates
c
      if (torsmove) then
         call makeint (0)
         call initrot
c
c     set all atoms active to simplify torsional calculation
c
         nuse = n
         do i = 1, n
            use(i) = .true.
         end do
      end if
c
c     get the desired Cartesian or torsional step size
c
      size = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=100,end=100)  size
  100 continue
      if (size .lt. 0.0d0) then
         if (torsmove) then
            write (iout,110)
  110       format (/,' Enter Maximum Step in Degrees [180.0] :  ', $)
         else
            write (iout,120)
  120       format (/,' Enter Maximum Step in Angstroms [3.0] :  ', $)
         end if
         read (input,130)  string
  130    format (a240)
         read (string,*,err=140,end=140)  size
  140    continue
         if (size .lt. 0.0d0) then
            if (torsmove) then
               size = 180.0d0
            else
               size = 3.0d0
            end if
         end if
         if (torsmove)  size = min(size,180.0d0)
      end if
c
c     get the gradient convergence for local minimizations
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=150,end=150)  grdmin
  150 continue
      if (grdmin .lt. 0.0d0) then
         write (iout,160)
  160    format (/,' Enter RMS Gradient Criterion for Minima',
     &              ' [0.01] :  ', $)
         read (input,170)  string
  170    format (a240)
         read (string,*,err=180,end=180)  grdmin
  180    continue
         if (grdmin .lt. 0.0d0)  grdmin = 0.01
      end if
c
c     get the desired temperature for Metropolis criterion
c
      temper = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=190,end=190)  temper
  190 continue
      if (temper .lt. 0.0d0) then
         write (iout,200)
  200    format (/,' Enter the Desired Temperature in Degrees',
     &              ' K [500] :  ', $)
         read (input,210)  string
  210    format (a240)
         read (string,*,err=220,end=220)  temper
  220    continue
         if (temper .lt. 0.0d0)  temper = 500.0d0
      end if
      beta = 1.0d0 / (gasconst*temper)
c
c     perform dynamic allocation of some local arrays
c
      allocate (xg(n))
      allocate (yg(n))
      allocate (zg(n))
      allocate (xi(n))
      allocate (yi(n))
      allocate (zi(n))
      allocate (xp(n))
      allocate (yp(n))
      allocate (zp(n))
c
c     print some information prior to initial iteration
c
      write (iout,230)
  230 format (/,' Monte Carlo Minimization Global Search :')
      write (iout,240)
  240 format (/,' MCM Iter       Current         Global',
     &           '    Efficiency    Accept      Status',/)
      flush (iout)
c
c     create and open an output file if using archive mode
c
      if (archive) then
         ixyz = freeunit ()
         xyzfile = filename(1:leng)
         call suffix (xyzfile,'arc','new')
         open (unit=ixyz,file=xyzfile,status='new')
         close (unit=ixyz)
      end if
c
c     store the coordinates, then perform a minimization
c
      do i = 1, n
         xi(i) = x(i)
         yi(i) = y(i)
         zi(i) = z(i)
      end do
      call mcmstep (minimum,grdmin)
      pminimum = minimum
      write (iout,250)  0,minimum
  250 format (i8,3x,f12.4)
c
c     save coordinates as the initial global minimum
c
      do i = 1, n
         xg(i) = x(i)
         yg(i) = y(i)
         zg(i) = z(i)
      end do
      global = minimum
      nmap = nmap + 1
      lext = 3
      call numeral (nmap,ext,lext)
      ixyz = freeunit ()
      if (archive) then
         xyzfile = filename(1:leng)
         call suffix (xyzfile,'arc','old')
         inquire (file=xyzfile,exist=exist)
         if (exist) then
            call openend (ixyz,xyzfile)
         else
            open (unit=ixyz,file=xyzfile,status='new')
         end if
      else
         xyzfile = filename(1:leng)//'.'//ext(1:lext)
         call version (xyzfile,'new')
         open (unit=ixyz,file=xyzfile,status='new')
      end if
      call prtxyz (ixyz)
      close (unit=ixyz)
      write (iout,260)  nmap,global
  260 format (/,4x,'Minimum Energy Structure',i7,6x,f16.4,/)
      call flush (iout)
c
c     optionally reset coordinates to before the minimization
c
      if (reset) then
         do i = 1, n
            x(i) = xi(i)
            y(i) = yi(i)
            z(i) = zi(i)
         end do
      end if
      if (torsmove)  call makeint (2)
c
c     store the prior coordinates to start each MCM iteration
c
      done = .false.
      do while (.not. done)
         istep = istep + 1
         do i = 1, n
            xp(i) = x(i)
            yp(i) = y(i)
            zp(i) = z(i)
         end do
c
c     generate random angle moves for a few torsions
c
         if (torsmove) then
            m = int(-log(max(random(),0.0001d0))) + 1
            do i = 1, m
               k = int(nomega * random()) + 1
               k = zline(k)
               tsize = 2.0d0 * size * (random()-0.5d0)
               ztors(k) = ztors(k) + tsize
               if (ztors(k) .gt. 180.0d0) then
                  ztors(k) = ztors(k) - 360.0d0
               else if (ztors(k) .lt. -180.0d0) then
                  ztors(k) = ztors(k) + 360.0d0
               end if
            end do
            call makexyz
c
c     generate a random Cartesian move for each atom
c
         else
            do i = 1, nuse
               k = iuse(i)
               call ranvec (vector)
               factor = size * random ()
               x(k) = x(k) + factor*vector(1)
               y(k) = y(k) + factor*vector(2)
               z(k) = z(k) + factor*vector(3)
            end do
         end if
c
c     store the coordinates, then perform a minimization
c
         do i = 1, n
            xi(i) = x(i)
            yi(i) = y(i)
            zi(i) = z(i)
         end do
         call mcmstep (minimum,grdmin)
c
c     test for an unreasonably low energy at the minimum
c
         if (minimum .lt. -big)  minimum = big
c
c     step is probably degenerate if energy is identical
c
         if (abs(minimum-pminimum) .le. eps) then
            status = 'Same'
            pminimum = minimum
c
c     accept the step if the new minimum has lower energy
c
         else if (minimum .le. pminimum) then
            status = 'Accept'
            pminimum = minimum
c
c     if the energy increased, apply the Metropolis criterion
c
         else
            boltz = exp(-beta*(minimum-pminimum))
            trial = random ()
c
c     reject the step if the energy increase is too large
c
            if (boltz .lt. trial) then
               status = 'Reject'
c
c     accept the step if the energy increase is small enough
c
            else
               status = 'Accept'
               pminimum = minimum
            end if
         end if
c
c     save coordinates with the best energy as global minimum
c
         if (minimum .lt. global-eps) then
            do i = 1, n
               xg(i) = x(i)
               yg(i) = y(i)
               zg(i) = z(i)
            end do
            global = minimum
            nmap = nmap + 1
            lext = 3
            call numeral (nmap,ext,lext)
            ixyz = freeunit ()
            if (archive) then
               xyzfile = filename(1:leng)
               call suffix (xyzfile,'arc','old')
               inquire (file=xyzfile,exist=exist)
               if (exist) then
                  call openend (ixyz,xyzfile)
               else
                  open (unit=ixyz,file=xyzfile,status='new')
               end if
            else
               xyzfile = filename(1:leng)//'.'//ext(1:lext)
               call version (xyzfile,'new')
               open (unit=ixyz,file=xyzfile,status='new')
            end if
            call prtxyz (ixyz)
            close (unit=ixyz)
            write (iout,270)  nmap,global
  270       format (/,4x,'Minimum Energy Structure',i7,6x,f16.4,/)
            flush (iout)
         end if
c
c     update the efficiency and Monte Carlo acceptance ratio
c
         efficient = dble(nmap) / dble(istep)
         if (status .eq. 'Accept')  keep = keep + 1
         ratio = dble(keep) / dble(istep)
c
c     print intermediate results for the current iteration
c
         if (istep.ne.1 .and. mod(istep,100).eq.1) then
            write (iout,280)
  280       format (/,' MCM Iter       Current         Global',
     &                 '    Efficiency    Accept      Status',/)
         end if
         if (minimum .lt. big) then
            nbig = 0
            write (iout,290)  istep,minimum,global,efficient,
     &                        ratio,status
  290       format (i8,3x,f12.4,3x,f12.4,3x,f9.4,3x,f9.4,6x,a6)
         else
            nbig = nbig + 1
            write (iout,300)  istep,global,efficient,ratio,status
  300       format (i8,9x,'------',3x,f12.4,3x,f9.4,3x,f9.4,6x,a6)
         end if
         flush (iout)
c
c     restore global minimum after repeated bad iterations
c
         if (nbig .ge. 3) then
            nbig = 0
            do i = 1, n
               x(i) = xg(i)
               y(i) = yg(i)
               z(i) = zg(i)
            end do
c
c     optionally reset coordinates to before the minimization
c
         else if (status.eq.'Same' .or. status.eq.'Accept') then
            if (reset) then
               do i = 1, n
                  x(i) = xi(i)
                  y(i) = yi(i)
                  z(i) = zi(i)
               end do
            end if
c
c     restore coordinates to those from the previous iteration
c
         else if (status .eq. 'Reject') then
            do i = 1, n
               x(i) = xp(i)
               y(i) = yp(i)
               z(i) = zp(i)
            end do
         end if
c
c     update internal coordinates if using torsional moves
c
         if (torsmove)  call makeint (2)
c
c     check criteria based on search efficiency and step number
c
         if (efficient .le. converge) then
            done = .true.
            write (iout,310)
  310       format (/,' MONTE  --  Termination based on Overall',
     &                 ' Search Efficiency')
         end if
         if (istep .ge. nstep) then
            done = .true.
            write (iout,320)
  320       format (/,' MONTE  --  Termination based on Maximum',
     &                 ' MCM Step Limit')
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xg)
      deallocate (yg)
      deallocate (zg)
      deallocate (xi)
      deallocate (yi)
      deallocate (zi)
      deallocate (xp)
      deallocate (yp)
      deallocate (zp)
c
c     write out the final global minimum energy value
c
      if (digits .ge. 8) then
         write (iout,330)  global
  330    format (/,' Global Minimum Energy Value :',2x,f18.8)
      else if (digits .ge. 6) then
         write (iout,340)  global
  340    format (/,' Global Minimum Energy Value :',4x,f16.6)
      else
         write (iout,350)  global
  350    format (/,' Global Minimum Energy Value :',6x,f14.4)
      end if
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  function mcmstep  --  minimization phase of an MCM step  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "mcmstep" implements the minimization phase of an MCM step
c     via Cartesian minimization following a Monte Carlo step
c
c
      subroutine mcmstep (minimum,grdmin)
      use atoms
      use bound
      use files
      use inform
      use output
      use potent
      use usage
      implicit none
      integer i,k,nvar
      real*8 mcm1,minimum,grdmin
      real*8, allocatable :: xx(:)
      character*6 mode,method
      external mcm1,mcm2,optsave
c
c
c     prepare for the truncated Newton minimization
c
      mode = 'AUTO'
      method = 'AUTO'
      verbose = .false.
      iprint = 0
      iwrite = 0
      coordtype = 'CARTESIAN'
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(3*n))
c
c     convert atomic coordinates to optimization parameters
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         xx(nvar) = x(k)
         nvar = nvar + 1
         xx(nvar) = y(k)
         nvar = nvar + 1
         xx(nvar) = z(k)
      end do
c
c     make the call to the optimization routine
c
      call tncg (mode,method,nvar,xx,minimum,grdmin,
     &                  mcm1,mcm2,optsave)
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         x(k) = xx(nvar)
         nvar = nvar + 1
         y(k) = xx(nvar)
         nvar = nvar + 1
         z(k) = xx(nvar)
      end do
c
c     maintain any periodic boundary conditions
c
      if (use_bounds)  call bounds
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  function mcm1  --  energy and gradient for MCM search  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "mcm1" is a service routine that computes the energy and
c     gradient for truncated Newton optimization in Cartesian
c     coordinate space
c
c
      function mcm1 (xx,g)
      use atoms
      use usage
      implicit none
      integer i,k,nvar
      real*8 mcm1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         x(k) = xx(nvar)
         nvar = nvar + 1
         y(k) = xx(nvar)
         nvar = nvar + 1
         z(k) = xx(nvar)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the energy and gradient
c
      call gradient (e,derivs)
      mcm1 = e
c
c     store gradient components to optimization parameters
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         g(nvar) = derivs(1,k)
         nvar = nvar + 1
         g(nvar) = derivs(2,k)
         nvar = nvar + 1
         g(nvar) = derivs(3,k)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine mcm2  --  Hessian values for MCM search  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "mcm2" is a service routine that computes the sparse matrix
c     Hessian elements for truncated Newton optimization in Cartesian
c     coordinate space
c
c
      subroutine mcm2 (mode,xx,h,hinit,hstop,hindex,hdiag)
      use atoms
      use usage
      implicit none
      integer i,j,k,nvar
      integer hinit(*)
      integer hstop(*)
      integer hindex(*)
      integer, allocatable :: hvar(:)
      integer, allocatable :: huse(:)
      real*8 xx(*)
      real*8 hdiag(*)
      real*8 h(*)
      character*4 mode
c
c
c     convert optimization parameters to atomic coordinates
c
      if (mode .eq. 'NONE')  return
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         x(k) = xx(nvar)
         nvar = nvar + 1
         y(k) = xx(nvar)
         nvar = nvar + 1
         z(k) = xx(nvar)
      end do
c
c     compute and store the Hessian elements
c
      call hessian (h,hinit,hstop,hindex,hdiag)
c
c     perform dynamic allocation of some local arrays
c
      allocate (hvar(nvar))
      allocate (huse(3*n))
c
c     transform the sparse Hessian to use only active atoms
c
      nvar = 0
      if (nuse .ne. n) then
         do i = 1, n
            k = 3 * (i-1)
            if (use(i)) then
               do j = 1, 3
                  nvar = nvar + 1
                  hvar(nvar) = j + k
                  huse(j+k) = nvar
               end do
            else
               do j = 1, 3
                  huse(j+k) = 0
               end do
            end if
         end do
         do i = 1, nvar
            k = hvar(i)
            hinit(i) = hinit(k)
            hstop(i) = hstop(k)
            hdiag(i) = hdiag(k)
            do j = hinit(i), hstop(i)
               hindex(j) = huse(hindex(j))
            end do
         end do
      end if
c
c     convert atomic coordinates to optimization parameters
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         xx(nvar) = x(k)
         nvar = nvar + 1
         xx(nvar) = y(k)
         nvar = nvar + 1
         xx(nvar) = z(k)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (hvar)
      deallocate (huse)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2001  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module mplpot  --  multipole functional form details  ##
c     ##                                                        ##
c     ############################################################
c
c
c     m2scale      scale factor for 1-2 multipole energy interactions
c     m3scale      scale factor for 1-3 multipole energy interactions
c     m4scale      scale factor for 1-4 multipole energy interactions
c     m5scale      scale factor for 1-5 multipole energy interactions
c     use_chgpen   flag to use charge penetration damped potential
c     pentyp       type of penetration damping (NONE, GORDON1, GORDON2)
c
c
      module mplpot
      implicit none
      real*8 m2scale,m3scale
      real*8 m4scale,m5scale
      logical use_chgpen
      character*7 pentyp
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module mpole  --  atomic multipoles in current structure  ##
c     ##                                                            ##
c     ################################################################
c
c
c     maxpole   max components (monopole=1,dipole=4,quadrupole=13)
c
c     npole     total number of multipole sites in the system
c     ipole     number of the atom for each multipole site
c     polsiz    number of multipole components for each atom
c     pollist   multipole site for each atom (0=no multipole)
c     zaxis     number of the z-axis defining atom for each atom
c     xaxis     number of the x-axis defining atom for each atom
c     yaxis     number of the y-axis defining atom for each atom
c     pole      local frame Cartesian multipoles for each atom
c     rpole     global frame Cartesian multipoles for each atom
c     mono0     original atomic monopole values for charge flux
c     polaxe    local coordinate frame type for each atom
c
c
      module mpole
      implicit none
      integer maxpole
      parameter (maxpole=13)
      integer npole
      integer, allocatable :: ipole(:)
      integer, allocatable :: polsiz(:)
      integer, allocatable :: pollist(:)
      integer, allocatable :: zaxis(:)
      integer, allocatable :: xaxis(:)
      integer, allocatable :: yaxis(:)
      real*8, allocatable :: pole(:,:)
      real*8, allocatable :: rpole(:,:)
      real*8, allocatable :: mono0(:)
      character*8, allocatable :: polaxe(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2015  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module mrecip  --  reciprocal PME for permanent multipoles  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     vmxx    scalar sum xx-component of virial due to multipoles
c     vmyy    scalar sum yy-component of virial due to multipoles
c     vmzz    scalar sum zz-component of virial due to multipoles
c     vmxy    scalar sum xy-component of virial due to multipoles
c     vmxz    scalar sum xz-component of virial due to multipoles
c     vmyz    scalar sum yz-component of virial due to multipoles
c     cmp     Cartesian permenent multipoles as polytensor vector
c     fmp     fractional permanent multipoles as polytensor vector
c     cphi    Cartesian permanent multipole potential and field
c     fphi    fractional permanent multipole potential and field
c
c
      module mrecip
      implicit none
      real*8 vmxx,vmyy,vmzz
      real*8 vmxy,vmxz,vmyz
      real*8, allocatable :: cmp(:,:)
      real*8, allocatable :: fmp(:,:)
      real*8, allocatable :: cphi(:,:)
      real*8, allocatable :: fphi(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module mutant  --  free energy calculation hybrid atoms  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     nmut       number of atoms mutated from initial to final state
c     vcouple    van der Waals lambda type (0=decouple, 1=annihilate)
c     imut       atom sites differing in initial and final state
c     type0      atom type of each atom in the initial state system
c     class0     atom class of each atom in the initial state system
c     type1      atom type of each atom in the final state system
c     class1     atom class of each atom in the final state system
c     lambda     generic weighting between initial and final states
c     vlambda    state weighting value for van der Waals potentials
c     elambda    state weighting value for electrostatic potentials
c     tlambda    state weighting value for torsional potential
c     scexp      scale factor for soft core buffered 14-7 potential
c     scalpha    scale factor for soft core buffered 14-7 potential
c     mut        true if an atom is to be mutated, false otherwise
c
c
      module mutant
      implicit none
      integer nmut
      integer vcouple
      integer, allocatable :: imut(:)
      integer, allocatable :: type0(:)
      integer, allocatable :: class0(:)
      integer, allocatable :: type1(:)
      integer, allocatable :: class1(:)
      real*8 lambda
      real*8 vlambda
      real*8 elambda
      real*8 tlambda
      real*8 scexp
      real*8 scalpha
      logical, allocatable :: mut(:)
      save
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 2009 by Chuanjie Wu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine mutate  --  set parameters for hybrid system  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "mutate" constructs the hybrid hamiltonian for a specified
c     initial state, final state and mutation parameter "lambda"
c
c     note torsional and most electrostatics terms apply "lambda"
c     by directly scaling parameters, while vdw and repulsion energy
c     terms use soft core functions from the references cited below
c
c     literature references:
c
c     T. Steinbrecher, D. L. Mobley and D. A. Case, "Nonlinear Scaling
c     Schemes for Lennard-Jones Interactions in Free Energy
c     Calculations", Journal of Chemical Physics, 127, 214108 (2007)
c
c     D. Jiao, P. A. Golubkov, T. A. Darden and P. Ren, "Calculation
c     of Protein-Ligand Binding Free Energy by Using a Polarizable
c     Potential", PNAS, 105, 6290-6295 (2008)
c
c
      subroutine mutate
      use atomid
      use atoms
      use bndstr
      use inform
      use iounit
      use katoms
      use keys
      use mutant
      use potent
      implicit none
      integer i,j,k,ihyb
      integer it0,it1
      integer next,size
      integer ntbnd
      integer, allocatable :: list(:)
      integer, allocatable :: itbnd(:,:)
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(imut))  deallocate (imut)
      if (allocated(type0))  deallocate (type0)
      if (allocated(class0))  deallocate (class0)
      if (allocated(type1))  deallocate (type1)
      if (allocated(class1))  deallocate (class1)
      if (allocated(mut))  deallocate (mut)
      allocate (imut(n))
      allocate (type0(n))
      allocate (class0(n))
      allocate (type1(n))
      allocate (class1(n))
      allocate (mut(n))
c
c     perform dynamic allocation of some local arrays
c
      size = 40
      allocate (list(size))
      allocate (itbnd(2,nbond))
c
c     set defaults for lambda perturbation scaling values
c
      lambda = 1.0d0
      vlambda = 1.0d0
      elambda = 1.0d0
      tlambda = 1.0d0
c
c     set defaults for vdw coupling type and soft core vdw
c
      vcouple = 0
      scexp = 5.0d0
      scalpha = 0.7d0
c
c     zero out number of hybrid atoms and mutated torsions
c
      nmut = 0
      do i = 1, n
         mut(i) = .false.
      end do
      ntbnd = 0
      do i = 1, nbond
         itbnd(1,i) = 0
         itbnd(2,i) = 0
      end do
c
c     search keywords for free energy perturbation options
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'LAMBDA ') then
            string = record(next:240)
            read (string,*,err=30)  lambda
         else if (keyword(1:11) .eq. 'VDW-LAMBDA ') then
            string = record(next:240)
            read (string,*,err=30)  vlambda
         else if (keyword(1:11) .eq. 'ELE-LAMBDA ') then
            string = record(next:240)
            read (string,*,err=30)  elambda
         else if (keyword(1:12) .eq. 'TORS-LAMBDA ') then
            string = record(next:240)
            read (string,*,err=30)  tlambda
         else if (keyword(1:15) .eq. 'VDW-ANNIHILATE ') then
            vcouple = 1
         else if (keyword(1:7) .eq. 'MUTATE ') then
            string = record(next:240)
            read (string,*,err=30)  ihyb,it0,it1
            nmut = nmut + 1
            imut(nmut) = ihyb
            mut(ihyb) = .true.
            type0(nmut) = it0
            type1(nmut) = it1
            class0(nmut) = atmcls(it0)
            class1(nmut) = atmcls(it1)
         else if (keyword(1:7) .eq. 'LIGAND ') then
            do k = 1, size
               list(k) = 0
            end do
            string = record(next:240)
            read (string,*,err=10,end=10)  (list(k),k=1,size)
   10       continue
            k = 1
            do while (list(k) .ne. 0)
               if (list(k).gt.0 .and. list(k).le.n) then
                  j = list(k)
                  nmut = nmut + 1
                  imut(nmut) = j
                  mut(j) = .true.
                  type0(nmut) = 0
                  type1(nmut) = type(j)
                  class0(nmut) = 0
                  class1(nmut) = class(j)
                  k = k + 1
               else
                  do j = max(1,abs(list(k))), min(n,abs(list(k+1)))
                     nmut = nmut + 1
                     imut(nmut) = j
                     mut(j) = .true.
                     type0(nmut) = 0
                     type1(nmut) = type(i)
                     class0(nmut) = 0
                     class1(nmut) = class(i)
                  end do
                  k = k + 2
               end if
            end do
         else if (keyword(1:15) .eq. 'ROTATABLE-BOND ') then
            do k = 1, size
               list(k) = 0
            end do
            string = record(next:240)
            read (string,*,err=20,end=20)  (list(k),k=1,size)
   20       continue
            k = 1
            do while (list(k) .ne. 0)
               ntbnd = ntbnd + 1
               itbnd(1,ntbnd) = list(k)
               itbnd(2,ntbnd) = list(k+1)
               k = k + 2
            end do
         end if
   30    continue
      end do
c
c     scale electrostatic parameter values based on lambda
c
      if (elambda.ge.0.0d0 .and. elambda.lt.1.0d0) then
         call altelec
      end if
c
c     scale torsional parameter values based on lambda
c
      if (tlambda.ge.0.0d0 .and. tlambda.lt.1.0d0) then
         if (ntbnd .ne. 0)  call alttors (ntbnd,itbnd)
      end if
c
c     scale implicit solvation parameter values based on lambda
c
      if (elambda.ge.0.0d0 .and. elambda.lt.1.0d0) then
         call altsolv
      end if
c
c     turn off hybrid potentials if no sites are mutated
c
      use_mutate = .true.
      if (nmut .eq. 0)  use_mutate = .false.
c
c     write status of current hybrid potential lambda values
c
      if (use_mutate .and. .not.silent) then
         write (iout,40)
   40    format (/,' Free Energy Perturbation Parameters :')
         write (iout,50)  nmut,vlambda,elambda,tlambda
   50    format (/,' Number of FEP Hybrid Atoms',9x,i8,
     &           /,' van der Waals Lambda Value',9x,f8.3,
     &           /,' Electrostatics Lambda Value',8x,f8.3,
     &           /,' Torsion Angle Lambda Value',9x,f8.3)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (itbnd)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine altelec  --  mutated electrostatic parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "altelec" constructs mutated electrostatic parameters based
c     on the lambda mutation parameter "elambda"
c
c     note charge transfer electrostatics is not treated by parameter
c     scaling due to the functional form used, and must be done via
c     modification of pairwise energy terms in the potential routines
c
c
      subroutine altelec
      use angbnd
      use atoms
      use bndstr
      use cflux
      use charge
      use chgpen
      use dipole
      use mplpot
      use mpole
      use mutant
      use polar
      use potent
      implicit none
      integer i,j,k
      integer k1,k2
      integer ia,ib,ic
c
c
c     set scaled parameters for partial charge models
c
      if (use_charge) then
         do i = 1, nion
            k = iion(i)
            if (mut(k)) then
               pchg(k) = pchg(k) * elambda
            end if
            pchg0(k) = pchg(k)
         end do
      end if
c
c     set scaled parameters for bond dipole models
c
      if (use_dipole) then
         do i = 1, ndipole
            k1 = idpl(1,i)
            k2 = idpl(2,i)
            if (mut(k1) .or. mut(k2)) then
               bdpl(i) = bdpl(i) * elambda
            end if
         end do
      end if
c
c     set scaled parameters for atomic multipole models
c
      if (use_mpole) then
         do i = 1, npole
            k = ipole(i)
            if (mut(k)) then
               do j = 1, 13
                  pole(j,k) = pole(j,k) * elambda
               end do
               mono0(k) = pole(1,k)
               if (use_chgpen) then
                  pcore(k) = pcore(k) * elambda
                  pval(k) = pval(k) * elambda
                  pval0(k) = pval(k)
               end if
            end if
         end do
      end if
c
c     set scaled parameters for atomic polarizability models
c
      if (use_polar) then
         do i = 1, npole
            k = ipole(i)
            if (mut(k)) then
               polarity(k) = polarity(k) * elambda
               if (elambda .eq. 0.0d0)  douind(k) = .false.
            end if
         end do
      end if
c
c     set scaled parameters for bond stretch charge flux
c
      if (use_chgflx) then
         do i = 1, nbond
            ia = ibnd(1,i)
            ib = ibnd(2,i)
            if (mut(ia) .and. mut(ib)) then
               bflx(i) = bflx(i) * elambda
            end if
         end do
      end if
c
c     set scaled parameters for angle bend charge flux
c
      if (use_chgflx) then
         do i = 1, nangle
            ia = iang(1,i)
            ib = iang(2,i)
            ic = iang(3,i)
            if (mut(ia) .and. mut(ib) .and. mut(ic)) then
               aflx(1,i) = aflx(1,i) * elambda
               aflx(2,i) = aflx(2,i) * elambda
               abflx(1,i) = abflx(1,i) * elambda
               abflx(2,i) = abflx(2,i) * elambda
            end if
         end do
      end if
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine alttors  --  mutated torsional parameters  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "alttors" constructs mutated torsional parameters based
c     on the lambda mutation parameter "tlambda"
c
c
      subroutine alttors (ntbnd,itbnd)
      use mutant
      use potent
      use tors
      implicit none
      integer i,j
      integer ia,ib,ic,id
      integer kb,kc
      integer ntbnd
      integer itbnd(2,*)
c
c
c     set scaled parameters for specified rotatable bonds
c
      if (use_tors) then
         do i = 1, ntors
            ia = itors(1,i)
            ib = itors(2,i)
            ic = itors(3,i)
            id = itors(4,i)
            if (mut(ia) .and. mut(ib) .and. mut(ic) .and. mut(id)) then
               do j = 1, ntbnd
                  kb = itbnd(1,j)
                  kc = itbnd(2,j)
                  if ((kb.eq.ib .and. kc.eq.ic) .or.
     &                (kb.eq.ic .and. kc.eq.ib)) then
                     tors1(1,i) = tors1(1,i) * tlambda
                     tors2(1,i) = tors2(1,i) * tlambda
                     tors3(1,i) = tors3(1,i) * tlambda
                     tors4(1,i) = tors4(1,i) * tlambda
                     tors5(1,i) = tors5(1,i) * tlambda
                     tors6(1,i) = tors6(1,i) * tlambda
                  end if
               end do
            end if
         end do
      end if
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine altsolv  --  mutated solvation parameters  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "altsolv" constructs mutated implicit solvation parameters
c     based on the lambda mutation parameter "elambda"
c
c
      subroutine altsolv
      use atoms
      use mutant
      use nonpol
      use potent
      use solute
      implicit none
      integer i
c
c
c     set scaled parameters for implicit solvation models
c
      if (use_solv) then
         do i = 1, n
            if (mut(i)) then
               shct(i) = shct(i) * elambda
               radcav(i) = radcav(i) * elambda
               raddsp(i) = raddsp(i) * elambda
               epsdsp(i) = epsdsp(i) * elambda
               cdsp(i) = cdsp(i) * elambda
            end if
         end do
      end if
      return
      end
c
c
c     ###############################################################
c     ##  COPYRIGHT (C) 2006 by David Gohara & Jay William Ponder  ##
c     ##                    All Rights Reserved                    ##
c     ###############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine nblist  --  maintain pairwise neighbor lists  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "nblist" builds and maintains nonbonded pair neighbor lists
c     for vdw, dispersion, electrostatic and polarization terms
c
c
      subroutine nblist
      use limits
      use neigh
      use potent
      implicit none
c
c
c     rebuild list if using both vdw and dispersion terms
c
      if (use_vdw .and. use_disp) then
         dovlst = .true.
         dodlst = .true.
      end if
c
c     rebuild list if using both charge and multipole terms
c
      if (use_charge .and. use_mpole) then
         doclst = .true.
         domlst = .true.
      end if
c
c     update the appropriate nonbonded neighbor lists
c
      if (use_vdw .and. use_vlist)  call vlist
      if (use_disp .and. use_dlist)  call dlist
      if ((use_charge.or.use_solv) .and. use_clist)  call clist
      if ((use_repel.or.use_mpole.or.use_polar
     &       .or.use_chgtrn.or.use_solv) .and. use_mlist)  call mlist
      if (use_polar .and. use_ulist)  call ulist
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine vlist  --  get van der Waals neighbor lists  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "vlist" performs an update or a complete rebuild of the
c     nonbonded neighbor lists for vdw sites
c
c
      subroutine vlist
      use atoms
      use bound
      use boxes
      use iounit
      use neigh
      use vdw
      implicit none
      integer i,j,k
      integer ii,kk,iv
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 radius
      real*8 rdn,r2
      logical, allocatable :: update(:)
c
c
c     apply reduction factors to find coordinates for each site
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     neighbor list cannot be used with the replicates method
c
      radius = sqrt(vbuf2)
      call replica (radius)
      if (use_replica) then
         write (iout,10)
   10    format (/,' VLIST  --  Pairwise Neighbor List cannot',
     &              ' be used with Replicas')
         call fatal
      end if
c
c     perform a complete list build instead of an update
c
      if (dovlst) then
         dovlst = .false.
         if (nonprism) then
            call vbuild
         else
            call vlight
         end if
         return
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (update(n))
c
c     test sites for displacement exceeding half the buffer
c
!$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi,xr,yr,zr,r2)
!$OMP DO
      do ii = 1, nvdw
         i = ivdw(ii)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         xr = xi - xvold(i)
         yr = yi - yvold(i)
         zr = zi - zvold(i)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
         update(i) = .false.
         if (r2 .ge. lbuf2) then
            update(i) = .true.
            xvold(i) = xi
            yvold(i) = yi
            zvold(i) = zi
         end if
      end do
!$OMP END DO
c
c     rebuild the higher numbered neighbors of updated sites
c
!$OMP DO
      do ii = 1, nvdw
         i = ivdw(ii)
         if (update(i)) then
            xi = xvold(i)
            yi = yvold(i)
            zi = zvold(i)
            nvlst(i) = 0
            do kk = ii+1, nvdw
               k = ivdw(kk)
               xr = xi - xvold(k)
               yr = yi - yvold(k)
               zr = zi - zvold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. vbuf2) then
                  nvlst(i) = nvlst(i) + 1
                  vlst(nvlst(i),i) = k
               end if
            end do
         end if
      end do
!$OMP END DO
c
c     adjust lists for lower numbered neighbors of updated sites
c
!$OMP DO
      do ii = 1, nvdw
         i = ivdw(ii)
         if (update(i)) then
            xi = xvold(i)
            yi = yvold(i)
            zi = zvold(i)
            do kk = 1, ii-1
               k = ivdw(kk)
               if (.not. update(k)) then
                  xr = xi - xvold(k)
                  yr = yi - yvold(k)
                  zr = zi - zvold(k)
                  call imagen (xr,yr,zr)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. vbuf2) then
!$OMP CRITICAL
                     do j = 1, nvlst(k)
                        if (vlst(j,k) .eq. i)  goto 20
                     end do
                     nvlst(k) = nvlst(k) + 1
                     vlst(nvlst(k),k) = i
   20                continue
!$OMP END CRITICAL
                  else if (r2 .le. vbufx) then
!$OMP CRITICAL
                     do j = 1, nvlst(k)
                        if (vlst(j,k) .eq. i) then
                           vlst(j,k) = vlst(nvlst(k),k)
                           nvlst(k) = nvlst(k) - 1
                           goto 30
                        end if
                     end do
   30                continue
!$OMP END CRITICAL
                  end if
               end if
            end do
         end if
      end do
!$OMP END DO
c
c     check to see if any neighbor lists are too long
c
!$OMP DO
      do ii = 1, nvdw
         i = ivdw(ii)
         if (nvlst(i) .ge. maxvlst) then
            write (iout,40)
   40       format (/,' VLIST  --  Too many Neighbors;',
     &                 ' Increase MAXVLST')
            call fatal
         end if
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (update)
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine vbuild  --  build vdw list for all sites  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "vbuild" performs a complete rebuild of the van der Waals
c     pair neighbor list for all sites
c
c
      subroutine vbuild
      use bound
      use iounit
      use neigh
      use vdw
      implicit none
      integer i,k,ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr,r2
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private(i,k,ii,kk,xi,yi,zi,xr,yr,zr,r2)
!$OMP DO
c
c     store coordinates to reflect update of the site
c
      do ii = 1, nvdw
         i = ivdw(ii)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         xvold(i) = xi
         yvold(i) = yi
         zvold(i) = zi
c
c     generate all neighbors for the site being rebuilt
c
         nvlst(i) = 0
         do kk = ii+1, nvdw
            k = ivdw(kk)
            xr = xi - xred(k)
            yr = yi - yred(k)
            zr = zi - zred(k)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. vbuf2) then
               nvlst(i) = nvlst(i) + 1
               vlst(nvlst(i),i) = k
            end if
         end do
c
c     check to see if the neighbor list is too long
c
         if (nvlst(i) .ge. maxvlst) then
            write (iout,10)
   10       format (/,' VBUILD  --  Too many Neighbors;',
     &                 ' Increase MAXVLST')
            call fatal
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine vlight  --  build vdw pair list via lights  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "vlight" performs a complete rebuild of the van der Waals
c     pair neighbor list for all sites using the method of lights
c
c
      subroutine vlight
      use atoms
      use bound
      use cell
      use iounit
      use light
      use neigh
      use vdw
      implicit none
      integer i,j,k
      integer ii,kk
      integer kgy,kgz
      integer start,stop
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r2,off
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical unique,repeat
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xsort(nvdw))
      allocate (ysort(nvdw))
      allocate (zsort(nvdw))
c
c     transfer interaction site coordinates to sorting arrays
c
      do ii = 1, nvdw
         i = ivdw(ii)
         nvlst(i) = 0
         xvold(i) = xred(i)
         yvold(i) = yred(i)
         zvold(i) = zred(i)
         xsort(ii) = xred(i)
         ysort(ii) = yred(i)
         zsort(ii) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .false.
      off = sqrt(vbuf2)
      call lights (off,nvdw,xsort,ysort,zsort,unique)
c
c     perform deallocation of some local arrays
c
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private(i,j,k,ii,kk,
!$OMP& xi,yi,zi,xr,yr,zr,r2,kgy,kgz,start,stop,repeat)
!$OMP DO
c
c     loop over all atoms computing the neighbor lists
c
      do ii = 1, nvdw
         i = ivdw(ii)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii)
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            if (kk .le. ii)  goto 20
            k = ivdw(kk)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            xr = xi - xred(k)
            yr = yi - yred(k)
            zr = zi - zred(k)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. vbuf2) then
               nvlst(i) = nvlst(i) + 1
               vlst(nvlst(i),i) = k
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii)
            stop = nvdw
            goto 10
         end if
c
c     check to see if the neighbor list is too long
c
         if (nvlst(i) .ge. maxvlst) then
            write (iout,30)
   30       format (/,' VLIGHT  --  Too many Neighbors;',
     &                 ' Increase MAXVLST')
            call fatal
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine dlist  --  get damped dispersion neighbor lists  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "dlist" performs an update or a complete rebuild of the
c     nonbonded neighbor lists for damped dispersion sites
c
c
      subroutine dlist
      use atoms
      use bound
      use boxes
      use disp
      use iounit
      use neigh
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 radius,r2
      logical, allocatable :: update(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (update(n))
c
c     neighbor list cannot be used with the replicates method
c
      radius = sqrt(dbuf2)
      call replica (radius)
      if (use_replica) then
         write (iout,10)
   10    format (/,' DLIST  --  Pairwise Neighbor List cannot',
     &              ' be used with Replicas')
         call fatal
      end if
c
c     perform a complete list build instead of an update
c
      if (dodlst) then
         dodlst = .false.
         if (nonprism) then
            call dbuild
         else
            call dlight
         end if
         return
      end if
c
c     test sites for displacement exceeding half the buffer
c
!$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi,xr,yr,zr,r2)
!$OMP DO
      do ii = 1, ndisp
         i = idisp(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         xr = xi - xvold(i)
         yr = yi - yvold(i)
         zr = zi - zvold(i)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
         update(i) = .false.
         if (r2 .ge. lbuf2) then
            update(i) = .true.
            xvold(i) = xi
            yvold(i) = yi
            zvold(i) = zi
         end if
      end do
!$OMP END DO
c
c     rebuild the higher numbered neighbors of updated sites
c
!$OMP DO
      do ii = 1, ndisp
         i = idisp(ii)
         if (update(i)) then
            xi = xvold(i)
            yi = yvold(i)
            zi = zvold(i)
            nvlst(i) = 0
            do kk = ii+1, ndisp
               k = idisp(kk)
               xr = xi - xvold(k)
               yr = yi - yvold(k)
               zr = zi - zvold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. dbuf2) then
                  nvlst(i) = nvlst(i) + 1
                  vlst(nvlst(i),i) = k
               end if
            end do
         end if
      end do
!$OMP END DO
c
c     adjust lists for lower numbered neighbors of updated sites
c
!$OMP DO
      do ii = 1, ndisp
         i = idisp(ii)
         if (update(i)) then
            xi = xvold(i)
            yi = yvold(i)
            zi = zvold(i)
            do k = 1, i-1
               if (.not. update(k)) then
                  xr = xi - xvold(k)
                  yr = yi - yvold(k)
                  zr = zi - zvold(k)
                  call imagen (xr,yr,zr)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. dbuf2) then
!$OMP CRITICAL
                     do j = 1, nvlst(k)
                        if (vlst(j,k) .eq. i)  goto 20
                     end do
                     nvlst(k) = nvlst(k) + 1
                     vlst(nvlst(k),k) = i
   20                continue
!$OMP END CRITICAL
                  else if (r2 .le. dbufx) then
!$OMP CRITICAL
                     do j = 1, nvlst(k)
                        if (vlst(j,k) .eq. i) then
                           vlst(j,k) = vlst(nvlst(k),k)
                           nvlst(k) = nvlst(k) - 1
                           goto 30
                        end if
                     end do
   30                continue
!$OMP END CRITICAL
                  end if
               end if
            end do
         end if
      end do
!$OMP END DO
c
c     check to see if any neighbor lists are too long
c
!$OMP DO
      do ii = 1, ndisp
         i = idisp(ii)
         if (nvlst(i) .ge. maxvlst) then
            write (iout,40)
   40       format (/,' DLIST  --  Too many Neighbors;',
     &                 ' Increase MAXVLST')
            call fatal
         end if
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (update)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine dbuild  --  build dispersion list for all sites  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "dbuild" performs a complete rebuild of the damped dispersion
c     neighbor list for all sites
c
c
      subroutine dbuild
      use atoms
      use bound
      use disp
      use iounit
      use neigh
      implicit none
      integer i,k,ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr,r2
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private(i,k,ii,kk,xi,yi,zi,xr,yr,zr,r2)
!$OMP DO
c
c     store new coordinates to reflect update of the site
c
      do ii = 1, ndisp
         i = idisp(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         xvold(i) = xi
         yvold(i) = yi
         zvold(i) = zi
c
c     generate all neighbors for the site being rebuilt
c
         nvlst(i) = 0
         do kk = ii+1, ndisp
            k = idisp(kk)
            xr = xi - x(k)
            yr = yi - y(k)
            zr = zi - z(k)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. dbuf2) then
               nvlst(i) = nvlst(i) + 1
               vlst(nvlst(i),i) = k
            end if
         end do
c
c     check to see if the neighbor list is too long
c
         if (nvlst(i) .ge. maxvlst) then
            write (iout,10)
   10       format (/,' DBUILD  --  Too many Neighbors;',
     &                 ' Increase MAXVLST')
            call fatal
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine dlight  --  get damp dispersion list via lights  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "dlight" performs a complete rebuild of the damped dispersion
c     pair neighbor list for all sites using the method of lights
c
c
      subroutine dlight
      use atoms
      use bound
      use cell
      use disp
      use iounit
      use light
      use neigh
      implicit none
      integer i,j,k
      integer ii,kk
      integer kgy,kgz
      integer start,stop
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r2,off
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical unique,repeat
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xsort(ndisp))
      allocate (ysort(ndisp))
      allocate (zsort(ndisp))
c
c     transfer interaction site coordinates to sorting arrays
c
      do ii = 1, ndisp
         i = idisp(ii)
         nvlst(i) = 0
         xvold(i) = x(i)
         yvold(i) = y(i)
         zvold(i) = z(i)
         xsort(ii) = x(i)
         ysort(ii) = y(i)
         zsort(ii) = z(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .false.
      off = sqrt(dbuf2)
      call lights (off,ndisp,xsort,ysort,zsort,unique)
c
c     perform deallocation of some local arrays
c
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi,
!$OMP& xr,yr,zr,r2,kgy,kgz,start,stop,repeat)
!$OMP DO
c
c     loop over all atoms computing the neighbor lists
c
      do ii = 1, ndisp
         i = idisp(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii)
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            if (kk .le. ii)  goto 20
            k = idisp(kk)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            xr = xi - x(k)
            yr = yi - y(k)
            zr = zi - z(k)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. dbuf2) then
               nvlst(i) = nvlst(i) + 1
               vlst(nvlst(i),i) = k
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii)
            stop = ndisp
            goto 10
         end if
c
c     check to see if the neighbor list is too long
c
         if (nvlst(i) .ge. maxvlst) then
            write (iout,30)
   30       format (/,' DLIGHT  --  Too many Neighbors;',
     &                 ' Increase MAXVLST')
            call fatal
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine clist  --  get partial charge neighbor lists  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "clist" performs an update or a complete rebuild of the
c     nonbonded neighbor lists for partial charges
c
c
      subroutine clist
      use atoms
      use bound
      use boxes
      use charge
      use iounit
      use neigh
      implicit none
      integer i,j,k
      integer ii,kk,ic
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 radius,r2
      logical, allocatable :: update(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (update(n))
c
c     neighbor list cannot be used with the replicates method
c
      radius = sqrt(cbuf2)
      call replica (radius)
      if (use_replica) then
         write (iout,10)
   10    format (/,' CLIST  --  Pairwise Neighbor List cannot',
     &              ' be used with Replicas')
         call fatal
      end if
c
c     perform a complete list build instead of an update
c
      if (doclst) then
         doclst = .false.
         if (nonprism) then
            call cbuild
         else
            call clight
         end if
         return
      end if
c
c     test sites for displacement exceeding half the buffer
c
!$OMP PARALLEL default(shared) private(i,j,k,ii,kk,ic,
!$OMP& xi,yi,zi,xr,yr,zr,r2)
!$OMP DO
      do ii = 1, nion
         i = iion(ii)
         ic = kion(i)
         xi = x(ic)
         yi = y(ic)
         zi = z(ic)
         xr = xi - xeold(i)
         yr = yi - yeold(i)
         zr = zi - zeold(i)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
         update(i) = .false.
         if (r2 .ge. lbuf2) then
            update(i) = .true.
            xeold(i) = xi
            yeold(i) = yi
            zeold(i) = zi
         end if
      end do
!$OMP END DO
c
c     rebuild the higher numbered neighbors of updated sites
c
!$OMP DO
      do ii = 1, nion
         i = iion(ii)
         if (update(i)) then
            xi = xeold(i)
            yi = yeold(i)
            zi = zeold(i)
            nelst(i) = 0
            do kk = ii+1, nion
               k = iion(kk)
               xr = xi - xeold(k)
               yr = yi - yeold(k)
               zr = zi - zeold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. cbuf2) then
                  nelst(i) = nelst(i) + 1
                  elst(nelst(i),i) = k
               end if
            end do
         end if
      end do
!$OMP END DO
c
c     adjust lists for lower numbered neighbors of updated sites
c
!$OMP DO
      do ii = 1, nion
         i = iion(ii)
         if (update(i)) then
            xi = xeold(i)
            yi = yeold(i)
            zi = zeold(i)
            do kk = 1, ii-1
               k = iion(kk)
               if (.not. update(k)) then
                  xr = xi - xeold(k)
                  yr = yi - yeold(k)
                  zr = zi - zeold(k)
                  call imagen (xr,yr,zr)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. cbuf2) then
!$OMP CRITICAL
                     do j = 1, nelst(k)
                        if (elst(j,k) .eq. i)  goto 20
                     end do
                     nelst(k) = nelst(k) + 1
                     elst(nelst(k),k) = i
   20                continue
!$OMP END CRITICAL
                  else if (r2 .le. cbufx) then
!$OMP CRITICAL
                     do j = 1, nelst(k)
                        if (elst(j,k) .eq. i) then
                           elst(j,k) = elst(nelst(k),k)
                           nelst(k) = nelst(k) - 1
                           goto 30
                        end if
                     end do
   30                continue
!$OMP END CRITICAL
                  end if
               end if
            end do
         end if
      end do
!$OMP END DO
c
c     check to see if any neighbor lists are too long
c
!$OMP DO
      do ii = 1, nion
         i = iion(ii)
         if (nelst(i) .ge. maxelst) then
            write (iout,40)
   40       format (/,' CLIST  --  Too many Neighbors;',
     &                 ' Increase MAXELST')
            call fatal
         end if
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (update)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine cbuild  --  build charge list for all sites  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "cbuild" performs a complete rebuild of the partial charge
c     electrostatic neighbor list for all sites
c
c
      subroutine cbuild
      use atoms
      use bound
      use charge
      use iounit
      use neigh
      implicit none
      integer i,k
      integer ii,kk
      integer ic,kc
      real*8 xi,yi,zi
      real*8 xr,yr,zr,r2
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private(i,k,ii,kk,ic,kc,
!$OMP& xi,yi,zi,xr,yr,zr,r2)
!$OMP DO
c
c     store new coordinates to reflect update of the site
c
      do ii = 1, nion
         i = iion(ii)
         ic = kion(i)
         xi = x(ic)
         yi = y(ic)
         zi = z(ic)
         xeold(i) = xi
         yeold(i) = yi
         zeold(i) = zi
c
c     generate all neighbors for the site being rebuilt
c
         nelst(i) = 0
         do kk = ii+1, nion
            k = iion(kk)
            kc = kion(k)
            xr = xi - x(kc)
            yr = yi - y(kc)
            zr = zi - z(kc)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. cbuf2) then
               nelst(i) = nelst(i) + 1
               elst(nelst(i),i) = k
            end if
         end do
c
c     check to see if the neighbor list is too long
c
         if (nelst(i) .ge. maxelst) then
            write (iout,10)
   10       format (/,' CBUILD  --  Too many Neighbors;',
     &                 ' Increase MAXELST')
            call fatal
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine clight  --  get partial charge list via lights  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "clight" performs a complete rebuild of the partial charge
c     pair neighbor list for all sites using the method of lights
c
c
      subroutine clight
      use atoms
      use bound
      use cell
      use charge
      use iounit
      use light
      use neigh
      implicit none
      integer i,j,k
      integer ii,kk
      integer ic,kc
      integer kgy,kgz
      integer start,stop
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r2,off
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical unique,repeat
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xsort(nion))
      allocate (ysort(nion))
      allocate (zsort(nion))
c
c     transfer interaction site coordinates to sorting arrays
c
      do ii = 1, nion
         i = iion(ii)
         ic = kion(i)
         nelst(i) = 0
         xeold(i) = x(ic)
         yeold(i) = y(ic)
         zeold(i) = z(ic)
         xsort(ii) = x(ic)
         ysort(ii) = y(ic)
         zsort(ii) = z(ic)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .false.
      off = sqrt(cbuf2)
      call lights (off,nion,xsort,ysort,zsort,unique)
c
c     perform deallocation of some local arrays
c
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private(i,j,k,ii,kk,ic,kc,
!$OMP& xi,yi,zi,xr,yr,zr,r2,kgy,kgz,start,stop,repeat)
!$OMP DO
c
c     loop over all atoms computing the neighbor lists
c
      do ii = 1, nion
         i = iion(ii)
         ic = kion(i)
         xi = x(ic)
         yi = y(ic)
         zi = z(ic)
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii)
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            if (kk .le. ii)  goto 20
            k = iion(kk)
            kc = kion(k)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            xr = xi - x(kc)
            yr = yi - y(kc)
            zr = zi - z(kc)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. cbuf2) then
               nelst(i) = nelst(i) + 1
               elst(nelst(i),i) = k
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii)
            stop = nion
            goto 10
         end if
c
c     check to see if the neighbor list is too long
c
         if (nelst(i) .ge. maxelst) then
            write (iout,30)
   30       format (/,' CLIGHT  --  Too many Neighbors;',
     &                 ' Increase MAXELST')
            call fatal
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine mlist  --  get atomic multipole neighbor lists  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "mlist" performs an update or a complete rebuild of the
c     nonbonded neighbor lists for atomic multipoles
c
c
      subroutine mlist
      use atoms
      use bound
      use boxes
      use iounit
      use mpole
      use neigh
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 radius,r2
      logical, allocatable :: update(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (update(n))
c
c     neighbor list cannot be used with the replicates method
c
      radius = sqrt(mbuf2)
      call replica (radius)
      if (use_replica) then
         write (iout,10)
   10    format (/,' MLIST  --  Pairwise Neighbor List cannot',
     &              ' be used with Replicas')
         call fatal
      end if
c
c     perform a complete list build instead of an update
c
      if (domlst) then
         domlst = .false.
         if (nonprism) then
            call mbuild
         else
            call mlight
         end if
         return
      end if
c
c     test sites for displacement exceeding half the buffer
c
!$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi,xr,yr,zr,r2)
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         xr = xi - xeold(i)
         yr = yi - yeold(i)
         zr = zi - zeold(i)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
         update(i) = .false.
         if (r2 .ge. lbuf2) then
            update(i) = .true.
            xeold(i) = xi
            yeold(i) = yi
            zeold(i) = zi
         end if
      end do
!$OMP END DO
c
c     rebuild the higher numbered neighbors of updated sites
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         if (update(i)) then
            xi = xeold(i)
            yi = yeold(i)
            zi = zeold(i)
            nelst(i) = 0
            do kk = ii+1, npole
               k = ipole(kk)
               xr = xi - xeold(k)
               yr = yi - yeold(k)
               zr = zi - zeold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. mbuf2) then
                  nelst(i) = nelst(i) + 1
                  elst(nelst(i),i) = k
               end if
            end do
         end if
      end do
!$OMP END DO
c
c     adjust lists for lower numbered neighbors of updated sites
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         if (update(i)) then
            xi = xeold(i)
            yi = yeold(i)
            zi = zeold(i)
            do kk = 1, ii-1
               k = ipole(kk)
               if (.not. update(k)) then
                  xr = xi - xeold(k)
                  yr = yi - yeold(k)
                  zr = zi - zeold(k)
                  call imagen (xr,yr,zr)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. mbuf2) then
!$OMP CRITICAL
                     do j = 1, nelst(k)
                        if (elst(j,k) .eq. i)  goto 20
                     end do
                     nelst(k) = nelst(k) + 1
                     elst(nelst(k),k) = i
   20                continue
!$OMP END CRITICAL
                  else if (r2 .le. mbufx) then
!$OMP CRITICAL
                     do j = 1, nelst(k)
                        if (elst(j,k) .eq. i) then
                           elst(j,k) = elst(nelst(k),k)
                           nelst(k) = nelst(k) - 1
                           goto 30
                        end if
                     end do
   30                continue
!$OMP END CRITICAL
                  end if
               end if
            end do
         end if
      end do
!$OMP END DO
c
c     check to see if any neighbor lists are too long
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         if (nelst(i) .ge. maxelst) then
            write (iout,40)
   40       format (/,' MLIST  --  Too many Neighbors;',
     &                 ' Increase MAXELST')
            call fatal
         end if
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (update)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine mbuild  --  build mpole list for all sites  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "mbuild" performs a complete rebuild of the atomic multipole
c     electrostatic neighbor list for all sites
c
c
      subroutine mbuild
      use atoms
      use bound
      use iounit
      use mpole
      use neigh
      implicit none
      integer i,k,ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr,r2
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private(i,k,ii,kk,xi,yi,zi,xr,yr,zr,r2)
!$OMP DO
c
c     store new coordinates to reflect update of the site
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         xeold(i) = xi
         yeold(i) = yi
         zeold(i) = zi
c
c     generate all neighbors for the site being rebuilt
c
         nelst(i) = 0
         do kk = ii+1, npole
            k = ipole(kk)
            xr = xi - x(k)
            yr = yi - y(k)
            zr = zi - z(k)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. mbuf2) then
               nelst(i) = nelst(i) + 1
               elst(nelst(i),i) = k
            end if
         end do
c
c     check to see if the neighbor list is too long
c
         if (nelst(i) .ge. maxelst) then
            write (iout,10)
   10       format (/,' MBUILD  --  Too many Neighbors;',
     &                 ' Increase MAXELST')
            call fatal
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine mlight  --  get multipole pair list via lights  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "mlight" performs a complete rebuild of the atomic multipole
c     pair neighbor list for all sites using the method of lights
c
c
      subroutine mlight
      use atoms
      use bound
      use cell
      use iounit
      use light
      use mpole
      use neigh
      implicit none
      integer i,j,k
      integer ii,kk
      integer kgy,kgz
      integer start,stop
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r2,off
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical unique,repeat
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xsort(npole))
      allocate (ysort(npole))
      allocate (zsort(npole))
c
c     transfer interaction site coordinates to sorting arrays
c
      do ii = 1, npole
         i = ipole(ii)
         nelst(i) = 0
         xeold(i) = x(i)
         yeold(i) = y(i)
         zeold(i) = z(i)
         xsort(ii) = x(i)
         ysort(ii) = y(i)
         zsort(ii) = z(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .false.
      off = sqrt(mbuf2)
      call lights (off,npole,xsort,ysort,zsort,unique)
c
c     perform deallocation of some local arrays
c
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi,
!$OMP& xr,yr,zr,r2,kgy,kgz,start,stop,repeat)
!$OMP DO
c
c     loop over all atoms computing the neighbor lists
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii)
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            if (kk .le. ii)  goto 20
            k = ipole(kk)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            xr = xi - x(k)
            yr = yi - y(k)
            zr = zi - z(k)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. mbuf2) then
               nelst(i) = nelst(i) + 1
               elst(nelst(i),i) = k
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii)
            stop = npole
            goto 10
         end if
c
c     check to see if the neighbor list is too long
c
         if (nelst(i) .ge. maxelst) then
            write (iout,30)
   30       format (/,' MLIGHT  --  Too many Neighbors;',
     &                 ' Increase MAXELST')
            call fatal
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ulist  --  get preconditioner neighbor lists  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ulist" performs an update or a complete rebuild of the
c     neighbor lists for the polarization preconditioner
c
c
      subroutine ulist
      use atoms
      use bound
      use boxes
      use iounit
      use mpole
      use neigh
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 radius,r2
      logical, allocatable :: update(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (update(n))
c
c     neighbor list cannot be used with the replicates method
c
      radius = sqrt(ubuf2)
      call replica (radius)
      if (use_replica) then
         write (iout,10)
   10    format (/,' ULIST  --  Pairwise Neighbor List cannot',
     &              ' be used with Replicas')
         call fatal
      end if
c
c     perform a complete list build instead of an update
c
      if (doulst) then
         doulst = .false.
         if (nonprism) then
            call ubuild
         else
            call ulight
         end if
         return
      end if
c
c     test sites for displacement exceeding half the buffer
c
!$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi,xr,yr,zr,r2)
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         xr = xi - xuold(i)
         yr = yi - yuold(i)
         zr = zi - zuold(i)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
         update(i) = .false.
         if (r2 .ge. pbuf2) then
            update(i) = .true.
            xuold(i) = xi
            yuold(i) = yi
            zuold(i) = zi
         end if
      end do
!$OMP END DO
c
c     rebuild the higher numbered neighbors of updated sites
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         if (update(i)) then
            xi = xuold(i)
            yi = yuold(i)
            zi = zuold(i)
            nulst(i) = 0
            do kk = ii+1, npole
               k = ipole(kk)
               xr = xi - xuold(k)
               yr = yi - yuold(k)
               zr = zi - zuold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. ubuf2) then
                  nulst(i) = nulst(i) + 1
                  ulst(nulst(i),i) = k
               end if
            end do
         end if
      end do
!$OMP END DO
c
c     adjust lists for lower numbered neighbors of updated sites
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         if (update(i)) then
            xi = xuold(i)
            yi = yuold(i)
            zi = zuold(i)
            do kk = 1, ii-1
               k = ipole(kk)
               if (.not. update(k)) then
                  xr = xi - xuold(k)
                  yr = yi - yuold(k)
                  zr = zi - zuold(k)
                  call imagen (xr,yr,zr)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. ubuf2) then
!$OMP CRITICAL
                     do j = 1, nulst(k)
                        if (ulst(j,k) .eq. i)  goto 20
                     end do
                     nulst(k) = nulst(k) + 1
                     ulst(nulst(k),k) = i
   20                continue
!$OMP END CRITICAL
                  else if (r2 .le. ubufx) then
!$OMP CRITICAL
                     do j = 1, nulst(k)
                        if (ulst(j,k) .eq. i) then
                           ulst(j,k) = ulst(nulst(k),k)
                           nulst(k) = nulst(k) - 1
                           goto 30
                        end if
                     end do
   30                continue
!$OMP END CRITICAL
                  end if
               end if
            end do
         end if
      end do
!$OMP END DO
c
c     check to see if any neighbor lists are too long
c
!$OMP DO
      do ii = 1, npole
         i = ipole(ii)
         if (nulst(i) .ge. maxulst) then
            write (iout,40)
   40       format (/,' ULIST  --  Too many Neighbors;',
     &                 ' Increase MAXULST')
            call fatal
         end if
      end do
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (update)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ubuild  --  preconditioner list for all sites  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ubuild" performs a complete rebuild of the polarization
c     preconditioner neighbor list for all sites
c
c
      subroutine ubuild
      use atoms
      use bound
      use iounit
      use mpole
      use neigh
      implicit none
      integer i,k,ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr,r2
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private(i,k,ii,kk,xi,yi,zi,xr,yr,zr,r2)
!$OMP DO
c
c     store new coordinates to reflect update of the site
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         xuold(i) = xi
         yuold(i) = yi
         zuold(i) = zi
c
c     generate all neighbors for the site being rebuilt
c
         nulst(i) = 0
         do kk = ii+1, npole
            k = ipole(kk)
            xr = xi - x(k)
            yr = yi - y(k)
            zr = zi - z(k)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. ubuf2) then
               nulst(i) = nulst(i) + 1
               ulst(nulst(i),i) = k
            end if
         end do
c
c     check to see if the neighbor list is too long
c
         if (nulst(i) .ge. maxulst) then
            write (iout,10)
   10       format (/,' UBUILD  --  Too many Neighbors;',
     &                 ' Increase MAXULST')
            call fatal
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ulight  --  get preconditioner list via lights  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ulight" performs a complete rebuild of the polarization
c     preconditioner pair neighbor list for all sites using the
c     method of lights
c
c
      subroutine ulight
      use atoms
      use bound
      use cell
      use iounit
      use light
      use mpole
      use neigh
      implicit none
      integer i,j,k
      integer ii,kk
      integer kgy,kgz
      integer start,stop
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r2,off
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical unique,repeat
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xsort(npole))
      allocate (ysort(npole))
      allocate (zsort(npole))
c
c     transfer interaction site coordinates to sorting arrays
c
      do ii = 1, npole
         i = ipole(ii)
         nulst(i) = 0
         xuold(i) = x(i)
         yuold(i) = y(i)
         zuold(i) = z(i)
         xsort(ii) = x(i)
         ysort(ii) = y(i)
         zsort(ii) = z(i)
      end do
c
c     use the method of lights to generate neighbors
c
      unique = .false.
      off = sqrt(ubuf2)
      call lights (off,npole,xsort,ysort,zsort,unique)
c
c     perform deallocation of some local arrays
c
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi,
!$OMP& xr,yr,zr,r2,kgy,kgz,start,stop,repeat)
!$OMP DO
c
c     loop over all atoms computing the neighbor lists
c
      do ii = 1, npole
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii)
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            if (kk .le. ii)  goto 20
            k = ipole(kk)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            xr = xi - x(k)
            yr = yi - y(k)
            zr = zi - z(k)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. ubuf2) then
               nulst(i) = nulst(i) + 1
               ulst(nulst(i),i) = k
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii)
            stop = npole
            goto 10
         end if
c
c     check to see if the neighbor list is too long
c
         if (nulst(i) .ge. maxulst) then
            write (iout,30)
   30       format (/,' ULIGHT  --  Too many Neighbors;',
     &                 ' Increase MAXULST')
            call fatal
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##########################################################
c     ##  COPYRIGHT (C) 2023 by Rae Corrigan & Jay W. Ponder  ##
c     ##                  All Rights Reserved                 ##
c     ##########################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine neck  --  neck contribution to effective radii  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "neck" calculates the descreening contribution of any neck 
c     formed between two atoms
c
c     literature reference:
c
c     B. Aguilar, R. Shadrach, and A. V. Onufriev, "Reducing the 
c     Secondary Structure Bias in the Generalized Born Model via 
c     R6 Effective Radii", Journal of Chemical Theory and 
c     Computation, 6, 3613-3630 (2010)
c
c     variables and parameters:
c
c     r          separation distance between two atoms
c     intstarti  start of descreening integral for atom i
c     desck      descreening radius of atom k
c     mixsn      mixed Sneck scale factor for atoms i and k
c
c
      subroutine neck (r,intstarti,desck,mixsn,neckval)
      use math
      use solute
      implicit none
      real*8 r,intstarti
      real*8 desck,mixsn
      real*8 neckval
      real*8 usea,useb
      real*8 rhow,pi43
      real*8 rminb,radminr
      real*8 rminb4,radminr4
c
c
c     assign and initialize probe radius and constants
c
      rhow = 1.4d0
      usea = 0.0d0
      useb = 0.0d0
c
c     if atoms too far separated then no neck is formed
c
      if (r .gt. intstarti+desck+2.0d0*rhow) then
          neckval = 0.0d0
c
c     if atoms form a neck then calculate neck contribution
c
      else
         call neckcon (intstarti,desck,usea,useb)
         pi43 = 4.0d0 * third * pi 
         rminb = r - useb
         rminb4 = rminb**4
         radminr = intstarti + desck + 2.0d0*rhow - r
         radminr4 = radminr**4
         neckval = pi43 * mixsn * usea * rminb4 * radminr4
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine neckder  --  get neck descreening derivatives  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "neckder" returns the derivative of the neck descreening
c     integral for the Born chain rule term  
c
c
      subroutine neckder (r,intstarti,desck,mixsn,neckderi)
      use math
      use solute
      implicit none
      real*8 r,intstarti
      real*8 desck,mixsn
      real*8 neckderi
      real*8 usea,useb
      real*8 rhow,pi43
      real*8 rminb,radminr
      real*8 rminb3,radminr3
      real*8 rminb4,radminr4

c
c     assign and initialize probe radius and constants
c
      rhow = 1.4d0
      usea = 0.0d0
      useb = 0.0d0
c
c     if atoms too far separated then no neck is formed
c
      if (r .gt. intstarti+desck+2.0d0*rhow) then
         neckderi = 0.0d0
c
c     if atoms form a neck then calculate neck contribution
c
      else
         call neckcon (intstarti,desck,usea,useb)
         pi43 = 4.0d0 * third * pi 
         rminb = r - useb
         rminb3 = rminb**3
         rminb4 = rminb3 * rminb
         radminr = intstarti + desck + 2.0d0*rhow - r
         radminr3 = radminr**3
         radminr4 = radminr3 * radminr
         neckderi = 4.0d0 * pi43 * (mixsn*usea*rminb3*radminr4
     &                            - mixsn*usea*rminb4*radminr3)
      end if
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine getbounds  --  get the radii array indices  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "getbounds" returns the indices in the radii array table    
c     to use for interpolation of Aij and Bij values  
c
c     variables and parameters:
c
c     rho     value of the input atom radius
c     below   radius bin index for radius next smaller than rho
c     above   radius bin index for radius next larger than rho
c
c
      subroutine getbounds (rho,below,above)
      integer below,above
      integer numpoints
      real*8 rho
      real*8 calcindex
      real*8 minrad,maxrad
      real*8 space
c
c
      minrad = 0.80d0
      maxrad = 3.00d0
      space = 0.05d0
      numpoints = 45
      calcindex = 0.0d0
      below = 0
      above = 0
      calcindex = (rho-minrad) / space
      below = floor(calcindex) + 1
      above = below + 1
      if (above .ge. numpoints) then
         below = numpoints
         above = numpoints - 1
      else if (below .lt. 0) then
         below = 1
         above = 2
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine interp2d  --  interpolation of Aij/Bij values  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "interp2d" returns the Aij and Bij values interpolated from
c     benchmark tables derived from Poisson-Boltzmann calculations
c
c     variables and parameters:
c
c     x1      radius bin immediately smaller than descreened atom
c     x2      radius bin immediately larger than descreened atom
c     y1      radius bin immediately smaller than descreening atom
c     y2      radius bin immediately larger than descreening atom
c     x       descreened atom radius + descreening offset, if used
c     y       descreening atom radius
c     fx1y1   constant for interacting atoms with radii x1 and y1
c     fx2y1   constant for interacting atoms with radii x2 and y1
c     fx1y2   constant for interacting atoms with radii x1 and y2
c     fx2y2   constant for interacting atoms with radii x2 and y2
c     val     returned interpolated constant value
c
c
      subroutine interp2d (x1,x2,y1,y2,x,y,fx1y1,fx2y1,fx1y2,fx2y2,val)
      real*8 x,x1,x2
      real*8 y,y1,y2
      real*8 fx1y1,fx1y2
      real*8 fx2y1,fx2y2
      real*8 fxy1,fxy2
      real*8 val
c
c
c     perform 2D interpolation of neck correction constant
c
      fxy1 = (x2-x)/(x2-x1)*fx1y1 + (x-x1)/(x2-x1)*fx2y1
      fxy2 = (x2-x)/(x2-x1)*fx1y2 + (x-x1)/(x2-x1)*fx2y2
      val = (y2-y)/(y2-y1)*fxy1 + (y-y1)/(y2-y1)*fxy2
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine neckcon  --  generate the neck constants  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "neckcon" returns the neck correction values for a specific
c     pair of input radii
c
c     variables and parameters:
c
c     rhdsd    rho descreened, radius of descreened atom
c     rhdsg    rho descreening, radius of descreening atom
c     aloc     returned value of "aneck" parameter value
c     bloc     returned value of "bneck" parameter value
c
c
      subroutine neckcon (rhdsd,rhdsg,aloc,bloc)
      use solute
      integer lowi,highi
      integer lowj,highj
      real*8 rhdsd,rhdsg
      real*8 aloc,bloc
      real*8 rli,rhi
      real*8 rlj,rhj
      real*8 lla,hla
      real*8 lha,hha
      real*8 llb,hlb
      real*8 lhb,hhb
c
c
c     initialize some bounds and values
c
      lowi = 0
      lowj = 0
      highi = 0
      highj = 0
      aloc = 0.0d0
      bloc = 0.0d0
c
c     find neck correction values via the bin index array
c
      call getbounds (rhdsd,lowi,highi)
      call getbounds (rhdsg,lowj,highj)
      rli = rneck(lowi)
      rhi = rneck(highi)
      rlj = rneck(lowj)
      rhj = rneck(highj)
      lla = aneck(lowi,lowj)
      hla = aneck(highi,lowj)
      lha = aneck(lowi,highj)
      hha = aneck(highi,highj)
      llb = bneck(lowi,lowj)
      hlb = bneck(highi,lowj)
      lhb = bneck(lowi,highj)
      hhb = bneck(highi,highj)
      call interp2d (rli,rhi,rlj,rhj,rhdsd,rhdsg,lla,hla,lha,hha,aloc)
      call interp2d (rli,rhi,rlj,rhj,rhdsd,rhdsg,llb,hlb,lhb,hhb,bloc)
      if (aloc .lt. 0.0d0) then
         aloc = 0.0d0
      end if
      return
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2006 by Michael Schnieders & Jay W. Ponder  ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module neigh  --  pairwise neighbor list indices & storage  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     maxvlst     maximum size of van der Waals pair neighbor lists
c     maxelst     maximum size of electrostatic pair neighbor lists
c     maxulst     maximum size of dipole preconditioner pair lists
c     nvlst       number of sites in list for each vdw site
c     vlst        site numbers in neighbor list of each vdw site
c     nelst       number of sites in list for each electrostatic site
c     elst        site numbers in list of each electrostatic site
c     nulst       number of sites in list for each preconditioner site
c     ulst        site numbers in list of each preconditioner site
c     lbuffer     width of the neighbor list buffer region
c     pbuffer     width of the preconditioner list buffer region
c     lbuf2       square of half the neighbor list buffer width
c     pbuf2       square of half the preconditioner list buffer width
c     vbuf2       square of van der Waals cutoff plus the list buffer
c     vbufx       square of van der Waals cutoff plus 2X list buffer
c     dbuf2       square of dispersion cutoff plus the list buffer
c     dbufx       square of dispersion cutoff plus 2X list buffer
c     cbuf2       square of charge cutoff plus the list buffer
c     cbufx       square of charge cutoff plus 2X list buffer
c     mbuf2       square of multipole cutoff plus the list buffer
c     mbufx       square of multipole cutoff plus 2X list buffer
c     ubuf2       square of preconditioner cutoff plus the list buffer
c     ubufx       square of preconditioner cutoff plus 2X list buffer
c     xvold       x-coordinate at last vdw/dispersion list update
c     yvold       y-coordinate at last vdw/dispersion list update
c     zvold       z-coordinate at last vdw/dispersion list update
c     xeold       x-coordinate at last electrostatic list update
c     yeold       y-coordinate at last electrostatic list update
c     zeold       z-coordinate at last electrostatic list update
c     xuold       x-coordinate at last preconditioner list update
c     yuold       y-coordinate at last preconditioner list update
c     zuold       z-coordinate at last preconditioner list update
c     dovlst      logical flag to rebuild vdw neighbor list
c     dodlst      logical flag to rebuild dispersion neighbor list
c     doclst      logical flag to rebuild charge neighbor list
c     domlst      logical flag to rebuild multipole neighbor list
c     doulst      logical flag to rebuild preconditioner neighbor list
c
c
      module neigh
      implicit none
      integer maxvlst
      integer maxelst
      integer maxulst
      integer, allocatable :: nvlst(:)
      integer, allocatable :: vlst(:,:)
      integer, allocatable :: nelst(:)
      integer, allocatable :: elst(:,:)
      integer, allocatable :: nulst(:)
      integer, allocatable :: ulst(:,:)
      real*8 lbuffer,pbuffer
      real*8 lbuf2,pbuf2
      real*8 vbuf2,vbufx
      real*8 dbuf2,dbufx
      real*8 cbuf2,cbufx
      real*8 mbuf2,mbufx
      real*8 ubuf2,ubufx
      real*8, allocatable :: xvold(:)
      real*8, allocatable :: yvold(:)
      real*8, allocatable :: zvold(:)
      real*8, allocatable :: xeold(:)
      real*8, allocatable :: yeold(:)
      real*8, allocatable :: zeold(:)
      real*8, allocatable :: xuold(:)
      real*8, allocatable :: yuold(:)
      real*8, allocatable :: zuold(:)
      logical dovlst,dodlst
      logical doclst,domlst
      logical doulst
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  program newton  --  perform TNCG Cartesian optimization  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "newton" performs an energy minimization in Cartesian
c     coordinate space using a truncated Newton method
c
c
      program newton
      use atoms
      use bound
      use files
      use inform
      use iounit
      use usage
      implicit none
      integer i,j,k,next
      integer imin,nvar
      integer freeunit
      real*8 gnorm,grms,grdmin
      real*8 minimum,newton1
      real*8, allocatable :: xx(:)
      real*8, allocatable :: derivs(:,:)
      logical exist
      character*1 answer
      character*6 mode,method
      character*240 minfile
      character*240 record
      character*240 string
      external newton1
      external newton2
      external optsave
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     perform the setup functions needed for optimization
c
      call optinit
c
c     get the type of optimization algorithm to use
c
      mode = 'AUTO'
      call nextarg (answer,exist)
      if (.not. exist) then
         answer = 'A'
         write (iout,10)  answer
   10    format (/,' Choose Automatic, Newton, TNCG or DTNCG',
     &              ' Method [',a1,'] :  ',$)
         read (input,20)  record
   20    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'A')  mode = 'AUTO'
      if (answer .eq. 'N')  mode = 'NEWTON'
      if (answer .eq. 'T')  mode = 'TNCG'
      if (answer .eq. 'D')  mode = 'DTNCG'
c
c     get the type of linear equation preconditioning to use
c
      method = 'AUTO'
      call nextarg (answer,exist)
      if (.not. exist) then
         answer = 'A'
         write (iout,30)  answer
   30    format (/,' Precondition via Auto/None/Diag/Block/',
     &              'SSOR/ICCG [',a1,'] :  ',$)
         read (input,40)  record
   40    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'A')  method = 'AUTO'
      if (answer .eq. 'N')  method = 'NONE'
      if (answer .eq. 'D')  method = 'DIAG'
      if (answer .eq. 'B')  method = 'BLOCK'
      if (answer .eq. 'S')  method = 'SSOR'
      if (answer .eq. 'I')  method = 'ICCG'
c
c     get the termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=50,end=50)  grdmin
   50 continue
      if (grdmin .le. 0.0d0) then
         write (iout,60)
   60    format (/,' Enter RMS Gradient per Atom Criterion',
     &              ' [0.01] :  ',$)
         read (input,70)  grdmin
   70    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.01d0
c
c     write out a copy of coordinates for later update
c
      imin = freeunit ()
      minfile = filename(1:leng)//'.xyz'
      call version (minfile,'new')
      open (unit=imin,file=minfile,status='new')
      call prtxyz (imin)
      close (unit=imin)
      outfile = minfile
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(3*n))
      allocate (derivs(3,n))
c
c     convert atomic coordinates to optimization parameters
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         xx(nvar) = x(k)
         nvar = nvar + 1
         xx(nvar) = y(k)
         nvar = nvar + 1
         xx(nvar) = z(k)
      end do
c
c     make the call to the optimization routine
c
      call tncg (mode,method,nvar,xx,minimum,grdmin,
     &               newton1,newton2,optsave)
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         x(k) = xx(nvar)
         nvar = nvar + 1
         y(k) = xx(nvar)
         nvar = nvar + 1
         z(k) = xx(nvar)
      end do
c
c     compute the final function and RMS gradient values
c
      call gradient (minimum,derivs)
      gnorm = 0.0d0
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            gnorm = gnorm + derivs(j,k)**2
         end do
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(nvar/3))
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      deallocate (derivs)
c
c     write out the final function and gradient values
c
      if (digits .ge. 8) then
         if (grms .gt. 1.0d-8) then
            write (iout,80)  minimum,grms,gnorm
   80       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,f20.8,
     &              /,' Final Gradient Norm :',3x,f20.8)
         else
            write (iout,90)  minimum,grms,gnorm
   90       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,d20.8,
     &              /,' Final Gradient Norm :',3x,d20.8)
         end if
      else if (digits .ge. 6) then
         if (grms .gt. 1.0d-6) then
            write (iout,100)  minimum,grms,gnorm
  100       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,f18.6,
     &              /,' Final Gradient Norm :',3x,f18.6)
         else
            write (iout,110)  minimum,grms,gnorm
  110       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,d18.6,
     &              /,' Final Gradient Norm :',3x,d18.6)
         end if
      else
         if (grms .gt. 1.0d-4) then
            write (iout,120)  minimum,grms,gnorm
  120       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,f16.4,
     &              /,' Final Gradient Norm :',3x,f16.4)
         else
            write (iout,130)  minimum,grms,gnorm
  130       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,d16.4,
     &              /,' Final Gradient Norm :',3x,d16.4)
         end if
      end if
c
c     move stray molecules into periodic box if desired
c
      if (use_wrap)  call bounds
c
c     write the final coordinates into a file
c
      imin = freeunit ()
      open (unit=imin,file=minfile,status='old')
      rewind (unit=imin)
      call prtxyz (imin)
      close (unit=imin)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  function newton1  --  energy and gradient for newton  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "newton1" is a service routine that computes the energy
c     and gradient for truncated Newton optimization in Cartesian
c     coordinate space
c
c
      function newton1 (xx,g)
      use atoms
      use usage
      implicit none
      integer i,k,nvar
      real*8 newton1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         x(k) = xx(nvar)
         nvar = nvar + 1
         y(k) = xx(nvar)
         nvar = nvar + 1
         z(k) = xx(nvar)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the energy and gradient
c
      call gradient (e,derivs)
      newton1 = e
c
c     convert gradient components to optimization parameters
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         g(nvar) = derivs(1,k)
         nvar = nvar + 1
         g(nvar) = derivs(2,k)
         nvar = nvar + 1
         g(nvar) = derivs(3,k)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     #########################################################
c     ##                                                     ##
c     ##  subroutine newton2  --  Hessian values for newton  ##
c     ##                                                     ##
c     #########################################################
c
c
c     "newton2" is a service routine that computes the sparse
c     matrix Hessian elements for truncated Newton optimization
c     in Cartesian coordinate space
c
c
      subroutine newton2 (mode,xx,h,hinit,hstop,hindex,hdiag)
      use atoms
      use usage
      implicit none
      integer i,j,k,nvar
      integer hinit(*)
      integer hstop(*)
      integer hindex(*)
      integer, allocatable :: hvar(:)
      integer, allocatable :: huse(:)
      real*8 xx(*)
      real*8 hdiag(*)
      real*8 h(*)
      character*4 mode
c
c
c     convert optimization parameters to atomic coordinates
c
      if (mode .eq. 'NONE')  return
      nvar = 0
      do i = 1, n
         k = iuse(i)
         nvar = nvar + 1
         x(k) = xx(nvar)
         nvar = nvar + 1
         y(k) = xx(nvar)
         nvar = nvar + 1
         z(k) = xx(nvar)
      end do
c
c     compute and store the Hessian elements
c
      call hessian (h,hinit,hstop,hindex,hdiag)
c
c     perform dynamic allocation of some local arrays
c
      allocate (hvar(nvar))
      allocate (huse(3*n))
c
c     transform the sparse Hessian to use only active atoms
c
      nvar = 0
      if (nuse .ne. n) then
         do i = 1, n
            k = 3 * (i-1)
            if (use(i)) then
               do j = 1, 3
                  nvar = nvar + 1
                  hvar(nvar) = j + k
                  huse(j+k) = nvar
               end do
            else
               do j = 1, 3
                  huse(j+k) = 0
               end do
            end if
         end do
         do i = 1, nvar
            k = hvar(i)
            hinit(i) = hinit(k)
            hstop(i) = hstop(k)
            hdiag(i) = hdiag(k)
            do j = hinit(i), hstop(i)
               hindex(j) = huse(hindex(j))
            end do
         end do
      end if
c
c     convert atomic coordinates to optimization parameters
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         xx(nvar) = x(k)
         nvar = nvar + 1
         xx(nvar) = y(k)
         nvar = nvar + 1
         xx(nvar) = z(k)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (hvar)
      deallocate (huse)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program newtrot  --  perform TNCG torsional optimization  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "newtrot" performs an energy minimization in torsional angle
c     space using a truncated Newton conjugate gradient method
c
c
      program newtrot
      use files
      use inform
      use iounit
      use math
      use omega
      use zcoord
      implicit none
      integer i,imin,next
      integer freeunit
      real*8 grdmin,gnorm,grms
      real*8 minimum,newtrot1
      real*8, allocatable :: xx(:)
      real*8, allocatable :: derivs(:)
      logical exist
      character*1 answer
      character*6 mode,method
      character*240 minfile
      character*240 record
      character*240 string
      external newtrot1
      external newtrot2
      external optsave
c
c
c     set up the molecular mechanics calculation
c
      call initial
      call getint
      call mechanic
c
c     perform the setup functions needed for optimization
c
      call optinit
      call initrot
c
c     get the type of optimization algorithm to use
c
      mode = 'AUTO'
      call nextarg (answer,exist)
      if (.not. exist) then
         answer = 'A'
         write (iout,10)  answer
   10    format (/,' Choose Automatic, Newton, TNCG or DTNCG',
     &              ' Method [',a1,'] :  ',$)
         read (input,20)  record
   20    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'A')  mode = 'AUTO'
      if (answer .eq. 'N')  mode = 'NEWTON'
      if (answer .eq. 'T')  mode = 'TNCG'
      if (answer .eq. 'D')  mode = 'DTNCG'
c
c     get the type of linear equation preconditioning to use
c
      method = 'DIAG'
      call nextarg (answer,exist)
      if (.not. exist) then
         answer = 'D'
         write (iout,30)  answer
   30    format (/,' Precondition via Auto/None/Diag/',
     &              'SSOR/ICCG [',a1,'] :  ',$)
         read (input,40)  record
   40    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'A')  method = 'AUTO'
      if (answer .eq. 'N')  method = 'NONE'
      if (answer .eq. 'D')  method = 'DIAG'
      if (answer .eq. 'S')  method = 'SSOR'
      if (answer .eq. 'I')  method = 'ICCG'
c
c     get termination criterion as RMS torsional gradient
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=50,end=50)  grdmin
   50 continue
      if (grdmin .le. 0.0d0) then
         write (iout,60)
   60    format (/,' Enter RMS Gradient per Torsion Criterion',
     &              ' [0.01] :  ',$)
         read (input,70)  grdmin
   70    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.01d0
c
c     write out a copy of coordinates for later update
c
      imin = freeunit ()
      minfile = filename(1:leng)//'.int'
      call version (minfile,'new')
      open (unit=imin,file=minfile,status='new')
      call prtint (imin)
      close (unit=imin)
      outfile = minfile
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nomega))
c
c     convert dihedral angles to optimization parameters
c
      do i = 1, nomega
         xx(i) = dihed(i)
      end do
c
c     make the call to the optimization routine
c
      call tncg (mode,method,nomega,xx,minimum,grdmin,
     &                newtrot1,newtrot2,optsave)
c
c     convert optimization parameters to dihedral angles
c
      do i = 1, nomega
         dihed(i) = xx(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(nomega))
c
c     compute the final function and RMS gradient values
c
      call gradrot (minimum,derivs)
      gnorm = 0.0d0
      do i = 1, nomega
         gnorm = gnorm + derivs(i)**2
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(nomega))
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
c
c     write out the final function and gradient values
c
      if (digits .ge. 8) then
         if (grms .gt. 1.0d-8) then
            write (iout,80)  minimum,grms,gnorm
   80       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,f20.8,
     &              /,' Final Gradient Norm :',3x,f20.8)
         else
            write (iout,90)  minimum,grms,gnorm
   90       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,d20.8,
     &              /,' Final Gradient Norm :',3x,d20.8)
         end if
      else if (digits .ge. 6) then
         if (grms .gt. 1.0d-6) then
            write (iout,100)  minimum,grms,gnorm
  100       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,f18.6,
     &              /,' Final Gradient Norm :',3x,f18.6)
         else
            write (iout,110)  minimum,grms,gnorm
  110       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,d18.6,
     &              /,' Final Gradient Norm :',3x,d18.6)
         end if
      else
         if (grms .gt. 1.0d-4) then
            write (iout,120)  minimum,grms,gnorm
  120       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,f16.4,
     &              /,' Final Gradient Norm :',3x,f16.4)
         else
            write (iout,130)  minimum,grms,gnorm
  130       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,d16.4,
     &              /,' Final Gradient Norm :',3x,d16.4)
         end if
      end if
c
c     write the final coordinates into a file
c
      imin = freeunit ()
      open (unit=imin,file=minfile,status='old')
      rewind (unit=imin)
      call prtint (imin)
      close (unit=imin)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function newtrot1  --  energy and gradient for newtrot  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "newtrot1" is a service routine that computes the energy
c     and gradient for truncated Newton conjugate gradient
c     optimization in torsional angle space
c
c
      function newtrot1 (xx,g)
      use math
      use omega
      use zcoord
      implicit none
      integer i
      real*8 newtrot1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:)
c
c
c     translate optimization variables into dihedrals
c
      do i = 1, nomega
         dihed(i) = xx(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(nomega))
c
c     get coordinates, then compute energy and gradient
c
      call makexyz
      call gradrot (e,derivs)
      newtrot1 = e
c
c     store torsional gradient as optimization gradient
c
      do i = 1, nomega
         g(i) = derivs(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine newtrot2  --  Hessian values for newtrot  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "newtrot2" is a service routine that computes the sparse
c     matrix Hessian elements for truncated Newton optimization
c     in torsional angle space
c
c
      subroutine newtrot2 (mode,xx,h,hinit,hstop,hindex,hdiag)
      use hescut
      use math
      use omega
      use zcoord
      implicit none
      integer i,j,ihess
      integer hinit(*)
      integer hstop(*)
      integer hindex(*)
      real*8 xx(*)
      real*8 hdiag(*)
      real*8 h(*)
      real*8, allocatable :: hrot(:,:)
      character*4 mode
c
c
c     translate optimization parameters and compute
c     Cartesian coordinates from internal coordinates
c
      if (mode .eq. 'NONE')  return
      do i = 1, nomega
         dihed(i) = xx(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (hrot(nomega,nomega))
c
c     compute the desired portion of the Hessian
c
      call makexyz
      call hessrot (mode,hrot)
c
c     store the large elements in sparse matrix format
c
      if (mode .eq. 'FULL') then
         ihess = 0
         do i = 1, nomega
            hdiag(i) = hrot(i,i)
            hinit(i) = ihess + 1
            do j = i+1, nomega
               if (abs(hrot(j,i)) .ge. hesscut) then
                  ihess = ihess + 1
                  hindex(ihess) = j
                  h(ihess) = hrot(j,i)
               end if
            end do
            hstop(i) = ihess
         end do
c
c     store only the Hessian matrix diagonal
c
      else if (mode .eq. 'DIAG') then
         do i = 1, nomega
            hdiag(i) = hrot(i,i)
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (hrot)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine nextarg  --  find next command line argument  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "nextarg" finds the next unused command line argument
c     and returns it in the input character string
c
c
      subroutine nextarg (string,exist)
      use argue
      implicit none
      integer i,length
      logical exist
      character*(*) string
c
c
c     initialize the command argument as a blank string
c
      string = '          '
      exist = .false.
c
c     get the next command line argument and mark it as used
c
      if (narg .ne. 0) then
         length = min(len(string),len(arg(maxarg)))
         do i = 1, narg
            if (listarg(i)) then
               listarg(i) = .false.
               string = arg(i)(1:length)
               exist = .true.
               goto 10
            end if
         end do
   10    continue
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  function nexttext  --  find next non-blank character  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "nexttext" finds and returns the location of the first
c     non-blank character within an input text string; zero
c     is returned if no such character is found
c
c
      function nexttext (string)
      implicit none
      integer i,size
      integer len,nexttext
      character*(*) string
c
c
c     move forward through the string, one character
c     at a time, looking for first non-blank character
c
      nexttext = 0
      size = len(string)
      do i = 1, size
         if (string(i:i) .gt. ' ') then
            nexttext = i
            goto 10
         end if
      end do
   10 continue
      return
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2006 by Michael Schnieders & Jay W. Ponder  ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module nonpol  --  nonpolar cavity & dispersion parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     epso      water oxygen eps for implicit dispersion term
c     epsh      water hydrogen eps for implicit dispersion term
c     rmino     water oxygen Rmin for implicit dispersion term
c     rminh     water hydrogen Rmin for implicit dispersion term
c     awater    water number density at standard temp & pressure
c     slevy     enthalpy-to-free energy scale factor for dispersion
c     shctd     HCT overlap scale factor for the dispersion integral
c     dspoff    radius offset for the start of dispersion integral
c
c     cavprb    probe radius for use in computing cavitation energy
c     solvprs   limiting microscopic solvent pressure value
c     surften   limiting macroscopic surface tension value
c     spcut     starting radius for solvent pressure tapering
c     spoff     cutoff radius for solvent pressure tapering
c     stcut     starting radius for surface tension tapering
c     stoff     cutoff radius for surface tension tapering
c     radcav    atomic radius of each atom for cavitation energy
c     raddsp    atomic radius of each atom for dispersion energy
c     epsdsp    vdw well depth of each atom for dispersion energy
c     cdsp      maximum dispersion energy for each atom
c
c
      module nonpol
      implicit none
      real*8 epso,epsh
      real*8 rmino,rminh
      real*8 awater,slevy
      real*8 shctd,dspoff
      parameter (epso=0.1100d0)
      parameter (epsh=0.0135d0)
      parameter (rmino=1.7025d0)
      parameter (rminh=1.3275d0)
      parameter (awater=0.033428d0)
      parameter (slevy=1.0d0)
      parameter (shctd=0.75d0)
      parameter (dspoff=1.056d0)
      real*8 cavprb
      real*8 solvprs
      real*8 surften
      real*8 spcut,spoff
      real*8 stcut,stoff
      real*8, allocatable :: radcav(:)
      real*8, allocatable :: raddsp(:)
      real*8, allocatable :: epsdsp(:)
      real*8, allocatable :: cdsp(:)
      save
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2011 by Teresa Head-Gordon & Jay W. Ponder  ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine nose  --  Nose-Hoover NPT molecular dynamics  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "nose" performs a molecular dynamics time step via the
c     Nose-Hoover extended system isothermal-isobaric algorithm
c
c     literature reference:
c
c     G. J. Martyna, M. E. Tuckerman, D. J. Tobias and M. L. Klein,
c     "Explicit Reversible Integrators for Extended Systems Dynamics",
c     Molecular Physics, 87, 1117-1157 (1996)
c
c     original version written by Teresa Head-Gordon, University of
c     California, Berkeley, November 2011
c
c
      subroutine nose (istep,dt)
      use atomid
      use atoms
      use bath
      use boxes
      use freeze
      use iounit
      use moldyn
      use units
      use usage
      use virial
      implicit none
      integer i,j,k
      integer istep
      real*8 dt,dt_2
      real*8 epot,etot
      real*8 eksum,temp
      real*8 pres,press
      real*8 poly,factor
      real*8 term,expterm
      real*8 term2,eterm2
      real*8 e2,e4,e6,e8
      real*8 ekin(3,3)
      real*8 stress(3,3)
      real*8, allocatable :: derivs(:,:)
      save press
c
c
c     set some time values for the dynamics integration
c
      dt_2 = 0.5d0 * dt
      if (istep .eq. 1)  press = atmsph
c
c     update thermostat and barostat values, scale atomic velocities
c
      call hoover (dt,press)
c
c     get half-step velocities via Verlet recursion
c
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            v(j,k) = v(j,k) + a(j,k)*dt_2
         end do
      end do
c
c     update atomic positions via coupling to barostat
c
      term = vbar * dt_2
      term2 = term * term
      expterm = exp(term)
      eterm2 = expterm * expterm
      e2 = 1.0d0 / 6.0d0
      e4 = e2 / 20.0d0
      e6 = e4 / 42.0d0
      e8 = e6 / 72.0d0
      poly = 1.0d0 + term2*(e2+term2*(e4+term2*(e6+term2*e8)))
      poly = expterm * poly * dt
      do i = 1, nuse
         k = iuse(i)
         x(k) = x(k)*eterm2 + v(1,k)*poly
         y(k) = y(k)*eterm2 + v(2,k)*poly
         z(k) = z(k)*eterm2 + v(3,k)*poly
      end do
c
c     constraints with Nose-Hoover NPT requires ROLL algorithm
c
      if (use_freeze) then
         write (iout,10)
   10    format (/,' NOSE  --  Nose-Hoover NPT MD Requires the',
     &              ' ROLL Algorithm')
         call fatal
      end if
c
c     update the periodic box size and total volume
c
      xbox = xbox * eterm2
      ybox = ybox * eterm2
      zbox = zbox * eterm2
      call lattice
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     get the potential energy and atomic forces
c
      call gradient (epot,derivs)
c
c     use Newton's second law to get the next accelerations;
c     find the full-step velocities using the Verlet recursion
c
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            a(j,k) = -ekcal * derivs(j,k) / mass(k)
            v(j,k) = v(j,k) + a(j,k)*dt_2
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
c
c     constraints under NH-NPT require the ROLL algorithm
c
      if (use_freeze)  call fatal
c
c     update thermostat and barostat values, scale atomic velocities
c
      call hoover (dt,press)
c
c     set isotropic pressure to the average of tensor diagonal
c
      factor = prescon / volbox
      do i = 1, 3
         do j = 1, 3
            stress(j,i) = factor * (-vir(j,i))
         end do
      end do
      press = (stress(1,1)+stress(2,2)+stress(3,3)) / 3.0d0
c
c     accumulate the kinetic energy and its outer product
c
      call kinetic (eksum,ekin,temp)
c
c     calculate the stress tensor for anisotropic systems
c
      do i = 1, 3
         do j = 1, 3
            stress(j,i) = factor * (2.0d0*ekin(j,i)-vir(j,i))
         end do
      end do
      pres = (stress(1,1)+stress(2,2)+stress(3,3)) / 3.0d0
c
c     total energy is sum of kinetic and potential energies
c
      etot = epot + eksum
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,eksum,temp,pres)
      call mdsave (istep,dt,epot,eksum)
      call mdrest (istep)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine hoover  --  Nose-Hoover thermostat/barostat  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "hoover" applies a combined thermostat and barostat via a
c     Nose-Hoover chain algorithm
c
c
      subroutine hoover (dt,press)
      use atoms
      use bath
      use boxes
      use mdstuf
      use moldyn
      use units
      use usage
      implicit none
      integer i,j,k
      integer nc,ns
      real*8 dt,dtc,dts
      real*8 dt2,dt4,dt8
      real*8 ekt,eksum,temp
      real*8 df,odnf,gn1kt
      real*8 press,dpress
      real*8 expterm,scale
      real*8 w(3),ekin(3,3)
c
c
c     find kinetic energy and set an initial scale factor
c
      call kinetic (eksum,ekin,temp)
      ekt = gasconst * kelvin
      nc = 5
      ns = 3
      dtc = dt / dble(nc)
      w(1) = 1.0d0 / (2.0d0-2.0d0**(1.0d0/3.0d0))
      w(2) = 1.0d0 - 2.0d0*w(1)
      w(3) = w(1)
      df = dble(nfree)
      odnf = 1.0d0 + 3.0d0/df
      gn1kt = (1.0d0+df) * ekt
      dpress = (press-atmsph) / prescon
      scale = 1.0d0
c
c     use multiple time steps to apply thermostat and barostat
c
      do k = 1, nc
         do j = 1, ns
            dts = w(j) * dtc
            dt2 = 0.5d0 * dts
            dt4 = 0.25d0 * dts
            dt8 = 0.125d0 * dts
c
c     update thermostat and barostat velocities and forces
c
            gnh(4) = (qnh(3)*vnh(3)*vnh(3)-ekt) / qnh(4)
            vnh(4) = vnh(4) + gnh(4)*dt4
            gnh(3) = (qnh(2)*vnh(2)*vnh(2)-ekt) / qnh(3)
            expterm = exp(-vnh(4)*dt8)
            vnh(3) = expterm * (vnh(3)*expterm+gnh(3)*dt4)
            gnh(2) = (qnh(1)*vnh(1)*vnh(1)-ekt) / qnh(2)
            expterm = exp(-vnh(3)*dt8)
            vnh(2) = expterm * (vnh(2)*expterm+gnh(2)*dt4)
            gnh(1) = (2.0d0*eksum+qbar*vbar*vbar-gn1kt) / qnh(1)
            expterm = exp(-vnh(2)*dt8)
            vnh(1) = expterm * (vnh(1)*expterm+gnh(1)*dt4)
            gbar = (2.0d0*eksum*odnf+3.0d0*volbox*dpress) / qbar
            expterm = exp(-vnh(1)*dt8)
            vbar = expterm * (vbar*expterm+gbar*dt4)
c
c     find velocity scale factor and update kinetic energy
c
            expterm = exp(-(vnh(1)+vbar*odnf)*dt2)
            scale = scale * expterm
            eksum = eksum * expterm * expterm
c
c     update barostat and thermostat velocities and forces
c
            gbar = (2.0d0*eksum*odnf+3.0d0*volbox*dpress) / qbar
            expterm = exp(-vnh(1)*dt8)
            vbar = expterm * (vbar*expterm+gbar*dt4)
            gnh(1) = (2.0d0*eksum+qbar*vbar*vbar-gn1kt) / qnh(1)
            expterm = exp(-vnh(2)*dt8)
            vnh(1) = expterm * (vnh(1)*expterm+gnh(1)*dt4)
            gnh(2) = (qnh(1)*vnh(1)*vnh(1)-ekt) / qnh(2)
            expterm = exp(-vnh(3)*dt8)
            vnh(2) = expterm * (vnh(2)*expterm+gnh(2)*dt4)
            gnh(3) = (qnh(2)*vnh(2)*vnh(2)-ekt) / qnh(3)
            expterm = exp(-vnh(4)*dt8)
            vnh(3) = expterm * (vnh(3)*expterm+gnh(3)*dt4)
            gnh(4) = (qnh(3)*vnh(3)*vnh(3)-ekt) / qnh(4)
            vnh(4) = vnh(4) + gnh(4)*dt4
         end do
      end do
c
c     use scale factor to update the atomic velocities
c
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            v(j,k) = scale * v(j,k)
         end do
      end do
      return
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2006 by Chuanjie Wu and Jay William Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##   subroutine nspline  --  nonperiodic natural cubic spline   ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "nspline" computes coefficients for an nonperiodic cubic spline
c     with natural boundary conditions where the first and last second
c     derivatives are already known
c
c
      subroutine nspline (n,x0,y0,s1,s2,h,g,dy,dla,dmu)
      implicit none
      integer i,n
      real*8 t,y21,y2n
      real*8 x0(0:*)
      real*8 y0(0:*)
      real*8 s1(0:*)
      real*8 s2(0:*)
      real*8 h(0:*)
      real*8 g(0:*)
      real*8 dy(0:*)
      real*8 dla(0:*)
      real*8 dmu(0:*)
c
c
c     set first and last second deriviatives to zero
c
      y21 = 0.0d0
      y2n = 0.0d0
c
c     find the intervals to be used
c
      do i = 0, n-1
         h(i) = x0(i+1) - x0(i)
         dy(i) = (y0(i+1)-y0(i)) / h(i)
      end do
c
c     calculate the spline coeffcients
c
      do i = 1, n-1
         dla(i) = h(i) / (h(i)+h(i-1))
         dmu(i) = 1.0d0 - dla(i)
         g(i) = 3.0d0 * (dla(i)*dy(i-1)+dmu(i)*dy(i))
      end do
c
c     set the initial value via natural boundary condition
c
      dla(n) = 1.0d0
      dla(0) = 0.0d0
      dmu(n) = 0.0d0
      dmu(0) = 1.0d0
      g(0) = 3.0d0*dy(0) - 0.5d0*h(0)*y21
      g(n) = 3.0d0*dy(n-1) + 0.5d0*h(n-1)*y2n
c
c     solve the triagonal system of linear equations
c
      dmu(0) = 0.5d0 * dmu(0)
      g(0) = 0.5d0 * g(0)
      do i = 1, n
         t = 2.0d0 - dmu(i-1)*dla(i)
         dmu(i) = dmu(i) / t
         g(i) = (g(i)-g(i-1)*dla(i)) / t
      end do
      do i = n-1, 0, -1
         g(i) = g(i) - dmu(i)*g(i+1)
      end do
c
c     get the first derivative at each grid point
c
      do i = 0, n
         s1(i) = g(i)
      end do
c
c     get the second derivative at each grid point
c
      s2(0) = y21
      s2(n) = y2n
      do i = 1, n-1
         s2(i) = 6.0d0*(y0(i+1)-y0(i))/(h(i)*h(i))
     &              - 4.0d0*s1(i)/h(i) - 2.0d0*s1(i+1)/h(i)
      end do
      return
      end
c
c
c     #############################################################
c     ##                  COPYRIGHT (C) 1999 by                  ##
c     ##  Marina A. Vorobieva, Nina N. Sokolova & Jay W. Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  program nucleic  --  build a nucleic acid from sequence  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "nucleic" builds the internal and Cartesian coordinates
c     of a polynucleotide from nucleic acid sequence and torsional
c     angle values for the nucleic acid backbone and side chains
c
c
      program nucleic
      use atoms
      use couple
      use files
      use iounit
      use nucleo
      use titles
      implicit none
      integer i,natom,mode
      integer izmt,ixyz,iseq
      integer freeunit
      integer trimtext
      logical exist
      character*240 seqfile
      character*240 intfile
      character*240 xyzfile
c
c
c     get the name to use for the output structure files
c
      call initial
      call nextarg (filename,exist)
      if (.not. exist) then
         write (iout,10)
   10    format (/,' Enter Name to be Used for Output Files :  ',$)
         read (input,20)  filename
   20    format (a240)
      end if
      call basefile (filename)
c
c     get the title line for the output files
c
      write (iout,30)
   30 format (/,' Enter Title :  ',$)
      read (input,40)  title
   40 format (a240)
      ltitle = trimtext (title)
c
c     read the keyfile and force field parameter file
c
      call getkey
      call field
c
c     get the sequence and build Z-matrix for the structure
c
      call getseqn
      call nucchain
c
c     find connectivities and generate Cartesian coordinates
c
      call connect
      call molecule
      call makexyz
c
c     perform the alignment of the strands of a double helix
c
      if (dblhlx) then
         call watson
         call inertia (2)
      end if
c
c     remove dummy atoms and set undefined atoms to type zero
c
      natom = n
      do i = natom, 1, -1
         if (type(i) .eq. 0)  call delete (i)
         if (type(i) .lt. 0)  type(i) = 0
      end do
c
c     convert to internal and Cartesian coordinates
c
      mode = 0
      call makeint (mode)
      call makexyz
c
c     write out a nucleic acid sequence file
c
      iseq = freeunit ()
      seqfile = filename(1:leng)//'.seq'
      call version (seqfile,'new')
      open (unit=iseq,file=seqfile,status='new')
      call prtseq (iseq)
      close (unit=iseq)
c
c     write out an internal coordinates file
c
      izmt = freeunit ()
      intfile = filename(1:leng)//'.int'
      call version (intfile,'new')
      open (unit=izmt,file=intfile,status='new')
      call prtint (izmt)
      close (unit=izmt)
c
c     write out a Cartesian coordinates file
c
      ixyz = freeunit ()
      xyzfile = filename(1:leng)//'.xyz'
      call version (xyzfile,'new')
      open (unit=ixyz,file=xyzfile,status='new')
      call prtxyz (ixyz)
      close (unit=ixyz)
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine getseqn  --  nucleic acid sequence and angles  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "getseqn" asks the user for the nucleotide sequence and
c     torsional angle values needed to define a nucleic acid
c
c
      subroutine getseqn
      use iounit
      use nucleo
      use resdue
      use sequen
      implicit none
      integer i,j,k,next
      integer start,stop
      integer length
      logical done
      logical, allocatable :: purine(:)
      character*1 answer
      character*1 ucase(26)
      character*3 name,resname
      character*240 record
      character*240 string
      data ucase  / 'A','B','C','D','E','F','G','H','I','J','K','L',
     &              'M','N','O','P','Q','R','S','T','U','V','W','X',
     &              'Y','Z' /
c
c
c     choose to generate either an A-, B- or Z-form helix
c
      write (iout,10)
   10 format (/,' Enter A-, B- or Z-Form Helix for the Structure',
     &           ' [B] :  ',$)
      read (input,20)  record
   20 format (a240)
      call upcase (record)
      next = 1
      call getword (record,answer,next)
      hlxform = 'B'
      if (answer .eq. 'A')  hlxform = 'A'
      if (answer .eq. 'Z')  hlxform = 'Z'
c
c     provide a header to explain the method of sequence input
c
      write (iout,30)
   30 format (/,' Enter One Nucleotide per Line, 5'' to 3'': ',
     &           ' Give PDB Residue Code, and',
     &        /,' optionally, six Backbone Torsions (6F) and',
     &           ' the Glycosidic Torsion (1F)',
     &        //,' Use Residue=MOL to Start a New Strand,',
     &           ' and Use <Enter> to End Input')
c
c     initially, assume that only a single strand is present
c
      nchain = 1
      ichain(1,1) = 1
      chnnam(1) = ' '
c
c     get the nucleotide sequence data and dihedral angle values
c
      i = 0
      done = .false.
      do while (.not. done)
         i = i + 1
         do j = 1, 6
            bkbone(j,i) = 0.0d0
         end do
         glyco(i) = 0.0d0
         pucker(i) = 0
         write (iout,40)  i
   40    format (/,' Enter Residue',i4,' :  ',$)
         read (input,50)  record
   50    format (a240)
         call upcase (record)
         next = 1
         call gettext (record,name,next)
         call justify (name)
         length = 3
c        length = trimtext (name)
         string = record(next:240)
         read (string,*,err=60,end=60)  (bkbone(j,i),j=1,6),glyco(i)
   60    continue
c
c     process and store the current nucleotide type
c
         if (name .eq. 'MOL') then
            i = i - 1
            ichain(2,nchain) = i
            nchain = nchain + 1
            ichain(1,nchain) = i + 1
         else
            if (name .eq. '   ') then
               done = .true.
               nseq = i - 1
               ichain(2,nchain) = nseq
            else
               seq(i) = nuclz(maxnuc)
               seqtyp(i) = 0
               if (length .eq. 1) then
                  do j = 1, maxnuc
                     if (name(1:1) .eq. nuclz1(j)) then
                        seq(i) = nuclz(j)
                        seqtyp(i) = j
                     end if
                  end do
               else
                  do j = 1, maxnuc
                     if (name .eq. nuclz(j)) then
                        seq(i) = nuclz(j)
                        seqtyp(i) = j
                     end if
                  end do
               end if
               if (seqtyp(i) .eq. 0) then
                  i = i - 1
                  write (iout,70)  name
   70             format (/,' GETSEQN  --  Nucleotide Type ',a3,
     &                       ' is Not Supported')
               end if
            end if
         end if
      end do
c
c     offer the option to construct an idealized double helix
c
      dblhlx = .false.
      if (nchain .eq. 1) then
         write (iout,80)
   80    format (/,' Build a Double Helix using Complimentary Bases',
     &              ' [N] :  ',$)
         read (input,90)  record
   90    format (a240)
         next = 1
         call gettext (record,answer,next)
         call upcase (answer)
         if (answer .eq. 'Y')  dblhlx = .true.
      else if (nchain .eq. 2) then
         write (iout,100)
  100    format (/,' Combine the Two Single Strands into Double Helix',
     &              ' [Y] :  ',$)
         read (input,110)  record
  110    format (a240)
         next = 1
         call gettext (record,answer,next)
         call upcase (answer)
         if (answer .ne. 'N')  dblhlx = .true.
      end if
c
c     build a second strand as the reverse-complement sequence
c
      if (nchain.eq.1 .and. dblhlx) then
         start = 1
         stop = nseq
         resname = nuclz(seqtyp(1))
         if (resname.eq.' MP' .or. resname.eq.' DP'
     &          .or. resname.eq.' TP') then
            k = nseq + 1
            seq(k) = seq(1)
            seqtyp(k) = seqtyp(1)
            start = 2
         end if
         resname = nuclz(seqtyp(nseq))
         if (resname.eq.' MP' .or. resname.eq.' DP'
     &          .or. resname.eq.' TP') then
            k = 2 * nseq
            seq(k) = seq(nseq)
            seqtyp(k) = seqtyp(nseq)
            stop = nseq - 1
         end if
         do i = start, stop
            resname = nuclz(seqtyp(i))
            if (resname .eq. '  A') then
               resname = '  U'
            else if (resname .eq. '  G') then
               resname = '  C'
            else if (resname .eq. '  C') then
               resname = '  G'
            else if (resname .eq. '  U') then
               resname = '  A'
            else if (resname .eq. ' DA') then
               resname = ' DT'
            else if (resname .eq. ' DG') then
               resname = ' DC'
            else if (resname .eq. ' DC') then
               resname = ' DG'
            else if (resname .eq. ' DT') then
               resname = ' DA'
            end if
            k = nseq + stop + start - i
            do j = 1, maxnuc
               if (resname .eq. nuclz(j)) then
                  seq(k) = nuclz(j)
                  seqtyp(k) = j
               end if
            end do
         end do
         do i = 1, nseq
            k = nseq + i
            do j = 1, 6
               bkbone(j,k) = bkbone(j,i)
            end do
            glyco(k) = glyco(i)
            pucker(k) = pucker(i)
         end do
         nchain = 2
         nseq = 2 * nseq
         ichain(1,nchain) = nseq/2 + 1
         ichain(2,nchain) = nseq
      end if
c
c     set chain identifiers if multiple chains are present
c
      if (nchain .gt. 1) then
         do i = 1, nchain
            chnnam(i) = ucase(i)
         end do
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (purine(nseq))
c
c     set the nucleic acid base and sugar structural type
c
      do i = 1, nseq
         resname = nuclz(seqtyp(i))
         purine(i) = .false.
         if (resname .eq. '  A')  purine(i) = .true.
         if (resname .eq. '  G')  purine(i) = .true.
         if (resname .eq. ' DA')  purine(i) = .true.
         if (resname .eq. ' DG')  purine(i) = .true.
         deoxy(i) = .false.
         if (resname .eq. ' DA')  deoxy(i) = .true.
         if (resname .eq. ' DG')  deoxy(i) = .true.
         if (resname .eq. ' DC')  deoxy(i) = .true.
         if (resname .eq. ' DT')  deoxy(i) = .true.
      end do
c
c     set the backbone and glycosidic torsions and sugar pucker
c
      do i = 1, nseq
         done = .false.
         do j = 1, 6
            if (bkbone(j,i) .ne. 0.0d0)  done = .true.
         end do
         if (glyco(i) .ne. 0.0d0)  done = .true.
         if (pucker(i) .ne. 0)  done = .true.
         if (.not. done) then
            if (hlxform .eq. 'A') then
               bkbone(1,i) = -52.0d0
               bkbone(2,i) = 175.0d0
               bkbone(3,i) = 42.0d0
               bkbone(4,i) = 79.0d0
               bkbone(5,i) = -148.0d0
               bkbone(6,i) = -75.0d0
               glyco(i) = -157.0d0
               pucker(i) = 3
            else if (hlxform .eq. 'B') then
               bkbone(1,i) = -30.0d0
               bkbone(2,i) = 136.0d0
               bkbone(3,i) = 31.0d0
               bkbone(4,i) = 143.0d0
               bkbone(5,i) = -141.0d0
               bkbone(6,i) = -161.0d0
               glyco(i) = -98.0d0
               pucker(i) = 2
            else if (hlxform .eq. 'Z') then
               if (purine(i)) then
                  bkbone(1,i) = 47.0d0
                  bkbone(2,i) = 179.0d0
                  bkbone(3,i) = -169.0d0
                  bkbone(4,i) = 99.0d0
                  bkbone(5,i) = -104.0d0
                  bkbone(6,i) = -69.0d0
                  glyco(i) = 68.0d0
                  pucker(i) = 3
               else
                  bkbone(1,i) = -137.0d0
                  bkbone(2,i) = -139.0d0
                  bkbone(3,i) = 56.0d0
                  bkbone(4,i) = 138.0d0
                  bkbone(5,i) = -95.0d0
                  bkbone(6,i) = 80.0d0
                  glyco(i) = -159.0d0
                  pucker(i) = 1
               end if
            end if
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (purine)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine nucchain  --  build polynucleotide backbone  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "nucchain" builds up the internal coordinates for a nucleic
c     acid sequence from the sugar type, backbone and glycosidic
c     torsional values
c
c
      subroutine nucchain
      use atoms
      use nucleo
      use resdue
      use sequen
      implicit none
      integer i,k,m
      integer poi,o2i,c1i
      integer c2i,c3i,c4i
      integer c5i,o3i,o4i,o5i
      integer phtyp,ophtyp
      integer ostyp,ottyp
      logical single,last
      logical cap3,cap5
      character*3 resname
c
c
c     initialize the atom counter to the first atom
c
      n = 1
c
c     check for single residue and 3'- or 5'-phosphate caps
c
      do m = 1, nchain
         single = .false.
         last = .false.
         cap5 = .false.
         cap3 = .false.
         if (ichain(1,m) .eq. ichain(2,m))  single = .true.
         i = ichain(1,m)
         k = seqtyp(i)
         resname = nuclz(k)
         if (resname.eq.' MP' .or. resname.eq.' DP'
     &          .or. resname.eq.' TP')  cap5 = .true.
         i = ichain(2,m)
         k = seqtyp(i)
         resname = nuclz(k)
         if (resname.eq.' MP' .or. resname.eq.' DP'
     &          .or. resname.eq.' TP')  cap3 = .true.
c
c     build the first residue or a phosphate capping group;
c     for now, di- and triphosphate are set to monophosphate
c
         i = ichain(1,m)
         k = seqtyp(i)
         resname = nuclz(k)
         if (resname .eq. ' MP') then
            if (deoxy(i+1)) then
               ostyp = 1246
               phtyp = 1247
               ophtyp = 1248
            else
               ostyp = 1234
               phtyp = 1235
               ophtyp = 1236
            end if
            if (m .eq. 1) then
               o3i = n
               call zatom (ophtyp,0.0d0,0.0d0,0.0d0,0,0,0,0)
               poi = n
               call zatom (phtyp,1.52d0,0.0d0,0.0d0,o3i,0,0,0)
               call zatom (ophtyp,1.52d0,113.0d0,0.0d0,poi,o3i,0,0)
            else
               o3i = n
               call zatom (ophtyp,30.0d0,150.0d0,180.0d0,n-1,n-2,n-3,0)
               call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
               poi = n
               call zatom (phtyp,1.52d0,150.0d0,180.0d0,o3i,n-2,n-3,0)
               call zatom (ophtyp,1.52d0,113.0d0,180.0d0,poi,o3i,n-3,0)
            end if
            call zatom (ophtyp,1.52d0,113.0d0,113.0d0,poi,o3i,n-1,1)
            o5i = n
            call zatom (ostyp,1.63d0,106.0d0,106.0d0,poi,o3i,n-2,-1)
         else if (resname .eq. ' DP') then
            if (deoxy(i+1)) then
               ostyp = 1246
               phtyp = 1247
               ophtyp = 1248
            else
               ostyp = 1234
               phtyp = 1235
               ophtyp = 1236
            end if
            if (m .eq. 1) then
               o3i = n
               call zatom (ophtyp,0.0d0,0.0d0,0.0d0,0,0,0,0)
               poi = n
               call zatom (phtyp,1.52d0,0.0d0,0.0d0,o3i,0,0,0)
               call zatom (ophtyp,1.52d0,113.0d0,0.0d0,poi,o3i,0,0)
            else
               o3i = n
               call zatom (ophtyp,30.0d0,150.0d0,180.0d0,n-1,n-2,n-3,0)
               call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
               poi = n
               call zatom (phtyp,1.52d0,150.0d0,180.0d0,o3i,n-2,n-3,0)
               call zatom (ophtyp,1.52d0,113.0d0,180.0d0,poi,o3i,n-3,0)
            end if
            call zatom (ophtyp,1.52d0,113.0d0,113.0d0,poi,o3i,n-1,1)
            o5i = n
            call zatom (ostyp,1.63d0,106.0d0,106.0d0,poi,o3i,n-2,-1)
         else if (resname .eq. ' TP') then
            if (deoxy(i+1)) then
               ostyp = 1246
               phtyp = 1247
               ophtyp = 1248
            else
               ostyp = 1234
               phtyp = 1235
               ophtyp = 1236
            end if
            if (m .eq. 1) then
               o3i = n
               call zatom (ophtyp,0.0d0,0.0d0,0.0d0,0,0,0,0)
               poi = n
               call zatom (phtyp,1.52d0,0.0d0,0.0d0,o3i,0,0,0)
               call zatom (ophtyp,1.52d0,113.0d0,0.0d0,poi,o3i,0,0)
            else
               o3i = n
               call zatom (ophtyp,30.0d0,150.0d0,180.0d0,n-1,n-2,n-3,0)
               call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
               poi = n
               call zatom (phtyp,1.52d0,150.0d0,180.0d0,o3i,n-2,n-3,0)
               call zatom (ophtyp,1.52d0,113.0d0,180.0d0,poi,o3i,n-3,0)
            end if
            call zatom (ophtyp,1.52d0,113.0d0,113.0d0,poi,o3i,n-1,1)
            o5i = n
            call zatom (ostyp,1.63d0,106.0d0,106.0d0,poi,o3i,n-2,-1)
         else
            if (deoxy(i)) then
               ottyp = 1244
            else
               ottyp = 1232
            end if
            if (m .eq. 1) then
               o5i = n
               call zatom (ottyp,0.0d0,0.0d0,0.0d0,0,0,0,0)
               c5i = n
               call zatom (c5typ(k),1.44d0,0.0d0,0.0d0,o5i,0,0,0)
               c4i = n
               call zatom (c4typ(k),1.52d0,110.1d0,0.0d0,c5i,o5i,0,0)
            else
               o5i = n
               call zatom (ottyp,0.96d0,150.0d0,180.0d0,n-1,n-2,n-3,0)
               call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
               c5i = n
               call zatom (c5typ(k),1.44d0,119.0d0,180.0d0,
     &                        o5i,n-2,n-3,0)
               c4i = n
               call zatom (c4typ(k),1.52d0,110.1d0,180.0d0,
     &                        c5i,o5i,n-3,0)
            end if
            o4i = n
            call zatom (o4typ(k),1.46d0,108.9d0,bkbone(3,i)-120.0d0,
     &                     c4i,c5i,o5i,0)
            c1i = n
            if (pucker(i) .eq. 3) then
               call zatom (c1typ(k),1.42d0,109.8d0,145.0d0,
     &                        o4i,c4i,c5i,0)
            else if (pucker(i) .eq. 2) then
               call zatom (c1typ(k),1.42d0,109.8d0,107.0d0,
     &                        o4i,c4i,c5i,0)
            else if (pucker(i) .eq. 1) then
               call zatom (c1typ(k),1.42d0,109.8d0,140.0d0,
     &                        o4i,c4i,c5i,0)
            end if
            c3i = n
            call zatom (c3typ(k),1.53d0,115.9d0,bkbone(3,i),
     &                     c4i,c5i,o5i,0)
            c2i = n
            call zatom (c2typ(k),1.53d0,102.4d0,bkbone(4,i)+120.0d0,
     &                     c3i,c4i,c5i,0)
            call zatom (-1,0.0d0,0.0d0,0.0d0,c1i,c2i,0,0)
            o3i = n
            if (deoxy(i)) then
               if (single) then
                  call zatom (1249,1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               else
                  call zatom (o3typ(k),1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               end if
            else
               if (single) then
                  call zatom (1237,1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               else
                  call zatom (o3typ(k),1.42d0,112.1 d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               end if
               o2i = n
               call zatom (o2typ(k),1.43d0,109.5d0,109.5d0,
     &                        c2i,c3i,c1i,1)
            end if
            call zatom (h5ttyp(k),0.96d0,107.0d0,180.0d0,
     &                     o5i,c5i,c4i,0)
            call zatom (h51typ(k),1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,1)
            call zatom (h52typ(k),1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,-1)
            call zatom (h4typ(k),1.09d0,109.5d0,109.5d0,c4i,c5i,c3i,-1)
            if (pucker(i) .eq. 3) then
               call zatom (h1typ(k),1.09d0,109.5d0,120.0d0,
     &                        c1i,o4i,c2i,-1)
            else if (pucker(i) .eq. 2) then
               call zatom (h1typ(k),1.09d0,109.5d0,115.0d0,
     &                        c1i,o4i,c2i,-1)
            else if (pucker(i) .eq. 1) then
               call zatom (h1typ(k),1.09d0,109.5d0,90.0d0,
     &                        c1i,o4i,c2i,-1)
            end if
            call zatom (h3typ(k),1.09d0,109.5d0,109.5d0,c3i,c4i,c2i,-1)
            call zatom (h21typ(k),1.09d0,109.5d0,109.5d0,c2i,c3i,c1i,-1)
            if (deoxy(i)) then
               call zatom (h22typ(k),1.09d0,109.5d0,109.5d0,
     &                        c2i,c3i,c1i,1)
            else
               call zatom (h22typ(k),0.96d0,107.0d0,180.0d0,
     &                        o2i,c2i,c3i,0)
            end if
            if (single) then
               call zatom (h3ttyp(k),0.96d0,115.0d0,180.0d0,
     &                        o3i,c3i,c4i,0)
            end if
            call nucbase (resname,i,c1i,o4i,c2i)
         end if
c
c     build atoms for residues in the middle of the chain
c
         do i = ichain(1,m)+1, ichain(2,m)-1
            if (i .eq. ichain(2,m)-1)  last = .true.
            k = seqtyp(i)
            resname = nuclz(k)
            if (cap5) then
               cap5 = .false.
            else
               poi = n
               call zatom (ptyp(k),1.60d0,119.0d0,bkbone(5,i-1),
     &                        o3i,c3i,c4i,0)
               call zatom (optyp(k),1.48d0,109.0d0,
     &                        bkbone(6,i-1)+120.0d0,poi,o3i,c3i,0)
               call zatom (optyp(k),1.48d0,109.0d0,
     &                        bkbone(6,i-1)-120.0d0,poi,o3i,c3i,0)
               o5i = n
               call zatom (o5typ(k),1.60d0,101.8d0,bkbone(6,i-1),
     &                        poi,o3i,c3i,0)
            end if
            c5i = n
            call zatom (c5typ(k),1.44d0,119.0d0,bkbone(1,i),
     &                     o5i,poi,o3i,0)
            c4i = n
            call zatom (c4typ(k),1.52d0,110.1d0,bkbone(2,i),
     &                     c5i,o5i,poi,0)
            o4i = n
            call zatom (o4typ(k),1.46d0,108.9d0,bkbone(3,i)-120.0d0,
     &                     c4i,c5i,o5i,0)
            c1i = n
            if (pucker(i) .eq. 3) then
               call zatom (c1typ(k),1.42d0,109.8d0,145.0d0,
     &                        o4i,c4i,c5i,0)
            else if (pucker(i) .eq. 2) then
               call zatom (c1typ(k),1.42d0,109.8d0,107.0d0,
     &                        o4i,c4i,c5i,0)
            else if (pucker(i) .eq. 1) then
               call zatom (c1typ(k),1.42d0,109.8d0,140.0d0,
     &                        o4i,c4i,c5i,0)
            end if
            c3i = n
            call zatom (c3typ(k),1.53d0,115.9d0,bkbone(3,i),
     &                     c4i,c5i,o5i,0)
            c2i = n
            call zatom (c2typ(k),1.53d0,102.4d0,bkbone(4,i)+120.0d0,
     &                     c3i,c4i,c5i,0)
            call zatom (-1,0.0d0,0.0d0,0.0d0,c1i,c2i,0,0)
            o3i = n
            if (deoxy(i)) then
               if (cap3 .and. last) then
                  call zatom (1251,1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               else
                  call zatom (o3typ(k),1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               end if
            else
               if (cap3 .and. last) then
                  call zatom (1239,1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               else
                  call zatom (o3typ(k),1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               end if
               o2i = n
               call zatom (o2typ(k),1.43d0,109.5d0,109.5d0,
     &                        c2i,c3i,c1i,1)
            end if
            call zatom (h51typ(k),1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,1)
            call zatom (h52typ(k),1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,-1)
            call zatom (h4typ(k),1.09d0,109.5d0,109.5d0,c4i,c5i,c3i,-1)
            if (pucker(i) .eq. 3) then
               call zatom (h1typ(k),1.09d0,109.5d0,120.0d0,
     &                        c1i,o4i,c2i,-1)
            else if (pucker(i) .eq. 2) then
               call zatom (h1typ(k),1.09d0,109.5d0,115.0d0,
     &                        c1i,o4i,c2i,-1)
            else if (pucker(i) .eq. 1) then
               call zatom (h1typ(k),1.09d0,109.5d0,90.0d0,
     &                        c1i,o4i,c2i,-1)
            end if
            call zatom (h3typ(k),1.09d0,109.5d0,109.5d0,c3i,c4i,c2i,-1)
            call zatom (h21typ(k),1.09d0,109.5d0,109.5d0,c2i,c3i,c1i,-1)
            if (deoxy(i)) then
               call zatom (h22typ(k),1.09d0,109.5d0,109.5d0,
     &                        c2i,c3i,c1i,1)
            else
               call zatom (h22typ(k),0.96d0,107.0d0,180.0d0,
     &                        o2i,c2i,c3i,0)
            end if
            call nucbase (resname,i,c1i,o4i,c2i)
         end do
c
c     build the last residue or a phosphate capping group;
c     for now, di- and triphosphate are set to monophosphate
c
         i = ichain(2,m)
         k = seqtyp(i)
         resname = nuclz(k)
         if (single) then
            continue
         else if (resname .eq. ' MP') then
            poi = n
            if (deoxy(i-1)) then
               call zatom (1252,1.63d0,119.0d0,bkbone(5,i-1),
     &                        o3i,c3i,c4i,0)
               call zatom (1253,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0)
               call zatom (1253,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0)
               call zatom (1253,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0)
            else
               call zatom (1240,1.63d0,119.0d0,bkbone(5,i-1),
     &                        o3i,c3i,c4i,0)
               call zatom (1241,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0)
               call zatom (1241,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0)
               call zatom (1241,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0)
            end if
         else if (resname .eq. ' DP') then
            poi = n
            if (deoxy(i-1)) then
               call zatom (1252,1.63d0,119.0d0,bkbone(5,i-1),
     &                        o3i,c3i,c4i,0)
               call zatom (1253,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0)
               call zatom (1253,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0)
               call zatom (1253,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0)
            else
               call zatom (1240,1.63d0,119.0d0,bkbone(5,i-1),
     &                        o3i,c3i,c4i,0)
               call zatom (1241,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0)
               call zatom (1241,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0)
               call zatom (1241,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0)
            end if
         else if (resname .eq. ' TP') then
            poi = n
            if (deoxy(i-1)) then
               call zatom (1252,1.63d0,119.0d0,bkbone(5,i-1),
     &                        o3i,c3i,c4i,0)
               call zatom (1253,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0)
               call zatom (1253,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0)
               call zatom (1253,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0)
            else
               call zatom (1240,1.63d0,119.0d0,bkbone(5,i-1),
     &                        o3i,c3i,c4i,0)
               call zatom (1241,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0)
               call zatom (1241,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0)
               call zatom (1241,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0)
            end if
         else
            if (cap5) then
               cap5 = .false.
            else
               poi = n
               call zatom (ptyp(k),1.60d0,119.0d0,bkbone(5,i-1),
     &                        o3i,c3i,c4i,0)
               call zatom (optyp(k),1.48d0,109.0d0,
     &                        bkbone(6,i-1)+120.0d0,poi,o3i,c3i,0)
               call zatom (optyp(k),1.48d0,109.0d0,
     &                        bkbone(6,i-1)-120.0d0,poi,o3i,c3i,0)
               o5i = n
               call zatom (o5typ(k),1.60d0,101.8d0,bkbone(6,i-1),
     &                        poi,o3i,c3i,0)
            end if
            c5i = n
            call zatom (c5typ(k),1.44d0,119.0d0,bkbone(1,i),
     &                     o5i,poi,o3i,0)
            c4i = n
            call zatom (c4typ(k),1.52d0,110.1d0,bkbone(2,i),
     &                     c5i,o5i,poi,0)
            o4i = n
            call zatom (o4typ(k),1.46d0,108.9d0,bkbone(3,i)-120.0d0,
     &                     c4i,c5i,o5i,0)
            c1i = n
            if (pucker(i) .eq. 3) then
               call zatom (c1typ(k),1.42d0,109.8d0,145.0d0,
     &                        o4i,c4i,c5i,0)
            else if (pucker(i) .eq. 2) then
               call zatom (c1typ(k),1.42d0,109.8d0,107.0d0,
     &                        o4i,c4i,c5i,0)
            else if (pucker(i) .eq. 1) then
               call zatom (c1typ(k),1.42d0,109.8d0,140.0d0,
     &                        o4i,c4i,c5i,0)
            end if
            c3i = n
            call zatom (c3typ(k),1.53d0,115.9d0,bkbone(3,i),
     &                     c4i,c5i,o5i,0)
            c2i = n
            call zatom (c2typ(k),1.53d0,102.4d0,bkbone(4,i)+120.0d0,
     &                     c3i,c4i,c5i,0)
            call zatom (-1,0.0d0,0.0d0,0.0d0,c1i,c2i,0,0)
            o3i = n
            if (deoxy(i)) then
               call zatom (1249,1.42d0,112.1d0,bkbone(4,i),
     &                        c3i,c4i,c5i,0)
            else
               call zatom (1237,1.42d0,112.1d0,bkbone(4,i),
     &                        c3i,c4i,c5i,0)
               o2i = n
               call zatom (o2typ(k),1.43d0,109.5d0,109.5d0,
     &                        c2i,c3i,c1i,1)
            end if
            call zatom (h51typ(k),1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,1)
            call zatom (h52typ(k),1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,-1)
            call zatom (h4typ(k),1.09d0,109.5d0,109.5d0,c4i,c5i,c3i,-1)
            if (pucker(i) .eq. 3) then
               call zatom (h1typ(k),1.09d0,109.5d0,120.0d0,
     &                        c1i,o4i,c2i,-1)
            else if (pucker(i) .eq. 2) then
               call zatom (h1typ(k),1.09d0,109.5d0,115.0d0,
     &                        c1i,o4i,c2i,-1)
            else if (pucker(i) .eq. 1) then
               call zatom (h1typ(k),1.09d0,109.5d0,90.0d0,
     &                        c1i,o4i,c2i,-1)
            end if
            call zatom (h3typ(k),1.09d0,109.5d0,109.5d0,c3i,c4i,c2i,-1)
            call zatom (h21typ(k),1.09d0,109.5d0,109.5d0,c2i,c3i,c1i,-1)
            if (deoxy(i)) then
               call zatom (h22typ(k),1.09d0,109.5d0,109.5d0,
     &                        c2i,c3i,c1i,1)
            else
               call zatom (h22typ(k),0.96d0,107.0d0,180.0d0,
     &                        o2i,c2i,c3i,0)
            end if
            call zatom (h3ttyp(k),0.96d0,115.0d0,180.0d0,o3i,c3i,c4i,0)
            call nucbase (resname,i,c1i,o4i,c2i)
         end if
      end do
c
c     finally, set the total number of atoms
c
      n = n - 1
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine nucbase  --  build nucleotide base side chain  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "nucbase" builds the side chain for a single nucleotide base
c     in terms of internal coordinates
c
c     resname   3-letter name of current nucleotide residue
c     i         number of the current nucleotide residue
c     c1i       atom number of carbon C1' in residue i
c     o4i       atom number of oxygen O4' in residue i
c     c2i       atom number of carbon C2' in residue i
c
c     literature references:
c
c     R. Lavery, K. Zakrzewska, "Base and Base Pair Morphologies,
c     Helical Parameters, and Definitions" in "Oxford Handbook of
c     Nucleic Acid Structure", S. Neidel, Editor, Oxford University
c     Press, 1999, pages 40-42
c
c     W. Saenger, "Principles of Nucleic Acid Structure", Springer-
c     Verlag, 1984, page 52
c
c
      subroutine nucbase (resname,i,c1i,o4i,c2i)
      use atoms
      use nucleo
      implicit none
      integer i,c1i,o4i,c2i
      character*3 resname
c
c
c     adenine in adenosine residue  (A)
c
      if (resname .eq. '  A') then
         call zatom (1017,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1)
         call zatom (1021,1.37d0,128.4d0,glyco(i)+180.0d0,
     &                  n-1,c1i,o4i,0)
         call zatom (1020,1.30d0,113.8d0,180.0d0,n-1,n-2,c1i,0)
         call zatom (1019,1.39d0,104.0d0,0.0d0,n-1,n-2,n-3,0)
         call zatom (1025,1.40d0,132.4d0,180.0d0,n-1,n-2,n-3,0)
         call zatom (1027,1.34d0,123.5d0,0.0d0,n-1,n-2,n-3,0)
         call zatom (1024,1.35d0,117.4d0,180.0d0,n-2,n-3,n-4,0)
         call zatom (1023,1.33d0,118.8d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (1022,1.32d0,129.2d0,0.0d0,n-1,n-2,n-4,0)
         call zatom (1018,1.35d0,110.9d0,0.0d0,n-1,n-2,n-3,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-7,0,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-10,0,0)
         call zatom (1030,1.08d0,123.1d0,180.0d0,n-9,n-8,n-7,0)
         call zatom (1028,1.00d0,120.0d0,180.0d0,n-6,n-7,n-8,0)
         call zatom (1029,1.00d0,120.0d0,0.0d0,n-7,n-8,n-9,0)
         call zatom (1026,1.08d0,115.4d0,180.0d0,n-6,n-5,n-4,0)
c
c     guanine in guanosine residue  (G)
c
      else if (resname .eq. '  G') then
         call zatom (1047,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1)
         call zatom (1051,1.38d0,128.4d0,glyco(i)+180.0d0,
     &                  n-1,c1i,o4i,0)
         call zatom (1050,1.31d0,114.0d0,180.0d0,n-1,n-2,c1i,0)
         call zatom (1049,1.39d0,103.8d0,0.0d0,n-1,n-2,n-3,0)
         call zatom (1055,1.40d0,130.1d0,180.0d0,n-1,n-2,n-3,0)
         call zatom (1060,1.23d0,128.8d0,0.0d0,n-1,n-2,n-3,0)
         call zatom (1054,1.40d0,111.4d0,180.0d0,n-2,n-3,n-4,0)
         call zatom (1053,1.38d0,125.2d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (1057,1.34d0,116.1d0,180.0d0,n-1,n-2,n-4,0)
         call zatom (1052,1.33d0,123.3d0,0.0d0,n-2,n-3,n-4,0)
         call zatom (1048,1.36d0,112.3d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-8,0,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-11,0,0)
         call zatom (1061,1.08d0,123.0d0,180.0d0,n-10,n-9,n-8,0)
         call zatom (1056,1.00d0,117.4d0,180.0d0,n-6,n-8,n-9,0)
         call zatom (1058,1.00d0,120.0d0,0.0d0,n-5,n-6,n-7,0)
         call zatom (1059,1.00d0,120.0d0,180.0d0,n-6,n-7,n-8,0)
c
c     cytosine in cytidine residue  (C)
c
      else if (resname .eq. '  C') then
         call zatom (1078,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1)
         call zatom (1079,1.37d0,117.8d0,glyco(i),n-1,c1i,o4i,0)
         call zatom (1084,1.24d0,118.9d0,0.0d0,n-1,n-2,c1i,0)
         call zatom (1080,1.38d0,118.7d0,180.0d0,n-2,n-3,c1i,0)
         call zatom (1081,1.34d0,120.6d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (1085,1.32d0,118.3d0,180.0d0,n-1,n-2,n-4,0)
         call zatom (1082,1.43d0,121.6d0,0.0d0,n-2,n-3,n-5,0)
         call zatom (1083,1.36d0,116.9d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-8,0,0)
         call zatom (1086,1.00d0,120.0d0,0.0d0,n-3,n-4,n-5,0)
         call zatom (1087,1.00d0,120.0d0,180.0d0,n-4,n-5,n-6,0)
         call zatom (1088,1.08d0,121.6d0,180.0d0,n-4,n-6,n-7,0)
         call zatom (1089,1.08d0,119.5d0,180.0d0,n-4,n-5,n-7,0)
c
c     uracil in uridine residue  (U)
c
      else if (resname .eq. '  U') then
         call zatom (1106,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1)
         call zatom (1107,1.38d0,117.1d0,glyco(i),n-1,c1i,o4i,0)
         call zatom (1112,1.22d0,123.2d0,0.0d0,n-1,n-2,c1i,0)
         call zatom (1108,1.37d0,114.8d0,180.0d0,n-2,n-3,c1i,0)
         call zatom (1109,1.38d0,127.0d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (1114,1.23d0,119.8d0,180.0d0,n-1,n-2,n-4,0)
         call zatom (1110,1.44d0,114.7d0,0.0d0,n-2,n-3,n-5,0)
         call zatom (1111,1.34d0,119.2d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-8,0,0)
         call zatom (1113,1.00d0,116.5d0,180.0d0,n-5,n-7,n-8,0)
         call zatom (1115,1.08d0,120.4d0,180.0d0,n-3,n-5,n-6,0)
         call zatom (1116,1.08d0,118.6d0,180.0d0,n-3,n-4,n-6,0)
c
c     adenine in deoxyadenosine residue  (DA)
c
      else if (resname .eq. ' DA') then
         call zatom (1132,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1)
         call zatom (1136,1.37d0,128.4d0,glyco(i)+180.0d0,
     &                  n-1,c1i,o4i,0)
         call zatom (1135,1.30d0,113.8d0,180.0d0,n-1,n-2,c1i,0)
         call zatom (1134,1.39d0,104.0d0,0.0d0,n-1,n-2,n-3,0)
         call zatom (1140,1.40d0,132.4d0,180.0d0,n-1,n-2,n-3,0)
         call zatom (1142,1.34d0,123.5d0,0.0d0,n-1,n-2,n-3,0)
         call zatom (1139,1.35d0,117.4d0,180.0d0,n-2,n-3,n-4,0)
         call zatom (1138,1.33d0,118.8d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (1137,1.32d0,129.2d0,0.0d0,n-1,n-2,n-4,0)
         call zatom (1133,1.35d0,110.9d0,0.0d0,n-1,n-2,n-3,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-7,0,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-10,0,0)
         call zatom (1145,1.08d0,123.1d0,180.0d0,n-9,n-8,n-7,0)
         call zatom (1143,1.00d0,120.0d0,180.0d0,n-6,n-7,n-8,0)
         call zatom (1144,1.00d0,120.0d0,0.0d0,n-7,n-8,n-9,0)
         call zatom (1141,1.08d0,115.4d0,180.0d0,n-6,n-5,n-4,0)
c
c     guanine in deoxyguanosine residue  (DG)
c
      else if (resname .eq. ' DG') then
         call zatom (1161,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1)
         call zatom (1165,1.38d0,128.4d0,glyco(i)+180.0d0,
     &                  n-1,c1i,o4i,0)
         call zatom (1164,1.31d0,114.0d0,180.0d0,n-1,n-2,c1i,0)
         call zatom (1163,1.39d0,103.8d0,0.0d0,n-1,n-2,n-3,0)
         call zatom (1169,1.40d0,130.1d0,180.0d0,n-1,n-2,n-3,0)
         call zatom (1174,1.23d0,128.8d0,0.0d0,n-1,n-2,n-3,0)
         call zatom (1168,1.40d0,111.4d0,180.0d0,n-2,n-3,n-4,0)
         call zatom (1167,1.38d0,125.2d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (1171,1.34d0,116.1d0,180.0d0,n-1,n-2,n-4,0)
         call zatom (1166,1.33d0,123.3d0,0.0d0,n-2,n-3,n-4,0)
         call zatom (1162,1.36d0,112.3d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-8,0,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-11,0,0)
         call zatom (1175,1.08d0,123.0d0,180.0d0,n-10,n-9,n-8,0)
         call zatom (1170,1.00d0,117.4d0,180.0d0,n-6,n-8,n-9,0)
         call zatom (1172,1.00d0,120.0d0,0.0d0,n-5,n-6,n-7,0)
         call zatom (1173,1.00d0,120.0d0,180.0d0,n-6,n-7,n-8,0)
c
c     cytosine in deoxycytidine residue  (DC)
c
      else if (resname .eq. ' DC') then
         call zatom (1191,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1)
         call zatom (1192,1.37d0,117.8d0,glyco(i),n-1,c1i,o4i,0)
         call zatom (1197,1.24d0,118.9d0,0.0d0,n-1,n-2,c1i,0)
         call zatom (1193,1.38d0,118.7d0,180.0d0,n-2,n-3,c1i,0)
         call zatom (1194,1.34d0,120.6d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (1198,1.32d0,118.3d0,180.0d0,n-1,n-2,n-4,0)
         call zatom (1195,1.43d0,121.6d0,0.0d0,n-2,n-3,n-5,0)
         call zatom (1196,1.36d0,116.9d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-8,0,0)
         call zatom (1199,1.00d0,120.0d0,0.0d0,n-3,n-4,n-5,0)
         call zatom (1200,1.00d0,120.0d0,180.0d0,n-4,n-5,n-6,0)
         call zatom (1201,1.08d0,121.6d0,180.0d0,n-4,n-6,n-7,0)
         call zatom (1202,1.08d0,119.5d0,180.0d0,n-4,n-5,n-7,0)
c
c     thymine in deoxythymidine residue  (DT)
c
      else if (resname .eq. ' DT') then
         call zatom (1218,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1)
         call zatom (1219,1.37d0,117.1d0,glyco(i),n-1,c1i,o4i,0)
         call zatom (1224,1.22d0,122.9d0,0.0d0,n-1,n-2,c1i,0)
         call zatom (1220,1.38d0,115.4d0,180.0d0,n-2,n-3,c1i,0)
         call zatom (1221,1.38d0,126.4d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (1226,1.23d0,120.5d0,180.0d0,n-1,n-2,n-4,0)
         call zatom (1222,1.44d0,114.1d0,0.0d0,n-2,n-3,n-5,0)
         call zatom (1227,1.50d0,117.5d0,180.0d0,n-1,n-3,n-4,0)
         call zatom (1223,1.34d0,120.8d0,0.0d0,n-2,n-4,n-5,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-9,0,0)
         call zatom (1225,1.00d0,116.8d0,180.0d0,n-6,n-8,n-9,0)
         call zatom (1228,1.09d0,109.5d0,0.0d0,n-3,n-4,n-6,0)
         call zatom (1228,1.09d0,109.5d0,109.5d0,n-4,n-5,n-1,1)
         call zatom (1228,1.09d0,109.5d0,109.5d0,n-5,n-6,n-2,-1)
         call zatom (1229,1.08d0,119.4d0,180.0d0,n-5,n-7,n-9,0)
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine watson  --  align strands of a double helix  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "watson" uses a rigid body optimization to approximately
c     align the paired strands of a nucleic acid double helix
c
c
      subroutine watson
      use atoms
      use couple
      use group
      use inform
      use katoms
      use molcul
      use nucleo
      use output
      use potent
      use resdue
      use restrn
      use rigid
      use sequen
      use usage
      implicit none
      integer i,j,nvar
      integer ia,ib,ic,id
      integer start,stop
      integer kseq,offset
      integer nbase,nphos
      integer, allocatable :: iphos(:)
      integer, allocatable :: root(:)
      integer, allocatable :: list(:,:)
      real*8 minimum,grdmin
      real*8 watson1,sum,dist
      real*8, allocatable :: xx(:)
      character*3 resname
      external watson1,optsave
c
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(iuse))  allocate (iuse(n))
      if (.not. allocated(use))  allocate (use(0:n))
c
c     set all atoms to be active during energy evaluations
c
      nuse = n
      do i = 1, n
         use(i) = .true.
      end do
c
c     only geometric restraints will by used in optimization
c
      call potoff
      use_geom = .true.
c
c     set the default values for the restraint variables
c
      npfix = 0
      ndfix = 0
      ntfix = 0
      ngfix = 0
      nchir = 0
      use_basin = .false.
      use_wall = .false.
c
c     perform dynamic allocation of some local arrays
c
      allocate (iphos(nseq+10))
      allocate (root(nseq))
      allocate (list(2,nseq))
c
c     find root atom and hydrogen bond partners for each base
c
      kseq = 0
      nbase = 0
      do i = 1, n
         if (atmnum(type(i)).eq.6 .and. n12(i).eq.4) then
            ia = atmnum(type(i12(1,i)))
            ib = atmnum(type(i12(2,i)))
            ic = atmnum(type(i12(3,i)))
            id = atmnum(type(i12(4,i)))
            sum = ia + ib + ic + id
            if (sum .eq. 22) then
               nbase = nbase + 1
               j = i12(4,i)
               root(nbase) = j
               kseq = kseq + 1
               resname = nuclz(seqtyp(kseq))
               do while (resname.eq.' MP' .or. resname.eq.' DP'
     &                         .or. resname.eq.' TP')
                  kseq = kseq + 1
                  resname = nuclz(seqtyp(kseq))
               end do
               if (resname.eq.'  A' .or. resname.eq.' DA') then
                  list(1,nbase) = j + 6
                  list(2,nbase) = j + 11
               else if (resname.eq.'  G' .or. resname.eq.' DG') then
                  list(1,nbase) = j + 12
                  list(2,nbase) = j + 5
               else if (resname.eq.'  C' .or. resname.eq.' DC') then
                  list(1,nbase) = j + 3
                  list(2,nbase) = j + 8
               else if (resname .eq. '  U') then
                  list(1,nbase) = j + 8
                  list(2,nbase) = j + 5
               else if (resname .eq. ' DT') then
                  list(1,nbase) = j + 9
                  list(2,nbase) = j + 5
               end if
            end if
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      maxfix = 3 * nbase
      if (allocated(idfix))  deallocate(idfix)
      if (allocated(dfix))  deallocate(dfix)
      if (allocated(itfix))  deallocate(itfix)
      if (allocated(tfix))  deallocate(tfix)
      allocate (idfix(2,maxfix))
      allocate (dfix(3,maxfix))
      allocate (itfix(4,maxfix))
      allocate (tfix(3,maxfix))
c
c     distance restraints for the base pair hydrogen bonds
c
      do i = 1, nbase/2
         j = nbase + 1 - i
         ndfix = ndfix + 1
         idfix(1,ndfix) = list(1,i)
         idfix(2,ndfix) = list(1,j)
         dfix(1,ndfix) = 50.0d0
         dfix(2,ndfix) = 1.85d0
         dfix(3,ndfix) = 1.95d0
         ndfix = ndfix + 1
         idfix(1,ndfix) = list(2,i)
         idfix(2,ndfix) = list(2,j)
         dfix(1,ndfix) = 50.0d0
         dfix(2,ndfix) = 1.85d0
         dfix(3,ndfix) = 1.95d0
      end do
c
c     torsional restraints to enforce base pair planarity
c
      do i = 1, nbase/2
         j = nbase + 1 - i
         ntfix = ntfix + 1
         itfix(1,ntfix) = root(i)
         itfix(2,ntfix) = list(1,i)
         itfix(3,ntfix) = list(2,i)
         itfix(4,ntfix) = list(1,j)
         tfix(1,ntfix) = 2.5d0
         tfix(2,ntfix) = 180.0d0
         tfix(3,ntfix) = 180.0d0
         ntfix = ntfix + 1
         itfix(1,ntfix) = root(i)
         itfix(2,ntfix) = list(2,i)
         itfix(3,ntfix) = list(1,i)
         itfix(4,ntfix) = list(2,j)
         tfix(1,ntfix) = 2.5d0
         tfix(2,ntfix) = 180.0d0
         tfix(3,ntfix) = 180.0d0
         ntfix = ntfix + 1
         itfix(1,ntfix) = root(j)
         itfix(2,ntfix) = list(1,j)
         itfix(3,ntfix) = list(2,j)
         itfix(4,ntfix) = list(1,i)
         tfix(1,ntfix) = 2.5d0
         tfix(2,ntfix) = 180.0d0
         tfix(3,ntfix) = 180.0d0
         ntfix = ntfix + 1
         itfix(1,ntfix) = root(j)
         itfix(2,ntfix) = list(2,j)
         itfix(3,ntfix) = list(1,j)
         itfix(4,ntfix) = list(2,i)
         tfix(1,ntfix) = 2.5d0
         tfix(2,ntfix) = 180.0d0
         tfix(3,ntfix) = 180.0d0
      end do
c
c     distance restraints between interstrand phosphates
c
      nphos = 0
      do i = 1, n
         if (atmnum(type(i)) .eq. 15) then
            nphos = nphos + 1
            iphos(nphos) = i
         end if
      end do
      start = 1
      stop = nphos / 2
      resname = nuclz(seqtyp(1))
      if (resname .eq. ' MP')  start = start + 1
      if (resname .eq. ' DP')  start = start + 2
      if (resname .eq. ' TP')  start = start + 3
      resname = nuclz(seqtyp(nseq))
      if (resname .eq. ' MP')  stop = stop - 1
      if (resname .eq. ' DP')  stop = stop - 2
      if (resname .eq. ' TP')  stop = stop - 3
      offset = stop + nphos/2 + 1
      if (hlxform .eq. 'A')  dist = 17.78d0
      if (hlxform .eq. 'B')  dist = 17.46d0
      if (hlxform .eq. 'Z')  dist = 13.2d0
      do i = start, stop
         ndfix = ndfix + 1
         idfix(1,ndfix) = iphos(i)
         idfix(2,ndfix) = iphos(offset-i)
         dfix(1,ndfix) = 100.0d0
         dfix(2,ndfix) = dist
         dfix(3,ndfix) = dist
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iphos)
      deallocate (root)
      deallocate (list)
c
c     enable use of groups based on number of molecules
c
      use_group = .true.
      ngrp = nmol
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(kgrp))  allocate (kgrp(n))
      if (.not. allocated(grplist))  allocate (grplist(n))
      if (.not. allocated(igrp))  allocate (igrp(2,0:ngrp))
      if (.not. allocated(grpmass))  allocate (grpmass(0:ngrp))
      if (.not. allocated(wgrp))  allocate (wgrp(0:ngrp,0:ngrp))
c
c     assign each strand to a separate molecule-based group
c
      do i = 1, ngrp
         igrp(1,i) = imol(1,i)
         igrp(2,i) = imol(2,i)
         do j = igrp(1,i), igrp(2,i)
            kgrp(j) = kmol(j)
            grplist(kgrp(j)) = i
         end do
      end do
      do i = 0, ngrp
         do j = 0, ngrp
            wgrp(j,i) = 1.0d0
         end do
         wgrp(i,i) = 0.0d0
      end do
c
c     get rigid body reference coordinates for each strand
c
      call orient
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(6*ngrp))
c
c     convert rigid body coordinates to optimization parameters
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            xx(nvar) = rbc(j,i)
         end do
      end do
c
c     make the call to the optimization routine
c
      iprint = 0
      iwrite = 0
      grdmin = 0.1d0
      coordtype = 'NONE'
      call ocvm (nvar,xx,minimum,grdmin,watson1,optsave)
c
c     convert optimization parameters to rigid body coordinates
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            rbc(j,i) = xx(nvar)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
c
c     convert from rigid body to Cartesian coordinates
c
      call rigidxyz
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  function watson1  --  energy and gradient for watson  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "watson1" is a service routine that computes the energy
c     and gradient for optimally conditioned variable metric
c     optimization of rigid bodies
c
c
      function watson1 (xx,g)
      use group
      use math
      use rigid
      implicit none
      integer i,j,nvar
      real*8 watson1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to rigid body coordinates
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            rbc(j,i) = xx(nvar)
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(6,ngrp))
c
c     compute and store the energy and gradient
c
      call rigidxyz
      call gradrgd (e,derivs)
      watson1 = e
c
c     convert gradient components to optimization parameters
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            g(nvar) = derivs(j,i)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     #############################################################
c     ##                  COPYRIGHT (C) 1999 by                  ##
c     ##  Marina A. Vorobieva, Nina N. Sokolova & Jay W. Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module nucleo  --  parameters for nucleic acid structure  ##
c     ##                                                            ##
c     ################################################################
c
c
c     pucker    sugar pucker, either 2=2'-endo or 3=3'-endo
c     glyco     glycosidic torsional angle for each nucleotide
c     bkbone    phosphate backbone angles for each nucleotide
c     dblhlx    flag to mark system as nucleic acid double helix
c     deoxy     flag to mark deoxyribose or ribose sugar units
c     hlxform   helix form (A, B or Z) of polynucleotide strands
c
c
      module nucleo
      use sizes
      implicit none
      integer pucker(maxres)
      real*8 glyco(maxres)
      real*8 bkbone(6,maxres)
      logical dblhlx
      logical deoxy(maxres)
      character*1 hlxform
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##########################################################
c     ##                                                      ##
c     ##  function number  --  convert text string to number  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "number" converts a text numeral into an integer value;
c     the input string must contain only numeric characters
c
c
      function number (string)
      use inform
      use iounit
      implicit none
      integer i,j,number
      integer first,last,trimtext
      integer digit,place(10)
      character*1 letter
      character*(*) string
      data place  / 1, 10, 100, 1000, 10000, 100000, 1000000,
     &              10000000, 100000000, 1000000000 /
c
c
c     initialize the integer value of number to zero
c
      number = 0
c
c     get the first and last nonblank characters
c
      last = trimtext (string)
      if (last .gt. 10) then
         write (iout,10)
   10    format (' NUMBER  --  Input Text String is Too Long')
         return
      end if
      first = 1
      do i = 1, last
         letter = string(i:i)
         if (letter .ne. ' ') then
            first = i
            goto 20
         end if
      end do
   20 continue
c
c     convert the text numeral into an integer number
c
      j = 0
      do i = last, first, -1
         j = j + 1
         letter = string(i:i)
         if (letter .eq. '0') then
            digit = 0
         else if (letter .eq. '1') then
            digit = 1
         else if (letter .eq. '2') then
            digit = 2
         else if (letter .eq. '3') then
            digit = 3
         else if (letter .eq. '4') then
            digit = 4
         else if (letter .eq. '5') then
            digit = 5
         else if (letter .eq. '6') then
            digit = 6
         else if (letter .eq. '7') then
            digit = 7
         else if (letter .eq. '8') then
            digit = 8
         else if (letter .eq. '9') then
            digit = 9
         else
            if (debug) then
               write (iout,30)
   30          format (/,' NUMBER  --  Non-Numeric Characters Found',
     &                    ' in Numeral String')
            end if
            number = 0
            goto 40
         end if
         number = number + digit * place(j)
      end do
   40 continue
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine numeral  --  convert number to text string  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "numeral" converts an input integer number into the
c     corresponding right- or left-justified text numeral
c
c     number  integer value of the number to be transformed
c     string  text string to be filled with corresponding numeral
c     size    on input, the minimal acceptable numeral length, if
c               zero then output will be right justified, if
c               nonzero then numeral is left-justified and padded
c               with leading zeros as necessary; upon output, the
c               number of non-blank characters in the numeral
c
c
      subroutine numeral (number,string,size)
      implicit none
      integer i,j
      integer number,size
      integer multi,pos,len
      integer length,minsize
      integer hunmill,tenmill
      integer million,hunthou
      integer tenthou,thousand
      integer hundred,tens,ones
      logical right,negative
      character*1 digit(0:9)
      character*(*) string
      data digit  / '0','1','2','3','4','5','6','7','8','9' /
c
c
c     set justification and size bounds for numeral string
c
      if (size .eq. 0) then
         right = .true.
         size = 1
      else
         right = .false.
      end if
      minsize = size
      length = len(string)
c
c     test the sign of the original number
c
      if (number .ge. 0) then
         negative = .false.
      else
         negative = .true.
         number = -number
      end if
c
c     use modulo arithmetic to find place-holding digits
c
      hunmill = number / 100000000
      multi = 100000000 * hunmill
      tenmill = (number-multi) / 10000000
      multi = multi + 10000000*tenmill
      million = (number-multi) / 1000000
      multi = multi + 1000000*million
      hunthou = (number-multi) / 100000
      multi = multi + 100000*hunthou
      tenthou = (number-multi) / 10000
      multi = multi + 10000*tenthou
      thousand = (number-multi) / 1000
      multi = multi + 1000*thousand
      hundred = (number-multi) / 100
      multi = multi + 100*hundred
      tens = (number-multi) / 10
      multi = multi + 10*tens
      ones = number - multi
c
c     find the correct length to be used for the numeral
c
      if (hunmill .ne. 0) then
         size = 9
      else if (tenmill .ne. 0) then
         size = 8
      else if (million .ne. 0) then
         size = 7
      else if (hunthou .ne. 0) then
         size = 6
      else if (tenthou .ne. 0) then
         size = 5
      else if (thousand .ne. 0) then
         size = 4
      else if (hundred .ne. 0) then
         size = 3
      else if (tens .ne. 0) then
         size = 2
      else
         size = 1
      end if
      size = min(size,length)
      size = max(size,minsize)
c
c     convert individual digits to a string of numerals
c
      if (size .eq. 9) then
         string(1:1) = digit(hunmill)
         string(2:2) = digit(tenmill)
         string(3:3) = digit(million)
         string(4:4) = digit(hunthou)
         string(5:5) = digit(tenthou)
         string(6:6) = digit(thousand)
         string(7:7) = digit(hundred)
         string(8:8) = digit(tens)
         string(9:9) = digit(ones)
      else if (size .eq. 8) then
         string(1:1) = digit(tenmill)
         string(2:2) = digit(million)
         string(3:3) = digit(hunthou)
         string(4:4) = digit(tenthou)
         string(5:5) = digit(thousand)
         string(6:6) = digit(hundred)
         string(7:7) = digit(tens)
         string(8:8) = digit(ones)
      else if (size .eq. 7) then
         string(1:1) = digit(million)
         string(2:2) = digit(hunthou)
         string(3:3) = digit(tenthou)
         string(4:4) = digit(thousand)
         string(5:5) = digit(hundred)
         string(6:6) = digit(tens)
         string(7:7) = digit(ones)
      else if (size .eq. 6) then
         string(1:1) = digit(hunthou)
         string(2:2) = digit(tenthou)
         string(3:3) = digit(thousand)
         string(4:4) = digit(hundred)
         string(5:5) = digit(tens)
         string(6:6) = digit(ones)
      else if (size .eq. 5) then
         string(1:1) = digit(tenthou)
         string(2:2) = digit(thousand)
         string(3:3) = digit(hundred)
         string(4:4) = digit(tens)
         string(5:5) = digit(ones)
      else if (size .eq. 4) then
         string(1:1) = digit(thousand)
         string(2:2) = digit(hundred)
         string(3:3) = digit(tens)
         string(4:4) = digit(ones)
      else if (size .eq. 3) then
         string(1:1) = digit(hundred)
         string(2:2) = digit(tens)
         string(3:3) = digit(ones)
      else if (size .eq. 2) then
         string(1:1) = digit(tens)
         string(2:2) = digit(ones)
      else
         string(1:1) = digit(ones)
      end if
c
c     right- or left-justify as desired, with padding
c
      if (right) then
         do i = size, 1, -1
            pos = length - size + i
            string(pos:pos) = string(i:i)
         end do
         do i = 1, length-size
            string(i:i) = ' '
         end do
      else
         do i = size+1, length
            string(i:i) = ' '
         end do
      end if
c
c     handle negative numbers, if possible to do so
c
      if (negative) then
         number = -number
         if (right) then
            pos = length - size
            if (pos .ne. 0) then
               string(pos:pos) = '-'
               size = min(size,length)
            end if
         else
            do i = 1, size
               if (string(i:i) .ne. '0') then
                  if (i .eq. 1) then
                     if (size .lt. length) then
                        do j = size, 1, -1
                           string(j+1:j+1) = string(j:j)
                        end do
                        string(1:1) = '-'
                     end if
                     size = size + 1
                  else
                     string(i-1:i-1) = '-'
                  end if
                  goto 10
               end if
            end do
   10       continue
         end if
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine numgrad  --  numerical gradient of a function  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "numgrad" computes the gradient of the objective function
c     "evalue" with respect to Cartesian coordinates of the atoms
c     via a one-sided or two-sided numerical differentiation
c
c
      subroutine numgrad (evalue,g,eps)
      use atoms
      implicit none
      integer i
      real*8 evalue,eps
      real*8 e,e0,old
      real*8 g(3,*)
      logical twosided
      external evalue
c
c
c     chose between use of one-sided or two-sided gradient
c
      twosided = .true.
      if (.not. twosided)  e0 = evalue ()
c
c     compute the numerical gradient from function values
c
      do i = 1, n
         old = x(i)
         if (twosided) then
            x(i) = x(i) - 0.5d0*eps
            e0 = evalue ()
         end if
         x(i) = x(i) + eps
         e = evalue ()
         x(i) = old
         g(1,i) = (e - e0) / eps
         old = y(i)
         if (twosided) then
            y(i) = y(i) - 0.5d0*eps
            e0 = evalue ()
         end if
         y(i) = y(i) + eps
         e = evalue ()
         y(i) = old
         g(2,i) = (e - e0) / eps
         old = z(i)
         if (twosided) then
            z(i) = z(i) - 0.5d0*eps
            e0 = evalue ()
         end if
         z(i) = z(i) + eps
         e = evalue ()
         z(i) = old
         g(3,i) = (e - e0) / eps
      end do
c
c     distribute gradient on four-site water extra centers
c
      call watfour2 (g)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ocvm  --  variable metric optimization method  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ocvm" implements an optimally conditioned variable metric
c     nonlinear optimization routine without line searches
c
c     literature references:
c
c     W. C. Davidon, "Optimally Conditioned Optimization Algorithms
c     Without Line Searches", Mathematical Programming, 9, 1-30 (1975)
c
c     D. F. Shanno and K-H. Phua, "Matrix Conditioning and Nonlinear
c     Optimization", Mathematical Programming, 14, 149-16 (1977)
c
c     D. F. Shanno and K-H. Phua, "Numerical Comparison of Several
c     Variable-Metric Algorithms", Journal of Optimization Theory
c     and Applications, 25, 507-518 (1978)
c
c     variables and parameters:
c
c     nvar       number of parameters in the objective function
c     x0         contains starting point upon input, upon return
c                  contains the best point found
c     f0         during optimization contains best current function
c                  value; returns final best function value
c     grdmin     normal exit if rms gradient gets below this value
c     ncalls     total number of function/gradient evaluations
c
c     required external routines:
c
c     fgvalue    function to evaluate function and gradient values
c     optsave    subroutine to write out info about current status
c
c
      subroutine ocvm (nvar,x0,f0,grdmin,fgvalue,optsave)
      use inform
      use iounit
      use keys
      use linmin
      use math
      use minima
      use output
      use potent
      use scales
      implicit none
      integer i,j,nvar
      integer mvar,next
      integer niter,ncalls
      integer nbig,nstep
      integer maxbig,maxstep
      real*8 fgvalue,eps
      real*8 f,f0,f0old
      real*8 fprime,f0prime
      real*8 grdmin,srchnorm
      real*8 sgangle,sg,snorm
      real*8 zeta,cosang
      real*8 fmove,xmove
      real*8 gnorm,grms,rms
      real*8 m2,n2,u2,v
      real*8 micron,mw,us,qk0
      real*8 a,b,b0,c
      real*8 alpha,gamma,delta
      real*8 x0(*)
      real*8, allocatable :: x0old(:)
      real*8, allocatable :: x(:)
      real*8, allocatable :: g(:)
      real*8, allocatable :: hq(:)
      real*8, allocatable :: search(:)
      real*8, allocatable :: s(:)
      real*8, allocatable :: w(:)
      real*8, allocatable :: k(:)
      real*8, allocatable :: k0(:)
      real*8, allocatable :: m(:)
      real*8, allocatable :: n(:)
      real*8, allocatable :: p(:)
      real*8, allocatable :: q(:)
      real*8, allocatable :: u(:)
      real*8, allocatable :: h(:,:)
      logical restart,done
      character*9 status
      character*20 keyword
      character*240 record
      character*240 string
      external fgvalue,optsave
c
c
c     initialization and set-up for the optimization
c
      mvar = nvar
      rms = sqrt(dble(nvar))
      if (coordtype .eq. 'CARTESIAN') then
         rms = rms / sqrt(3.0d0)
      else if (coordtype .eq. 'RIGIDBODY') then
         rms = rms / sqrt(6.0d0)
      end if
      maxbig = 2
      maxstep = 10
      eps = 1.0d-16
      restart = .true.
      done = .false.
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(scale))  allocate (scale(nvar))
c
c     set default values for variable scale factors
c
      if (.not. set_scale) then
         do i = 1, nvar
            if (scale(i) .eq. 0.0d0)  scale(i) = 1.0d0
         end do
      end if
c
c     set default parameters for the optimization
c
      if (fctmin .eq. 0.0d0)  fctmin = -100000000.0d0
      if (maxiter .eq. 0)  maxiter = 1000000
      if (nextiter .eq. 0)  nextiter = 1
      if (iprint .lt. 0)  iprint = 1
      if (iwrite .lt. 0)  iwrite = 1
      if (stpmax .eq. 0.0d0)  stpmax = 5.0d0
      if (hguess .eq. 0.0d0)  hguess = 0.4d0
      angmax = 180.0d0
c
c     search the keywords for optimization parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:7) .eq. 'FCTMIN ') then
            read (string,*,err=10,end=10)  fctmin
         else if (keyword(1:8) .eq. 'MAXITER ') then
            read (string,*,err=10,end=10)  maxiter
         else if (keyword(1:9) .eq. 'NEXTITER ') then
            read (string,*,err=10,end=10)  nextiter
         else if (keyword(1:7) .eq. 'HGUESS ') then
            read (string,*,err=10,end=10)  hguess
         else if (keyword(1:8) .eq. 'STEPMAX ') then
            read (string,*,err=10,end=10)  stpmax
         else if (keyword(1:7) .eq. 'ANGMAX ') then
            read (string,*,err=10,end=10)  angmax
         end if
   10    continue
      end do
c
c     print initial information prior to first iteration
c
      if (iprint .gt. 0) then
         write (iout,20)
   20    format (/,' Optimally Conditioned Variable Metric',
     &             ' Optimization :')
         write (iout,30)
   30    format (/,' VM Iter     F Value       G RMS      F Move',
     &              '   X Move      Angle   FG Call')
         flush (iout)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (x0old(nvar))
      allocate (x(nvar))
      allocate (g(nvar))
      allocate (hq(nvar))
      allocate (search(nvar))
      allocate (s(mvar))
      allocate (w(mvar))
      allocate (k(mvar))
      allocate (k0(mvar))
      allocate (m(mvar))
      allocate (n(mvar))
      allocate (p(mvar))
      allocate (q(mvar))
      allocate (u(mvar))
      allocate (h(nvar,mvar))
c
c     evaluate the function and get the initial gradient
c
      niter = nextiter - 1
      maxiter = niter + maxiter
      do i = 1, nvar
         x0old(i) = x0(i)
      end do
      ncalls = 1
      f0 = fgvalue (x0,g)
      f0old = f0
c
c     set the "h" matrix to a diagonal upon restarting
c
      do while (.not. done)
         if (restart) then
            do j = 1, mvar
               do i = 1, nvar
                  h(i,j) = 0.0d0
               end do
            end do
            do j = 1, mvar
               h(j,j) = hguess
            end do
            do j = 1, mvar
               k0(j) = 0.0d0
               do i = 1, nvar
                  k0(j) = k0(j) + h(i,j)*g(i)
               end do
               w(j) = k0(j)
            end do
            restart = .false.
         end if
c
c     start the next iteration using either an updated "h"
c     matrix or the "h" matrix from the previous iteration
c
         gnorm = 0.0d0
         grms = 0.0d0
         do i = 1, nvar
            gnorm = gnorm + g(i)**2
            grms = grms + (g(i)*scale(i))**2
         end do
         gnorm = sqrt(gnorm)
         grms = sqrt(grms) / rms
         xmove = 0.0d0
         if (niter .ne. 0) then
            do i = 1, nvar
               xmove = xmove + ((x0(i)-x0old(i))/scale(i))**2
               x0old(i) = x0(i)
            end do
            xmove = sqrt(xmove) / rms
            if (coordtype .eq. 'INTERNAL') then
               xmove = radian * xmove
            end if
            fmove = f0old - f0
            f0old = f0
         end if
c
c     print intermediate results for the current iteration
c
         if (iprint .gt. 0) then
            if (niter .eq. 0) then
               if (f0.lt.1.0d8 .and. f0.gt.-1.0d7 .and.
     &                    grms.lt.1.0d6) then
                  write (iout,40)  niter,f0,grms,ncalls
   40             format (/,i6,f14.4,f12.4,32x,i9)
               else
                  write (iout,50)  niter,f0,grms,ncalls
   50             format (/,i6,d14.4,d12.4,32x,i9)
               end if
            else if (mod(niter,iprint) .eq. 0) then
               if (f0.lt.1.0d8 .and. f0.gt.-1.0d7 .and.
     &             grms.lt.1.0d6 .and. fmove.lt.1.0d6 .and.
     &             fmove.gt.-1.0d5) then
                  write (iout,60)  niter,f0,grms,fmove,
     &                             xmove,sgangle,ncalls
   60             format (i6,f14.4,f12.4,f12.4,f9.4,f11.4,i9)
               else
                  write (iout,70)  niter,f0,grms,fmove,
     &                             xmove,sgangle,ncalls
   70             format (i6,d14.4,d12.4,d12.4,f9.4,f11.4,i9)
               end if
            end if
            flush (iout)
         end if
c
c     write intermediate results for the current iteration
c
         if (iwrite .gt. 0) then
            if (mod(niter,iwrite) .eq. 0) then
               call optsave (niter,f0,x0)
            end if
         end if
c
c     before starting the next iteration, check to see whether
c     the gradient norm, function decrease or iteration limit
c     termination criteria have been satisfied
c
         if (grms.lt.grdmin .or. f0.lt.fctmin
     &          .or. niter.ge.maxiter) then
            if (iprint .gt. 0) then
               if (niter.ne.0 .and. mod(niter,iprint).ne.0) then
                  if (f0.lt.1.0d8 .and. f0.gt.-1.0d7 .and.
     &                grms.lt.1.0d6 .and. fmove.lt.1.0d6 .and.
     &                fmove.gt.-1.0d5) then
                     write (iout,80)  niter,f0,grms,fmove,
     &                                xmove,sgangle,ncalls
   80                format (i6,f14.4,f12.4,f12.4,f9.4,f11.4,i9)
                  else
                     write (iout,90)  niter,f0,grms,fmove,
     &                                 xmove,sgangle,ncalls
   90                format (i6,d14.4,d12.4,d12.4,f9.4,f11.4,i9)
                  end if
               end if
               if (niter .ge. maxiter)  status = 'IterLimit'
               if (f0 .lt. fctmin)  status = 'SmallFct '
               if (grms .lt. grdmin)  status = 'SmallGrad'
               if (status .eq. 'IterLimit') then
                  write (iout,100)  status
  100             format (/,' OCVM  --  Incomplete Convergence',
     &                       ' due to ',a9)
               else
                  write (iout,110)  status
  110             format (/,' OCVM  --  Normal Termination',
     &                       ' due to ',a9)
               end if
               flush (iout)
            end if
            if (iwrite .gt. 0) then
               if (mod(niter,iwrite) .ne. 0) then
                  call optsave (niter,f0,x)
               end if
            end if
            done = .true.
            goto 160
         end if
c
c     start of the next iteration
c
         niter = niter + 1
         sg = 0.0d0
         snorm = 0.0d0
         do j = 1, mvar
            s(j) = -k0(j)
            snorm = snorm + s(j)**2
            sg = sg - s(j)*g(j)
         end do
         f0prime = -snorm
         snorm = sqrt(snorm)
         cosang = sg / (snorm*gnorm)
         cosang = min(1.0d0,max(-1.0d0,cosang))
         sgangle = radian * acos(cosang)
         if (sgangle .gt. angmax) then
            nbig = nbig + 1
         else
            nbig = 0
         end if
         zeta = 2.0d0
         if (4.0d0*(f0-fctmin) .lt. -f0prime) then
            do j = 1, mvar
               s(j) = -s(j) * (4.0d0*(f0-fctmin)/f0prime)
            end do
            f0prime = -4.0d0 * (f0-fctmin)
         end if
c
c     location of the next starting point
c
         nstep = 0
  120    continue
         do i = 1, nvar
            search(i) = 0.0d0
         end do
         do j = 1, mvar
            do i = 1, nvar
               search(i) = search(i) + h(i,j)*s(j)
            end do
         end do
         srchnorm = 0.0d0
         do i = 1, nvar
            srchnorm = srchnorm + search(i)**2
         end do
         srchnorm = sqrt(srchnorm)
         if (srchnorm .gt. stpmax) then
            do j = 1, mvar
               s(j) = (stpmax/srchnorm) * s(j)
            end do
            do i = 1, nvar
               search(i) = (stpmax/srchnorm) * search(i)
            end do
            f0prime = (stpmax/srchnorm) * f0prime
            zeta = 0.5d0
         end if
c
c     invoke abnormal termination if -f0prime is too small
c
         if (-f0prime .lt. eps) then
            if (iprint .gt. 0) then
               if (niter.ne.0 .and. mod(niter,iprint).ne.0) then
                  if (f0.lt.1.0d8 .and. f0.gt.-1.0d7 .and.
     &                       grms.lt.1.0d6) then
                     write (iout,130)  niter,f0,grms,0.0,0.0,
     &                                 sgangle,ncalls
  130                format (i6,f14.4,f12.4,f12.4,f9.4,f11.4,i9)
                  else
                     write (iout,140)  niter,f0,grms,0.0,0.0,
     &                                 sgangle,ncalls
  140                format (i6,d14.4,d12.4,f12.4,f9.4,f11.4,i9)
                  end if
               end if
               status = 'SmallMove'
               write (iout,150)  status
  150          format (/,' OCVM  --  Incomplete Convergence',
     &                    ' due to ',a9)
               flush (iout)
            end if
            if (iwrite .gt. 0) then
               if (mod(niter,iwrite) .ne. 0) then
                  call optsave (niter,f0,x)
               end if
            end if
            done = .true.
            goto 160
         end if
         do i = 1, nvar
            x(i) = x0(i) + search(i)
         end do
         ncalls = ncalls + 1
         f = fgvalue (x,g)
         if (f .ge. f0) then
            do j = 1, mvar
               s(j) = 0.5d0 * s(j)
            end do
            f0prime = 0.5d0 * f0prime
            zeta = 0.5d0
            goto 120
         end if
c
c     decide whether to update or take another step
c
         do j = 1, mvar
            k(j) = 0.0d0
            do i = 1, nvar
               k(j) = k(j) + h(i,j)*g(i)
            end do
         end do
         fprime = 0.0d0
         do j = 1, mvar
            fprime = fprime + k(j)*s(j)
         end do
         b0 = fprime - f0prime
         do j = 1, mvar
            m(j) = s(j) + k0(j) - k(j)
            k0(j) = k(j)
         end do
         do i = 1, nvar
            x0(i) = x(i)
         end do
         f0 = f
         f0prime = fprime
         if (b0 .lt. eps) then
            nstep = nstep + 1
            if (nstep .ge. maxstep) then
               restart = .true.
               goto 160
            end if
            do j = 1, mvar
               s(j) = s(j) * zeta
            end do
            f0prime = f0prime * zeta
            goto 120
         end if
c
c     check to see if we need to update
c
         if (nbig .ge. maxbig) then
            restart = .true.
            goto 160
         end if
         m2 = 0.0d0
         do j = 1, mvar
            m2 = m2 + m(j)**2
         end do
         if (m2 .lt. eps) then
            goto 160
         end if
         v = 0.0d0
         do j = 1, mvar
            v = v + m(j)*s(j)
         end do
         micron = v - m2
         mw = 0.0d0
         do j = 1, mvar
            mw = mw + m(j)*w(j)
         end do
         do j = 1, mvar
            u(j) = w(j) - m(j)*(mw/m2)
         end do
         u2 = 0.0d0
         do j = 1, mvar
            u2 = u2 + u(j)**2
         end do
         if (m2*u2 .ge. eps) then
            us = 0.0d0
            do j = 1, mvar
               us = us + u(j)*s(j)
            end do
            do j = 1, mvar
               n(j) = u(j)*(us/u2)
            end do
            n2 = us * us/u2
         else
            do j = 1, mvar
               n(j) = 0.0d0
            end do
            n2 = 0.0d0
         end if
c
c     test inner product of projected s and del-g
c
         b = n2 + micron * v/m2
         if (b .lt. eps) then
            do j = 1, mvar
               n(j) = s(j) - m(j)*(v/m2)
            end do
            n2 = b0 - micron * v/m2
            b = b0
         end if
c
c     set "gamma" and "delta" for the update
c
         if (micron*v .ge. m2*n2) then
            gamma = 0.0d0
            delta = sqrt(v/micron)
         else
            a = b - micron
            c = b + v
            gamma = sqrt((1.0d0-micron*v/(m2*n2))/(a*b))
            delta = sqrt(c/a)
            if (c .lt. a) then
               gamma = -gamma
            end if
         end if
c
c     perform the update of the "h" matrix
c
         alpha = v + micron*delta + m2*n2*gamma
         do j = 1, mvar
            p(j) = m(j)*(delta-n2*gamma) + n(j)*(gamma*v)
            q(j) = m(j)*((1.0d0+n2*gamma)/alpha)
     &             - n(j)*(gamma * micron/alpha)
            w(j) = m(j)*(n2*(1.0d0+gamma*micron*v)/alpha)
     &             - n(j)*((1.0d0+delta)*micron*v/alpha)
         end do
         qk0 = 0.0d0
         do j = 1, mvar
            qk0 = qk0 + q(j)*k0(j)
         end do
         do j = 1, mvar
            k0(j) = k0(j) + p(j)*qk0
         end do
         do i = 1, nvar
            hq(i) = 0.0d0
         end do
         do j = 1, mvar
            do i = 1, nvar
               hq(i) = hq(i) + h(i,j)*q(j)
            end do
         end do
         do j = 1, mvar
            do i = 1, nvar
               h(i,j) = h(i,j) + hq(i)*p(j)
            end do
         end do
         if (n2 .le. 0.0d0) then
            do j = 1, mvar
               w(j) = k0(j)
            end do
         end if
  160    continue
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (x0old)
      deallocate (x)
      deallocate (g)
      deallocate (hq)
      deallocate (search)
      deallocate (s)
      deallocate (w)
      deallocate (k)
      deallocate (k0)
      deallocate (m)
      deallocate (n)
      deallocate (p)
      deallocate (q)
      deallocate (u)
      deallocate (h)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module omega  --  torsional space dihedral angle values  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     nomega   number of dihedral angles allowed to rotate
c     iomega   numbers of two atoms defining rotation axis
c     zline    line number in Z-matrix of each dihedral angle
c     dihed    current value in radians of each dihedral angle
c
c
      module omega
      implicit none
      integer nomega
      integer, allocatable :: iomega(:,:)
      integer, allocatable :: zline(:)
      real*8, allocatable :: dihed(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module opbend  --  out-of-plane bends in current structure  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     nopbend   total number of out-of-plane bends in the system
c     iopb      bond angle numbers used in out-of-plane bending
c     opbk      force constant values for out-of-plane bending
c
c
      module opbend
      implicit none
      integer nopbend
      integer, allocatable :: iopb(:)
      real*8, allocatable :: opbk(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module opdist  --  out-of-plane distances in structure  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     nopdist   total number of out-of-plane distances in the system
c     iopd      numbers of the atoms in each out-of-plane distance
c     opdk      force constant values for out-of-plane distance
c
c
      module opdist
      implicit none
      integer nopdist
      integer, allocatable :: iopd(:,:)
      real*8, allocatable :: opdk(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2000  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine openend  --  open a file positioned for append  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "openend" opens a file on a Fortran unit such that the position
c     is set to the bottom for appending to the end of the file
c
c
      subroutine openend (iunit,name)
      implicit none
      integer iunit
      character*240 name
c
c
c     standard Fortran 90, unavailable in some Fortran 77 compilers
c
      open (unit=iunit,file=name,status='old',position='append')
c
c     common extension supported by many Fortran 77 compilers
c
c     open (unit=iunit,file=name,status='old',access='append')
c
c     some Fortran 77 compilers open files for append by default
c
c     open (unit=iunit,file=name,status='old')
c
c     read to the end of formatted file, slow but always correct
c
c     open (unit=iunit,file=name,status='old')
c     do while (.true.)
c        read (iunit,10,err=20,end=20)
c  10    format ()
c     end do
c  20 continue
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2010  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module openmp  --  OpenMP processor and thread values  ##
c     ##                                                         ##
c     #############################################################
c
c
c     nproc     number of processors available to OpenMP
c     nthread   number of threads to be used with OpenMP
c     nnest     number of nested active parallel regions
c
c
      module openmp
      implicit none
      integer nproc
      integer nthread
      integer nnest
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program optimize  --  variable metric Cartesian optimizer  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "optimize" performs energy minimization in Cartesian coordinate
c     space using an optimally conditioned variable metric method
c
c
      program optimize
      use atoms
      use bound
      use files
      use freeze
      use inform
      use iounit
      use scales
      use usage
      implicit none
      integer i,j,k
      integer imin,nvar
      integer freeunit
      real*8 minimum,optimiz1
      real*8 grdmin,gnorm,grms
      real*8 energy,eps
      real*8, allocatable :: xx(:)
      real*8, allocatable :: derivs(:,:)
      logical exist,analytic
      character*240 minfile
      character*240 string
      external energy
      external optimiz1
      external optsave
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     perform the setup functions needed for optimization
c
      call optinit
c
c     use either analytical or numerical gradients
c
      analytic = .true.
      eps = 0.00001d0
c
c     get termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  grdmin
   10 continue
      if (grdmin .le. 0.0d0) then
         write (iout,20)
   20    format (/,' Enter RMS Gradient per Atom Criterion',
     &              ' [0.01] :  ',$)
         read (input,30)  grdmin
   30    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.01d0
c
c     write out a copy of coordinates for later update
c
      imin = freeunit ()
      minfile = filename(1:leng)//'.xyz'
      call version (minfile,'new')
      open (unit=imin,file=minfile,status='new')
      call prtxyz (imin)
      close (unit=imin)
      outfile = minfile
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(scale))  allocate (scale(3*n))
c
c     set scaling parameter for function and derivative values;
c     use square root of median eigenvalue of typical Hessian
c
      set_scale = .true.
      nvar = 0
      do i = 1, nuse
         do j = 1, 3
            nvar = nvar + 1
            scale(nvar) = 12.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nvar))
      allocate (derivs(3,n))
c
c     convert atomic coordinates to optimization parameters
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         xx(nvar) = x(k) * scale(nvar)
         nvar = nvar + 1
         xx(nvar) = y(k) * scale(nvar)
         nvar = nvar + 1
         xx(nvar) = z(k) * scale(nvar)
      end do
c
c     make the call to the optimization routine
c
      call ocvm (nvar,xx,minimum,grdmin,optimiz1,optsave)
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         x(k) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         y(k) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         z(k) = xx(nvar) / scale(nvar)
      end do
c
c     compute the final function and RMS gradient values
c
      if (analytic) then
         call gradient (minimum,derivs)
      else
         minimum = energy ()
         call numgrad (energy,derivs,eps)
      end if
      if (use_freeze)  call shakeg (derivs)
      gnorm = 0.0d0
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            gnorm = gnorm + derivs(j,k)**2
         end do
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(nvar/3))
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      deallocate (derivs)
c
c     write out the final function and gradient values
c
      if (digits .ge. 8) then
         if (grms .gt. 1.0d-8) then
            write (iout,40)  minimum,grms,gnorm
   40       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,f20.8,
     &              /,' Final Gradient Norm :',3x,f20.8)
         else
            write (iout,50)  minimum,grms,gnorm
   50       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,d20.8,
     &              /,' Final Gradient Norm :',3x,d20.8)
         end if
      else if (digits .ge. 6) then
         if (grms .gt. 1.0d-6) then
            write (iout,60)  minimum,grms,gnorm
   60       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,f18.6,
     &              /,' Final Gradient Norm :',3x,f18.6)
         else
            write (iout,70)  minimum,grms,gnorm
   70       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,d18.6,
     &              /,' Final Gradient Norm :',3x,d18.6)
         end if
      else
         if (grms .gt. 1.0d-4) then
            write (iout,80)  minimum,grms,gnorm
   80       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,f16.4,
     &              /,' Final Gradient Norm :',3x,f16.4)
         else
            write (iout,90)  minimum,grms,gnorm
   90       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,d16.4,
     &              /,' Final Gradient Norm :',3x,d16.4)
         end if
      end if
c
c     move stray molecules into periodic box if desired
c
      if (use_wrap)  call bounds
c
c     write the final coordinates into a file
c
      imin = freeunit ()
      open (unit=imin,file=minfile,status='old')
      rewind (unit=imin)
      call prtxyz (imin)
      close (unit=imin)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  function optimiz1  --  energy and gradient for optimize  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "optimiz1" is a service routine that computes the energy and
c     gradient for optimally conditioned variable metric optimization
c     in Cartesian coordinate space
c
c
      function optimiz1 (xx,g)
      use atoms
      use freeze
      use scales
      use usage
      implicit none
      integer i,k,nvar
      real*8 optimiz1,e
      real*8 energy,eps
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
      logical analytic
      external energy
c
c
c     use either analytical or numerical gradients
c
      analytic = .true.
      eps = 0.00001d0
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         x(k) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         y(k) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         z(k) = xx(nvar) / scale(nvar)
      end do
c
c     adjust atomic coordinates to satisfy distance constraints
c
      if (use_freeze)  call shake (x,y,z)
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the energy and gradient
c
      if (analytic) then
         call gradient (e,derivs)
      else
         e = energy ()
         call numgrad (energy,derivs,eps)
      end if
      optimiz1 = e
c
c     adjust gradient to remove components along constraints
c
      if (use_freeze)  call shakeg (derivs)
c
c     convert gradient components to optimization parameters
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         xx(nvar) = x(k) * scale(nvar)
         g(nvar) = derivs(1,k) / scale(nvar)
         nvar = nvar + 1
         xx(nvar) = y(k) * scale(nvar)
         g(nvar) = derivs(2,k) / scale(nvar)
         nvar = nvar + 1
         xx(nvar) = z(k) * scale(nvar)
         g(nvar) = derivs(3,k) / scale(nvar)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2018  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine optinit  --  initialize structure optimization  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "optinit" initializes values and keywords used by multiple
c     structure optimization methods
c
c
      subroutine optinit
      use bound
      use inform
      use keys
      use output
      use potent
      implicit none
      integer i,next
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set default values for optimization parameters
c
      iprint = -1
      iwrite = -1
      use_wrap = .false.
      frcsave = .false.
      uindsave = .false.
c
c     check for keywords containing any altered parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:9) .eq. 'PRINTOUT ') then
            read (string,*,err=10,end=10)  iprint
         else if (keyword(1:9) .eq. 'WRITEOUT ') then
            read (string,*,err=10,end=10)  iwrite
         else if (keyword(1:12) .eq. 'WRAP-COORDS ') then
            use_wrap = .true.
         else if (keyword(1:11) .eq. 'SAVE-FORCE ') then
            frcsave = .true.
         else if (keyword(1:13) .eq. 'SAVE-INDUCED ') then
            uindsave = .true.
         end if
   10    continue
      end do
c
c     check for use of induced dipole prediction methods
c
      if (use_polar)  call predict
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program optirot  --  variable metric torsional optimizer  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "optirot" performs an energy minimization in torsional angle
c     space using an optimally conditioned variable metric method
c
c
      program optirot
      use files
      use inform
      use iounit
      use math
      use omega
      use scales
      use zcoord
      implicit none
      integer i,imin
      integer freeunit
      real*8 minimum,optirot1
      real*8 grdmin,gnorm,grms
      real*8, allocatable :: xx(:)
      real*8, allocatable :: derivs(:)
      logical exist
      character*240 minfile
      character*240 string
      external optirot1
      external optsave
c
c
c     set up the molecular mechanics calculation
c
      call initial
      call getint
      call mechanic
c
c     perform the setup functions needed for optimization
c
      call optinit
      call initrot
c
c     get termination criterion as RMS torsional gradient
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  grdmin
   10 continue
      if (grdmin .le. 0.0d0) then
         write (iout,20)
   20    format (/,' Enter RMS Gradient per Torsion Criterion',
     &              ' [0.01] :  ',$)
         read (input,30)  grdmin
   30    format (f20.0)
      end if
      if (grdmin .eq. 0.0d0)  grdmin = 0.01d0
c
c     write out a copy of coordinates for later update
c
      imin = freeunit ()
      minfile = filename(1:leng)//'.int'
      call version (minfile,'new')
      open (unit=imin,file=minfile,status='new')
      call prtint (imin)
      close (unit=imin)
      outfile = minfile
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(scale))  allocate (scale(nomega))
c
c     set scaling parameter for function and derivative values;
c     use square root of median eigenvalue of typical Hessian
c
      set_scale = .true.
      do i = 1, nomega
         scale(i) = 5.0d0
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nomega))
c
c     convert dihedral angles to optimization parameters
c
      do i = 1, nomega
         xx(i) = dihed(i) * scale(i)
      end do
c
c     make the call to the optimization routine
c
      call ocvm (nomega,xx,minimum,grdmin,optirot1,optsave)
c
c     convert optimization parameters to dihedral angles
c
      do i = 1, nomega
         dihed(i) = xx(i) / scale(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(nomega))
c
c     compute the final function and RMS gradient values
c
      call gradrot (minimum,derivs)
      gnorm = 0.0d0
      do i = 1, nomega
         gnorm = gnorm + derivs(i)**2
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(nomega))
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
c
c     write out the final function and gradient values
c
      if (digits .ge. 8) then
         if (grms .gt. 1.0d-8) then
            write (iout,40)  minimum,grms,gnorm
   40       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,f20.8,
     &              /,' Final Gradient Norm :',3x,f20.8)
         else
            write (iout,50)  minimum,grms,gnorm
   50       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,d20.8,
     &              /,' Final Gradient Norm :',3x,d20.8)
         end if
      else if (digits .ge. 6) then
         if (grms .gt. 1.0d-6) then
            write (iout,60)  minimum,grms,gnorm
   60       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,f18.6,
     &              /,' Final Gradient Norm :',3x,f18.6)
         else
            write (iout,70)  minimum,grms,gnorm
   70       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,d18.6,
     &              /,' Final Gradient Norm :',3x,d18.6)
         end if
      else
         if (grms .gt. 1.0d-4) then
            write (iout,80)  minimum,grms,gnorm
   80       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,f16.4,
     &              /,' Final Gradient Norm :',3x,f16.4)
         else
            write (iout,90)  minimum,grms,gnorm
   90       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,d16.4,
     &              /,' Final Gradient Norm :',3x,d16.4)
         end if
      end if
c
c     write the final coordinates into a file
c
      imin = freeunit ()
      open (unit=imin,file=minfile,status='old')
      rewind (unit=imin)
      call prtint (imin)
      close (unit=imin)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function optirot1  --  energy and gradient for optirot  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "optirot1" is a service routine that computes the energy and
c     gradient for optimally conditioned variable metric optimization
c     in torsional angle space
c
c
      function optirot1 (xx,g)
      use math
      use omega
      use scales
      use zcoord
      implicit none
      integer i
      real*8 optirot1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:)
c
c
c     convert optimization parameters to dihedral angles
c
      do i = 1, nomega
         dihed(i) = xx(i) / scale(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(nomega))
c
c     get coordinates, then compute energy and gradient
c
      call makexyz
      call gradrot (e,derivs)
      optirot1 = e
c
c     convert torsional gradient to optimization parameters
c
      do i = 1, nomega
         g(i) = derivs(i) / scale(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  program optrigid  --  variable metric rigid body optimizer  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "optrigid" performs an energy minimization of rigid body atom
c     groups using an optimally conditioned variable metric method
c
c
      program optrigid
      use files
      use group
      use inform
      use iounit
      use output
      use rigid
      implicit none
      integer i,j
      integer imin,nvar
      integer freeunit
      real*8 minimum,optrigid1
      real*8 grdmin,grms,gnorm
      real*8, allocatable :: xx(:)
      real*8, allocatable :: derivs(:,:)
      logical exist
      character*240 minfile
      character*240 string
      external optrigid1
      external optsave
c
c
c     set up the molecular mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     set up the use of rigid body coordinate system
c
      coordtype = 'RIGIDBODY'
      use_rigid = .true.
      call orient
c
c     perform the setup functions needed for optimization
c
      call optinit
c
c     get termination criterion as RMS rigid body gradient
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  grdmin
   10 continue
      if (grdmin .le. 0.0d0) then
         write (iout,20)
   20    format (/,' Enter RMS Gradient per Rigid Body Criterion',
     &              ' [0.01] :  ',$)
         read (input,30)  grdmin
   30    format (f20.0)
      end if
      if (grdmin .eq. 0.0d0)  grdmin = 0.01d0
c
c     write out a copy of coordinates for later update
c
      imin = freeunit ()
      minfile = filename(1:leng)//'.xyz'
      call version (minfile,'new')
      open (unit=imin,file=minfile,status='new')
      call prtxyz (imin)
      close (unit=imin)
      outfile = minfile
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(6*ngrp))
c
c     convert rigid body coordinates to optimization parameters
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            xx(nvar) = rbc(j,i)
         end do
      end do
c
c     make the call to the optimization routine
c
      call ocvm (nvar,xx,minimum,grdmin,optrigid1,optsave)
c
c     convert optimization parameters to rigid body coordinates
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            rbc(j,i) = xx(nvar)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(6,ngrp))
c
c     compute the final function and RMS gradient values
c
      call gradrgd (minimum,derivs)
      gnorm = 0.0d0
      do i = 1, ngrp
         do j = 1, 6
            gnorm = gnorm + derivs(j,i)**2
         end do
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(ngrp))
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
c
c     write out the final function and gradient values
c
      if (digits .ge. 8) then
         if (grms .gt. 1.0d-8) then
            write (iout,40)  minimum,grms,gnorm
   40       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,f20.8,
     &              /,' Final Gradient Norm :',3x,f20.8)
         else
            write (iout,50)  minimum,grms,gnorm
   50       format (/,' Final Function Value :',2x,f20.8,
     &              /,' Final RMS Gradient :',4x,d20.8,
     &              /,' Final Gradient Norm :',3x,d20.8)
         end if
      else if (digits .ge. 6) then
         if (grms .gt. 1.0d-6) then
            write (iout,60)  minimum,grms,gnorm
   60       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,f18.6,
     &              /,' Final Gradient Norm :',3x,f18.6)
         else
            write (iout,70)  minimum,grms,gnorm
   70       format (/,' Final Function Value :',2x,f18.6,
     &              /,' Final RMS Gradient :',4x,d18.6,
     &              /,' Final Gradient Norm :',3x,d18.6)
         end if
      else
         if (grms .gt. 1.0d-4) then
            write (iout,80)  minimum,grms,gnorm
   80       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,f16.4,
     &              /,' Final Gradient Norm :',3x,f16.4)
         else
            write (iout,90)  minimum,grms,gnorm
   90       format (/,' Final Function Value :',2x,f16.4,
     &              /,' Final RMS Gradient :',4x,d16.4,
     &              /,' Final Gradient Norm :',3x,d16.4)
         end if
      end if
c
c     write the final coordinates into a file
c
      imin = freeunit ()
      open (unit=imin,file=minfile,status='old')
      rewind (unit=imin)
      call prtxyz (imin)
      close (unit=imin)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function optrigid1  --  energy and gradient for optrigid  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "optrigid1" is a service routine that computes the energy
c     and gradient for optimally conditioned variable metric
c     optimization of rigid bodies
c
c
      function optrigid1 (xx,g)
      use group
      use math
      use rigid
      implicit none
      integer i,j,nvar
      real*8 optrigid1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to rigid body coordinates
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            rbc(j,i) = xx(nvar)
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(6,ngrp))
c
c     compute and store the energy and gradient
c
      call rigidxyz
      call gradrgd (e,derivs)
      optrigid1 = e
c
c     convert rigid body gradient to optimization parameters
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            g(nvar) = derivs(j,i)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine optsave  --  save optimization info and results  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "optsave" is used by the optimizers to write imtermediate
c     coordinates and other relevant information; also checks for
c     user requested termination of an optimization
c
c
      subroutine optsave (ncycle,f,xx)
      use atomid
      use atoms
      use bound
      use deriv
      use files
      use group
      use iounit
      use math
      use mpole
      use omega
      use output
      use polar
      use potent
      use scales
      use socket
      use titles
      use units
      use usage
      use zcoord
      implicit none
      integer i,ii,lext
      integer ixyz,ifrc
      integer iind,iend
      integer ncycle,nvar
      integer freeunit
      integer trimtext
      real*8 f,xx(*)
      logical exist,first
      character*7 ext
      character*240 xyzfile
      character*240 frcfile
      character*240 indfile
      character*240 endfile
c
c
c     nothing to do if coordinate type is undefined
c
      if (coordtype .eq. 'NONE')  return
c
c     check scaling factors for optimization parameters
c
      if (.not. set_scale) then
         set_scale = .true.
         if (coordtype .eq. 'CARTESIAN') then
            if (.not. allocated(scale))  allocate (scale(3*n))
            do i = 1, 3*n
               scale(i) = 1.0d0
            end do
         else if (coordtype .eq. 'INTERNAL') then
            if (.not. allocated(scale))  allocate (scale(nomega))
            do i = 1, nomega
               scale(i) = 1.0d0
            end do
         else if (coordtype .eq. 'RIGIDBODY') then
            if (.not. allocated(scale))  allocate (scale(6*ngrp))
            do i = 1, 6*ngrp
               scale(i) = 1.0d0
            end do
         end if
      end if
c
c     convert optimization parameters to atomic coordinates
c
      if (coordtype .eq. 'CARTESIAN') then
         nvar = 0
         do ii = 1, nuse
            i = iuse(ii)
            nvar = nvar + 1
            x(i) = xx(nvar) / scale(nvar)
            nvar = nvar + 1
            y(i) = xx(nvar) / scale(nvar)
            nvar = nvar + 1
            z(i) = xx(nvar) / scale(nvar)
         end do
      else if (coordtype .eq. 'INTERNAL') then
         do i = 1, nomega
            dihed(i) = xx(i) / scale(i)
            ztors(zline(i)) = dihed(i) * radian
         end do
      end if
c
c     move stray molecules into periodic box if desired
c
      if (coordtype .eq. 'CARTESIAN') then
         if (use_wrap)  call bounds
      end if
c
c     save coordinates to archive or numbered structure file
c
      ixyz = freeunit ()
      if (cyclesave) then
         if (dcdsave) then
            xyzfile = filename(1:leng)
            call suffix (xyzfile,'dcd','old')
            inquire (file=xyzfile,exist=exist)
            if (exist) then
               first = .false.
               open (unit=ixyz,file=xyzfile,form='unformatted',
     &                  status='old',position='append')
            else
               first = .true.
               open (unit=ixyz,file=xyzfile,form='unformatted',
     &                  status='new')
            end if
            call prtdcd (ixyz,first)
         else if (arcsave) then
            xyzfile = filename(1:leng)
            call suffix (xyzfile,'arc','old')
            inquire (file=xyzfile,exist=exist)
            if (exist) then
               call openend (ixyz,xyzfile)
            else
               open (unit=ixyz,file=xyzfile,status='new')
            end if
         else
            lext = 3
            call numeral (ncycle,ext,lext)
            xyzfile = filename(1:leng)//'.'//ext(1:lext)
            call version (xyzfile,'new')
            open (unit=ixyz,file=xyzfile,status='new')
         end if
      else
         xyzfile = outfile
         call version (xyzfile,'old')
         open (unit=ixyz,file=xyzfile,status='old')
         rewind (unit=ixyz)
      end if
c
c     update intermediate file with desired coordinate type
c
      if (coordtype .eq. 'CARTESIAN') then
         if (.not. dcdsave)  call prtxyz (ixyz)
      else if (coordtype .eq. 'INTERNAL') then
         call prtint (ixyz)
      else if (coordtype .eq. 'RIGIDBODY') then
         call prtxyz (ixyz)
      end if
      close (unit=ixyz)
c
c     save the force vector components for the current step
c
      if (frcsave .and. coordtype.eq.'CARTESIAN') then
         ifrc = freeunit ()
         if (cyclesave) then
            if (dcdsave) then
               frcfile = filename(1:leng)
               call suffix (frcfile,'dcdf','old')
               inquire (file=frcfile,exist=exist)
               if (exist) then
                  first = .false.
                  open (unit=ifrc,file=frcfile,form='unformatted',
     &                     status='old',position='append')
               else
                  first = .true.
                  open (unit=ifrc,file=frcfile,form='unformatted',
     &                     status='new')
               end if
               call prtdcdf (ifrc,first)
            else if (arcsave) then
               frcfile = filename(1:leng)
               call suffix (frcfile,'frc','old')
               inquire (file=frcfile,exist=exist)
               if (exist) then
                  call openend (ifrc,frcfile)
               else
                  open (unit=ifrc,file=frcfile,status='new')
               end if
               call prtfrc (ifrc)
            else
               frcfile = filename(1:leng)//'.'//ext(1:lext)//'f'
               call version (frcfile,'new')
               open (unit=ifrc,file=frcfile,status='new')
               call prtfrc (ifrc)
            end if
         else
            frcfile = filename(1:leng)
            call suffix (frcfile,'frc','old')
            call version (frcfile,'old')
            inquire (file=frcfile,exist=exist)
            if (exist) then
               open (unit=ifrc,file=frcfile,status='old')
            else
               open (unit=ifrc,file=frcfile,status='new')
            end if
            rewind (unit=ifrc)
            call prtfrc (ifrc)
         end if
         close (unit=ifrc)
         write (iout,10)  frcfile(1:trimtext(frcfile))
   10    format (' Force Vector File',11x,a)
      end if
c
c     save the current induced dipole moment at each site
c
      if (uindsave .and. use_polar .and. coordtype.eq.'CARTESIAN') then
         iind = freeunit ()
         if (cyclesave) then
            if (dcdsave) then
               indfile = filename(1:leng)
               call suffix (indfile,'dcdu','old')
               inquire (file=indfile,exist=exist)
               if (exist) then
                  first = .false.
                  open (unit=iind,file=indfile,form='unformatted',
     &                     status='old',position='append')
               else
                  first = .true.
                  open (unit=iind,file=indfile,form='unformatted',
     &                     status='new')
               end if
               call prtdcdu (iind,first)
            else if (arcsave) then
               indfile = filename(1:leng)
               call suffix (indfile,'uind','old')
               inquire (file=indfile,exist=exist)
               if (exist) then
                  call openend (iind,indfile)
               else
                  open (unit=iind,file=indfile,status='new')
               end if
               call prtuind (iind)
            else
               indfile = filename(1:leng)//'.'//ext(1:lext)//'u'
               call version (indfile,'new')
               open (unit=iind,file=indfile,status='new')
               call prtuind (iind)
            end if
         else
            indfile = filename(1:leng)
            call suffix (indfile,'uind','old')
            call version (indfile,'old')
            inquire (file=indfile,exist=exist)
            if (exist) then
               open (unit=iind,file=indfile,status='old')
            else
               open (unit=iind,file=indfile,status='new')
            end if
            rewind (unit=iind)
            call prtuind (iind)
         end if
         close (unit=iind)
         write (iout,20)  indfile(1:trimtext(indfile))
   20    format (' Induced Dipole File',10x,a)
      end if
c
c     send data via external socket communication if desired
c
      if (.not.sktstart .or. use_socket) then
         if (coordtype .eq. 'INTERNAL')  call makexyz
         call sktopt (ncycle,f)
      end if
c
c     test for requested termination of the optimization
c
      endfile = 'tinker.end'
      inquire (file=endfile,exist=exist)
      if (.not. exist) then
         endfile = filename(1:leng)//'.end'
         inquire (file=endfile,exist=exist)
         if (exist) then
            iend = freeunit ()
            open (unit=iend,file=endfile,status='old')
            close (unit=iend,status='delete')
         end if
      end if
      if (exist) then
         write (iout,30)
   30    format (/,' OPTSAVE  --  Optimization Calculation Ending',
     &              ' due to User Request')
         call fatal
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine orbital  --  setup for pisystem calculation  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "orbital" finds and organizes lists of atoms in a pisystem,
c     bonds connecting pisystem atoms and torsions whose central
c     atoms are both pisystem atoms
c
c
      subroutine orbital
      use atoms
      use bndstr
      use couple
      use iounit
      use keys
      use piorbs
      use potent
      use tors
      implicit none
      integer i,j,k,m,ii
      integer mi,mj,mk
      integer iorb,jorb,korb
      integer nlist,next
      integer, allocatable :: list(:)
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(iorbit))  deallocate (iorbit)
      if (allocated(iconj))  deallocate (iconj)
      if (allocated(kconj))  deallocate (kconj)
      if (allocated(piperp))  deallocate (piperp)
      if (allocated(ibpi))  deallocate (ibpi)
      if (allocated(itpi))  deallocate (itpi)
      if (allocated(pbpl))  deallocate (pbpl)
      if (allocated(pnpl))  deallocate (pnpl)
      if (allocated(listpi))  deallocate (listpi)
      allocate (iorbit(n))
      allocate (iconj(2,n))
      allocate (kconj(n))
      allocate (piperp(3,n))
      allocate (ibpi(3,nbond))
      allocate (itpi(2,ntors))
      allocate (pbpl(nbond))
      allocate (pnpl(nbond))
      allocate (listpi(n))
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
c
c     set the default values for the pisystem variables
c
      nlist = 0
      do i = 1, n
         list(i) = 0
      end do
      reorbit = 1
c
c     check the keywords for any lists of pisystem atoms
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:9) .eq. 'PISYSTEM ') then
            string = record(next:240)
            read (string,*,err=10,end=10)  (list(k),k=nlist+1,n)
   10       continue
            do while (list(nlist+1) .ne. 0)
               nlist = nlist + 1
               list(nlist) = max(-n,min(n,list(nlist)))
            end do
         end if
      end do
c
c     quit if no pisystem was found for consideration
c
      if (list(1) .eq. 0) then
         use_orbit = .false.
         return
      else
         use_orbit = .true.
      end if
c
c     organize and make lists of the pisystem atoms
c
      do i = 1, n
         listpi(i) = .false.
      end do
      i = 1
      do while (list(i) .ne. 0)
         if (list(i) .gt. 0) then
            listpi(list(i)) = .true.
            i = i + 1
         else
            do j = -list(i), list(i+1)
               listpi(j) = .true.
            end do
            i = i + 2
         end if
      end do
c
c     set number of orbitals and an initial orbital list
c
      norbit = 0
      nconj = 0
      do i = 1, n
         list(i) = 0
         if (listpi(i)) then
            norbit = norbit + 1
            iorbit(norbit) = i
         end if
      end do
c
c     assign each orbital to its respective pisystem
c
      do i = 1, norbit
         iorb = iorbit(i)
         if (list(iorb) .eq. 0) then
            nconj = nconj + 1
            list(iorb) = nconj
         end if
         mi = list(iorb)
         do ii = 1, n12(iorb)
            j = i12(ii,iorb)
            if (listpi(j)) then
               mj = list(j)
               if (mj .eq. 0) then
                  list(j) = mi
               else if (mi .lt. mj) then
                  nconj = nconj - 1
                  do k = 1, norbit
                     korb = iorbit(k)
                     mk = list(korb)
                     if (mk .eq. mj) then
                        list(korb) = mi
                     else if (mk .gt. mj) then
                        list(korb) = mk - 1
                     end if
                  end do
               else if (mi .gt. mj) then
                  nconj = nconj - 1
                  do k = 1, norbit
                     korb = iorbit(k)
                     mk = list(korb)
                     if (mk .eq. mi) then
                        list(korb) = mj
                     else if (mk .gt. mi) then
                        list(korb) = mk - 1
                     end if
                  end do
                  mi = mj
               end if
            end if
         end do
      end do
c
c     pack atoms of each pisystem into a contiguous indexed list
c
      call sort3 (n,list,kconj)
      k = n - norbit
      do i = 1, norbit
         k = k + 1
         list(i) = list(k)
         kconj(i) = kconj(k)
      end do
c
c     find the first and last piatom in each pisystem
c
      k = 1
      iconj(1,1) = 1
      do i = 2, norbit
         j = list(i)
         if (j .ne. k) then
            iconj(2,k) = i - 1
            k = j
            iconj(1,k) = i
         end if
      end do
      iconj(2,nconj) = norbit
c
c     perform deallocation of some local arrays
c
      deallocate (list)
c
c     sort atoms in each pisystem, copy list to orbital sites
c
      do i = 1, nconj
         k = iconj(2,i) - iconj(1,i) + 1
         call sort (k,kconj(iconj(1,i)))
      end do
      do i = 1, norbit
         iorbit(i) = kconj(i)
      end do
c
c     find atoms defining a plane perpendicular to each orbital
c
      call piplane
c
c     find and store all of the pisystem bonds
c
      nbpi = 0
      do ii = 1, nconj
         do i = iconj(1,ii), iconj(2,ii)-1
            iorb = kconj(i)
            do j = i+1, iconj(2,ii)
               jorb = kconj(j)
               do k = 1, n12(iorb)
                  if (i12(k,iorb) .eq. jorb) then
                     nbpi = nbpi + 1
                     do m = 1, nbond
                        if (iorb.eq.ibnd(1,m) .and.
     &                      jorb.eq.ibnd(2,m)) then
                           ibpi(1,nbpi) = m
                           ibpi(2,nbpi) = i
                           ibpi(3,nbpi) = j
                           goto 20
                        end if
                     end do
   20                continue
                  end if
               end do
            end do
         end do
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine piplane  --  plane perpendicular to orbital  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "piplane" selects the three atoms which specify the plane
c     perpendicular to each p-orbital; the current version will
c     fail in certain situations, including ketenes, allenes,
c     and isolated or adjacent triple bonds
c
c
      subroutine piplane
      use atomid
      use atoms
      use couple
      use iounit
      use piorbs
      implicit none
      integer i,j,iorb
      integer atmnum,trial
      integer alpha,beta,gamma
      integer attach
      logical done
c
c
c     for each pisystem atom, find a set of atoms which define
c     the p-orbital's plane based on piatom's atomic number and
c     the number and type of attached atoms
c
      do iorb = 1, norbit
         i = iorbit(iorb)
         attach = n12(i)
         atmnum = atomic(i)
         done = .false.
c
c     most common case of an atom bonded to three atoms
c
         if (attach .eq. 3) then
            piperp(1,i) = i12(1,i)
            piperp(2,i) = i12(2,i)
            piperp(3,i) = i12(3,i)
            done = .true.
c
c     any non-alkyne atom bonded to exactly two atoms
c
         else if (attach.eq.2 .and. atmnum.ne.6) then
            piperp(1,i) = i
            piperp(2,i) = i12(1,i)
            piperp(3,i) = i12(2,i)
            done = .true.
c
c     atom bonded to four different atoms (usually two lone
c     pairs and two "real" atoms); use the "real" atoms
c
         else if (attach .eq. 4) then
            piperp(1,i) = i
            do j = 1, n12(i)
               trial = i12(j,i)
               if (atomic(trial) .ne. 0) then
                  if (piperp(2,i) .eq. 0) then
                     piperp(2,i) = trial
                  else
                     piperp(3,i) = trial
                     done = .true.
                  end if
               end if
            end do
c
c     "carbonyl"-type oxygen atom, third atom is any atom
c     attached to the "carbonyl carbon"; fails for ketenes
c
         else if (attach.eq.1 .and. atmnum.eq.8) then
            alpha = i12(1,i)
            beta = i12(1,alpha)
            if (beta .eq. i)  beta = i12(2,alpha)
            piperp(1,i) = i
            piperp(2,i) = alpha
            piperp(3,i) = beta
            done = .true.
c
c     an sp nitrogen atom, third atom must be a gamma atom
c
         else if (attach.eq.1 .and. atmnum.eq.7) then
            alpha = i12(1,i)
            do j = 1, n12(alpha)
               trial = i12(j,alpha)
               if (trial.ne.i .and. listpi(trial) .and.
     &             n12(trial).eq.3) then
                  beta = trial
                  done = .true.
               end if
            end do
            gamma = i12(1,beta)
            if (gamma .eq. alpha)  gamma = i12(2,beta)
            piperp(1,i) = i
            piperp(2,i) = alpha
            piperp(3,i) = gamma
c
c     an sp carbon atom; third atom must be an atom attached
c     to the non-sp piatom bonded to the original carbon
c
         else if (attach.eq.2 .and. atmnum.eq.6) then
            alpha = i12(1,i)
            if ((n12(alpha).eq.2 .and. atomic(alpha).eq.6) .or.
     &          (n12(alpha).eq.1 .and. atomic(alpha).eq.7))
     &         alpha = i12(2,i)
            do j = 1, n12(i)
               trial = i12(j,i)
               if (trial.ne.i .and. trial.ne.alpha .and.
     &             listpi(trial) .and. n12(trial).eq.3) then
                  beta = trial
                  done = .true.
               end if
            end do
            do j = 1, n12(alpha)
               trial = i12(j,alpha)
               if (trial.ne.i .and. trial.ne.alpha .and.
     &             listpi(trial) .and. n12(trial).eq.3) then
                  beta = trial
                  done = .true.
               end if
            end do
            gamma = i12(1,beta)
            if (gamma.eq.i .or. gamma.eq.alpha)  gamma = i12(2,beta)
            piperp(1,i) = i
            piperp(2,i) = alpha
            piperp(3,i) = gamma
         end if
c
c     quit if the p-orbital plane remains undefined
c
         if (.not. done) then
            write (iout,10)  i
   10       format(/,' PIPLANE  --  Failure to Define',
     &                ' p-Orbital Plane for Atom',i6)
            call fatal
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module orbits  --  conjugated pisystem orbital energies  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     qorb    number of pi-electrons contributed by each atom
c     worb    ionization potential of each pisystem atom
c     emorb   repulsion integral for each pisystem atom
c
c
      module orbits
      implicit none
      real*8, allocatable :: qorb(:)
      real*8, allocatable :: worb(:)
      real*8, allocatable :: emorb(:)
      save
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 1997 by Rohit Pappu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine orient  --  rigid body reference coordinates  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "orient" computes a set of reference Cartesian coordinates
c     in standard orientation for each rigid body atom group
c
c
      subroutine orient
      use atoms
      use group
      use rigid
      implicit none
      integer i,j,k
      integer init,stop
      real*8 xcm,ycm,zcm
      real*8 phi,theta,psi
      real*8 xterm,yterm,zterm
      real*8 cphi,ctheta,cpsi
      real*8 sphi,stheta,spsi
      real*8 a(3,3)
c
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(xrb))  allocate (xrb(n))
      if (.not. allocated(yrb))  allocate (yrb(n))
      if (.not. allocated(zrb))  allocate (zrb(n))
      if (.not. allocated(rbc))  allocate (rbc(6,ngrp))
c
c     use current coordinates as default reference coordinates
c
      do i = 1, n
         xrb(i) = x(i)
         yrb(i) = y(i)
         zrb(i) = z(i)
      end do
c
c     compute the rigid body coordinates for each atom group
c
      call xyzrigid
c
c     get the center of mass and Euler angles for each group
c
      do i = 1, ngrp
         xcm = rbc(1,i)
         ycm = rbc(2,i)
         zcm = rbc(3,i)
         phi = rbc(4,i)
         theta = rbc(5,i)
         psi = rbc(6,i)
         cphi = cos(phi)
         sphi = sin(phi)
         ctheta = cos(theta)
         stheta = sin(theta)
         cpsi = cos(psi)
         spsi = sin(psi)
c
c     construct the rotation matrix from Euler angle values
c
         a(1,1) = ctheta * cphi
         a(2,1) = spsi*stheta*cphi - cpsi*sphi
         a(3,1) = cpsi*stheta*cphi + spsi*sphi
         a(1,2) = ctheta * sphi
         a(2,2) = spsi*stheta*sphi + cpsi*cphi
         a(3,2) = cpsi*stheta*sphi - spsi*cphi
         a(1,3) = -stheta
         a(2,3) = ctheta * spsi
         a(3,3) = ctheta * cpsi
c
c     translate and rotate each atom group into inertial frame
c
         init = igrp(1,i)
         stop = igrp(2,i)
         do j = init, stop
            k = kgrp(j)
            xterm = x(k) - xcm
            yterm = y(k) - ycm
            zterm = z(k) - zcm
            xrb(k) = a(1,1)*xterm + a(1,2)*yterm + a(1,3)*zterm
            yrb(k) = a(2,1)*xterm + a(2,2)*yterm + a(2,3)*zterm
            zrb(k) = a(3,1)*xterm + a(3,2)*yterm + a(3,3)*zterm
         end do
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine xyzrigid  --  determine rigid body coordinates  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "xyzrigid" computes the center of mass and Euler angle rigid
c     body coordinates for each atom group in the system
c
c     literature reference:
c
c     H. Goldstein, C. Poole and J. Safko, "Classical Mechanics,
c     3rd Edition", Addison-Wesley, Boston, MA, 2001; see the Euler
c     angle xyz convention in Appendix A
c
c
      subroutine xyzrigid
      use atoms
      use atomid
      use group
      use rigid
      implicit none
      integer i,j,k,m
      integer init,stop
      real*8 xcm,ycm,zcm
      real*8 phi,theta,psi
      real*8 weigh,total,dot
      real*8 xx,xy,xz,yy,yz,zz
      real*8 xterm,yterm,zterm
      real*8 moment(3)
      real*8 vec(3,3)
      real*8 tensor(3,3)
      real*8 a(3,3)
c
c
c     get the first and last atom in the current group
c
      do i = 1, ngrp
         init = igrp(1,i)
         stop = igrp(2,i)
c
c     compute the position of the group center of mass
c
         total = 0.0d0
         xcm = 0.0d0
         ycm = 0.0d0
         zcm = 0.0d0
         do j = init, stop
            k = kgrp(j)
            weigh = mass(k)
            total = total + weigh
            xcm = xcm + x(k)*weigh
            ycm = ycm + y(k)*weigh
            zcm = zcm + z(k)*weigh
         end do
         if (total .ne. 0.0d0) then
            xcm = xcm / total
            ycm = ycm / total
            zcm = zcm / total
         end if
c
c     compute and then diagonalize the inertia tensor
c
         xx = 0.0d0
         xy = 0.0d0
         xz = 0.0d0
         yy = 0.0d0
         yz = 0.0d0
         zz = 0.0d0
         do j = init, stop
            k = kgrp(j)
            weigh = mass(k)
            xterm = x(k) - xcm
            yterm = y(k) - ycm
            zterm = z(k) - zcm
            xx = xx + xterm*xterm*weigh
            xy = xy + xterm*yterm*weigh
            xz = xz + xterm*zterm*weigh
            yy = yy + yterm*yterm*weigh
            yz = yz + yterm*zterm*weigh
            zz = zz + zterm*zterm*weigh
         end do
         tensor(1,1) = yy + zz
         tensor(2,1) = -xy
         tensor(3,1) = -xz
         tensor(1,2) = -xy
         tensor(2,2) = xx + zz
         tensor(3,2) = -yz
         tensor(1,3) = -xz
         tensor(2,3) = -yz
         tensor(3,3) = xx + yy
         call jacobi (3,tensor,moment,vec)
c
c     select the direction for each principle moment axis
c
         do m = 1, 2
            do j = init, stop
               k = kgrp(j)
               xterm = vec(1,m) * (x(k)-xcm)
               yterm = vec(2,m) * (y(k)-ycm)
               zterm = vec(3,m) * (z(k)-zcm)
               dot = xterm + yterm + zterm
               if (dot .lt. 0.0d0) then
                  vec(1,m) = -vec(1,m)
                  vec(2,m) = -vec(2,m)
                  vec(3,m) = -vec(3,m)
               end if
               if (dot .ne. 0.0d0)  goto 10
            end do
   10       continue
         end do
c
c     moment axes must give a right-handed coordinate system
c
         xterm = vec(1,1) * (vec(2,2)*vec(3,3)-vec(2,3)*vec(3,2))
         yterm = vec(2,1) * (vec(1,3)*vec(3,2)-vec(1,2)*vec(3,3))
         zterm = vec(3,1) * (vec(1,2)*vec(2,3)-vec(1,3)*vec(2,2))
         dot = xterm + yterm + zterm
         if (dot .lt. 0.0d0) then
            do j = 1, 3
               vec(j,3) = -vec(j,3)
            end do
         end if
c
c     principal moment axes form rows of Euler rotation matrix
c
         do k = 1, 3
            do j = 1, 3
               a(k,j) = vec(j,k)
            end do
         end do
c
c     compute Euler angles consistent with the rotation matrix
c
         call roteuler (a,phi,theta,psi)
c
c     set the rigid body coordinates for each atom group
c
         rbc(1,i) = xcm
         rbc(2,i) = ycm
         rbc(3,i) = zcm
         rbc(4,i) = phi
         rbc(5,i) = theta
         rbc(6,i) = psi
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine roteuler  --  rotation matrix to Euler angles   ##
c     ##                                                             ##
c     #################################################################
c
c
c     "roteuler" computes a set of Euler angle values consistent
c     with an input rotation matrix
c
c
      subroutine roteuler (a,phi,theta,psi)
      use math
      implicit none
      integer i
      real*8 phi,theta,psi,eps
      real*8 cphi,ctheta,cpsi
      real*8 sphi,stheta,spsi
      real*8 a(3,3),b(3)
      logical flip(3)
c
c
c     set the tolerance for Euler angles and rotation elements
c
      eps = 1.0d-7
c
c     get a trial value of theta from a single rotation element
c
      theta = asin(min(1.0d0,max(-1.0d0,-a(1,3))))
      ctheta = cos(theta)
      stheta = -a(1,3)
c
c     set the phi/psi difference when theta is either 90 or -90
c
      if (abs(ctheta) .le. eps) then
         phi = 0.0d0
         if (abs(a(3,1)) .lt. eps) then
            psi = asin(min(1.0d0,max(-1.0d0,-a(2,1)/a(1,3))))
         else if (abs(a(2,1)) .lt. eps) then
            psi = acos(min(1.0d0,max(-1.0d0,-a(3,1)/a(1,3))))
         else
            psi = atan(a(2,1)/a(3,1))
         end if
c
c     set the phi and psi values for all other theta values
c
      else
         if (abs(a(1,1)) .lt. eps) then
            phi = asin(min(1.0d0,max(-1.0d0,a(1,2)/ctheta)))
         else if (abs(a(1,2)) .lt. eps) then
            phi = acos(min(1.0d0,max(-1.0d0,a(1,1)/ctheta)))
         else
            phi = atan(a(1,2)/a(1,1))
         end if
         if (abs(a(3,3)) .lt. eps) then
            psi = asin(min(1.0d0,max(-1.0d0,a(2,3)/ctheta)))
         else if (abs(a(2,3)) .lt. eps) then
            psi = acos(min(1.0d0,max(-1.0d0,a(3,3)/ctheta)))
         else
            psi = atan(a(2,3)/a(3,3))
         end if
      end if
c
c     find sine and cosine of the trial phi and psi values
c
      cphi = cos(phi)
      sphi = sin(phi)
      cpsi = cos(psi)
      spsi = sin(psi)
c
c     reconstruct the diagonal of the rotation matrix
c
      b(1) = ctheta * cphi
      b(2) = spsi*stheta*sphi + cpsi*cphi
      b(3) = ctheta * cpsi
c
c     compare the correct matrix diagonal to rebuilt diagonal
c
      do i = 1, 3
         flip(i) = .false.
         if (abs(a(i,i)-b(i)) .gt. eps)  flip(i) = .true.
      end do
c
c     alter Euler angles to get correct rotation matrix values
c
      if (flip(1) .and. flip(2))  phi = phi - sign(pi,phi)
      if (flip(1) .and. flip(3))  theta = -theta + sign(pi,theta)
      if (flip(2) .and. flip(3))  psi = psi - sign(pi,psi)
c
c     convert maximum negative angles to positive values
c
      if (phi .le. -pi)  phi = pi
      if (theta .le. -pi)  theta = pi
      if (psi .le. -pi)  psi = pi
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine rigidxyz  --  rigid body to Cartesian coords  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "rigidxyz" computes Cartesian coordinates for a rigid body
c     group via rotation and translation of reference coordinates
c
c     literature reference:
c
c     H. Goldstein, C. Poole and J. Safko, "Classical Mechanics,
c     3rd Edition", Addison-Wesley, Boston, MA, 2001; see the Euler
c     angle xyz convention in Appendix A
c
c
      subroutine rigidxyz
      use atoms
      use group
      use rigid
      implicit none
      integer i,j,k
      integer init,stop
      real*8 xcm,ycm,zcm
      real*8 phi,theta,psi
      real*8 xterm,yterm,zterm
      real*8 cphi,ctheta,cpsi
      real*8 sphi,stheta,spsi
      real*8 a(3,3)
c
c
c     get the center of mass and Euler angles for each group
c
      do i = 1, ngrp
         xcm = rbc(1,i)
         ycm = rbc(2,i)
         zcm = rbc(3,i)
         phi = rbc(4,i)
         theta = rbc(5,i)
         psi = rbc(6,i)
         cphi = cos(phi)
         sphi = sin(phi)
         ctheta = cos(theta)
         stheta = sin(theta)
         cpsi = cos(psi)
         spsi = sin(psi)
c
c     construct the rotation matrix from Euler angle values
c
         a(1,1) = ctheta * cphi
         a(2,1) = spsi*stheta*cphi - cpsi*sphi
         a(3,1) = cpsi*stheta*cphi + spsi*sphi
         a(1,2) = ctheta * sphi
         a(2,2) = spsi*stheta*sphi + cpsi*cphi
         a(3,2) = cpsi*stheta*sphi - spsi*cphi
         a(1,3) = -stheta
         a(2,3) = ctheta * spsi
         a(3,3) = ctheta * cpsi
c
c     rotate and translate reference coordinates into global frame
c
         init = igrp(1,i)
         stop = igrp(2,i)
         do j = init, stop
            k = kgrp(j)
            xterm = xrb(k)
            yterm = yrb(k)
            zterm = zrb(k)
            x(k) = a(1,1)*xterm + a(2,1)*yterm + a(3,1)*zterm + xcm
            y(k) = a(1,2)*xterm + a(2,2)*yterm + a(3,2)*zterm + ycm
            z(k) = a(1,3)*xterm + a(2,3)*yterm + a(3,3)*zterm + zcm
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine orthog  --  Gram-Schmidt orthogonalization  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "orthog" performs an orthogonalization of an input matrix
c     via the modified Gram-Schmidt algorithm
c
c     variables and parameters:
c
c     m     first dimension of the matrix to orthogonalize
c     n     second dimension of the matrix to orthogonalize
c     a     matrix to orthogonalize; contains result on exit
c
c
      subroutine orthog (m,n,a)
      implicit none
      integer i,j,k
      integer m,n
      real*8 rkk,rkj
      real*8 a(m,*)
c
c
c     compute the modified Gram-Schmidt orthogonalization
c
      do k = 1, n
         rkk = 0.0d0
         do i = 1, m
            rkk = rkk + a(i,k)**2
         end do
         rkk = sqrt(rkk)
         do i = 1, m
            a(i,k) = a(i,k) / rkk
         end do
         do j = k+1, n
            rkj = 0.0d0
            do i = 1, m
               rkj = rkj + a(i,k)*a(i,j)
            end do
            do i = 1, m
               a(i,j) = a(i,j) - a(i,k)*rkj
            end do
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module output  --  output file format control parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     archive     logical flag for coordinates in Tinker XYZ format
c     binary      logical flag for coordinates in DCD binary format
c     noversion   logical flag governing use of filename versions
c     overwrite   logical flag to overwrite intermediate files inplace
c     arcsave     logical flag to save coordinates in Tinker XYZ format
c     dcdsave     logical flag to save coordinates in DCD binary format
c     cyclesave   logical flag to mark use of numbered cycle files
c     velsave     logical flag to save velocity vector components
c     frcsave     logical flag to save force vector components
c     uindsave    logical flag to save induced atomic dipoles
c     coordtype   selects Cartesian, internal, rigid body or none
c
c
      module output
      implicit none
      logical archive
      logical binary
      logical noversion
      logical overwrite
      logical cyclesave
      logical arcsave
      logical dcdsave
      logical velsave
      logical frcsave
      logical uindsave
      character*9 coordtype
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine overlap  --  p-orbital overlap for pisystem  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "overlap" computes the overlap for two parallel p-orbitals
c     given the atomic numbers and distance of separation
c
c
      subroutine overlap (atmnum1,atmnum2,rang,ovlap)
      use units
      implicit none
      integer atmnum1
      integer atmnum2
      integer na,nb,la,lb
      real*8 ovlap
      real*8 rbohr,rang
      real*8 za,zb,s(3)
      real*8 zeta(18)
      save zeta
c
c     Slater orbital exponents for hydrogen through argon
c
      data zeta  / 1.000, 1.700, 0.650, 0.975, 1.300, 1.625,
     &             1.950, 2.275, 2.600, 2.925, 0.733, 0.950,
     &             1.167, 1.383, 1.600, 1.817, 2.033, 2.250 /
c
c
c     principal quantum number from atomic number
c
      na = 2
      nb = 2
      if (atmnum1 .gt. 10)  na = 3
      if (atmnum2 .gt. 10)  nb = 3
c
c     azimuthal quantum number for p-orbitals
c
      la = 1
      lb = 1
c
c     orbital exponent from stored ideal values
c
      za = zeta(atmnum1)
      zb = zeta(atmnum2)
c
c     convert interatomic distance to bohrs
c
      rbohr = rang / bohr
c
c     get pi-overlap via generic overlap integral routine
c
      call slater (na,la,za,nb,lb,zb,rbohr,s)
      ovlap = s(2)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine slater  --  find overlap integrals for STO's  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "slater" is a general routine for computing the overlap
c     integrals between two Slater-type orbitals
c
c     literature reference:
c
c     D. B. Cook, "Structures and Approximations for Electrons in
c     Molecules", Ellis Horwood Limited, Sussex, England, 1978,
c     adapted from the code in Chapter 7
c
c     variables and parameters:
c
c     na   principle quantum number for first orbital
c     la   azimuthal quantum number for first orbital
c     za   orbital exponent for the first orbital
c     nb   principle quantum number for second orbital
c     lb   azimuthal quantum number for second orbital
c     zb   orbital exponent for the second orbital
c     r    interatomic distance in atomic units
c     s    vector containing the sigma-sigma, pi-pi
c            and delta-delta overlaps upon output
c
c
      subroutine slater (na,la,za,nb,lb,zb,r,s)
      implicit none
      real*8 rmin,eps
      parameter (rmin=0.000001d0)
      parameter (eps=0.00000001d0)
      integer j,k,m,na,nb,la,lb,ja,jb
      integer nn,max,maxx,novi
      integer idsga(5),idsgb(5)
      integer icosa(2),icosb(2)
      integer isina(4),isinb(4)
      integer ia(200),ib(200)
      real*8 an,ana,anb,anr
      real*8 rhalf,coef,p,pt
      real*8 r,za,zb,cjkm
      real*8 s(3),fact(15)
      real*8 cbase(20),theta(6)
      real*8 cosa(2),cosb(2)
      real*8 sinab(4)
      real*8 dsiga(5),dsigb(5)
      real*8 a(20),b(20),c(200)
      logical done
      save icosa,icosb
      save cosa,cosb
      save idsga,idsgb
      save dsiga,dsigb
      save isina,isinb
      save sinab,theta,fact
      external cjkm
      data icosa  / 0, 1 /
      data icosb  / 0, 1 /
      data cosa   /  1.0d0, 1.0d0 /
      data cosb   / -1.0d0, 1.0d0 /
      data idsga  / 0, 1, 2, 2, 0 /
      data idsgb  / 0, 1, 2, 0, 2 /
      data dsiga  / 3.0d0, 4.0d0, 3.0d0, -1.0d0, -1.0d0 /
      data dsigb  / 3.0d0,-4.0d0, 3.0d0, -1.0d0, -1.0d0 /
      data isina  / 0, 2, 0, 2 /
      data isinb  / 0, 0, 2, 2 /
      data sinab  / -1.0d0, 1.0d0, 1.0d0, -1.0d0 /
      data theta  / 0.7071068d0, 1.2247450d0, 0.8660254d0,
     &              0.7905694d0, 1.9364916d0, 0.9682458d0 /
      data fact   / 1.0d0, 1.0d0, 2.0d0, 6.0d0, 24.0d0, 120.0d0,
     &              720.0d0, 5040.0d0, 40320.0d0, 362880.0d0,
     &              3628800.0d0, 39916800.0d0, 479001600.0d0,
     &              6227020800.0d0, 87178291200.0d0 /
c
c
c     zero out the overlap integrals
c
      done = .false.
      s(1) = 0.0d0
      s(2) = 0.0d0
      s(3) = 0.0d0
      ana = (2.0d0*za)**(2*na+1) / fact(2*na+1)
      anb = (2.0d0*zb)**(2*nb+1) / fact(2*nb+1)
c
c     orbitals are on the same atomic center
c
      if (r .lt. rmin) then
         anr = 1.0d0
         j = na + nb + 1
         s(1) = fact(j) / ((za+zb)**j)
         an = sqrt(ana*anb)
         do novi = 1, 3
            s(novi) = s(novi) * an * anr
         end do
         return
      end if
c
c     compute overlap integrals for general case
c
      rhalf = 0.5d0 * r
      p = rhalf * (za+zb)
      pt = rhalf * (za-zb)
      nn = na + nb
      call aset (p,nn,a)
      call bset (pt,nn,b)
      k = na - la
      m = nb - lb
      max = k + m + 1
      do j = 1, max
         ia(j) = j - 1
         ib(j) = max - j
         cbase(j) = cjkm(j-1,k,m)
         c(j) = cbase(j)
      end do
      maxx = max
      if (la .eq. 1) then
         call polyp (c,ia,ib,maxx,cosa,icosa,icosb,2)
      else if (la .eq. 2) then
         call polyp (c,ia,ib,maxx,dsiga,idsga,idsgb,5)
      end if
      if (lb .eq. 1) then
         call polyp (c,ia,ib,maxx,cosb,icosa,icosb,2)
      else if (lb .eq. 2) then
         call polyp (c,ia,ib,maxx,dsigb,idsga,idsgb,5)
      end if
      novi = 1
      do while (.not. done)
         do j = 1, maxx
            ja = ia(j) + 1
            jb = ib(j) + 1
            coef = c(j)
            if (abs(coef) .ge. eps) then
               s(novi) = s(novi) + coef*a(ja)*b(jb)
            end if
         end do
         ja = la*(la+1)/2 + novi
         jb = lb*(lb+1)/2 + novi
         s(novi) = s(novi) * theta(ja) * theta(jb)
         if (novi.eq.1 .and. la.ne.0 .and. lb.ne.0) then
            maxx = max
            do j = 1, maxx
               c(j) = cbase(j)
            end do
            call polyp (c,ia,ib,maxx,sinab,isina,isinb,4)
            if (la .eq. 2) then
               call polyp (c,ia,ib,maxx,cosa,icosa,icosb,2)
            end if
            if (lb .eq. 2) then
               call polyp (c,ia,ib,maxx,cosb,icosa,icosb,2)
            end if
            novi = 2
         else if (novi.eq.2 .and. la.eq.2 .and. lb.eq.2) then
            maxx = max
            do j = 1, maxx
               c(j) = cbase(j)
            end do
            call polyp (c,ia,ib,maxx,sinab,isina,isinb,4)
            call polyp (c,ia,ib,maxx,sinab,isina,isinb,4)
            novi = 3
         else
            anr = rhalf**(na+nb+1)
            an = sqrt(ana*anb)
            do novi = 1, 3
               s(novi) = s(novi) * an * anr
            end do
            done = .true.
         end if
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine polyp  --  polynomial product for STO overlap  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "polyp" is a polynomial product routine that multiplies two
c     algebraic forms
c
c
      subroutine polyp (c,ia,ib,max,d,iaa,ibb,n)
      implicit none
      integer i,j,k,m,max,n
      integer ia(200),ib(200)
      integer iaa(*),ibb(*)
      real*8 c(200),d(*)
c
c
      do j = 1, max
         do k = 1, n
            i = n - k + 1
            m = (i-1)*max + j
            c(m) = c(j) * d(i)
            ia(m) = ia(j) + iaa(i)
            ib(m) = ib(j) + ibb(i)
         end do
      end do
      max = n * max
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function cjkm  --  coefficients of spherical harmonics  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "cjkm" computes the coefficients of spherical harmonics
c     expressed in prolate spheroidal coordinates
c
c
      function cjkm (j,k,m)
      implicit none
      integer i,j,k,m
      integer min,max
      integer id,idd,ip1
      real*8 cjkm,b1,b2,sum
      real*8 fact(15)
      save fact
      data fact  / 1.0d0, 1.0d0, 2.0d0, 6.0d0, 24.0d0, 120.0d0,
     &             720.0d0, 5040.0d0, 40320.0d0, 362880.0d0,
     &             3628800.0d0, 39916800.0d0, 479001600.0d0,
     &             6227020800.0d0, 87178291200.0d0 /
c
c
      min = 1
      if (j .gt. m)  min = j - m + 1
      max = j + 1
      if (k .lt. j)  max = k + 1
      sum = 0.0d0
      do ip1 = min, max
         i = ip1 - 1
         id = k - i + 1
         b1 = fact(k+1) / (fact(i+1)*fact(id))
         if (j .lt. i) then
            b2 = 1.0d0
         else
            id = m - (j-i) + 1
            idd = j - i + 1
            b2 = fact(m+1) / (fact(idd)*fact(id))
         end if
         sum = sum + b1*b2*(-1.0d0)**i
      end do
      cjkm = sum * (-1.0d0)**(m-j)
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine aset  --  get "A" functions by recursion  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "aset" computes by recursion the A functions used in the
c     evaluation of Slater-type (STO) overlap integrals
c
c
      subroutine aset (alpha,n,a)
      implicit none
      integer i,n
      real*8 alpha,alp
      real*8 a(20)
c
c
      alp = 1.0d0 / alpha
      a(1) = exp(-alpha) * alp
      do i = 1, n
         a(i+1) = a(1) + dble(i)*a(i)*alp
      end do
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine bset  --  get "B" functions by recursion  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "bset" computes by downward recursion the B functions used
c     in the evaluation of Slater-type (STO) overlap integrals
c
c
      subroutine bset (beta,n,b)
      implicit none
      real*8 eps
      parameter (eps=0.000001d0)
      integer i,j,n
      real*8 beta,bmax
      real*8 betam,d1,d2
      real*8 b(20)
      external bmax
c
c
      if (abs(beta) .lt. eps) then
         do i = 1, n+1
            b(i) = 2.0d0 / dble(i)
            if ((i/2)*2 .eq. i)  b(i) = 0.0d0
         end do
      else if (abs(beta) .gt. (dble(n)/2.3d0)) then
         d1 = exp(beta)
         d2 = 1.0d0 / d1
         betam = 1.0d0 / beta
         b(1) = (d1-d2) * betam
         do i = 1, n
            d1 = -d1
            b(i+1) = (d1-d2+dble(i)*b(i)) * betam
         end do
      else
         b(n+1) = bmax(beta,n)
         d1 = exp(beta)
         d2 = 1.0d0 / d1
         if ((n/2)*2 .ne. n)  d1 = -d1
         do i = 1, n
            j = n - i + 1
            d1 = -d1
            b(j) = (d1+d2+beta*b(j+1)) / dble(j)
         end do
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function bmax  --  find maximum order of "B" functions  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "bmax" computes the maximum order of the B functions needed
c     for evaluation of Slater-type (STO) overlap integrals
c
c
      function bmax (beta,n)
      implicit none
      real*8 eps
      parameter (eps=0.0000001d0)
      integer n
      real*8 bmax,beta
      real*8 b,top,bot
      real*8 sum,fi
      real*8 sign,term
      logical done
c
c
      done = .false.
      b = beta**2
      top = dble(n) + 1.0d0
      sum = 1.0d0 / top
      fi = 2.0d0
      sign = 2.0d0
      if ((n/2)*2 .ne. n) then
         top = top + 1.0d0
         sum = beta / top
         fi = fi + 1.0d0
         sign = -2.0d0
      end if
      term = sum
      do while (.not. done)
         bot = top + 2.0d0
         term = term * b * top / (fi*(fi-1.0d0)*bot)
         sum = sum + term
         if (abs(term) .le. eps) then
            done = .true.
         else
            fi = fi + 2.0d0
            top = bot
         end if
      end do
      bmax = sign * sum
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module params  --  force field parameter file contents  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     nprm      number of nonblank lines in the parameter file
c     prmline   contents of each individual parameter file line
c
c
      module params
      implicit none
      integer nprm
      character*240, allocatable :: prmline(:)
      save
      end
c
c
c     ###############################################################
c     ##  COPYRIGHT (C) 1991 by Shawn Huston & Jay William Ponder  ##
c     ##                    All Rights Reserved                    ##
c     ###############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program path  --  conformational interconversion pathway  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "path" locates a series of structures equally spaced along
c     a conformational pathway connecting the input reactant and
c     product structures; a series of constrained optimizations
c     orthogonal to the path is done via Lagrangian multipliers
c
c     literature reference:
c
c     R. Czerminski and R. Elber, "Reaction Path Study of
c     Conformational Transitions in Flexible Systems: Applications
c     to Peptides", Journal of Chemical Physics, 92, 5580-5601 (1990)
c
c
      program path
      use align
      use atomid
      use atoms
      use files
      use inform
      use iounit
      use linmin
      use minima
      use output
      use paths
      implicit none
      integer i,j,k,nvar
      integer ix,iy,iz
      integer ipath,npath
      real*8 rmsvalue,project
      real*8 epot,etot
      real*8 epot0,epot1
      real*8 sum,rplen,path1
      real*8 grdmin,potnrg
      real*8, allocatable :: p(:)
      real*8, allocatable :: ge(:)
      real*8, allocatable :: xtmp(:)
      real*8, allocatable :: ytmp(:)
      real*8, allocatable :: ztmp(:)
      real*8, allocatable :: temp(:,:)
      logical exist
      character*240 string
      external path1
      external optsave
c
c
c     initialize constants and get initial structure
c
      call initial
      call getxyz
c
c     perform dynamic allocation of some global arrays
c
      nvar = 3 * n
      allocate (pc0(nvar))
      allocate (pc1(nvar))
      allocate (pvect(nvar))
      allocate (pstep(nvar))
      allocate (pzet(nvar))
      allocate (gc(nvar,7))
      allocate (ifit(2,n))
      allocate (wfit(n))
c
c     perform dynamic allocation of some local arrays
c
      allocate (xtmp(n))
      allocate (ytmp(n))
      allocate (ztmp(n))
c
c     get and store the initial structure coordinates
c
      do i = 1, n
         pc0(3*i-2) = x(i)
         pc0(3*i-1) = y(i)
         pc0(3*i) = z(i)
         xtmp(i) = x(i)
         ytmp(i) = y(i)
         ztmp(i) = z(i)
      end do
c
c     get the coordinates for the final structure
c
      call getxyz
      call mechanic
c
c     set default values for some control variables
c
      cyclesave = .true.
      stpmax = 1.0d0
      iwrite = 0
      if (verbose) then
         iprint = 1
      else
         iprint = 0
      end if
c
c     get the number of path points to be generated
c
      npath = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  npath
   10 continue
      if (npath .le. 0) then
         write (iout,20)
   20    format (/,' Enter Number of Path Points to Generate [9] :  ',$)
         read (input,30)  npath
   30    format (i10)
      end if
      if (npath .le. 0)  npath = 9
c
c     get the termination criterion as RMS gradient along path
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=40,end=40)  grdmin
   40 continue
      if (grdmin .le. 0.0d0) then
         write (iout,50)
   50    format (/,' Enter RMS Gradient per Atom Criterion',
     &              ' [0.1] :  ',$)
         read (input,60)  grdmin
   60    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.1d0
c
c     superimpose the reactant and product structures
c
      nfit = n
      do i = 1, n
         ifit(1,i) = i
         ifit(2,i) = i
         wfit(i) = mass(i)
      end do
      call impose (n,xtmp,ytmp,ztmp,n,x,y,z,rmsvalue)
      write (iout,70)  rmsvalue
   70 format (/,' RMS Fit for Reactant and Product :',f12.4)
c
c     perform deallocation of some local arrays
c
      deallocate (xtmp)
      deallocate (ytmp)
      deallocate (ztmp)
c
c     perform dynamic allocation of some local arrays
c
      allocate (p(nvar))
      allocate (ge(nvar))
c
c     store the coordinates for the superimposed product
c
      do i = 1, n
         pc1(3*i-2) = x(i)
         pc1(3*i-1) = y(i)
         pc1(3*i) = z(i)
      end do
c
c     write out the starting potential energy values
c
      epot0 = potnrg (pc0,ge)
      epot1 = potnrg (pc1,ge)
      write (iout,80)  epot0,epot1
   80 format (/,' Reactant Potential Energy :',f12.4,
     &        /,' Product Potential Energy : ',f12.4)
c
c     construct step vector for getting
c     optimization-initial coordinates
c
      rplen = npath + 1
      pnorm = 0.0d0
      do i = 1, nvar
         pvect(i) = pc1(i) - pc0(i)
         pstep(i) = pvect(i) / rplen
         pnorm = pnorm + pvect(i)**2
      end do
      pnorm = sqrt(pnorm)
c
c     set the gradient of constraints array
c
      do i = 1, n
         ix = 3*(i-1) + 1
         iy = ix + 1
         iz = iy + 1
         gc(ix,1) = pvect(ix)
         gc(iy,1) = pvect(iy)
         gc(iz,1) = pvect(iz)
         gc(ix,2) = mass(i)
         gc(iy,2) = 0.0d0
         gc(iz,2) = 0.0d0
         gc(ix,3) = 0.0d0
         gc(iy,3) = mass(i)
         gc(iz,3) = 0.0d0
         gc(ix,4) = 0.0d0
         gc(iy,4) = 0.0d0
         gc(iz,4) = mass(i)
         gc(ix,5) = 0.0d0
         gc(iy,5) = mass(i) * pc0(iz)
         gc(iz,5) = -mass(i) * pc0(iy)
         gc(ix,6) = -mass(i) * pc0(iz)
         gc(iy,6) = 0.0d0
         gc(iz,6) = mass(i) * pc0(ix)
         gc(ix,7) = mass(i) * pc0(iy)
         gc(iy,7) = -mass(i) * pc0(ix)
         gc(iz,7) = 0.0d0
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (temp(nvar,7))
c
c     copy to temporary storage and orthogonalize
c
      do i = 1, 7
         do j = 1, nvar
            temp(j,i) = gc(j,i)
         end do
      end do
      call orthog (nvar,7,gc)
c
c     set the A matrix to transform sigma into C space
c
      do i = 1, 7
         do k = 1, 7
            sum = 0.0d0
            do j = 1, nvar
               sum = sum + temp(j,i)*gc(j,k)
            end do
            acoeff(i,k) = sum
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (temp)
c
c     perform the matrix inversion to get A matrix
c     which transforms C into sigma space
c
      call invert (7,acoeff)
c
c     set the current path point to be the reactant
c
      do i = 1, nvar
         p(i) = pc0(i)
      end do
c
c     loop over structures along path to be optimized
c
      do ipath = 1, npath
         write (iout,90)  ipath
   90    format (/,' Path Point :',i12)
c
c     get r(zeta), set initial path point and energy
c
         do i = 1, nvar
            pzet(i) = pc0(i) + ipath*pstep(i)
            p(i) = p(i) + pstep(i)
         end do
         epot = potnrg (p,ge)
         write (iout,100)  epot
  100    format (' Initial Point :',12x,f12.4)
c
c     call optimizer to get constrained minimum
c
         call lbfgs (nvar,p,etot,grdmin,path1,optsave)
c        call ocvm (nvar,p,etot,grdmin,path1,optsave)
c
c     print energy and constraint value at the minimum
c
         epot = potnrg (p,ge)
         write (iout,110)  epot
  110    format (' Optimized Point :',10x,f12.4)
         write (iout,120)  etot-epot
  120    format (' Target-Energy Difference :',d13.3)
c
c     write coordinates of the current path point
c
         call optsave (ipath,epot,p)
c
c     find projection of the gradient along path direction
c
         project = 0.0d0
         do i = 1, nvar
            project = project + ge(i)*pvect(i)/pnorm
         end do
         write (iout,130)  project
  130    format (' Gradient along Path :',6x,f12.4)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (p)
      deallocate (ge)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  function path1  --  value and gradient of target function  ##
c     ##                                                             ##
c     #################################################################
c
c
      function path1 (p,gt)
      use atomid
      use atoms
      use paths
      implicit none
      integer i,j,nvar
      integer ix,iy,iz
      real*8 xx,yy,zz
      real*8 path1,cterm
      real*8 potnrg
      real*8 gamma(7)
      real*8 cnst(7)
      real*8 sigma(7)
      real*8 p(*)
      real*8 gt(*)
      real*8, allocatable :: ge(:)
c
c
c     perform dynamic allocation of some local arrays
c
      nvar = 3 * n
      allocate (ge(nvar))
c
c     get the value of the potential energy
c
      path1 = potnrg (p,ge)
c
c     construct the Lagrangian multipliers
c
      do i = 1, 7
         gamma(i) = 0.0d0
         do j = 1, nvar
            gamma(i) = gamma(i) - ge(j)*gc(j,i)
         end do
      end do
c
c     set the path value, translation and rotation constraints
c
      do i = 1, 7
         cnst(i) = 0.0d0
      end do
      do i = 1, n
         ix = 3*(i-1) + 1
         iy = ix + 1
         iz = iy + 1
         xx = p(ix) - pzet(ix)
         yy = p(iy) - pzet(iy)
         zz = p(iz) - pzet(iz)
         cnst(1) = cnst(1) + xx*pvect(ix) + yy*pvect(iy) + zz*pvect(iz)
         cnst(2) = cnst(2) + mass(i) * (p(ix)-pc0(ix))
         cnst(3) = cnst(3) + mass(i) * (p(iy)-pc0(iy))
         cnst(4) = cnst(4) + mass(i) * (p(iz)-pc0(iz))
         cnst(5) = cnst(5) + mass(i) * (p(iy)*pc0(iz)-p(iz)*pc0(iy))
         cnst(6) = cnst(6) + mass(i) * (p(iz)*pc0(ix)-p(ix)*pc0(iz))
         cnst(7) = cnst(7) + mass(i) * (p(ix)*pc0(iy)-p(iy)*pc0(ix))
      end do
c
c     construct the orthonormal "sigma" constraints
c
      do i = 1, 7
         sigma(i) = 0.0d0
         do j = 1, 7
            sigma(i) = sigma(i) + acoeff(i,j)*cnst(j)
         end do
      end do
c
c     find the target function value
c
      cterm = 0.0d0
      do i = 1, 7
         cterm = cterm + gamma(i)*sigma(i)
      end do
      path1 = path1 + cterm
c
c     construct the gradient of the target function
c
      do i = 1, nvar
         gt(i) = ge(i)
         do j = 1, 7
            gt(i) = gt(i) + gamma(j)*gc(i,j)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (ge)
      return
      end
c
c
c     ##########################################################
c     ##                                                      ##
c     ##  function potnrg  --  potential energy and gradient  ##
c     ##                                                      ##
c     ##########################################################
c
c
      function potnrg (xx,g)
      use atoms
      use paths
      implicit none
      integer i
      real*8 energy
      real*8 potnrg
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     copy position vector into atomic coordinates
c
      do i = 1, n
         x(i) = xx(3*i-2)
         y(i) = xx(3*i-1)
         z(i) = xx(3*i)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute potential energy and Cartesian derivatives
c
      call gradient (energy,derivs)
c
c     set the energy value and gradient vector
c
      potnrg = energy
      do i = 1, n
         g(3*i-2) = derivs(1,i)
         g(3*i-1) = derivs(2,i)
         g(3*i) = derivs(3,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module paths  --  Elber reaction path method parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     pnorm    length of the reactant-product vector
c     acoeff   transformation matrix 'A' from Elber algorithm
c     pc0      reactant Cartesian coordinates as variables
c     pc1      product Cartesian coordinates as variables
c     pvect    vector connecting the reactant and product
c     pstep    step per cycle along reactant-product vector
c     pzet     current projection on reactant-product vector
c     gc       gradient of the path constraints
c
c
      module paths
      implicit none
      real*8 pnorm
      real*8 acoeff(7,7)
      real*8, allocatable :: pc0(:)
      real*8, allocatable :: pc1(:)
      real*8, allocatable :: pvect(:)
      real*8, allocatable :: pstep(:)
      real*8, allocatable :: pzet(:)
      real*8, allocatable :: gc(:,:)
      save
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2006 by Michael Schnieders & Jay W. Ponder  ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module pbstuf  --  Poisson-Boltzmann solvation parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     APBS configuration parameters (see APBS documentation for details)
c     In the column on the right are possible values for each variable,
c     with default values given in brackets. Only a subset of the APBS
c     options are supported and/or are appropriate for use with AMOEBA
c
c     pbtyp                                     lpbe
c
c     At some point AMOEBA with the non-linear PBE could be supported,
c     but this is only worked out for energies (no gradients)
c
c     pbsoln                                    mg-auto, [mg-manual]
c
c     Currently there is only limited support for focusing calculations,
c     which is a powerful feature of APBS. At present, all energies and
c     forces must all be calculated using the finest solution
c
c     bcfl     boundary conditions              zero, sdh, [mdh]
c     chgm     multipole discretization         spl4
c
c     other charge discretization methods are not appropriate for AMOEBA
c
c     srfm     surface method                   mol, smol, [spl4]
c
c     spl4 is required for forces calculations, although mol is useful
c     for comparison with generalized Kirkwood
c
c     dime     number of grid points            [65, 65, 65]
c     grid     grid spacing (mg-manual)         fxn of "dime"
c     cgrid    coarse grid spacing              fxn of "dime"
c     fgrid    fine grid spacing                cgrid / 2
c
c     stable results require grid spacing to be fine enough to keep
c     multipoles inside the dielectric boundary (2.5 * grid < PBR)
c
c     gcent    grid center (mg-manual)          center of mass
c     cgcent   coarse grid center               center of mass
c     fgcent   fine grid center                 center of mass
c     pdie     solute/homogeneous dieletric     [1.0]
c     sdie     solvent dieletric                [78.3]
c     ionn     number of ion species            [0]
c     ionc     ion concentration (M)            [0.0]
c     ionq     ion charge (electrons)           [1.0]
c     ionr     ion radius (A)                   [2.0]
c     srad     solvent probe radius (A)         [1.4]
c     swin     surface spline window width      [0.3]
c     sdens    density of surface points        [10.0]
c
c     additional parameter to facilitate default grid setup
c
c     smin     minimum distance between an      [10.0]
c              atom and the grid boundary (A)
c
c     pbe      Poisson-Boltzmann permanent multipole solvation energy
c     apbe     Poisson-Boltzmann permanent multipole energy over atoms
c     pbep     Poisson-Boltzmann energies on permanent multipoles
c     pbfp     Poisson-Boltzmann forces on permanent multipoles
c     pbtp     Poisson-Boltzmann torques on permanent multipoles
c     pbeuind  Poisson-Boltzmann field due to induced dipoles
c     pbeuinp  Poisson-Boltzmann field due to non-local induced dipoles
c
c
      module pbstuf
      implicit none
      integer maxion
      parameter (maxion=10)
      integer ionn
      integer dime(3)
      integer ionq(maxion)
      real*8 pbe
      real*8 pdie,sdie
      real*8 srad,swin
      real*8 sdens,smin
      real*8 grid(3)
      real*8 gcent(3)
      real*8 cgrid(3)
      real*8 cgcent(3)
      real*8 fgrid(3)
      real*8 fgcent(3)
      real*8 ionr(maxion)
      real*8 ionc(maxion)
      real*8, allocatable :: apbe(:)
      real*8, allocatable :: pbep(:,:)
      real*8, allocatable :: pbfp(:,:)
      real*8, allocatable :: pbtp(:,:)
      real*8, allocatable :: pbeuind(:,:)
      real*8, allocatable :: pbeuinp(:,:)
      character*20 pbtyp,pbsoln
      character*20 bcfl,chgm,srfm
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module pdb  --  Protein Data Bank structure definition  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     npdb      number of atoms stored in Protein Data Bank format
c     nres      number of residues stored in Protein Data Bank format
c     nmodel    number of models stored in Protein Data Bank format
c     imodel    model number of structure to be used (0=All Models)
c     resnum    number of the residue to which each atom belongs
c     resatm    number of first and last atom in each residue
c     npdb12    number of atoms directly bonded to each CONECT atom
c     ipdb12    atom numbers of atoms connected to each CONECT atom
c     pdbmod    Protein Data Bank model number assigned to each atom
c     pdblist   list of the Protein Data Bank atom number of each atom
c     xpdb      x-coordinate of each atom stored in PDB format
c     ypdb      y-coordinate of each atom stored in PDB format
c     zpdb      z-coordinate of each atom stored in PDB format
c     altsym    string with PDB alternate locations to be included
c     pdbtyp    format of PDB files; PDB (legacy) or CIF (PDBx/mmCIF)
c     pdbres    Protein Data Bank residue name assigned to each atom
c     pdbsym    Protein Data Bank atomic symbol assigned to each atom
c     pdbatm    Protein Data Bank atom name assigned to each atom
c     pdbrec    Protein Data Bank record type assigned to each atom
c     chnsym    string with PDB chain identifiers to be included
c     instyp    string with PDB insertion records to be included
c
c
      module pdb
      implicit none
      integer npdb,nres
      integer nmodel,imodel
      integer, allocatable :: resnum(:)
      integer, allocatable :: resatm(:,:)
      integer, allocatable :: npdb12(:)
      integer, allocatable :: ipdb12(:,:)
      integer, allocatable :: pdbmod(:)
      integer, allocatable :: pdblist(:)
      real*8, allocatable :: xpdb(:)
      real*8, allocatable :: ypdb(:)
      real*8, allocatable :: zpdb(:)
      character*1 altsym
      character*3 pdbtyp
      character*3, allocatable :: pdbres(:)
      character*3, allocatable :: pdbsym(:)
      character*4, allocatable :: pdbatm(:)
      character*6, allocatable :: pdbrec(:)
      character*20 chnsym
      character*20 instyp
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program pdbxyz  --  Protein Data Bank to XYZ coordinates  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "pdbxyz" takes as input an RCSB Protein Data Bank file and then
c     converts to and writes out a Tinker Cartesian coordinates file,
c     and a sequence file for biopolymers
c
c
      program pdbxyz
      use atomid
      use atoms
      use couple
      use files
      use inform
      use katoms
      use pdb
      use resdue
      use sequen
      use titles
      implicit none
      integer i,j,it,next
      integer ipdb,ixyz,iseq
      integer last,pdbleng
      integer freeunit
      integer, allocatable :: row(:)
      real*8 xi,yi,zi,rij
      real*8 rcut,rmax(0:25)
      logical biopoly
      logical clash
      character*1 letter
      character*3 resname
      character*3 reslast
      character*240 pdbfile
      character*240 xyzfile
      character*240 seqfile
      character*240 pdbtitle
c
c
c     get the Protein Data Bank file and a parameter set
c
      call initial
      call getpdb
      call field
      call unitcell
c
c     save the title line from the PDB file for later use
c
      pdbleng = ltitle
      pdbtitle = title(1:ltitle)
c
c     decide whether the system has only biopolymers and water
c
      biopoly = .false.
      reslast = '***'
      do i = 1, npdb
         if (pdbrec(i) .eq. 'ATOM  ') then
            resname = pdbres(i)
            if (resname .ne. reslast) then
               reslast = resname
               do j = 1, maxamino
                  if (resname .eq. amino(j)) then
                     biopoly = .true.
                     goto 10
                  end if
               end do
               do j = 1, maxnuc
                  if (resname .eq. nuclz(j)) then
                     biopoly = .true.
                     goto 10
                  end if
               end do
               biopoly = .false.
               goto 20
   10          continue
            end if
         else if (pdbrec(i) .eq. 'HETATM') then
            resname = pdbres(i)
            if (resname .ne. reslast) then
               reslast = resname
               if (resname.eq.'HOH' .or. resname.eq.' LI' .or.
     &             resname.eq.' NA' .or. resname.eq.'  K' .or.
     &             resname.eq.' RB' .or. resname.eq.' CS' .or.
     &             resname.eq.' MG' .or. resname.eq.' CA' .or.
     &             resname.eq.' SR' .or. resname.eq.' BA' .or.
     &             resname.eq.'  F' .or. resname.eq.' CL' .or.
     &             resname.eq.' BR' .or. resname.eq.'  I' .or.
     &             resname.eq.' ZN') then
                  pdbrec(i) = 'HETATM'
               end if
            end if
         end if
      end do
   20 continue
c
c     open the Tinker coordinates file to be used for output
c
      ixyz = freeunit ()
      xyzfile = filename(1:leng)//'.xyz'
      call version (xyzfile,'new')
      open (unit=ixyz,file=xyzfile,status='new')
c
c     reopen the PDB file and read the first coordinate set
c
      ipdb = freeunit ()
      pdbfile = filename
      call suffix (pdbfile,'pdb','old')
      open (unit=ipdb,file=pdbfile,status ='old')
      rewind (unit=ipdb)
      if (pdbtyp .eq. 'PDB')  call readpdb (ipdb)
      if (pdbtyp .eq. 'CIF')  call readcif (ipdb)
c
c     use special translation mechanisms for biopolymers
c
      do while (.not. abort)
         if (biopoly) then
            n = 0
            do i = 1, nchain
               if (chntyp(i) .eq. 'PEPTIDE')  call ribosome (i)
               if (chntyp(i) .eq. 'NUCLEIC')  call ligase (i)
            end do
            call hetatom
            last = n
            do i = last, 1, -1
               if (type(i) .eq. 0)  call delete (i)
            end do
c
c     get general atom properties for non-biopolymer structures
c
         else
            n = npdb
            do i = 1, n
               x(i) = xpdb(i)
               y(i) = ypdb(i)
               z(i) = zpdb(i)
               if (pdbsym(i) .ne. '   ') then
                  name(i) = pdbsym(i)
               else
                  letter = pdbatm(i)(1:1)
                  if (letter.ge.'A' .and. letter.le.'Z') then
                     name(i) = pdbatm(i)(1:3)
                  else
                     name(i) = pdbatm(i)(2:4)
                  end if
               end if
               n12(i) = 0
               next = 1
               call getnumb (pdbres(i),type(i),next)
            end do
c
c     add missing hydrogen atoms to satisfy empty valences
c
c           call addhydro
c
c     perform dynamic allocation of some local arrays
c
            allocate (row(n))
c
c     set atom size classification from periodic table row
c
            do i = 1, n
               it = type(i)
               if (it .eq. 0) then
                  atomic(i) = 0
                  letter = name(i)(1:1)
                  call upcase (letter)
                  if (letter .eq. 'H') then
                     row(i) = 1
                     atomic(i) = 1
                  else if (letter .eq. 'B') then
                     row(i) = 2
                     atomic(i) = 5
                     if (name(i)(2:2) .eq. 'R') then
                        row(i) = 5
                        atomic(i) = 35
                     end if
                  else if (letter .eq. 'C') then
                     row(i) = 2
                     atomic(i) = 6
                     if (name(i)(2:2) .eq. 'L') then
                        row(i) = 3
                        atomic(i) = 17
                     end if
                  else if (letter .eq. 'N') then
                     row(i) = 2
                     atomic(i) = 7
                  else if (letter .eq. 'O') then
                     row(i) = 2
                     atomic(i) = 8
                  else if (letter .eq. 'F') then
                     row(i) = 2
                     atomic(i) = 9
                  else if (letter .eq. 'P') then
                     row(i) = 3
                     atomic(i) = 15
                  else if (letter .eq. 'S') then
                     row(i) = 3
                     atomic(i) = 16
                     if (name(i)(2:2) .eq. 'I') then
                        row(i) = 3
                        atomic(i) = 14
                     end if
                  else if (letter .eq. 'I') then
                     row(i) = 5
                     atomic(i) = 53
                  else
                     row(i) = 0
                  end if
               else if (ligand(it) .eq. 0) then
                  row(i) = 0
               else if (atmnum(it) .le. 2) then
                  row(i) = 1
               else if (atmnum(it) .le. 10) then
                  row(i) = 2
               else if (atmnum(it) .le. 18) then
                  row(i) = 3
               else
                  row(i) = 5
               end if
            end do
c
c     set the maximum bonded distance between atom type pairs
c
            rmax(0) = -1.0d0
            rmax(1) = -1.0d0
            rmax(2) = 1.3d0
            rmax(3) = 1.55d0
            rmax(4) = 1.75d0
            rmax(5) = 1.90d0
            rmax(6) = 2.0d0
            rmax(9) = 2.2d0
            rmax(10) = 2.4d0
            rmax(15) = 2.6d0
            rmax(25) = 2.8d0
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(n,x,y,z,row,rmax,n12,i12)
!$OMP DO
c
c     find and connect atom pairs within bonding distance
c
            do i = 1, n-1
               xi = x(i)
               yi = y(i)
               zi = z(i)
               do j = i+1, n
                  rcut = rmax(row(i)*row(j))**2
                  rij = (xi-x(j))**2 + (yi-y(j))**2 + (zi-z(j))**2
                  if (rij .le. rcut) then
                     n12(i) = n12(i) + 1
                     i12(n12(i),i) = j
                     n12(j) = n12(j) + 1
                     i12(n12(j),j) = i
                  end if
               end do
            end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
            deallocate (row)
c
c     assign generic atom types if currently unassigned
c
            do i = 1, n
               if (it .eq. 0)  type(i) = 10*atomic(i) + n12(i)
            end do      
         end if
c
c     sort the attached atom lists into ascending order
c
         do i = 1, n
            call sort8 (n12(i),i12(1,i))
         end do
c
c     check for atom pairs with identical coordinates
c
         clash = .false.
         call chkxyz (clash)
c
c     write the coordinates file and reset the connectivities
c
         ltitle = pdbleng
         title = pdbtitle(1:ltitle)
         call prtxyz (ixyz)
         do i = 1, npdb
            n12(i) = 0
         end do
c
c     read the next coordinate set from Protein Data Bank file
c
         if (nmodel .eq. 1) then
            abort = .true.
         else
            imodel = imodel + 1
            rewind (unit=ipdb)
            if (pdbtyp .eq. 'PDB')  call readpdb (ipdb)
            if (pdbtyp .eq. 'CIF')  call readcif (ipdb)
         end if
      end do
c
c     write a sequence file for proteins and nucleic acids
c
      if (biopoly) then
         iseq = freeunit ()
         seqfile = filename(1:leng)//'.seq'
         call version (seqfile,'new')
         open (unit=iseq,file=seqfile,status='new')
         call prtseq (iseq)
         close (unit=iseq)
      end if
c
c     perform any final tasks before program exit
c
      close (unit=ixyz)
      call final
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ribosome  --  coordinates from PDB polypeptide  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ribosome" translates a polypeptide structure in Protein Data
c     Bank format to a Cartesian coordinate file and sequence file
c
c
      subroutine ribosome (ichn)
      use atoms
      use fields
      use files
      use inform
      use iounit
      use pdb
      use resdue
      use sequen
      implicit none
      integer i,j,k,m
      integer ichn,ityp
      integer jres,kres
      integer start,stop
      integer cyxtyp
      integer ncys,ndisulf
      integer, allocatable :: ni(:)
      integer, allocatable :: cai(:)
      integer, allocatable :: ci(:)
      integer, allocatable :: oi(:)
      integer, allocatable :: si(:)
      integer, allocatable :: icys(:)
      integer, allocatable :: idisulf(:,:)
      real*8 xr,yr,zr,r
      real*8, allocatable :: xcys(:)
      real*8, allocatable :: ycys(:)
      real*8, allocatable :: zcys(:)
      logical newchn
      logical midchn
      logical endchn
      logical cyclic
      character*3 resname
      character*4 atmname
      save si
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (ni(nres))
      allocate (cai(nres))
      allocate (ci(nres))
      allocate (oi(nres))
      allocate (si(nres))
      allocate (icys(nres))
      allocate (idisulf(2,nres))
      allocate (xcys(nres))
      allocate (ycys(nres))
      allocate (zcys(nres))
c
c     set the next atom and the residue range of the chain
c
      n = n + 1
      jres = ichain(1,ichn)
      kres = ichain(2,ichn)
      do i = jres, kres
         ni(i) = 0
         cai(i) = 0
         ci(i) = 0
         oi(i) = 0
      end do
c
c     check for the presence of a cyclic polypeptide chain
c
      cyclic = .false.
      start = resatm(1,jres)
      stop = resatm(2,jres)
      call findatm (' N  ',start,stop,j)
      if (j .ne. 0)  ni(jres) = j
      start = resatm(1,kres)
      stop = resatm(2,kres)
      call findatm (' C  ',start,stop,k)
      if (k .ne. 0)  ci(kres) = k
      if (jres.ne.kres .and. j.ne.0 .and. k.ne.0) then
         xr = xpdb(k) - xpdb(j)
         yr = ypdb(k) - ypdb(j)
         zr = zpdb(k) - zpdb(j)
         r = sqrt(xr*xr + yr*yr + zr*zr)
         if (r .le. 3.0d0)  cyclic = .true.
      end if
c
c     search for any potential cystine disulfide bonds
c
      do i = 1, maxamino
         if (amino(i) .eq. 'CYX')  cyxtyp = i
      end do
      ncys = 0
      do i = 1, nres
         start = resatm(1,i)
         resname = pdbres(start)
         if (resname.eq.'CYS' .or. resname.eq.'CYX') then
            stop = resatm(2,i)
            call findatm (' SG ',start,stop,k)
            ncys = ncys + 1
            icys(ncys) = i
            xcys(ncys) = xpdb(k)
            ycys(ncys) = ypdb(k)
            zcys(ncys) = zpdb(k)
         end if
      end do
      ndisulf = 0
      do i = 1, ncys-1
         do k = i+1, ncys
            xr = xcys(k) - xcys(i)
            yr = ycys(k) - ycys(i)
            zr = zcys(k) - zcys(i)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            if (r .le. 3.0d0) then
               ndisulf = ndisulf + 1
               idisulf(1,ndisulf) = min(icys(i),icys(k))
               idisulf(2,ndisulf) = max(icys(i),icys(k))
            end if
         end do
      end do
      do i = 1, ndisulf
         j = idisulf(1,i)
         k = idisulf(2,i)
         seqtyp(j) = cyxtyp
         seqtyp(k) = cyxtyp
         seq(j) = 'CYX'
         seq(k) = 'CYX'
         start = resatm(1,j)
         stop = resatm(2,j)
         do m = start, stop
            pdbres(m) = 'CYX'
         end do
         start = resatm(1,k)
         stop = resatm(2,k)
         do m = start, stop
            pdbres(m) = 'CYX'
         end do
      end do
c
c     locate and assign the atoms that make up each residue
c
      do i = jres, kres
         ityp = seqtyp(i)
         start = resatm(1,i)
         stop = resatm(2,i)
         resname = seq(i)
c
c     check that the maximum allowed atoms is not exceeded
c
         if (n+25 .gt. maxatm) then
            write (iout,10)  maxatm
   10       format (/,' RIBOSOME  --  The Maximum of',i9,' Atoms',
     &                 ' has been Exceeded')
            call fatal
         end if
c
c     test location of residue within the current chain
c
         newchn = .false.
         midchn = .false.
         endchn = .false.
         if (i .eq. jres)  newchn = .true.
         if (i .eq. kres)  endchn = .true.
         if (.not.newchn .and. .not.endchn)  midchn = .true.
c
c     build the amide nitrogen of the current residue
c
         atmname = ' N  '
         if (resname .eq. 'COH')  atmname = ' OH '
         call findatm (atmname,start,stop,k)
         if (k .ne. 0)  ni(i) = n
         if (midchn) then
            j = ntyp(ityp)
            call oldatm (k,j,ci(i-1),i)
         else if (newchn) then
            if (cyclic) then
               j = ntyp(ityp)
            else
               j = nntyp(ityp)
            end if
            call oldatm (k,j,0,i)
         else if (endchn) then
            if (cyclic) then
               j = ntyp(ityp)
            else
               j = nctyp(ityp)
            end if
            call oldatm (k,j,ci(i-1),i)
         end if
c
c     build the alpha carbon of the current residue
c
         atmname = ' CA '
         if (resname .eq. 'ACE')  atmname = ' CH3'
         if (resname .eq. 'NME')  atmname = ' C  '
         call findatm (atmname,start,stop,k)
         if (k .ne. 0)  cai(i) = n
         if (midchn .or. cyclic .or. nres.eq.1) then
            j = catyp(ityp)
            call oldatm (k,j,ni(i),i)
         else if (newchn) then
            j = cantyp(ityp)
            call oldatm (k,j,ni(i),i)
         else if (endchn) then
            j = cactyp(ityp)
            call oldatm (k,j,ni(i),i)
         end if
c
c     build the carbonyl carbon of the current residue
c
         call findatm (' C  ',start,stop,k)
         if (k .ne. 0)  ci(i) = n
         if (midchn .or. cyclic) then
            j = ctyp(ityp)
            call oldatm (k,j,cai(i),i)
         else if (newchn) then
            j = cntyp(ityp)
            call oldatm (k,j,cai(i),i)
         else if (endchn) then
            j = cctyp(ityp)
            if (resname .eq. 'COH') then
               type(ci(i-1)) = biotyp(j)
            else
               call oldatm (k,j,cai(i),i)
            end if
         end if
c
c     build the carbonyl oxygen of the current residue
c
         call findatm (' O  ',start,stop,k)
         if (k .ne. 0)  oi(i) = n
         if (midchn .or. cyclic) then
            j = otyp(ityp)
            call oldatm (k,j,ci(i),i)
         else if (newchn) then
            j = ontyp(ityp)
            call oldatm (k,j,ci(i),i)
         else if (endchn) then
            j = octyp(ityp)
            if (resname .eq. 'COH') then
               type(oi(i-1)) = biotyp(j)
            else
               call oldatm (k,j,ci(i),i)
            end if
         end if
c
c     build the amide hydrogens of the current residue
c
         if (midchn .or. (endchn.and.cyclic)) then
            j = hntyp(ityp)
            call findatm (' H  ',start,stop,k)
            call newatm (k,j,ni(i),1.01d0,ci(i-1),119.0d0,
     &                      cai(i),119.0d0,1)
         else if (newchn .and. cyclic) then
            j = hntyp(ityp)
            call findatm (' H  ',start,stop,k)
            call newatm (k,j,ni(i),1.01d0,ci(kres),119.0d0,
     &                      cai(i),119.0d0,1)
         else if (newchn) then
            j = hnntyp(ityp)
            if (resname .eq. 'PRO') then
               call findatm (' H2 ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0,
     &                         ci(i),0.0d0,0)
               call findatm (' H3 ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0,
     &                         ci(i),-120.0d0,0)
            else if (resname .eq. 'PCA') then
               call findatm (' H  ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0,
     &                         ci(i),-60.0d0,0)
            else
               call findatm (' H1 ',start,stop,k)
               if (k .eq. 0)  call findatm (' H  ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0,
     &                         ci(i),180.0d0,0)
               call findatm (' H2 ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0,
     &                         ci(i),60.0d0,0)
               call findatm (' H3 ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0,
     &                         ci(i),-60.0d0,0)
            end if
         else if (endchn) then
            j = hnctyp(ityp)
            if (resname .eq. 'COH') then
               call findatm (' HO ',start,stop,k)
               call newatm (k,j,ni(i),0.98d0,ci(i-1),108.7d0,
     &                         cai(i-1),180.0d0,0)
            else if (resname .eq. 'NH2') then
               call findatm (' H1 ',start,stop,k)
               if (k .eq. 0)  call findatm (' H  ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,ci(i-1),120.9d0,
     &                         cai(i-1),0.0d0,0)
               call findatm (' H2 ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,ci(i-1),120.3d0,
     &                         cai(i-1),180.0d0,0)
            else if (resname .eq. 'NME') then
               call findatm (' H  ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,ci(i-1),119.0d0,
     &                         cai(i),119.0d0,1)
            else
               call findatm (' H  ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,ci(i-1),119.0d0,
     &                         cai(i),119.0d0,1)
            end if
         end if
c
c     build the alpha hydrogen of the current residue
c
         if (resname .eq. 'GLY') then
            call findatm (' HA2',start,stop,k)
         else
            call findatm (' HA ',start,stop,k)
         end if
         if (midchn .or. cyclic) then
            j = hatyp(ityp)
            call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0,
     &                      ci(i),109.5d0,-1)
         else if (newchn) then
            j = hantyp(ityp)
            if (resname .eq. 'FOR') then
               call findatm (' H  ',start,stop,k)
               call newatm (k,j,ci(i),1.12d0,oi(i),0.0d0,0,0.0d0,0)
            else if (resname .eq. 'ACE') then
               call findatm (' H1 ',start,stop,k)
               if (k .eq. 0)  call findatm (' H  ',start,stop,k)
               call newatm (k,j,cai(i),1.10d0,ci(i),109.5d0,
     &                         oi(i),180.0d0,0)
               call findatm (' H2 ',start,stop,k)
               call newatm (k,j,cai(i),1.10d0,ci(i),109.5d0,
     &                         oi(i),60.0d0,0)
               call findatm (' H3 ',start,stop,k)
               call newatm (k,j,cai(i),1.10d0,ci(i),109.5d0,
     &                         oi(i),-60.0d0,0)
            else
               call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0,
     &                         ci(i),109.5d0,-1)
            end if
         else if (endchn) then
            j = hactyp(ityp)
            if (resname .eq. 'NME') then
               call findatm (' H1 ',start,stop,k)
               if (k .eq. 0)  call findatm (' H  ',start,stop,k)
               call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0,
     &                         ci(i-1),180.0d0,0)
               call findatm (' H2 ',start,stop,k)
               call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0,
     &                         ci(i-1),60.0d0,0)
               call findatm (' H3 ',start,stop,k)
               call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0,
     &                         ci(i-1),-60.0d0,0)
            else
               call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0,
     &                         ci(i),109.5d0,-1)
            end if
         end if
c
c     build the side chain atoms of the current residue
c
         call addside (resname,i,newchn,endchn,start,stop,
     &                    cai(i),ni(i),ci(i),si(i))
c
c     build the terminal oxygen at the end of a peptide chain
c
         if (endchn .and. .not.cyclic .and. resname.ne.'COH') then
            call findatm (' OXT',start,stop,k)
            if (k .eq. 0)  call findatm (' OT2',start,stop,k)
            j = octyp(ityp)
            call newatm (k,j,ci(i),1.25d0,cai(i),117.0d0,
     &                      oi(i),126.0d0,1)
         end if
      end do
c
c     connect the terminal residues if the chain is cyclic
c
      if (cyclic) then
         call addbond (ni(jres),ci(kres))
         if (verbose) then
            write (iout,20)  jres,kres
   20       format (/,' Peptide Cyclization between Residues :  ',2i5)
         end if
      end if
c
c     connect the sulfur atoms involved in disulfide bonds
c
      do i = 1, ndisulf
         j = idisulf(1,i)
         k = idisulf(2,i)
         if (k.ge.ichain(1,ichn) .and. k.le.ichain(2,ichn)) then
            call addbond (si(j),si(k))
            if (verbose) then
               write (iout,30)  j,k
   30          format (/,' Disulfide Bond between Residues :  ',2i5)
            end if
         end if
      end do
c
c     total number of atoms is one less than the current atom
c
      n = n - 1
c
c     perform deallocation of some local arrays
c
      deallocate (ni)
      deallocate (cai)
      deallocate (ci)
      deallocate (oi)
      deallocate (si)
      deallocate (icys)
      deallocate (idisulf)
      deallocate (xcys)
      deallocate (ycys)
      deallocate (zcys)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine addside  --  build the amino acid side chains  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "addside" builds the Cartesian coordinates for a single amino
c     acid side chain; coordinates are read from the Protein Data
c     Bank file or found from internal coordinates, then atom types
c     are assigned and connectivity data generated
c
c     note biotypes of CD and HD atoms for N-terminal proline are
c     set as absolute values, not relative to the CB atom; this may
c     need updating if the list of biotypes changes in the future
c
c
      subroutine addside (resname,ires,newchn,endchn,
     &                    start,stop,cai,ni,ci,si)
      use atoms
      use resdue
      use sequen
      implicit none
      integer i,k,ires
      integer start,stop
      integer cai,ni,ci,si
      logical newchn,endchn
      character*3 resname
c
c
c     zero out disulfide and set CB atom as reference site
c
      si = 0
      k = cbtyp(seqtyp(ires))
c
c     glycine residue  (GLY)
c
      if (resname .eq. 'GLY') then
         call findatm (' HA3',start,stop,i)
         k = hatyp(seqtyp(ires))
         if (newchn)  k = hantyp(seqtyp(ires))
         if (endchn)  k = hactyp(seqtyp(ires))
         call newatm (i,k,cai,1.10d0,ni,109.5d0,ci,109.5d0,1)
c
c     alanine residue  (ALA)
c
      else if (resname .eq. 'ALA') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' HB1',start,stop,i)
         call newatm (i,k+1,n-1,1.10d0,cai,110.2d0,ni,180.0d0,0)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-2,1.10d0,cai,110.2d0,ni,60.0d0,0)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-3,1.10d0,cai,110.2d0,ni,-60.0d0,0)
c
c     valine residue  (VAL)
c
      else if (resname .eq. 'VAL') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG1',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CG2',start,stop,i)
         call oldatm (i,k+4,n-2,ires)
         call findatm (' HB ',start,stop,i)
         call newatm (i,k+1,n-3,1.10d0,cai,107.0d0,n-2,108.2d0,1)
         call findatm ('HG11',start,stop,i)
         call newatm (i,k+3,n-3,1.10d0,n-4,111.6d0,cai,180.0d0,0)
         call findatm ('HG12',start,stop,i)
         call newatm (i,k+3,n-4,1.10d0,n-5,111.6d0,cai,60.0d0,0)
         call findatm ('HG13',start,stop,i)
         call newatm (i,k+3,n-5,1.10d0,n-6,111.6d0,cai,-60.0d0,0)
         call findatm ('HG21',start,stop,i)
         call newatm (i,k+5,n-5,1.10d0,n-7,111.6d0,cai,180.0d0,0)
         call findatm ('HG22',start,stop,i)
         call newatm (i,k+5,n-6,1.10d0,n-8,111.6d0,cai,60.0d0,0)
         call findatm ('HG23',start,stop,i)
         call newatm (i,k+5,n-7,1.10d0,n-9,111.6d0,cai,-60.0d0,0)
c
c     leucine residue  (LEU)
c
      else if (resname .eq. 'LEU') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD1',start,stop,i)
         call oldatm (i,k+4,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,k+6,n-2,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1)
         call findatm (' HG ',start,stop,i)
         call newatm (i,k+3,n-5,1.10d0,n-6,107.0d0,n-4,108.2d0,1)
         call findatm ('HD11',start,stop,i)
         call newatm (i,k+5,n-5,1.10d0,n-6,111.6d0,n-7,180.0d0,0)
         call findatm ('HD12',start,stop,i)
         call newatm (i,k+5,n-6,1.10d0,n-7,111.6d0,n-8,60.0d0,0)
         call findatm ('HD13',start,stop,i)
         call newatm (i,k+5,n-7,1.10d0,n-8,111.6d0,n-9,-60.0d0,0)
         call findatm ('HD21',start,stop,i)
         call newatm (i,k+7,n-7,1.10d0,n-9,111.6d0,n-10,180.0d0,0)
         call findatm ('HD22',start,stop,i)
         call newatm (i,k+7,n-8,1.10d0,n-10,111.6d0,n-11,60.0d0,0)
         call findatm ('HD23',start,stop,i)
         call newatm (i,k+7,n-9,1.10d0,n-11,111.6d0,n-12,-60.0d0,0)
c
c     isoleucine residue  (ILE)
c
      else if (resname .eq. 'ILE') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG1',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CG2',start,stop,i)
         call oldatm (i,k+4,n-2,ires)
         call findatm (' CD1',start,stop,i)
         if (i .eq. 0)  call findatm (' CD ',start,stop,i)
         call oldatm (i,k+6,n-2,ires)
         call findatm (' HB ',start,stop,i)
         call newatm (i,k+1,n-4,1.10d0,cai,107.0d0,n-3,108.2d0,-1)
         call findatm ('HG12',start,stop,i)
         call newatm (i,k+3,n-4,1.10d0,n-5,109.5d0,n-2,109.5d0,1)
         call findatm ('HG13',start,stop,i)
         call newatm (i,k+3,n-5,1.10d0,n-6,109.5d0,n-3,109.5d0,-1)
         call findatm ('HG21',start,stop,i)
         call newatm (i,k+5,n-5,1.10d0,n-7,111.6d0,cai,180.0d0,0)
         call findatm ('HG22',start,stop,i)
         call newatm (i,k+5,n-6,1.10d0,n-8,111.6d0,cai,60.0d0,0)
         call findatm ('HG23',start,stop,i)
         call newatm (i,k+5,n-7,1.10d0,n-9,111.6d0,cai,-60.0d0,0)
         call findatm ('HD11',start,stop,i)
         call newatm (i,k+7,n-7,1.10d0,n-9,111.6d0,n-10,180.0d0,0)
         call findatm ('HD12',start,stop,i)
         call newatm (i,k+7,n-8,1.10d0,n-10,111.6d0,n-11,60.0d0,0)
         call findatm ('HD13',start,stop,i)
         call newatm (i,k+7,n-9,1.10d0,n-11,111.6d0,n-12,-60.0d0,0)
c
c     serine residue  (SER)
c
      else if (resname .eq. 'SER') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' OG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-2,1.10d0,cai,109.2d0,n-1,109.5d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-3,1.10d0,cai,109.2d0,n-2,109.5d0,-1)
         call findatm (' HG ',start,stop,i)
         call newatm (i,k+3,n-3,0.94d0,n-4,106.9d0,cai,180.0d0,0)
c
c     threonine residue  (THR)
c
      else if (resname .eq. 'THR') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' OG1',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CG2',start,stop,i)
         call oldatm (i,k+4,n-2,ires)
         call findatm (' HB ',start,stop,i)
         call newatm (i,k+1,n-3,1.10d0,cai,107.0d0,n-2,108.2d0,-1)
         call findatm (' HG1',start,stop,i)
         call newatm (i,k+3,n-3,0.94d0,n-4,106.9d0,cai,180.0d0,0)
         call findatm ('HG21',start,stop,i)
         call newatm (i,k+5,n-3,1.10d0,n-5,111.6d0,cai,180.0d0,0)
         call findatm ('HG22',start,stop,i)
         call newatm (i,k+5,n-4,1.10d0,n-6,111.6d0,cai,60.0d0,0)
         call findatm ('HG23',start,stop,i)
         call newatm (i,k+5,n-5,1.10d0,n-7,111.6d0,cai,-60.0d0,0)
c
c     cysteine residue  (CYS)
c
      else if (resname .eq. 'CYS') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' SG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-2,1.10d0,cai,109.5d0,n-1,107.5d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-3,1.10d0,cai,109.5d0,n-2,107.5d0,-1)
         call findatm (' HG ',start,stop,i)
         call newatm (i,k+3,n-3,1.34d0,n-4,96.0d0,cai,180.0d0,0)
c
c     cystine residue  (CYX)
c
      else if (resname .eq. 'CYX') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' SG ',start,stop,i)
         si = n
         call oldatm (i,k+2,n-1,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-2,1.10d0,cai,109.5d0,n-1,107.5d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-3,1.10d0,cai,109.5d0,n-2,107.5d0,-1)
c
c     deprotonated cysteine residue  (CYD)
c
      else if (resname .eq. 'CYD') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' SG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-2,1.10d0,cai,109.5d0,n-1,107.5d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-3,1.10d0,cai,109.5d0,n-2,107.5d0,-1)
c
c     proline residue  (PRO)
c
      else if (resname .eq. 'PRO') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD ',start,stop,i)
         if (newchn) then
            call oldatm (i,469,n-1,ires)
         else
            call oldatm (i,k+4,n-1,ires)
         end if
         call addbond (n-1,ni)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-3,1.10d0,cai,111.2d0,n-2,111.2d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-4,1.10d0,cai,111.2d0,n-3,111.2d0,-1)
         call findatm (' HG2',start,stop,i)
         call newatm (i,k+3,n-4,1.10d0,n-5,111.2d0,n-3,111.2d0,1)
         call findatm (' HG3',start,stop,i)
         call newatm (i,k+3,n-5,1.10d0,n-6,111.2d0,n-4,111.2d0,-1)
         if (newchn) then
            call findatm (' HD2',start,stop,i)
            call newatm (i,470,n-5,1.10d0,n-6,111.2d0,ni,111.2d0,1)
            call findatm (' HD3',start,stop,i)
            call newatm (i,470,n-6,1.10d0,n-7,111.2d0,ni,111.2d0,-1)
         else
            call findatm (' HD2',start,stop,i)
            call newatm (i,k+5,n-5,1.10d0,n-6,111.2d0,ni,111.2d0,1)
            call findatm (' HD3',start,stop,i)
            call newatm (i,k+5,n-6,1.10d0,n-7,111.2d0,ni,111.2d0,-1)
         end if
c
c     phenylalanine residue  (PHE)
c
      else if (resname .eq. 'PHE') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD1',start,stop,i)
         call oldatm (i,k+3,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,k+3,n-2,ires)
         call findatm (' CE1',start,stop,i)
         call oldatm (i,k+5,n-2,ires)
         call findatm (' CE2',start,stop,i)
         call oldatm (i,k+5,n-2,ires)
         call findatm (' CZ ',start,stop,i)
         call oldatm (i,k+7,n-1,ires)
         call addbond (n-1,n-3)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-8,1.10d0,cai,107.9d0,n-7,110.0d0,-1)
         call findatm (' HD1',start,stop,i)
         call newatm (i,k+4,n-7,1.09d0,n-8,120.0d0,n-9,0.0d0,0)
         call findatm (' HD2',start,stop,i)
         call newatm (i,k+4,n-7,1.09d0,n-9,120.0d0,n-10,0.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,k+6,n-7,1.09d0,n-9,120.0d0,n-10,180.0d0,0)
         call findatm (' HE2',start,stop,i)
         call newatm (i,k+6,n-7,1.09d0,n-9,120.0d0,n-11,180.0d0,0)
         call findatm (' HZ ',start,stop,i)
         call newatm (i,k+8,n-7,1.09d0,n-8,120.0d0,n-10,180.0d0,0)
c
c     tyrosine residue  (TYR)
c
      else if (resname .eq. 'TYR') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD1',start,stop,i)
         call oldatm (i,k+3,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,k+3,n-2,ires)
         call findatm (' CE1',start,stop,i)
         call oldatm (i,k+5,n-2,ires)
         call findatm (' CE2',start,stop,i)
         call oldatm (i,k+5,n-2,ires)
         call findatm (' CZ ',start,stop,i)
         call oldatm (i,k+7,n-1,ires)
         call addbond (n-1,n-3)
         call findatm (' OH ',start,stop,i)
         call oldatm (i,k+8,n-1,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-8,1.10d0,cai,107.9d0,n-7,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-9,1.10d0,cai,107.9d0,n-8,110.0d0,-1)
         call findatm (' HD1',start,stop,i)
         call newatm (i,k+4,n-8,1.09d0,n-9,120.0d0,n-10,0.0d0,0)
         call findatm (' HD2',start,stop,i)
         call newatm (i,k+4,n-8,1.09d0,n-10,120.0d0,n-11,0.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,k+6,n-8,1.09d0,n-10,120.0d0,n-11,180.0d0,0)
         call findatm (' HE2',start,stop,i)
         call newatm (i,k+6,n-8,1.09d0,n-10,120.0d0,n-12,180.0d0,0)
         call findatm (' HH ',start,stop,i)
         call newatm (i,k+9,n-7,0.97d0,n-8,108.0d0,n-9,0.0d0,0)
c
c     deprotonated tyrosine residue  (TYD)
c
      else if (resname .eq. 'TYD') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD1',start,stop,i)
         call oldatm (i,k+3,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,k+3,n-2,ires)
         call findatm (' CE1',start,stop,i)
         call oldatm (i,k+5,n-2,ires)
         call findatm (' CE2',start,stop,i)
         call oldatm (i,k+5,n-2,ires)
         call findatm (' CZ ',start,stop,i)
         call oldatm (i,k+7,n-1,ires)
         call addbond (n-1,n-3)
         call findatm (' OH ',start,stop,i)
         call oldatm (i,k+8,n-1,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-8,1.10d0,cai,107.9d0,n-7,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-9,1.10d0,cai,107.9d0,n-8,110.0d0,-1)
         call findatm (' HD1',start,stop,i)
         call newatm (i,k+4,n-8,1.09d0,n-9,120.0d0,n-10,0.0d0,0)
         call findatm (' HD2',start,stop,i)
         call newatm (i,k+4,n-8,1.09d0,n-10,120.0d0,n-11,0.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,k+6,n-8,1.09d0,n-10,120.0d0,n-11,180.0d0,0)
         call findatm (' HE2',start,stop,i)
         call newatm (i,k+6,n-8,1.09d0,n-10,120.0d0,n-12,180.0d0,0)
c
c     tryptophan residue  (TRP)
c
      else if (resname .eq. 'TRP') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD1',start,stop,i)
         call oldatm (i,k+3,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,k+5,n-2,ires)
         call findatm (' NE1',start,stop,i)
         call oldatm (i,k+6,n-2,ires)
         call findatm (' CE2',start,stop,i)
         call oldatm (i,k+8,n-1,ires)
         call addbond (n-1,n-3)
         call findatm (' CE3',start,stop,i)
         call oldatm (i,k+9,n-3,ires)
         call findatm (' CZ2',start,stop,i)
         call oldatm (i,k+11,n-2,ires)
         call findatm (' CZ3',start,stop,i)
         call oldatm (i,k+13,n-2,ires)
         call findatm (' CH2',start,stop,i)
         call oldatm (i,k+15,n-1,ires)
         call addbond (n-1,n-3)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-10,1.10d0,cai,107.9d0,n-9,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-11,1.10d0,cai,107.9d0,n-10,110.0d0,-1)
         call findatm (' HD1',start,stop,i)
         call newatm (i,k+4,n-10,1.09d0,n-11,126.0d0,n-12,0.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,k+7,n-9,1.01d0,n-11,126.3d0,n-12,180.0d0,0)
         call findatm (' HE3',start,stop,i)
         call newatm (i,k+10,n-8,1.09d0,n-6,120.0d0,n-5,180.0d0,0)
         call findatm (' HZ2',start,stop,i)
         call newatm (i,k+12,n-8,1.09d0,n-6,120.0d0,n-7,180.0d0,0)
         call findatm (' HZ3',start,stop,i)
         call newatm (i,k+14,n-8,1.09d0,n-7,120.0d0,n-9,180.0d0,0)
         call findatm (' HH2',start,stop,i)
         call newatm (i,k+16,n-8,1.09d0,n-9,120.0d0,n-11,180.0d0,0)
c
c     histidine (HD and HE) residue  (HIS)
c
      else if (resname .eq. 'HIS') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' ND1',start,stop,i)
         call oldatm (i,k+3,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,k+5,n-2,ires)
         call findatm (' CE1',start,stop,i)
         call oldatm (i,k+7,n-2,ires)
         call findatm (' NE2',start,stop,i)
         call oldatm (i,k+9,n-1,ires)
         call addbond (n-1,n-3)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,-1)
         call findatm (' HD1',start,stop,i)
         call newatm (i,k+4,n-6,1.02d0,n-4,126.0d0,n-3,180.0d0,0)
         call findatm (' HD2',start,stop,i)
         call newatm (i,k+6,n-6,1.09d0,n-4,126.0d0,n-5,180.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,k+8,n-6,1.09d0,n-5,126.0d0,n-7,180.0d0,0)
         call findatm (' HE2',start,stop,i)
         call newatm (i,k+10,n-6,1.02d0,n-7,126.0d0,n-9,180.0d0,0)
c
c     histidine (HD only) residue  (HID)
c
      else if (resname .eq. 'HID') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' ND1',start,stop,i)
         call oldatm (i,k+3,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,k+5,n-2,ires)
         call findatm (' CE1',start,stop,i)
         call oldatm (i,k+7,n-2,ires)
         call findatm (' NE2',start,stop,i)
         call oldatm (i,k+9,n-1,ires)
         call addbond (n-1,n-3)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,-1)
         call findatm (' HD1',start,stop,i)
         call newatm (i,k+4,n-6,1.02d0,n-4,126.0d0,n-3,180.0d0,0)
         call findatm (' HD2',start,stop,i)
         call newatm (i,k+6,n-6,1.09d0,n-4,126.0d0,n-5,180.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,k+8,n-6,1.09d0,n-5,126.0d0,n-7,180.0d0,0)
c
c     histidine (HE only) residue  (HIE)
c
      else if (resname .eq. 'HIE') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' ND1',start,stop,i)
         call oldatm (i,k+3,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,k+4,n-2,ires)
         call findatm (' CE1',start,stop,i)
         call oldatm (i,k+6,n-2,ires)
         call findatm (' NE2',start,stop,i)
         call oldatm (i,k+8,n-1,ires)
         call addbond (n-1,n-3)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,-1)
         call findatm (' HD2',start,stop,i)
         call newatm (i,k+5,n-5,1.09d0,n-3,126.0d0,n-4,180.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,k+7,n-5,1.09d0,n-4,126.0d0,n-6,180.0d0,0)
         call findatm (' HE2',start,stop,i)
         call newatm (i,k+9,n-5,1.02d0,n-6,126.0d0,n-8,180.0d0,0)
c
c     aspartate residue  (ASP)
c
      else if (resname .eq. 'ASP') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' OD1',start,stop,i)
         call oldatm (i,k+3,n-1,ires)
         call findatm (' OD2',start,stop,i)
         call oldatm (i,k+3,n-2,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1)
c
c     protonated aspartic acid residue  (ASH)
c
      else if (resname .eq. 'ASH') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' OD1',start,stop,i)
         call oldatm (i,k+3,n-1,ires)
         call findatm (' OD2',start,stop,i)
         call oldatm (i,k+4,n-2,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1)
         call findatm (' HD2',start,stop,i)
         call newatm (i,k+5,n-3,0.98d0,n-5,108.7d0,n-4,0.0d0,0)
c
c     asparagine residue  (ASN)
c
      else if (resname .eq. 'ASN') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' OD1',start,stop,i)
         call oldatm (i,k+3,n-1,ires)
         call findatm (' ND2',start,stop,i)
         call oldatm (i,k+4,n-2,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1)
         call findatm ('HD21',start,stop,i)
         call newatm (i,k+5,n-3,1.01d0,n-5,120.9d0,n-6,0.0d0,0)
         call findatm ('HD22',start,stop,i)
         call newatm (i,k+5,n-4,1.01d0,n-6,120.3d0,n-7,180.0d0,0)
c
c     glutamate residue  (GLU)
c
      else if (resname .eq. 'GLU') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,k+4,n-1,ires)
         call findatm (' OE1',start,stop,i)
         call oldatm (i,k+5,n-1,ires)
         call findatm (' OE2',start,stop,i)
         call oldatm (i,k+5,n-2,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1)
         call findatm (' HG2',start,stop,i)
         call newatm (i,k+3,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1)
         call findatm (' HG3',start,stop,i)
         call newatm (i,k+3,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1)
c
c     protonated glutamic acid residue  (GLH)
c
      else if (resname .eq. 'GLH') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,k+4,n-1,ires)
         call findatm (' OE1',start,stop,i)
         call oldatm (i,k+5,n-1,ires)
         call findatm (' OE2',start,stop,i)
         call oldatm (i,k+6,n-2,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1)
         call findatm (' HG2',start,stop,i)
         call newatm (i,k+3,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1)
         call findatm (' HG3',start,stop,i)
         call newatm (i,k+3,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1)
         call findatm (' HE2',start,stop,i)
         call newatm (i,k+7,n-5,0.98d0,n-7,108.7d0,n-6,0.0d0,0)
c
c     glutamine residue  (GLN)
c
      else if (resname .eq. 'GLN') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,k+4,n-1,ires)
         call findatm (' OE1',start,stop,i)
         call oldatm (i,k+5,n-1,ires)
         call findatm (' NE2',start,stop,i)
         call oldatm (i,k+6,n-2,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1)
         call findatm (' HG2',start,stop,i)
         call newatm (i,k+3,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1)
         call findatm (' HG3',start,stop,i)
         call newatm (i,k+3,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1)
         call findatm ('HE21',start,stop,i)
         call newatm (i,k+7,n-5,1.01d0,n-7,120.9d0,n-8,0.0d0,0)
         call findatm ('HE22',start,stop,i)
         call newatm (i,k+7,n-6,1.01d0,n-8,120.3d0,n-9,180.0d0,0)
c
c     methionine residue  (MET)
c
      else if (resname .eq. 'MET') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' SD ',start,stop,i)
         call oldatm (i,k+4,n-1,ires)
         call findatm (' CE ',start,stop,i)
         call oldatm (i,k+5,n-1,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1)
         call findatm (' HG2',start,stop,i)
         call newatm (i,k+3,n-5,1.10d0,n-6,109.5d0,n-4,109.5d0,1)
         call findatm (' HG3',start,stop,i)
         call newatm (i,k+3,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,-1)
         call findatm (' HE1',start,stop,i)
         call newatm (i,k+6,n-5,1.10d0,n-6,110.2d0,n-7,180.0d0,0)
         call findatm (' HE2',start,stop,i)
         call newatm (i,k+6,n-6,1.10d0,n-7,110.2d0,n-8,60.0d0,0)
         call findatm (' HE3',start,stop,i)
         call newatm (i,k+6,n-7,1.10d0,n-8,110.2d0,n-9,-60.0d0,0)
c
c     lysine residue  (LYS)
c
      else if (resname .eq. 'LYS') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,k+4,n-1,ires)
         call findatm (' CE ',start,stop,i)
         call oldatm (i,k+6,n-1,ires)
         call findatm (' NZ ',start,stop,i)
         call oldatm (i,k+8,n-1,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1)
         call findatm (' HG2',start,stop,i)
         call newatm (i,k+3,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1)
         call findatm (' HG3',start,stop,i)
         call newatm (i,k+3,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1)
         call findatm (' HD2',start,stop,i)
         call newatm (i,k+5,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,1)
         call findatm (' HD3',start,stop,i)
         call newatm (i,k+5,n-8,1.10d0,n-9,109.5d0,n-7,109.5d0,-1)
         call findatm (' HE2',start,stop,i)
         call newatm (i,k+7,n-8,1.10d0,n-9,110.9d0,n-7,107.3d0,1)
         call findatm (' HE3',start,stop,i)
         call newatm (i,k+7,n-9,1.10d0,n-10,110.9d0,n-8,107.3d0,-1)
         call findatm (' HZ1',start,stop,i)
         call newatm (i,k+9,n-9,1.04d0,n-10,110.5d0,n-11,180.0d0,0)
         call findatm (' HZ2',start,stop,i)
         call newatm (i,k+9,n-10,1.04d0,n-11,110.5d0,n-12,60.0d0,0)
         call findatm (' HZ3',start,stop,i)
         call newatm (i,k+9,n-11,1.04d0,n-12,110.5d0,n-13,-60.0d0,0)
c
c     deprotonated lysine residue  (LYD)
c
      else if (resname .eq. 'LYD') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,k+4,n-1,ires)
         call findatm (' CE ',start,stop,i)
         call oldatm (i,k+6,n-1,ires)
         call findatm (' NZ ',start,stop,i)
         call oldatm (i,k+8,n-1,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1)
         call findatm (' HG2',start,stop,i)
         call newatm (i,k+3,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1)
         call findatm (' HG3',start,stop,i)
         call newatm (i,k+3,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1)
         call findatm (' HD2',start,stop,i)
         call newatm (i,k+5,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,1)
         call findatm (' HD3',start,stop,i)
         call newatm (i,k+5,n-8,1.10d0,n-9,109.5d0,n-7,109.5d0,-1)
         call findatm (' HE2',start,stop,i)
         call newatm (i,k+7,n-8,1.10d0,n-9,110.9d0,n-7,107.3d0,1)
         call findatm (' HE3',start,stop,i)
         call newatm (i,k+7,n-9,1.10d0,n-10,110.9d0,n-8,107.3d0,-1)
         call findatm (' HZ1',start,stop,i)
         call newatm (i,k+9,n-9,1.04d0,n-10,110.5d0,n-11,180.0d0,0)
         call findatm (' HZ2',start,stop,i)
         call newatm (i,k+9,n-10,1.04d0,n-11,110.5d0,n-12,60.0d0,0)
c
c     arginine residue  (ARG)
c
      else if (resname .eq. 'ARG') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,k+4,n-1,ires)
         call findatm (' NE ',start,stop,i)
         call oldatm (i,k+6,n-1,ires)
         call findatm (' CZ ',start,stop,i)
         call oldatm (i,k+8,n-1,ires)
         call findatm (' NH1',start,stop,i)
         call oldatm (i,k+9,n-1,ires)
         call findatm (' NH2',start,stop,i)
         call oldatm (i,k+9,n-2,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-8,1.10d0,cai,107.9d0,n-7,110.0d0,-1)
         call findatm (' HG2',start,stop,i)
         call newatm (i,k+3,n-8,1.10d0,n-9,109.5d0,n-7,109.5d0,1)
         call findatm (' HG3',start,stop,i)
         call newatm (i,k+3,n-9,1.10d0,n-10,109.5d0,n-8,109.5d0,-1)
         call findatm (' HD2',start,stop,i)
         call newatm (i,k+5,n-9,1.10d0,n-10,109.5d0,n-8,109.5d0,1)
         call findatm (' HD3',start,stop,i)
         call newatm (i,k+5,n-10,1.10d0,n-11,109.5d0,n-9,109.5d0,-1)
         call findatm (' HE ',start,stop,i)
         call newatm (i,k+7,n-10,1.01d0,n-11,118.5d0,n-9,120.0d0,1)
         call findatm ('HH11',start,stop,i)
         call newatm (i,k+10,n-9,1.01d0,n-10,122.5d0,n-11,0.0d0,0)
         call findatm ('HH12',start,stop,i)
         call newatm (i,k+10,n-10,1.01d0,n-11,118.8d0,n-12,180.0d0,0)
         call findatm ('HH21',start,stop,i)
         call newatm (i,k+10,n-10,1.01d0,n-12,122.5d0,n-13,0.0d0,0)
         call findatm ('HH22',start,stop,i)
         call newatm (i,k+10,n-11,1.01d0,n-13,118.8d0,n-14,180.0d0,0)
c
c     ornithine residue  (ORN)
c
      else if (resname .eq. 'ORN') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,k+4,n-1,ires)
         call findatm (' NE ',start,stop,i)
         call oldatm (i,k+6,n-1,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1)
         call findatm (' HG2',start,stop,i)
         call newatm (i,k+3,n-5,1.10d0,n-7,109.5d0,n-4,109.5d0,1)
         call findatm (' HG3',start,stop,i)
         call newatm (i,k+3,n-6,1.10d0,n-8,109.5d0,n-5,109.5d0,-1)
         call findatm (' HD2',start,stop,i)
         call newatm (i,k+5,n-6,1.10d0,n-8,109.5d0,n-5,109.5d0,1)
         call findatm (' HD3',start,stop,i)
         call newatm (i,k+5,n-7,1.10d0,n-9,109.5d0,n-6,109.5d0,-1)
         call findatm (' HE1',start,stop,i)
         call newatm (i,k+7,n-7,1.04d0,n-8,110.5d0,n-9,180.0d0,0)
         call findatm (' HE2',start,stop,i)
         call newatm (i,k+7,n-8,1.04d0,n-9,110.5d0,n-10,60.0d0,0)
         call findatm (' HE3',start,stop,i)
         call newatm (i,k+7,n-9,1.04d0,n-10,110.5d0,n-11,-60.0d0,0)
c
c     methylalanine residue  (AIB)
c
      else if (resname .eq. 'AIB') then
         call findatm (' CB1',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CB2',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm ('HB11',start,stop,i)
         call newatm (i,k+1,n-2,1.10d0,cai,110.2d0,ni,180.0d0,0)
         call findatm ('HB12',start,stop,i)
         call newatm (i,k+1,n-3,1.10d0,cai,110.2d0,ni,60.0d0,0)
         call findatm ('HB13',start,stop,i)
         call newatm (i,k+1,n-4,1.10d0,cai,110.2d0,ni,-60.0d0,0)
         call findatm ('HB21',start,stop,i)
         call newatm (i,k+1,n-4,1.10d0,cai,110.2d0,ni,180.0d0,0)
         call findatm ('HB22',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,110.2d0,ni,60.0d0,0)
         call findatm ('HB23',start,stop,i)
         call newatm (i,k+1,n-6,1.10d0,cai,110.2d0,ni,-60.0d0,0)
c
c     pyroglutamic acid residue  (PCA)
c
      else if (resname .eq. 'PCA') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,k,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,k+2,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,k+4,n-1,ires)
         call addbond (n-1,ni)
         call findatm (' OE ',start,stop,i)
         call oldatm (i,k+5,n-1,ires)
         call findatm (' HB2',start,stop,i)
         call newatm (i,k+1,n-4,1.10d0,cai,111.2d0,n-3,111.2d0,1)
         call findatm (' HB3',start,stop,i)
         call newatm (i,k+1,n-5,1.10d0,cai,111.2d0,n-4,111.2d0,-1)
         call findatm (' HG2',start,stop,i)
         call newatm (i,k+3,n-5,1.10d0,n-6,111.2d0,n-4,111.2d0,1)
         call findatm (' HG3',start,stop,i)
         call newatm (i,k+3,n-6,1.10d0,n-7,111.2d0,n-5,111.2d0,-1)
c
c     unknown residue  (UNK)
c
      else if (resname .eq. 'UNK') then
         k = hatyp(seqtyp(ires))
         if (newchn)  k = hantyp(seqtyp(ires))
         if (endchn)  k = hactyp(seqtyp(ires))
         call newatm (i,k,cai,1.10d0,ni,109.5d0,ci,109.5d0,1)
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ligase  --  coordinates from PDB nucleic acid  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ligase" translates a nucleic acid structure in Protein Data
c     Bank format to a Cartesian coordinate file and sequence file
c
c
      subroutine ligase (ichn)
      use atoms
      use files
      use iounit
      use pdb
      use resdue
      use sequen
      implicit none
      integer i,j,k
      integer ichn,ityp
      integer jres,kres
      integer start,stop
      integer poi,o5i,c5i
      integer c4i,o4i,c1i
      integer c3i,c2i,o3i,o2i
      logical newchn,endchn
      logical, allocatable :: deoxy(:)
      character*3 resname
c
c
c     set the next atom and the residue range of the chain
c
      n = n + 1
      jres = ichain(1,ichn)
      kres = ichain(2,ichn)
c
c     perform dynamic allocation of some local arrays
c
      allocate (deoxy(nres))
c
c     check for deoxyribose and change residue name if necessary
c
      do i = jres, kres
         deoxy(i) = .false.
         start = resatm(1,i)
         stop = resatm(2,i)
         resname = pdbres(start)
         call findatm (' O2''',start,stop,k)
         if (k .eq. 0) then
            deoxy(i) = .true.
            do j = start, stop
               if (resname .eq. '  A')  pdbres(j) = ' DA'
               if (resname .eq. '  G')  pdbres(j) = ' DG'
               if (resname .eq. '  C')  pdbres(j) = ' DC'
               if (resname .eq. '  U')  pdbres(j) = ' DU'
               if (resname .eq. '  T')  pdbres(j) = ' DT'
            end do
         end if
      end do
c
c     locate and assign the atoms that make up each residue
c
      do i = jres, kres
         ityp = seqtyp(i)
         start = resatm(1,i)
         stop = resatm(2,i)
         resname = pdbres(start)
c
c     check that the maximum allowed atoms is not exceeded
c
         if (n+25 .gt. maxatm) then
            write (iout,10)  maxatm
   10       format (/,' LIGASE  --  The Maximum of',i9,' Atoms',
     &                 ' has been Exceeded')
            call fatal
         end if
c
c     test for initial or final residue of a nucleotide chain
c
         newchn = .false.
         endchn = .false.
         do j = 1, nchain
            if (i .eq. ichain(1,j)) then
               newchn = .true.
               poi = 0
               o3i = 0
            end if
            if (i .eq. ichain(2,j))  endchn = .true.
         end do
c
c     build the phosphate atoms of the current residue
c
         if (resname .eq. ' TP') then

         else if (resname .eq. ' DP') then

         else if (resname .eq. ' MP') then

         else if (.not. newchn) then
            call findatm (' P  ',start,stop,k)
            if (k .ne. 0)  poi = n
            j = ptyp(ityp)
            call oldatm (k,j,o3i,i)
            call findatm (' OP1',start,stop,k)
            j = optyp(ityp)
            call oldatm (k,j,n-1,i)
            call findatm (' OP2',start,stop,k)
            j = optyp(ityp)
            call oldatm (k,j,n-2,i)
         end if
c
c     build the ribose sugar atoms of the current residue
c
         call findatm (' O5''',start,stop,k)
         if (k .ne. 0)  o5i = n
         j = o5typ(ityp)
         if (newchn) then
            if (deoxy(i)) then
               j = 1244
            else
               j = 1232
            end if
         end if
         call oldatm (k,j,poi,i)
         call findatm (' C5''',start,stop,k)
         if (k .ne. 0)  c5i = n
         j = c5typ(ityp)
         call oldatm (k,j,n-1,i)
         call findatm (' C4''',start,stop,k)
         if (k .ne. 0)  c4i = n
         j = c4typ(ityp)
         call oldatm (k,j,n-1,i)
         call findatm (' O4''',start,stop,k)
         if (k .ne. 0)  o4i = n
         j = o4typ(ityp)
         call oldatm (k,j,n-1,i)
         call findatm (' C1''',start,stop,k)
         if (k .ne. 0)  c1i = n
         j = c1typ(ityp)
         call oldatm (k,j,n-1,i)
         call findatm (' C3''',start,stop,k)
         if (k .ne. 0)  c3i = n
         j = c3typ(ityp)
         call oldatm (k,j,n-3,i)
         call findatm (' C2''',start,stop,k)
         if (k .ne. 0)  c2i = n
         j = c2typ(ityp)
         call oldatm (k,j,n-1,i)
         call addbond (n-1,n-3)
         call findatm (' O3''',start,stop,k)
         if (k .ne. 0)  o3i = n
         j = o3typ(ityp)
         if (endchn) then
            if (deoxy(i)) then
               j = 1249
            else
               j = 1237
            end if
         end if
         call oldatm (k,j,n-2,i)
         if (.not. deoxy(i)) then
            call findatm (' O2''',start,stop,k)
            if (k .ne. 0)  o2i = n
            j = o2typ(ityp)
            call oldatm (k,j,n-2,i)
         end if
c
c     build the hydrogen atoms of the current residue
c
         if (newchn) then
            call findatm ('HO5''',start,stop,k)
            j = h5ttyp(ityp)
            call newatm (k,j,o5i,1.00d0,c5i,109.5d0,c4i,180.0d0,0)
         end if
         call findatm (' H5''',start,stop,k)
         j = h51typ(ityp)
         call newatm (k,j,c5i,1.09d0,o5i,109.5d0,c4i,109.5d0,1)
         call findatm ('H5''''',start,stop,k)
         j = h52typ(ityp)
         call newatm (k,j,c5i,1.09d0,o5i,109.5d0,c4i,109.5d0,-1)
         call findatm (' H4''',start,stop,k)
         j = h4typ(ityp)
         call newatm (k,j,c4i,1.09d0,c5i,109.5d0,c3i,109.5d0,-1)
         call findatm (' H3''',start,stop,k)
         j = h3typ(ityp)
         call newatm (k,j,c3i,1.09d0,c4i,109.5d0,c2i,109.5d0,-1)
         if (deoxy(i)) then
            call findatm (' H2''',start,stop,k)
            j = h21typ(ityp)
            call newatm (k,j,c2i,1.09d0,c3i,109.5d0,c1i,109.5d0,-1)
            call findatm ('H2''''',start,stop,k)
            j = h22typ(ityp)
            call newatm (k,j,c2i,1.09d0,c3i,109.5d0,c1i,109.5d0,1)
         else
            call findatm (' H2''',start,stop,k)
            j = h21typ(ityp)
            call newatm (k,j,c2i,1.09d0,c3i,109.5d0,c1i,109.5d0,-1)
            call findatm ('HO2''',start,stop,k)
            j = h22typ(ityp)
            call newatm (k,j,o2i,1.00d0,c2i,109.5d0,c3i,180.0d0,0)
         end if
         call findatm (' H1''',start,stop,k)
         j = h1typ(ityp)
         call newatm (k,j,c1i,1.09d0,o4i,109.5d0,c2i,109.5d0,-1)
         if (endchn) then
            call findatm ('HO3''',start,stop,k)
            j = h3ttyp(ityp)
            call newatm (k,j,o3i,1.00d0,c3i,109.5d0,c4i,180.0d0,0)
         end if
c
c     build the standard base atoms of the current residue
c
         call addbase (resname,i,start,stop,c1i)
      end do
c
c     total number of atoms is one less than the current atom
c
      n = n - 1
c
c     perform deallocation of some local arrays
c
      deallocate (deoxy)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine addbase  --  build a single nucleic acid base  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "addbase" builds the Cartesian coordinates for a single nucleic
c     acid base; coordinates are read from the Protein Data Bank file
c     or found from internal coordinates, then atom types are assigned
c     and connectivity data generated
c
c
      subroutine addbase (resname,ires,start,stop,c1i)
      use atoms
      implicit none
      integer i,ires
      integer start,stop
      integer c1i
      character*3 resname
c
c
c     adenine in adenosine residue  (A)
c
      if (resname .eq. '  A') then
         call findatm (' N9 ',start,stop,i)
         call oldatm (i,1017,c1i,ires)
         call findatm (' C8 ',start,stop,i)
         call oldatm (i,1021,n-1,ires)
         call findatm (' N7 ',start,stop,i)
         call oldatm (i,1020,n-1,ires)
         call findatm (' C5 ',start,stop,i)
         call oldatm (i,1019,n-1,ires)
         call findatm (' C6 ',start,stop,i)
         call oldatm (i,1025,n-1,ires)
         call findatm (' N6 ',start,stop,i)
         call oldatm (i,1027,n-1,ires)
         call findatm (' N1 ',start,stop,i)
         call oldatm (i,1024,n-2,ires)
         call findatm (' C2 ',start,stop,i)
         call oldatm (i,1023,n-1,ires)
         call findatm (' N3 ',start,stop,i)
         call oldatm (i,1022,n-1,ires)
         call findatm (' C4 ',start,stop,i)
         call oldatm (i,1018,n-1,ires)
         call addbond (n-1,n-7)
         call addbond (n-1,n-10)
         call findatm (' H8 ',start,stop,i)
         call newatm (i,1030,n-9,1.08d0,n-8,123.1d0,n-7,180.0d0,0)
         call findatm (' H61',start,stop,i)
         call newatm (i,1028,n-6,1.00d0,n-7,120.0d0,n-8,180.0d0,0)
         call findatm (' H62',start,stop,i)
         call newatm (i,1029,n-7,1.00d0,n-8,120.0d0,n-9,0.0d0,0)
         call findatm (' H2 ',start,stop,i)
         call newatm (i,1026,n-6,1.08d0,n-5,115.4d0,n-4,180.0d0,0)
c
c     guanine in guanosine residue  (G)
c
      else if (resname .eq. '  G') then
         call findatm (' N9 ',start,stop,i)
         call oldatm (i,1047,c1i,ires)
         call findatm (' C8 ',start,stop,i)
         call oldatm (i,1051,n-1,ires)
         call findatm (' N7 ',start,stop,i)
         call oldatm (i,1050,n-1,ires)
         call findatm (' C5 ',start,stop,i)
         call oldatm (i,1049,n-1,ires)
         call findatm (' C6 ',start,stop,i)
         call oldatm (i,1055,n-1,ires)
         call findatm (' O6 ',start,stop,i)
         call oldatm (i,1060,n-1,ires)
         call findatm (' N1 ',start,stop,i)
         call oldatm (i,1054,n-2,ires)
         call findatm (' C2 ',start,stop,i)
         call oldatm (i,1053,n-1,ires)
         call findatm (' N2 ',start,stop,i)
         call oldatm (i,1057,n-1,ires)
         call findatm (' N3 ',start,stop,i)
         call oldatm (i,1052,n-2,ires)
         call findatm (' C4 ',start,stop,i)
         call oldatm (i,1048,n-1,ires)
         call addbond (n-1,n-8)
         call addbond (n-1,n-11)
         call findatm (' H8 ',start,stop,i)
         call newatm (i,1061,n-10,1.08d0,n-9,123.0d0,n-8,180.0d0,0)
         call findatm (' H1 ',start,stop,i)
         call newatm (i,1056,n-6,1.00d0,n-8,117.4d0,n-9,180.0d0,0)
         call findatm (' H21',start,stop,i)
         call newatm (i,1058,n-5,1.00d0,n-6,120.0d0,n-7,0.0d0,0)
         call findatm (' H22',start,stop,i)
         call newatm (i,1059,n-6,1.00d0,n-7,120.0d0,n-8,180.0d0,0)
c
c     cytosine in cytidine residue  (C)
c
      else if (resname .eq. '  C') then
         call findatm (' N1 ',start,stop,i)
         call oldatm (i,1078,c1i,ires)
         call findatm (' C2 ',start,stop,i)
         call oldatm (i,1079,n-1,ires)
         call findatm (' O2 ',start,stop,i)
         call oldatm (i,1084,n-1,ires)
         call findatm (' N3 ',start,stop,i)
         call oldatm (i,1080,n-2,ires)
         call findatm (' C4 ',start,stop,i)
         call oldatm (i,1081,n-1,ires)
         call findatm (' N4 ',start,stop,i)
         call oldatm (i,1085,n-1,ires)
         call findatm (' C5 ',start,stop,i)
         call oldatm (i,1082,n-2,ires)
         call findatm (' C6 ',start,stop,i)
         call oldatm (i,1083,n-1,ires)
         call addbond (n-1,n-8)
         call findatm (' H41',start,stop,i)
         call newatm (i,1086,n-3,1.00d0,n-4,120.0d0,n-5,0.0d0,0)
         call findatm (' H42',start,stop,i)
         call newatm (i,1087,n-4,1.00d0,n-5,120.0d0,n-6,180.0d0,0)
         call findatm (' H5 ',start,stop,i)
         call newatm (i,1088,n-4,1.08d0,n-6,121.6d0,n-7,180.0d0,0)
         call findatm (' H6 ',start,stop,i)
         call newatm (i,1089,n-4,1.08d0,n-5,119.4d0,n-7,180.0d0,0)
c
c     uracil in uridine residue  (U)
c
      else if (resname .eq. '  U') then
         call findatm (' N1 ',start,stop,i)
         call oldatm (i,1106,c1i,ires)
         call findatm (' C2 ',start,stop,i)
         call oldatm (i,1107,n-1,ires)
         call findatm (' O2 ',start,stop,i)
         call oldatm (i,1112,n-1,ires)
         call findatm (' N3 ',start,stop,i)
         call oldatm (i,1108,n-2,ires)
         call findatm (' C4 ',start,stop,i)
         call oldatm (i,1109,n-1,ires)
         call findatm (' O4 ',start,stop,i)
         call oldatm (i,1114,n-1,ires)
         call findatm (' C5 ',start,stop,i)
         call oldatm (i,1110,n-2,ires)
         call findatm (' C6 ',start,stop,i)
         call oldatm (i,1111,n-1,ires)
         call addbond (n-1,n-8)
         call findatm (' H3 ',start,stop,i)
         call newatm (i,1113,n-5,1.00d0,n-7,116.5d0,n-8,180.0d0,0)
         call findatm (' H5 ',start,stop,i)
         call newatm (i,1115,n-3,1.08d0,n-5,120.4d0,n-6,180.0d0,0)
         call findatm (' H6 ',start,stop,i)
         call newatm (i,1116,n-3,1.08d0,n-4,118.6d0,n-6,180.0d0,0)
c
c     adenine in deoxyadenosine residue  (DA)
c
      else if (resname .eq. ' DA') then
         call findatm (' N9 ',start,stop,i)
         call oldatm (i,1132,c1i,ires)
         call findatm (' C8 ',start,stop,i)
         call oldatm (i,1136,n-1,ires)
         call findatm (' N7 ',start,stop,i)
         call oldatm (i,1135,n-1,ires)
         call findatm (' C5 ',start,stop,i)
         call oldatm (i,1134,n-1,ires)
         call findatm (' C6 ',start,stop,i)
         call oldatm (i,1140,n-1,ires)
         call findatm (' N6 ',start,stop,i)
         call oldatm (i,1142,n-1,ires)
         call findatm (' N1 ',start,stop,i)
         call oldatm (i,1139,n-2,ires)
         call findatm (' C2 ',start,stop,i)
         call oldatm (i,1138,n-1,ires)
         call findatm (' N3 ',start,stop,i)
         call oldatm (i,1137,n-1,ires)
         call findatm (' C4 ',start,stop,i)
         call oldatm (i,1133,n-1,ires)
         call addbond (n-1,n-7)
         call addbond (n-1,n-10)
         call findatm (' H8 ',start,stop,i)
         call newatm (i,1145,n-9,1.08d0,n-8,123.1d0,n-7,180.0d0,0)
         call findatm (' H61',start,stop,i)
         call newatm (i,1143,n-6,1.00d0,n-7,120.0d0,n-8,180.0d0,0)
         call findatm (' H62',start,stop,i)
         call newatm (i,1144,n-7,1.00d0,n-8,120.0d0,n-9,0.0d0,0)
         call findatm (' H2 ',start,stop,i)
         call newatm (i,1141,n-6,1.08d0,n-5,115.4d0,n-4,180.0d0,0)
c
c     guanine in deoxyguanosine residue  (DG)
c
      else if (resname .eq. ' DG') then
         call findatm (' N9 ',start,stop,i)
         call oldatm (i,1161,c1i,ires)
         call findatm (' C8 ',start,stop,i)
         call oldatm (i,1165,n-1,ires)
         call findatm (' N7 ',start,stop,i)
         call oldatm (i,1164,n-1,ires)
         call findatm (' C5 ',start,stop,i)
         call oldatm (i,1163,n-1,ires)
         call findatm (' C6 ',start,stop,i)
         call oldatm (i,1169,n-1,ires)
         call findatm (' O6 ',start,stop,i)
         call oldatm (i,1174,n-1,ires)
         call findatm (' N1 ',start,stop,i)
         call oldatm (i,1168,n-2,ires)
         call findatm (' C2 ',start,stop,i)
         call oldatm (i,1167,n-1,ires)
         call findatm (' N2 ',start,stop,i)
         call oldatm (i,1171,n-1,ires)
         call findatm (' N3 ',start,stop,i)
         call oldatm (i,1166,n-2,ires)
         call findatm (' C4 ',start,stop,i)
         call oldatm (i,1162,n-1,ires)
         call addbond (n-1,n-8)
         call addbond (n-1,n-11)
         call findatm (' H8 ',start,stop,i)
         call newatm (i,1175,n-10,1.08d0,n-9,123.0d0,n-8,180.0d0,0)
         call findatm (' H1 ',start,stop,i)
         call newatm (i,1170,n-6,1.00d0,n-8,117.4d0,n-9,180.0d0,0)
         call findatm (' H21',start,stop,i)
         call newatm (i,1172,n-5,1.00d0,n-6,120.0d0,n-7,0.0d0,0)
         call findatm (' H22',start,stop,i)
         call newatm (i,1173,n-6,1.00d0,n-7,120.0d0,n-8,180.0d0,0)
c
c     cytosine in deoxycytidine residue  (DC)
c
      else if (resname .eq. ' DC') then
         call findatm (' N1 ',start,stop,i)
         call oldatm (i,1191,c1i,ires)
         call findatm (' C2 ',start,stop,i)
         call oldatm (i,1192,n-1,ires)
         call findatm (' O2 ',start,stop,i)
         call oldatm (i,1197,n-1,ires)
         call findatm (' N3 ',start,stop,i)
         call oldatm (i,1193,n-2,ires)
         call findatm (' C4 ',start,stop,i)
         call oldatm (i,1194,n-1,ires)
         call findatm (' N4 ',start,stop,i)
         call oldatm (i,1198,n-1,ires)
         call findatm (' C5 ',start,stop,i)
         call oldatm (i,1195,n-2,ires)
         call findatm (' C6 ',start,stop,i)
         call oldatm (i,1196,n-1,ires)
         call addbond (n-1,n-8)
         call findatm (' H41',start,stop,i)
         call newatm (i,1199,n-3,1.00d0,n-4,120.0d0,n-5,0.0d0,0)
         call findatm (' H42',start,stop,i)
         call newatm (i,1200,n-4,1.00d0,n-5,120.0d0,n-6,180.0d0,0)
         call findatm (' H5 ',start,stop,i)
         call newatm (i,1201,n-4,1.08d0,n-6,121.6d0,n-7,180.0d0,0)
         call findatm (' H6 ',start,stop,i)
         call newatm (i,1202,n-4,1.08d0,n-5,119.4d0,n-7,180.0d0,0)
c
c     thymine in deoxythymidine residue  (DT)
c
      else if (resname .eq. ' DT') then
         call findatm (' N1 ',start,stop,i)
         call oldatm (i,1218,c1i,ires)
         call findatm (' C2 ',start,stop,i)
         call oldatm (i,1219,n-1,ires)
         call findatm (' O2 ',start,stop,i)
         call oldatm (i,1224,n-1,ires)
         call findatm (' N3 ',start,stop,i)
         call oldatm (i,1220,n-2,ires)
         call findatm (' C4 ',start,stop,i)
         call oldatm (i,1221,n-1,ires)
         call findatm (' O4 ',start,stop,i)
         call oldatm (i,1226,n-1,ires)
         call findatm (' C5 ',start,stop,i)
         call oldatm (i,1222,n-2,ires)
         call findatm (' C7 ',start,stop,i)
         call oldatm (i,1227,n-1,ires)
         call findatm (' C6 ',start,stop,i)
         call oldatm (i,1223,n-2,ires)
         call addbond (n-1,n-9)
         call findatm (' H3 ',start,stop,i)
         call newatm (i,1225,n-6,1.00d0,n-8,116.8d0,n-9,180.0d0,0)
         call findatm (' H71',start,stop,i)
         call newatm (i,1228,n-3,1.09d0,n-4,109.5d0,n-6,0.0d0,0)
         call findatm (' H72',start,stop,i)
         call newatm (i,1228,n-4,1.09d0,n-5,109.5d0,n-1,109.5d0,1)
         call findatm (' H73',start,stop,i)
         call newatm (i,1228,n-5,1.09d0,n-6,109.5d0,n-2,109.5d0,-1)
         call findatm (' H6 ',start,stop,i)
         call newatm (i,1229,n-5,1.08d0,n-7,119.4d0,n-9,180.0d0,0)
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine hetatom  --  coordinates of PDB water and ions  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "hetatom" translates water molecules and ions in Protein Data
c     Bank format to a Cartesian coordinate file and sequence file
c
c
      subroutine hetatom
      use atoms
      use pdb
      implicit none
      integer i
c
c
c     find water molecules and ions in PDB HETATM records
c
      n = n + 1
      i = 0
      do while (i .lt. npdb)
         i = i + 1
         if (pdbrec(i) .eq. 'HETATM') then
            if (pdbres(i) .eq. 'HOH') then
               if (pdbatm(i) .eq. ' O  ') then
                  call oldatm (i,2001,0,0)
                  if (pdbatm(i+1).eq.' H  ' .and.
     &                pdbatm(i+2).eq.' H  ') then
                     call oldatm (i+1,2002,n-1,0)
                     call oldatm (i+2,2002,n-2,0)
                     i = i + 2
                     if (pdbatm(i+1) .eq. ' EP ') then
                        call oldatm (i+1,2003,n-3,0)
                        i = i + 1
                        if (pdbatm(i+1) .eq. ' EP ') then
                           call oldatm (i+1,2003,n-4,0)
                           i = i + 1
                        end if
                     end if
                  else
                     call newatm (0,2002,n-1,0.96d0,n-2,109.5d0,
     &                               n-3,120.0d0,0)
                     call newatm (0,2002,n-2,0.96d0,n-1,109.5d0,
     &                               n-3,120.0d0,0)
                  end if
               end if
            else if (pdbres(i) .eq. ' LI') then
               call oldatm (i,2004,0,0)
            else if (pdbres(i) .eq. ' NA') then
               call oldatm (i,2005,0,0)
            else if (pdbres(i) .eq. '  K') then
               call oldatm (i,2006,0,0)
            else if (pdbres(i) .eq. ' RB') then
               call oldatm (i,2007,0,0)
            else if (pdbres(i) .eq. ' CS') then
               call oldatm (i,2008,0,0)
            else if (pdbres(i) .eq. ' MG') then
               call oldatm (i,2009,0,0)
            else if (pdbres(i) .eq. ' CA') then
               call oldatm (i,2010,0,0)
            else if (pdbres(i) .eq. ' SR') then
               call oldatm (i,2011,0,0)
            else if (pdbres(i) .eq. ' BA') then
               call oldatm (i,2012,0,0)
            else if (pdbres(i) .eq. '  F') then
               call oldatm (i,2013,0,0)
            else if (pdbres(i) .eq. ' CL') then
               call oldatm (i,2014,0,0)
            else if (pdbres(i) .eq. ' BR') then
               call oldatm (i,2015,0,0)
            else if (pdbres(i) .eq. '  I') then
               call oldatm (i,2016,0,0)
            else if (pdbres(i) .eq. ' ZN') then
               call oldatm (i,2017,0,0)
            end if
         end if
      end do
      n = n - 1
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine oldatm  --  transfer coordinates from PDB  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "oldatm" get the Cartesian coordinates for an atom from
c     the Protein Data Bank file, then assigns the atom type
c     and atomic connectivities
c
c
      subroutine oldatm (i,bionum,i1,ires)
      use atomid
      use atoms
      use fields
      use iounit
      use katoms
      use pdb
      use sequen
      implicit none
      integer i,bionum
      integer i1,ires
c
c
c     get coordinates, assign atom type, and update connectivities
c
      if (bionum .ne. 0) then
         if (i .ne. 0) then
            type(n) = biotyp(bionum)
            if (type(n) .gt. 0) then
               name(n) = symbol(type(n))
            else
               type(n) = 0
               name(n) = '   '
            end if
            x(n) = xpdb(i)
            y(n) = ypdb(i)
            z(n) = zpdb(i)
            if (i1 .ne. 0)  call addbond (n,i1)
            n = n + 1
         else
            write (iout,10)  bionum,ires,seq(ires)
   10       format (/,' OLDATM  --  A PDB Atom of Biotype',i5,
     &                 ' is Missing in Residue',i5,'-',a3)
            call fatal
         end if
      end if
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine newatm  --  create and define a new atom  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "newatm" creates and defines an atom needed for the
c     Cartesian coordinates file, but which may not present
c     in the original Protein Data Bank file
c
c
      subroutine newatm (i,bionum,ia,bond,ib,angle1,ic,angle2,chiral)
      use atomid
      use atoms
      use fields
      use katoms
      use pdb
      implicit none
      integer i,bionum
      integer ia,ib,ic
      integer chiral
      real*8 bond
      real*8 angle1
      real*8 angle2
c
c
c     set the atom type, compute coordinates, assign
c     connectivities and increment the atom counter
c
      if (bionum .ne. 0) then
         type(n) = biotyp(bionum)
         if (type(n) .gt. 0) then
            name(n) = symbol(type(n))
         else
            type(n) = 0
            name(n) = '   '
         end if
         if (i .eq. 0) then
            call xyzatm (n,ia,bond,ib,angle1,ic,angle2,chiral)
         else
            x(n) = xpdb(i)
            y(n) = ypdb(i)
            z(n) = zpdb(i)
         end if
         call addbond (n,ia)
         n = n + 1
      end if
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine addbond  --  add a bond between two atoms  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "addbond" adds entries to the attached atoms list in
c     order to generate a direct connection between two atoms
c
c
      subroutine addbond (i,j)
      use couple
      implicit none
      integer i,j
c
c
c     add connectivity between the two atoms
c
      if (i.ne.0 .and. j.ne.0) then
         n12(i) = n12(i) + 1
         i12(n12(i),i) = j
         n12(j) = n12(j) + 1
         i12(n12(j),j) = i
      end if
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine findatm  --  locate PDB atom in a residue  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "findatm" locates a specific PDB atom name type within a
c     range of atoms from the PDB file, returns zero if the name
c     type was not found
c
c
      subroutine findatm (name,start,stop,ipdb)
      use pdb
      implicit none
      integer i,ipdb
      integer start,stop
      character*4 name
c
c
c     search for the specified atom within the residue
c
      ipdb = 0
      do i = start, stop
         if (pdbatm(i) .eq. name) then
            ipdb = i
            goto 10
         end if
      end do
   10 continue
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module phipsi  --  phi-psi-omega-chi angles for protein  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     chiral   chirality of each amino acid residue (1=L, -1=D)
c     disulf   residue joined to each residue via a disulfide link
c     phi      value of the phi angle for each amino acid residue
c     psi      value of the psi angle for each amino acid residue
c     omg      value of the omega angle for each amino acid residue
c     chi      values of the chi angles for each amino acid residue
c
c
      module phipsi
      use sizes
      implicit none
      integer chiral(maxres)
      integer disulf(maxres)
      real*8 phi(maxres)
      real*8 psi(maxres)
      real*8 omg(maxres)
      real*8 chi(4,maxres)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine picalc  --  Pariser-Parr-Pople MO calculation  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "picalc" performs a modified Pariser-Parr-Pople molecular
c     orbital calculation for each conjugated pisystem
c
c
      subroutine picalc
      use bndstr
      use couple
      use inform
      use iounit
      use piorbs
      use tors
      implicit none
      integer i,j,k,m,ib,ic
      integer ii,jj,kk
      integer iorb,jorb
      integer ncalls
      data ncalls  / 0 /
      save ncalls
c
c
c     only needs to be done if pisystem is present
c
      if (norbit .eq. 0)  return
c
c     increment the number of calls to this routine
c
      ncalls = ncalls + 1
      if (reorbit.eq.0 .or. ncalls.lt.reorbit)  return
      ncalls = 0
c
c     loop over all pisystems computing separate MOs for each
c
      do i = 1, nconj
         norbit = 0
         do j = iconj(1,i), iconj(2,i)
            norbit = norbit + 1
            iorbit(norbit) = kconj(j)
         end do
c
c     find and store the pisystem bonds for this pisystem
c
         nbpi = 0
         kk = iconj(2,i) - iconj(1,i) + 1
         do ii = 1, norbit-1
            iorb = iorbit(ii)
            do jj = ii+1, norbit
               jorb = iorbit(jj)
               do k = 1, n12(iorb)
                  if (i12(k,iorb) .eq. jorb) then
                     nbpi = nbpi + 1
                     do m = 1, nbond
                        if (iorb.eq.ibnd(1,m) .and.
     &                      jorb.eq.ibnd(2,m)) then
                           ibpi(1,nbpi) = m
                           ibpi(2,nbpi) = ii
                           ibpi(3,nbpi) = jj
                           goto 10
                        end if
                     end do
   10                continue
                  end if
               end do
            end do
         end do
c
c     find and store the pisystem torsions for this pisystem
c
         ntpi = 0
         do ii = 1, ntors
            ib = itors(2,ii)
            ic = itors(3,ii)
            if (listpi(ib) .and. listpi(ic)) then
               do jj = 1, nbpi
                  k = ibpi(1,jj)
                  if (ib.eq.ibnd(1,k).and.ic.eq.ibnd(2,k) .or.
     &                ib.eq.ibnd(2,k).and.ic.eq.ibnd(1,k)) then
                     ntpi = ntpi + 1
                     itpi(1,ntpi) = ii
                     itpi(2,ntpi) = jj
                     goto 20
                  end if
               end do
   20          continue
            end if
         end do
c
c     print a header for the molecular orbital calculation
c
         if (debug) then
            if (nconj .eq. 1) then
               write (iout,30)
   30          format (/,' Modified Pariser-Parr-Pople Molecular',
     &                    ' Orbitals :')
            else
               write (iout,40)  i
   40          format (/,' Modified Pariser-Parr-Pople MOs for',
     &                    ' Pi-System',i4,' :')
            end if
         end if
c
c     get SCF-MOs, then scale bond and torsional parameters
c
         call piscf
         call pialter
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine piscf  --  SCF molecular orbital calculation  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "piscf" performs an SCF molecular orbital calculation for a
c     pisystem to determine bond orders used in parameter scaling
c
c
      subroutine piscf
      use atomid
      use atoms
      use bndstr
      use couple
      use inform
      use iounit
      use orbits
      use piorbs
      use pistuf
      use units
      implicit none
      integer i,j,k,m
      integer iter,maxiter
      integer iatn,jatn
      integer iorb,jorb,nfill
      real*8 delta,converge
      real*8 xij,yij,zij,p
      real*8 hcii,gii,gij
      real*8 g11,g11sq,g12,g14
      real*8 rij,erij,brij
      real*8 ovlap,covlap
      real*8 cionize
      real*8 iionize,jionize
      real*8 rijsq,hcij,qi
      real*8 total,totold
      real*8 ebeta,aeth,abnz
      real*8 ebe,ebb,ble,blb
      real*8 eebond,bebond
      real*8 s1,s2,gjk
      real*8 vij,vik,vmj,vmk
      real*8 xi,xj,xk,xg
      real*8, allocatable :: povlap(:)
      real*8, allocatable :: en(:)
      real*8, allocatable :: ip(:)
      real*8, allocatable :: fock(:,:)
      real*8, allocatable :: hc(:,:)
      real*8, allocatable :: vec(:,:)
      real*8, allocatable :: gamma(:,:)
      real*8, allocatable :: ed(:,:)
      character*6 mode
c
c
c     initialize some constants and parameters
c
c     mode       planar or nonplanar pi-calculation
c     maxiter    maximum number of SCF iterations
c     converge   criterion for SCF convergence
c     ebeta      value of resonance integral for ethylene
c     cionize    ionization potential of carbon (Hartree)
c
      mode = 'PLANAR'
      maxiter = 50
      converge = 0.00000001d0
      ebeta = -0.0757d0
      cionize = -11.16d0 / evolt
c
c     set the bond energies, alpha values and ideal bond length
c     parameter for carbon-carbon pibond type parameters
c
c     ebe    equilibrium bond energy in ethylene
c     ebb    equilibrium bond energy in benzene
c     aeth   the P-P-P constant "a" in ethylene
c     abnz   the P-P-P constant "a" in benzene
c     ble    equilibrium bond length in ethylene
c     blb    equilibrium bond length in benzene
c
      ebe = 129.37d0
      ebb = 117.58d0
      aeth = 2.309d0
      abnz = 2.142d0
      ble = 1.338d0
      blb = 1.397d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (povlap(nbpi))
      allocate (en(norbit))
      allocate (ip(norbit))
      allocate (fock(norbit,norbit))
      allocate (hc(norbit,norbit))
      allocate (vec(norbit,norbit))
      allocate (gamma(norbit,norbit))
      allocate (ed(norbit,norbit))
c
c     assign empirical one-center Coulomb integrals, and
c     first or second ionization potential depending on
c     whether the orbital contributes one or two electrons
c
      nfill = 0
      do i = 1, norbit
         iorb = iorbit(i)
         gamma(i,i) = emorb(iorb)
         ip(i) = worb(iorb) + (1.0d0-qorb(iorb))*emorb(iorb)
         nfill = nfill + nint(qorb(iorb))
      end do
      nfill = nfill / 2
c
c     calculate two-center repulsion integrals
c     according to Ohno's semi-empirical formula
c
      do i = 1, norbit-1
         iorb = iorbit(i)
         gii = gamma(i,i)
         do j = i+1, norbit
            jorb = iorbit(j)
            g11 = 0.5d0 * (gii+gamma(j,j))
            g11sq = 1.0d0 / g11**2
            xij = x(iorb) - x(jorb)
            yij = y(iorb) - y(jorb)
            zij = z(iorb) - z(jorb)
            rijsq = (xij**2 + yij**2 + zij**2) / bohr**2
            g12 = 1.0d0 / sqrt(rijsq+g11sq)
            gamma(i,j) = g12
            gamma(j,i) = g12
         end do
      end do
c
c     zero out the resonance integral values
c
      do i = 1, norbit
         do j = 1, norbit
            hc(j,i) = 0.0d0
         end do
      end do
c
c     the first term in the sum to find alpha is the first
c     or second ionization potential, then the two-center
c     repulsion integrals are added
c
      do i = 1, norbit
         hcii = ip(i)
         do j = 1, norbit
            if (i .ne. j) then
               jorb = iorbit(j)
               hcii = hcii - qorb(jorb)*gamma(i,j)
            end if
         end do
         hc(i,i) = hcii
      end do
c
c     get two-center repulsion integrals via Ohno's formula
c
      do k = 1, nbpi
         i = ibpi(2,k)
         j = ibpi(3,k)
         iorb = iorbit(i)
         jorb = iorbit(j)
         iatn = atomic(iorb)
         jatn = atomic(jorb)
         xij = x(iorb) - x(jorb)
         yij = y(iorb) - y(jorb)
         zij = z(iorb) - z(jorb)
         rij = sqrt(xij**2 + yij**2 + zij**2)
         rijsq = rij**2 / bohr**2
         g11 = 0.5d0 * (gamma(i,i)+gamma(j,j))
         g11sq = 1.0d0 / g11**2
         g12 = gamma(i,j)
c
c     compute the bond energy using a Morse potential
c
         erij = aeth * (ble-rij)
         brij = abnz * (blb-rij)
         eebond = (2.0d0*exp(erij)-exp(2.0d0*erij)) * ebe / hartree
         bebond = (2.0d0*exp(brij)-exp(2.0d0*brij)) * ebb / hartree
c
c     compute the carbon-carbon resonance integral using
c     the Whitehead and Lo formula
c
         g14 = 1.0d0 / sqrt(4.0d0*rijsq+g11sq)
         hcij = 1.5d0*(bebond-eebond) - 0.375d0*g11
     &             + (5.0d0/12.0d0)*g12 - g14/24.0d0
c
c     if either atom is non-carbon, then factor the resonance
c     integral by overlap ratio and ionization potential ratio
c
         if (iatn.ne.6 .or. jatn.ne.6) then
            call overlap (iatn,jatn,rij,ovlap)
            call overlap (6,6,rij,covlap)
            hcij = hcij * (ovlap/covlap)
            iionize = ip(i)
            if (qorb(iorb) .ne. 1.0d0) then
               if (iatn .eq. 7)  iionize = 0.595d0 * iionize
               if (iatn .eq. 8)  iionize = 0.525d0 * iionize
               if (iatn .eq. 16)  iionize = 0.89d0 * iionize
            end if
            jionize = ip(j)
            if (qorb(jorb) .ne. 1.0d0) then
               if (jatn .eq. 7)  jionize = 0.595d0 * jionize
               if (jatn .eq. 8)  jionize = 0.525d0 * jionize
               if (jatn .eq. 16)  jionize = 0.89d0 * jionize
            end if
            hcij = hcij * (iionize+jionize)/(2.0d0*cionize)
         end if
c
c     set symmetric elements to the same value
c
         hc(i,j) = hcij
         hc(j,i) = hcij
      end do
c
c     construct an initial guess to the Fock matrix
c
      do i = 1, norbit
         do j = 1, norbit
            fock(j,i) = hc(j,i)
         end do
      end do
      do i = 1, norbit
         fock(i,i) = 0.5d0 * ip(i)
      end do
c
c     make the SCF-MO computation; do it twice, for a planar analog
c     of the actual system and for the actual (nonplanar) system
c
      do while (mode.eq.'PLANAR' .or. mode.eq.'NONPLN')
         if (mode .eq. 'NONPLN') then
            call pitilt (povlap)
            do k = 1, nbpi
               i = ibpi(2,k)
               j = ibpi(3,k)
               hc(i,j) = hc(i,j) * povlap(k)
               hc(j,i) = hc(i,j)
            end do
         end if
c
c     perform SCF iterations until convergence is reached; diagonalize
c     the Fock matrix "f" to get the MOs, then use MOs to form the
c     next "f" matrix assuming zero differential overlap except for
c     one-center exchange repulsions
c
         iter = 0
         delta = 2.0d0 * converge
         do while (delta.gt.converge .and. iter.lt.maxiter)
            iter = iter + 1
            call jacobi (norbit,fock,en,vec)
            do i = 1, norbit
               do j = i, norbit
                  s1 = 0.0d0
                  s2 = 0.0d0
                  gij = gamma(i,j)
                  do k = 1, nfill
                     s2 = s2 - vec(i,k)*vec(j,k)*gij
                     if (i .eq. j) then
                        do m = 1, norbit
                           s1 = s1 + 2.0d0*gamma(i,m)*vec(m,k)**2
                        end do
                     end if
                  end do
                  fock(i,j) = s1 + s2 + hc(i,j)
                  fock(j,i) = fock(i,j)
               end do
            end do
c
c     calculate the ground state energy, where "xi" sums the
c     molecular core integrals, "xj" sums the molecular coulomb
c     repulsion integrals, "xk" sums the molecular exchange
c     repulsion integrals, and "xg" sums the nuclear repulsion
c
            xi = 0.0d0
            xj = 0.0d0
            xk = 0.0d0
            xg = 0.0d0
            do i = 1, nfill
               do j = 1, norbit
                  vij = vec(j,i)
                  do k = 1, norbit
                     vik = vec(k,i)
                     gjk = gamma(j,k)
                     xi = xi + 2.0d0*vij*vik*hc(j,k)
                     do m = 1, nfill
                        vmj = vec(j,m)
                        vmk = vec(k,m)
                        xj = xj + 2.0d0*vij*vij*vmk*vmk*gjk
                        xk = xk - vij*vmj*vik*vmk*gjk
                     end do
                  end do
               end do
            end do
            do i = 1, norbit-1
               iorb = iorbit(i)
               qi = qorb(iorb)
               do j = i+1, norbit
                  jorb = iorbit(j)
                  xg = xg + qi*qorb(jorb)*gamma(i,j)
               end do
            end do
            total = xi + xj + xk + xg
            if (iter .ne. 1)  delta = abs(total-totold)
            totold = total
         end do
c
c     print warning if SCF-MO iteration did not converge
c
         if (delta .gt. converge) then
            write (iout,10)
   10       format (' PISCF  --  The SCF Molecular Orbitals have',
     &                 ' Failed to Converge')
         end if
c
c     calculate electron densities from filled MO's
c
         do i = 1, norbit
            do j = 1, norbit
               ed(i,j) = 0.0d0
               do k = 1, nfill
                  ed(i,j) = ed(i,j) + 2.0d0*vec(i,k)*vec(j,k)
               end do
            end do
         end do
c
c     print out results for the SCF computation
c
         if (debug) then
            if (mode .eq. 'PLANAR') then
               write (iout,20)
   20          format (/,' SCF-MO Calculation for Planar System :')
            else
               write (iout,30)
   30          format (/,' SCF-MO Calculation for Non-Planar',
     &                    ' System :')
            end if
            write (iout,40)  total,norbit,delta,iter
   40       format (/,' Total Energy',11x,f12.4,
     &              /,' Number of Orbitals',5x,i12,
     &              /,' Convergence',12x,d12.4,
     &              /,' Iterations',13x,i12)
            write (iout,50)  xi,xj,xk,xg
   50       format (/,' Core Integrals',9x,f12.4,
     &              /,' Coulomb Repulsion',6x,f12.4,
     &              /,' Exchange Repulsion',5x,f12.4,
     &              /,' Nuclear Repulsion',6x,f12.4)
            write (iout,60)
   60       format (/,' Orbital Energies')
            write (iout,70)  (en(i),i=1,norbit)
   70       format (8f9.4)
            write (iout,80)
   80       format (/,' Molecular Orbitals')
            do i = 1, norbit
               write (iout,90)  (vec(i,j),j=1,norbit)
   90          format (8f9.4)
            end do
            write (iout,100)
  100       format (/,' Fock Matrix')
            do i = 1, norbit
               write (iout,110)  (fock(i,j),j=1,norbit)
  110          format (8f9.4)
            end do
            write (iout,120)
  120       format (/,' Density Matrix')
            do i = 1, norbit
               write (iout,130)  (ed(i,j),j=1,norbit)
  130          format (8f9.4)
            end do
            write (iout,140)
  140       format (/,' H-Core Matrix')
            do i = 1, norbit
               write (iout,150)  (hc(i,j),j=1,norbit)
  150          format (8f9.4)
            end do
            write (iout,160)
  160       format (/,' Gamma Matrix')
            do i = 1, norbit
               write (iout,170)  (gamma(i,j),j=1,norbit)
  170          format (8f9.4)
            end do
         end if
c
c     now, get the bond orders (compute p and p*b)
c
         if (debug) then
            write (iout,180)
  180       format (/,' Pisystem Bond Orders')
         end if
         do k = 1, nbpi
            i = ibpi(2,k)
            j = ibpi(3,k)
            p = 0.0d0
            do m = 1, nfill
               p = p + 2.0d0*vec(i,m)*vec(j,m)
            end do
            if (mode .eq. 'PLANAR') then
               pbpl(k) = p * hc(i,j)/ebeta
            else if (mode .eq. 'NONPLN') then
               pnpl(k) = p
            end if
            if (debug) then
               i = ibnd(1,ibpi(1,k))
               j = ibnd(2,ibpi(1,k))
               write (iout,190)  i,j,p
  190          format (3x,2i6,2x,f10.4)
            end if
         end do
c
c     if we have done planar calculation, do the nonplanar;
c     when both are complete, alter the pisystem constants
c
         if (mode .eq. 'PLANAR') then
            mode = 'NONPLN'
         else if (mode .eq. 'NONPLN') then
            mode = '      '
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (povlap)
      deallocate (en)
      deallocate (ip)
      deallocate (fock)
      deallocate (hc)
      deallocate (vec)
      deallocate (gamma)
      deallocate (ed)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine pitilt  --  direction cosines for pisystem  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "pitilt" calculates for each pibond the ratio of the
c     actual p-orbital overlap integral to the ideal overlap
c     if the same orbitals were perfectly parallel
c
c
      subroutine pitilt (povlap)
      use atomid
      use atoms
      use couple
      use piorbs
      implicit none
      integer i,j,k,m
      integer iorb,jorb
      integer list(8)
      real*8 ideal,cosine,rnorm
      real*8 xij,yij,zij,rij
      real*8 a1,b1,c1,a2,b2,c2
      real*8 x2,y2,z2,x3,y3,z3
      real*8 xr(8),yr(8),zr(8)
      real*8 povlap(*)
c
c
c     planes defining each p-orbital are in "piperp"; transform
c     coordinates of "iorb", "jorb" and their associated planes
c     to put "iorb" at origin and "jorb" along the x-axis
c
      do k = 1, nbpi
         i = ibpi(2,k)
         j = ibpi(3,k)
         iorb = iorbit(i)
         jorb = iorbit(j)
         list(1) = iorb
         list(2) = jorb
         do m = 1, 3
            list(m+2) = piperp(m,iorb)
            list(m+5) = piperp(m,jorb)
         end do
         call pimove (list,xr,yr,zr)
c
c     check for sp-hybridized carbon in current bond;
c     assume perfect overlap for any such pibond
c
         if ((atomic(iorb).eq.6 .and. n12(iorb).eq.2) .or.
     &       (atomic(jorb).eq.6 .and. n12(jorb).eq.2)) then
            povlap(k) = 1.0d0
c
c     find and normalize a vector parallel to first p-orbital
c
         else
            x2 = xr(4) - xr(3)
            y2 = yr(4) - yr(3)
            z2 = zr(4) - zr(3)
            x3 = xr(5) - xr(3)
            y3 = yr(5) - yr(3)
            z3 = zr(5) - zr(3)
            a1 = y2*z3 - y3*z2
            b1 = x3*z2 - x2*z3
            c1 = x2*y3 - x3*y2
            rnorm = sqrt(a1*a1+b1*b1+c1*c1)
            a1 = a1 / rnorm
            b1 = b1 / rnorm
            c1 = c1 / rnorm
c
c     now find vector parallel to the second p-orbital,
c     "a2" changes sign to correspond to internuclear axis
c
            x2 = xr(7) - xr(6)
            y2 = yr(7) - yr(6)
            z2 = zr(7) - zr(6)
            x3 = xr(8) - xr(6)
            y3 = yr(8) - yr(6)
            z3 = zr(8) - zr(6)
            a2 = y2*z3 - y3*z2
            b2 = x3*z2 - x2*z3
            c2 = x2*y3 - x3*y2
            rnorm = sqrt(a2*a2+b2*b2+c2*c2)
            a2 = -a2 / rnorm
            b2 = b2 / rnorm
            c2 = c2 / rnorm
c
c     compute the cosine of the angle between p-orbitals;
c     if more than 90 degrees, reverse one of the vectors
c
            cosine = a1*a2 + b1*b2 + c1*c2
            if (cosine .lt. 0.0d0) then
               a2 = -a2
               b2 = -b2
               c2 = -c2
            end if
c
c     find overlap if the orbitals were perfectly parallel
c
            xij = x(iorb) - x(jorb)
            yij = y(iorb) - y(jorb)
            zij = z(iorb) - z(jorb)
            rij = sqrt(xij**2 + yij**2 + zij**2)
            call overlap (atomic(iorb),atomic(jorb),rij,ideal)
c
c     set ratio of actual to ideal overlap for current pibond
c
            povlap(k) = ideal*a1*a2 + b1*b2 + c1*c2
         end if
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine pimove  --  transform pisystem bond vectors  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "pimove" rotates the vector between atoms "list(1)" and
c     "list(2)" so that atom 1 is at the origin and atom 2 along
c     the x-axis; the atoms defining the respective planes are
c     also moved and their bond lengths normalized
c
c
      subroutine pimove (list,xr,yr,zr)
      use atoms
      implicit none
      integer i,j,list(8)
      real*8 xt,yt,zt
      real*8 denom,xold
      real*8 sine,cosine
      real*8 xr(8),yr(8),zr(8)
c
c
c     translate "list" atoms to place atom 1 at origin
c
      j = list(1)
      xt = x(j)
      yt = y(j)
      zt = z(j)
      do i = 1, 8
         j = list(i)
         xr(i) = x(j) - xt
         yr(i) = y(j) - yt
         zr(i) = z(j) - zt
      end do
c
c     rotate "list" atoms to place atom 2 on the x-axis
c
      denom = sqrt(xr(2)**2 + yr(2)**2)
      if (denom .ne. 0.0d0) then
         sine = yr(2) / denom
         cosine = xr(2) / denom
         do i = 1, 8
            xold = xr(i)
            xr(i) = xr(i)*cosine + yr(i)*sine
            yr(i) = yr(i)*cosine - xold*sine
         end do
      end if
      denom = sqrt(xr(2)**2 + zr(2)**2)
      if (denom .ne. 0.0d0) then
         sine = zr(2) / denom
         cosine = xr(2) / denom
         do i = 1, 8
            xold = xr(i)
            xr(i) = xr(i)*cosine + zr(i)*sine
            zr(i) = zr(i)*cosine - xold*sine
         end do
      end if
c
c     normalize the coordinates of atoms defining the plane for atom 1
c     (ie, make all these atoms have unit length to atom 1) so that the
c     orbital makes equal angles with the atoms rather than simply being
c     perpendicular to the common plane of the atoms
c
      do i = 3, 5
         if (list(i) .ne. list(1)) then
            denom = sqrt(xr(i)**2+yr(i)**2+zr(i)**2)
            xr(i) = xr(i) / denom
            yr(i) = yr(i) / denom
            zr(i) = zr(i) / denom
         end if
      end do
c
c     normalization of plane defining atoms for atom 2; for the
c     x-coordinate we translate back to the origin, normalize
c     and then retranslate back along the x-axis
c
      do i = 6, 8
         if (list(i) .ne. list(2)) then
            denom = sqrt((xr(i)-xr(2))**2+yr(i)**2+zr(i)**2)
            xr(i) = (xr(i)-xr(2))/denom + xr(2)
            yr(i) = yr(i) / denom
            zr(i) = zr(i) / denom
         end if
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine pialter  --  modify parameters for pisystem  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "pialter" modifies bond lengths and force constants according
c     to the "planar" P-P-P bond order values; also alters 2-fold
c     torsional parameters based on the "nonplanar" bond orders
c
c
      subroutine pialter
      use atomid
      use bndstr
      use inform
      use iounit
      use piorbs
      use pistuf
      use tors
      implicit none
      integer i,j,k
      integer ia,ib,ic,id
c
c
c     modify the stretching constants and natural bond lengths
c
      if (debug .and. nbpi.ne.0) then
         write (iout,10)
   10    format (/,' Altered Bond Stretching Parameters',
     &              ' for Pi-System :',
     &           //,' Type',14x,'Atom Names',17x,'Initial',
     &              16x,'Final',/)
      end if
      do i = 1, nbpi
         j = ibpi(1,i)
         ia = ibnd(1,j)
         ib = ibnd(2,j)
         bk(j) = bkpi(j) - kslope(j) * (1.0d0-pnpl(i))
         bl(j) = blpi(j) + lslope(j) * (1.0d0-pnpl(i))
         if (debug) then
            write (iout,20)  ia,name(ia),ib,name(ib),bkpi(j),
     &                       blpi(j),bk(j),bl(j)
   20       format (' Bond',6x,2(i7,'-',a3),6x,
     &                 f9.3,f8.4,2x,'-->',f9.3,f8.4)
         end if
      end do
c
c     modify the 2-fold torsional constants across pibonds
c
      if (debug .and. ntpi.ne.0) then
         write (iout,30)
   30    format (/,' Altered 2-Fold Torsional Parameters',
     &              ' for Pi-System :',
     &           //,' Type',25x,'Atom Names',18x,'Initial',
     &              8x,'Final',/)
      end if
      do i = 1, ntpi
         j = itpi(1,i)
         k = itpi(2,i)
         ia = itors(1,j)
         ib = itors(2,j)
         ic = itors(3,j)
         id = itors(4,j)
         tors2(1,j) = pbpl(k) * torsp2(j)
         if (debug) then
            write (iout,40)  ia,name(ia),ib,name(ib),ic,name(ic),
     &                       id,name(id),torsp2(j),tors2(1,j)
   40       format (' Torsion',3x,4(i7,'-',a3),2x,f8.3,2x,'-->',f8.3)
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module piorbs  --  conjugated system in current structure  ##
c     ##                                                             ##
c     #################################################################
c
c
c     norbit    total number of pisystem orbitals in the system
c     nconj     total number of separate conjugated piystems
c     reorbit   number of evaluations between orbital updates
c     nbpi      total number of bonds affected by the pisystem
c     ntpi      total number of torsions affected by the pisystem
c     iorbit    numbers of the atoms containing pisystem orbitals
c     iconj     first and last atom of each pisystem in the list
c     kconj     contiguous list of atoms in each pisystem
c     piperp    atoms defining a normal plane to each orbital
c     ibpi      bond and piatom numbers for each pisystem bond
c     itpi      torsion and pibond numbers for each pisystem torsion
c     pbpl      pi-bond orders for bonds in "planar" pisystem
c     pnpl      pi-bond orders for bonds in "nonplanar" pisystem
c     listpi    atom list indicating whether each atom has an orbital
c
c
      module piorbs
      implicit none
      integer norbit
      integer nconj
      integer reorbit
      integer nbpi
      integer ntpi
      integer, allocatable :: iorbit(:)
      integer, allocatable :: iconj(:,:)
      integer, allocatable :: kconj(:)
      integer, allocatable :: piperp(:,:)
      integer, allocatable :: ibpi(:,:)
      integer, allocatable :: itpi(:,:)
      real*8, allocatable :: pbpl(:)
      real*8, allocatable :: pnpl(:)
      logical, allocatable :: listpi(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module pistuf  --  bond order-related pisystem parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     bkpi     bond stretch force constants for pi-bond order of 1.0
c     blpi     ideal bond length values for a pi-bond order of 1.0
c     kslope   rate of force constant decrease with bond order decrease
c     lslope   rate of bond length increase with a bond order decrease
c     torsp2   2-fold torsional energy barrier for pi-bond order of 1.0
c
c
      module pistuf
      implicit none
      real*8, allocatable :: bkpi(:)
      real*8, allocatable :: blpi(:)
      real*8, allocatable :: kslope(:)
      real*8, allocatable :: lslope(:)
      real*8, allocatable :: torsp2(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module pitors  --  pi-system torsions in current structure  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     npitors   total number of pi-system torsional interactions
c     ipit      numbers of the atoms in each pi-system torsion
c     kpit      2-fold pi-system torsional force constants
c
c
      module pitors
      implicit none
      integer npitors
      integer, allocatable :: ipit(:,:)
      real*8, allocatable :: kpit(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module pme  --  values for particle mesh Ewald summation  ##
c     ##                                                            ##
c     ################################################################
c
c
c     nfft1      current number of PME grid points along a-axis
c     nfft2      current number of PME grid points along b-axis
c     nfft3      current number of PME grid points along c-axis
c     nefft1     number of grid points along electrostatic a-axis
c     nefft2     number of grid points along electrostatic b-axis
c     nefft3     number of grid points along electrostatic c-axis
c     ndfft1     number of grid points along dispersion a-axis
c     ndfft2     number of grid points along dispersion b-axis
c     ndfft3     number of grid points along dispersion c-axis
c     bsorder    current order of the PME B-spline values
c     bseorder   order of the electrostatic PME B-spline values
c     bsporder   order of the polarization PME B-spline values
c     bsdorder   order of the dispersion PME B-spline values
c     igrid      initial Ewald grid values for B-spline
c     bsmod1     B-spline moduli along the a-axis direction
c     bsmod2     B-spline moduli along the b-axis direction
c     bsmod3     B-spline moduli along the c-axis direction
c     bsbuild    B-spline derivative coefficient temporary storage
c     thetai1    B-spline coefficients along the a-axis
c     thetai2    B-spline coefficients along the b-axis
c     thetai3    B-spline coefficients along the c-axis
c     qgrid      values on the particle mesh Ewald grid
c     qfac       prefactors for the particle mesh Ewald grid
c
c
      module pme
      implicit none
      integer nfft1,nfft2,nfft3
      integer nefft1,nefft2,nefft3
      integer ndfft1,ndfft2,ndfft3
      integer bsorder,bseorder
      integer bsporder,bsdorder
      integer, allocatable :: igrid(:,:)
      real*8, allocatable :: bsmod1(:)
      real*8, allocatable :: bsmod2(:)
      real*8, allocatable :: bsmod3(:)
      real*8, allocatable :: bsbuild(:,:)
      real*8, allocatable :: thetai1(:,:,:)
      real*8, allocatable :: thetai2(:,:,:)
      real*8, allocatable :: thetai3(:,:,:)
      real*8, allocatable :: qgrid(:,:,:,:)
      real*8, allocatable :: qfac(:,:,:)
      save
      end
c
c
c     ##################################################################
c     ##  COPYRIGHT (C) 2010 by T. Darden, D. Gohara & Jay W. Ponder  ##
c     ##                      All Rights Reserved                     ##
c     ##################################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  routines below implement various B-spline and coordinate  ##
c     ##  manipulations for particle mesh Ewald summation; spatial  ##
c     ##  grid assignment by David Gohara; modified from original   ##
c     ##  PME code by Thomas Darden, NIEHS, Research Triangle, NC   ##
c     ##                                                            ##
c     ################################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine getchunk  --  find number of chunks per axis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "getchunk" determines the number of grid point "chunks" used
c     along each axis of the PME grid for parallelization
c
c
      subroutine getchunk
      use chunks
      use openmp
      use pme
      implicit none
      integer i
c
c
c     initialize total chunks and number along each axis
c
      nchunk = 1
      nchk1 = 1
      nchk2 = 1
      nchk3 = 1
c
c     evaluate use of two to six chunks along each axis
c
      do i = 2, 6
         if (nthread.gt.nchunk .and. mod(nfft1,i).eq.0) then
            nchk1 = i
            nchunk = nchk1 * nchk2 * nchk3
         end if
         if (nthread.gt.nchunk .and. mod(nfft2,i).eq.0) then
            nchk2 = i
            nchunk = nchk1 * nchk2 * nchk3
         end if
         if (nthread.gt.nchunk .and. mod(nfft3,i).eq.0) then
            nchk3 = i
            nchunk = nchk1 * nchk2 * nchk3
         end if
      end do
c
c     set number of grid points per chunk along each axis
c
      ngrd1 = nfft1 / nchk1
      ngrd2 = nfft2 / nchk2
      ngrd3 = nfft3 / nchk3
c
c     set grid points to left and right, and B-spline offset
c
      nlpts = (bsorder-1) / 2
      nrpts = bsorder - nlpts - 1
      grdoff = (bsorder+1)/2 + 1
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine moduli  --  store the inverse DFT moduli  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "moduli" sets the moduli of the inverse discrete Fourier
c     transform of the B-splines
c
c
      subroutine moduli
      use pme
      implicit none
      integer i,maxfft
      real*8 x
      real*8, allocatable :: array(:)
      real*8, allocatable :: bsarray(:)
c
c
c     perform dynamic allocation of some local arrays
c
      maxfft = max(nfft1,nfft2,nfft3)
      allocate (array(bsorder))
      allocate (bsarray(max(maxfft,bsorder+1)))
c
c     compute and load the moduli values
c
      x = 0.0d0
      call bspline (x,bsorder,array)
      do i = 1, maxfft
         bsarray(i) = 0.0d0
      end do
      do i = 1, bsorder
         bsarray(i+1) = array(i)
      end do
      call dftmod (bsmod1,bsarray,nfft1,bsorder)
      call dftmod (bsmod2,bsarray,nfft2,bsorder)
      call dftmod (bsmod3,bsarray,nfft3,bsorder)
c
c     perform deallocation of some local arrays
c
      deallocate (array)
      deallocate (bsarray)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine bspline  --  determine B-spline coefficients  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "bspline" calculates the coefficients for an n-th order
c     B-spline approximation
c
c
      subroutine bspline (x,n,c)
      implicit none
      integer i,k,n
      real*8 x,denom
      real*8 c(*)
c
c
c     initialize the B-spline as the linear case
c
      c(1) = 1.0d0 - x
      c(2) = x
c
c     compute standard B-spline recursion to n-th order
c
      do k = 3, n
         denom = 1.0d0 / dble(k-1)
         c(k) = x * c(k-1) * denom
         do i = 1, k-2
            c(k-i) = ((x+dble(i))*c(k-i-1)
     &                  + (dble(k-i)-x)*c(k-i)) * denom
         end do
         c(1) = (1.0d0-x) * c(1) * denom
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine dftmod  --  discrete Fourier transform modulus  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "dftmod" computes the modulus of the discrete Fourier transform
c     of "bsarray" and stores it in "bsmod"
c
c
      subroutine dftmod (bsmod,bsarray,nfft,order)
      use math
      implicit none
      integer i,j,k
      integer nfft,jcut
      integer order,order2
      real*8 eps,zeta
      real*8 arg,factor
      real*8 sum1,sum2
      real*8 bsmod(*)
      real*8 bsarray(*)
c
c
c     get the modulus of the discrete Fourier transform
c
      factor = 2.0d0 * pi / dble(nfft)
      do i = 1, nfft
         sum1 = 0.0d0
         sum2 = 0.0d0
         do j = 1, nfft
            arg = factor * dble((i-1)*(j-1))
            sum1 = sum1 + bsarray(j)*cos(arg)
            sum2 = sum2 + bsarray(j)*sin(arg)
         end do
         bsmod(i) = sum1**2 + sum2**2
      end do
c
c     fix for exponential Euler spline interpolation failure
c
      eps = 1.0d-7
      if (bsmod(1) .lt. eps)  bsmod(1) = 0.5d0 * bsmod(2)
      do i = 2, nfft-1
         if (bsmod(i) .lt. eps)
     &      bsmod(i) = 0.5d0 * (bsmod(i-1)+bsmod(i+1))
      end do
      if (bsmod(nfft) .lt. eps)  bsmod(nfft) = 0.5d0 * bsmod(nfft-1)
c
c     compute and apply the optimal zeta coefficient
c
      jcut = 50
      order2 = 2 * order
      do i = 1, nfft
         k = i - 1
         if (i .gt. nfft/2)  k = k - nfft
         if (k .eq. 0) then
            zeta = 1.0d0
         else
            sum1 = 1.0d0
            sum2 = 1.0d0
            factor = pi * dble(k) / dble(nfft)
            do j = 1, jcut
               arg = factor / (factor+pi*dble(j))
               sum1 = sum1 + arg**order
               sum2 = sum2 + arg**order2
            end do
            do j = 1, jcut
               arg = factor / (factor-pi*dble(j))
               sum1 = sum1 + arg**order
               sum2 = sum2 + arg**order2
            end do
            zeta = sum2 / sum1
         end if
         bsmod(i) = bsmod(i) * zeta**2
      end do
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine bspline_fill  --  get PME B-spline coefficients  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "bspline_fill" finds B-spline coefficients and derivatives
c     for PME atomic sites along the fractional coordinate axes
c
c
      subroutine bspline_fill
      use atoms
      use boxes
      use pme
      implicit none
      integer i,ifr
      real*8 xi,yi,zi
      real*8 w,fr,eps
c
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(igrid))  allocate (igrid(3,n))
c
c     offset used to shift sites off exact lattice bounds
c
      eps = 1.0d-8
c
c     get the B-spline coefficients for each atomic site
c
      do i = 1, n
         xi = x(i)
         yi = y(i)
         zi = z(i)
         w = xi*recip(1,1) + yi*recip(2,1) + zi*recip(3,1)
         fr = dble(nfft1) * (w-dble(anint(w))+0.5d0)
         ifr = int(fr-eps)
         w = fr - dble(ifr)
         igrid(1,i) = ifr - bsorder
         call bsplgen (w,thetai1(1,1,i))
         w = xi*recip(1,2) + yi*recip(2,2) + zi*recip(3,2)
         fr = dble(nfft2) * (w-dble(anint(w))+0.5d0)
         ifr = int(fr-eps)
         w = fr - dble(ifr)
         igrid(2,i) = ifr - bsorder
         call bsplgen (w,thetai2(1,1,i))
         w = xi*recip(1,3) + yi*recip(2,3) + zi*recip(3,3)
         fr = dble(nfft3) * (w-dble(anint(w))+0.5d0)
         ifr = int(fr-eps)
         w = fr - dble(ifr)
         igrid(3,i) = ifr - bsorder
         call bsplgen (w,thetai3(1,1,i))
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine bsplgen  --  B-spline coefficients for an atom  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "bsplgen" gets B-spline coefficients and derivatives for
c     a single PME atomic site along a particular direction
c
c
      subroutine bsplgen (w,thetai)
      use pme
      use potent
      implicit none
      integer i,j,k
      integer level
      real*8 w,denom
      real*8 thetai(4,*)
c
c
c     set B-spline depth for partial charges or multipoles
c
      level = 2
      if (use_mpole .or. use_polar)  level = 4
c
c     initialization to get to 2nd order recursion
c
      bsbuild(2,2) = w
      bsbuild(2,1) = 1.0d0 - w
c
c     perform one pass to get to 3rd order recursion
c
      bsbuild(3,3) = 0.5d0 * w * bsbuild(2,2)
      bsbuild(3,2) = 0.5d0 * ((1.0d0+w)*bsbuild(2,1)
     &                       +(2.0d0-w)*bsbuild(2,2))
      bsbuild(3,1) = 0.5d0 * (1.0d0-w) * bsbuild(2,1)
c
c     compute standard B-spline recursion to desired order
c
      do i = 4, bsorder
         k = i - 1
         denom = 1.0d0 / dble(k)
         bsbuild(i,i) = denom * w * bsbuild(k,k)
         do j = 1, i-2
            bsbuild(i,i-j) = denom * ((w+dble(j))*bsbuild(k,i-j-1)
     &                               +(dble(i-j)-w)*bsbuild(k,i-j))
         end do
         bsbuild(i,1) = denom * (1.0d0-w) * bsbuild(k,1)
      end do
c
c     get coefficients for the B-spline first derivative
c
      k = bsorder - 1
      bsbuild(k,bsorder) = bsbuild(k,bsorder-1)
      do i = bsorder-1, 2, -1
         bsbuild(k,i) = bsbuild(k,i-1) - bsbuild(k,i)
      end do
      bsbuild(k,1) = -bsbuild(k,1)
c
c     get coefficients for the B-spline second derivative
c
      if (level .eq. 4) then
         k = bsorder - 2
         bsbuild(k,bsorder-1) = bsbuild(k,bsorder-2)
         do i = bsorder-2, 2, -1
            bsbuild(k,i) = bsbuild(k,i-1) - bsbuild(k,i)
         end do
         bsbuild(k,1) = -bsbuild(k,1)
         bsbuild(k,bsorder) = bsbuild(k,bsorder-1)
         do i = bsorder-1, 2, -1
            bsbuild(k,i) = bsbuild(k,i-1) - bsbuild(k,i)
         end do
         bsbuild(k,1) = -bsbuild(k,1)
c
c     get coefficients for the B-spline third derivative
c
         k = bsorder - 3
         bsbuild(k,bsorder-2) = bsbuild(k,bsorder-3)
         do i = bsorder-3, 2, -1
            bsbuild(k,i) = bsbuild(k,i-1) - bsbuild(k,i)
         end do
         bsbuild(k,1) = -bsbuild(k,1)
         bsbuild(k,bsorder-1) = bsbuild(k,bsorder-2)
         do i = bsorder-2, 2, -1
            bsbuild(k,i) = bsbuild(k,i-1) - bsbuild(k,i)
         end do
         bsbuild(k,1) = -bsbuild(k,1)
         bsbuild(k,bsorder) = bsbuild(k,bsorder-1)
         do i = bsorder-1, 2, -1
            bsbuild(k,i) = bsbuild(k,i-1) - bsbuild(k,i)
         end do
         bsbuild(k,1) = -bsbuild(k,1)
      end if
c
c     copy coefficients from temporary to permanent storage
c
      do i = 1, bsorder
         do j = 1, level
            thetai(j,i) = bsbuild(bsorder-j+1,i)
         end do
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine table_fill  --  spatial chunks for each site  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "table_fill" constructs an array which stores the spatial
c     regions of the particle mesh Ewald grid with contributions
c     from each site
c
c
      subroutine table_fill
      use atoms
      use chunks
      use pme
      implicit none
      integer i,k
      integer cid(3)
      integer nearpt(3)
      integer abound(6)
      integer cbound(6)
      logical negx,negy,negz
      logical posx,posy,posz
      logical midx,midy,midz
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(n,nchunk,pmetable,igrid,
!$OMP& nfft1,nfft2,nfft3,nchk1,nchk2,nchk3,ngrd1,ngrd2,ngrd3,
!$OMP& nlpts,nrpts,grdoff)
!$OMP DO
c
c     zero out the PME table marking chunks per site
c
      do k = 1, nchunk
         do i = 1, n
            pmetable(i,k) = 0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP DO
c
c     loop over sites to find the spatial chunks for each
c
      do i = 1, n
         nearpt(1) = igrid(1,i) + grdoff
         nearpt(2) = igrid(2,i) + grdoff
         nearpt(3) = igrid(3,i) + grdoff
         if (nearpt(1) .lt. 1) then
            nearpt(1) = mod(nearpt(1),nfft1) + nfft1
         else if (nearpt(1) .gt. nfft1) then
            nearpt(1) = mod(nearpt(1),nfft1)
         end if
         if (nearpt(2) .lt. 1) then
            nearpt(2) = mod(nearpt(2),nfft2) + nfft2
         else if (nearpt(2) .gt. nfft2) then
            nearpt(2) = mod(nearpt(2),nfft2)
         end if
         if (nearpt(3) .lt. 1) then
            nearpt(3) = mod(nearpt(3),nfft3) + nfft3
         else if (nearpt(3) .gt. nfft3) then
            nearpt(3) = mod(nearpt(3),nfft3)
         end if
         abound(1) = nearpt(1) - nlpts
         abound(2) = nearpt(1) + nrpts
         abound(3) = nearpt(2) - nlpts
         abound(4) = nearpt(2) + nrpts
         abound(5) = nearpt(3) - nlpts
         abound(6) = nearpt(3) + nrpts
         cid(1) = (nearpt(1)-1)/ngrd1 + 1
         cid(2) = (nearpt(2)-1)/ngrd2 + 1
         cid(3) = (nearpt(3)-1)/ngrd3 + 1
         cbound(1) = (cid(1)-1)*ngrd1 + 1
         cbound(2) = cbound(1) + ngrd1 - 1
         cbound(3) = (cid(2)-1)*ngrd2 + 1
         cbound(4) = cbound(3) + ngrd2 - 1
         cbound(5) = (cid(3)-1)*ngrd3 + 1
         cbound(6) = cbound(5) + ngrd3 - 1
c
c     set and store central chunk where the site is located
c
         k = (cid(3)-1)*nchk1*nchk2 + (cid(2)-1)*nchk1 + cid(1)
         pmetable(i,k) = 1
c
c     flags for atom bounds to left or right of central chunk
c
         negx = (abound(1) .lt. cbound(1))
         negy = (abound(3) .lt. cbound(3))
         negz = (abound(5) .lt. cbound(5))
         posx = (abound(2) .gt. cbound(2))
         posy = (abound(4) .gt. cbound(4))
         posz = (abound(6) .gt. cbound(6))
c
c     flags for atom bounds fully inside the central chunk
c
         midx = (.not.negx .and. .not.posx)
         midy = (.not.negy .and. .not.posy)
         midz = (.not.negz .and. .not.posz)
         if (midx .and. midy .and. midz)  goto 10
c
c     flags for atom bounds that overlap the central chunk
c
         midx = (.not.negx .or. .not.posx)
         midy = (.not.negy .or. .not.posy)
         midz = (.not.negz .or. .not.posz)
c
c     check for overlap with any of the neighboring chunks
c
         if (midx .and. midy .and. negz)  call setchunk (i,cid,0,0,-1)
         if (midx .and. midy .and. posz)  call setchunk (i,cid,0,0,1)
         if (midx .and. negy .and. midz)  call setchunk (i,cid,0,-1,0)
         if (midx .and. posy .and. midz)  call setchunk (i,cid,0,1,0)
         if (negx .and. midy .and. midz)  call setchunk (i,cid,-1,0,0)
         if (posx .and. midy .and. midz)  call setchunk (i,cid,1,0,0)
         if (midx .and. negy .and. negz)  call setchunk (i,cid,0,-1,-1)
         if (midx .and. negy .and. posz)  call setchunk (i,cid,0,-1,1)
         if (midx .and. posy .and. negz)  call setchunk (i,cid,0,1,-1)
         if (midx .and. posy .and. posz)  call setchunk (i,cid,0,1,1)
         if (negx .and. midy .and. negz)  call setchunk (i,cid,-1,0,-1)
         if (negx .and. midy .and. posz)  call setchunk (i,cid,-1,0,1)
         if (posx .and. midy .and. negz)  call setchunk (i,cid,1,0,-1)
         if (posx .and. midy .and. posz)  call setchunk (i,cid,1,0,1)
         if (negx .and. negy .and. midz)  call setchunk (i,cid,-1,-1,0)
         if (negx .and. posy .and. midz)  call setchunk (i,cid,-1,1,0)
         if (posx .and. negy .and. midz)  call setchunk (i,cid,1,-1,0)
         if (posx .and. posy .and. midz)  call setchunk (i,cid,1,1,0)
         if (negx .and. negy .and. negz)  call setchunk (i,cid,-1,-1,-1)
         if (negx .and. negy .and. posz)  call setchunk (i,cid,-1,-1,1)
         if (negx .and. posy .and. negz)  call setchunk (i,cid,-1,1,-1)
         if (posx .and. negy .and. negz)  call setchunk (i,cid,1,-1,-1)
         if (negx .and. posy .and. posz)  call setchunk (i,cid,-1,1,1)
         if (posx .and. negy .and. posz)  call setchunk (i,cid,1,-1,1)
         if (posx .and. posy .and. negz)  call setchunk (i,cid,1,1,-1)
         if (posx .and. posy .and. posz)  call setchunk (i,cid,1,1,1)
   10    continue
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine setchunk  --  site overlaps neighboring chunk  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "setchunk" marks a chunk in the PME spatial table which is
c     overlapped by the B-splines for a site
c
c
      subroutine setchunk (i,cid,off1,off2,off3)
      use chunks
      use pme
      implicit none
      integer i,k
      integer off1,off2,off3
      integer cid(3),temp(3)
c
c
c     mark neighboring chunk overlapped by an electrostatic site
c
      temp(1) = cid(1) + off1
      if (temp(1) .lt. 1)  temp(1) = nchk1
      if (temp(1) .gt. nchk1)  temp(1) = 1
      temp(2) = cid(2) + off2
      if (temp(2) .lt. 1)  temp(2) = nchk2
      if (temp(2) .gt. nchk2)  temp(2) = 1
      temp(3) = cid(3) + off3
      if (temp(3) .lt. 1)  temp(3) = nchk3
      if (temp(3) .gt. nchk3)  temp(3) = 1
      k = (temp(3)-1)*nchk1*nchk2 + (temp(2)-1)*nchk1 + temp(1)
      pmetable(i,k) = 1
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine grid_pchg  --  put partial charges on PME grid  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "grid_pchg" places the fractional atomic partial charges onto
c     the particle mesh Ewald grid
c
c     note the main loop does not need to be an OpenMP reduction
c     since a given qgrid element is always part of the same chunk,
c     and the code runs faster without use of a reduction
c
c
      subroutine grid_pchg
      use atoms
      use charge
      use chunks
      use pme
      implicit none
      integer i,j,k,m
      integer ii,jj,kk
      integer ichk,isite,iatm
      integer offsetx,offsety
      integer offsetz
      integer cid(3)
      integer nearpt(3)
      integer abound(6)
      integer cbound(6)
      real*8 v0,u0,t0
      real*8 term
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,pchg,pmetable,
!$OMP& nfft1,nfft2,nfft3,nchunk,nchk1,nchk2,nchk3,ngrd1,ngrd2,
!$OMP& ngrd3,nlpts,nrpts,igrid,grdoff,thetai1,thetai2,thetai3)
!$OMP& shared(qgrid)
!$OMP DO
c
c     zero out the particle mesh Ewald grid
c
      do k = 1, nfft3
         do j = 1, nfft2
            do i = 1, nfft1
               qgrid(1,i,j,k) = 0.0d0
               qgrid(2,i,j,k) = 0.0d0
            end do
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP DO
c
c     put the permanent multipole moments onto the grid
c
      do ichk = 1, nchunk
         cid(1) = mod(ichk-1,nchk1)
         cid(2) = mod(((ichk-1-cid(1))/nchk1),nchk2)
         cid(3) = mod((ichk-1)/(nchk1*nchk2),nchk3)
         cbound(1) = cid(1)*ngrd1 + 1
         cbound(2) = cbound(1) + ngrd1 - 1
         cbound(3) = cid(2)*ngrd2 + 1
         cbound(4) = cbound(3) + ngrd2 - 1
         cbound(5) = cid(3)*ngrd3 + 1
         cbound(6) = cbound(5) + ngrd3 - 1
         do isite = 1, nion
            iatm = iion(isite)
            if (pmetable(iatm,ichk) .eq. 1) then
               nearpt(1) = igrid(1,iatm) + grdoff
               nearpt(2) = igrid(2,iatm) + grdoff
               nearpt(3) = igrid(3,iatm) + grdoff
               abound(1) = nearpt(1) - nlpts
               abound(2) = nearpt(1) + nrpts
               abound(3) = nearpt(2) - nlpts
               abound(4) = nearpt(2) + nrpts
               abound(5) = nearpt(3) - nlpts
               abound(6) = nearpt(3) + nrpts
               call adjust (offsetx,nfft1,nchk1,abound(1),
     &                         abound(2),cbound(1),cbound(2))
               call adjust (offsety,nfft2,nchk2,abound(3),
     &                         abound(4),cbound(3),cbound(4))
               call adjust (offsetz,nfft3,nchk3,abound(5),
     &                         abound(6),cbound(5),cbound(6))
               do kk = abound(5), abound(6)
                  k = kk
                  m = k + offsetz
                  if (k .lt. 1)  k = k + nfft3
                  v0 = thetai3(1,m,iatm) * pchg(iatm)
                  do jj = abound(3), abound(4)
                     j = jj
                     m = j + offsety
                     if (j .lt. 1)  j = j + nfft2
                     u0 = thetai2(1,m,iatm)
                     term = v0 * u0
                     do ii = abound(1), abound(2)
                        i = ii
                        m = i + offsetx
                        if (i .lt. 1)  i = i + nfft1
                        t0 = thetai1(1,m,iatm)
                        qgrid(1,i,j,k) = qgrid(1,i,j,k) + term*t0
                     end do
                  end do
               end do
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine grid_mpole  --  put multipoles on PME grid  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "grid_mpole" places the fractional atomic multipoles onto
c     the particle mesh Ewald grid
c
c     note the main loop does not need to be an OpenMP reduction
c     since a given qgrid element is always part of the same chunk,
c     and the code runs faster without use of a reduction
c
c
      subroutine grid_mpole (fmp)
      use atoms
      use chunks
      use mpole
      use pme
      implicit none
      integer i,j,k,m
      integer ii,jj,kk
      integer ichk,isite,iatm
      integer offsetx,offsety
      integer offsetz
      integer cid(3)
      integer nearpt(3)
      integer abound(6)
      integer cbound(6)
      real*8 v0,u0,t0
      real*8 v1,u1,t1
      real*8 v2,u2,t2
      real*8 term0,term1,term2
      real*8 fmp(10,*)
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,fmp,pmetable,
!$OMP& nfft1,nfft2,nfft3,nchunk,nchk1,nchk2,nchk3,ngrd1,ngrd2,
!$OMP& ngrd3,nlpts,nrpts,igrid,grdoff,thetai1,thetai2,thetai3)
!$OMP& shared(qgrid)
!$OMP DO
c
c     zero out the particle mesh Ewald grid
c
      do k = 1, nfft3
         do j = 1, nfft2
            do i = 1, nfft1
               qgrid(1,i,j,k) = 0.0d0
               qgrid(2,i,j,k) = 0.0d0
            end do
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP DO
c
c     put the permanent multipole moments onto the grid
c
      do ichk = 1, nchunk
         cid(1) = mod(ichk-1,nchk1)
         cid(2) = mod(((ichk-1-cid(1))/nchk1),nchk2)
         cid(3) = mod((ichk-1)/(nchk1*nchk2),nchk3)
         cbound(1) = cid(1)*ngrd1 + 1
         cbound(2) = cbound(1) + ngrd1 - 1
         cbound(3) = cid(2)*ngrd2 + 1
         cbound(4) = cbound(3) + ngrd2 - 1
         cbound(5) = cid(3)*ngrd3 + 1
         cbound(6) = cbound(5) + ngrd3 - 1
         do isite = 1, npole
            iatm = ipole(isite)
            if (pmetable(iatm,ichk) .eq. 1) then
               nearpt(1) = igrid(1,iatm) + grdoff
               nearpt(2) = igrid(2,iatm) + grdoff
               nearpt(3) = igrid(3,iatm) + grdoff
               abound(1) = nearpt(1) - nlpts
               abound(2) = nearpt(1) + nrpts
               abound(3) = nearpt(2) - nlpts
               abound(4) = nearpt(2) + nrpts
               abound(5) = nearpt(3) - nlpts
               abound(6) = nearpt(3) + nrpts
               call adjust (offsetx,nfft1,nchk1,abound(1),
     &                         abound(2),cbound(1),cbound(2))
               call adjust (offsety,nfft2,nchk2,abound(3),
     &                         abound(4),cbound(3),cbound(4))
               call adjust (offsetz,nfft3,nchk3,abound(5),
     &                         abound(6),cbound(5),cbound(6))
               do kk = abound(5), abound(6)
                  k = kk
                  m = k + offsetz
                  if (k .lt. 1)  k = k + nfft3
                  v0 = thetai3(1,m,iatm)
                  v1 = thetai3(2,m,iatm)
                  v2 = thetai3(3,m,iatm)
                  do jj = abound(3), abound(4)
                     j = jj
                     m = j + offsety
                     if (j .lt. 1)  j = j + nfft2
                     u0 = thetai2(1,m,iatm)
                     u1 = thetai2(2,m,iatm)
                     u2 = thetai2(3,m,iatm)
                     term0 = fmp(1,iatm)*u0*v0 + fmp(3,iatm)*u1*v0
     &                     + fmp(4,iatm)*u0*v1 + fmp(6,iatm)*u2*v0
     &                     + fmp(7,iatm)*u0*v2 + fmp(10,iatm)*u1*v1
                     term1 = fmp(2,iatm)*u0*v0 + fmp(8,iatm)*u1*v0
     &                          + fmp(9,iatm)*u0*v1
                     term2 = fmp(5,iatm) * u0 * v0
                     do ii = abound(1), abound(2)
                        i = ii
                        m = i + offsetx
                        if (i .lt. 1)  i = i + nfft1
                        t0 = thetai1(1,m,iatm)
                        t1 = thetai1(2,m,iatm)
                        t2 = thetai1(3,m,iatm)
                        qgrid(1,i,j,k) = qgrid(1,i,j,k) + term0*t0
     &                                      + term1*t1 + term2*t2
                     end do
                  end do
               end do
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine grid_uind  --  put induced dipoles on PME grid  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "grid_uind" places the fractional induced dipoles onto the
c     particle mesh Ewald grid
c
c     note the main loop does not need to be an OpenMP reduction
c     since a given qgrid element is always part of the same chunk,
c     and the code runs faster without use of a reduction
c
c
      subroutine grid_uind (fuind,fuinp)
      use atoms
      use chunks
      use mpole
      use pme
      implicit none
      integer i,j,k,m
      integer ii,jj,kk
      integer ichk,isite,iatm
      integer offsetx,offsety
      integer offsetz
      integer cid(3)
      integer nearpt(3)
      integer abound(6)
      integer cbound(6)
      real*8 v0,u0,t0
      real*8 v1,u1,t1
      real*8 term01,term11
      real*8 term02,term12
      real*8 fuind(3,*)
      real*8 fuinp(3,*)
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,fuind,fuinp,
!$OMP& pmetable,nfft1,nfft2,nfft3,nchunk,nchk1,nchk2,nchk3,ngrd1,
!$OMP& ngrd2,ngrd3,nlpts,nrpts,igrid,grdoff,thetai1,thetai2,thetai3)
!$OMP& shared(qgrid)
!$OMP DO
c
c     zero out the particle mesh Ewald grid
c
      do k = 1, nfft3
         do j = 1, nfft2
            do i = 1, nfft1
               qgrid(1,i,j,k) = 0.0d0
               qgrid(2,i,j,k) = 0.0d0
            end do
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP DO
c
c     put the induced dipole moments onto the grid
c
      do ichk = 1, nchunk
         cid(1) = mod(ichk-1,nchk1)
         cid(2) = mod(((ichk-1-cid(1))/nchk1),nchk2)
         cid(3) = mod((ichk-1)/(nchk1*nchk2),nchk3)
         cbound(1) = cid(1)*ngrd1 + 1
         cbound(2) = cbound(1) + ngrd1 - 1
         cbound(3) = cid(2)*ngrd2 + 1
         cbound(4) = cbound(3) + ngrd2 - 1
         cbound(5) = cid(3)*ngrd3 + 1
         cbound(6) = cbound(5) + ngrd3 - 1
         do isite = 1, npole
            iatm = ipole(isite)
            if (pmetable(iatm,ichk) .eq. 1) then
               nearpt(1) = igrid(1,iatm) + grdoff
               nearpt(2) = igrid(2,iatm) + grdoff
               nearpt(3) = igrid(3,iatm) + grdoff
               abound(1) = nearpt(1) - nlpts
               abound(2) = nearpt(1) + nrpts
               abound(3) = nearpt(2) - nlpts
               abound(4) = nearpt(2) + nrpts
               abound(5) = nearpt(3) - nlpts
               abound(6) = nearpt(3) + nrpts
               call adjust (offsetx,nfft1,nchk1,abound(1),
     &                         abound(2),cbound(1),cbound(2))
               call adjust (offsety,nfft2,nchk2,abound(3),
     &                         abound(4),cbound(3),cbound(4))
               call adjust (offsetz,nfft3,nchk3,abound(5),
     &                         abound(6),cbound(5),cbound(6))
               do kk = abound(5), abound(6)
                  k = kk
                  m = k + offsetz
                  if (k .lt. 1)  k = k + nfft3
                  v0 = thetai3(1,m,iatm)
                  v1 = thetai3(2,m,iatm)
                  do jj = abound(3), abound(4)
                     j = jj
                     m = j + offsety
                     if (j .lt. 1)  j = j + nfft2
                     u0 = thetai2(1,m,iatm)
                     u1 = thetai2(2,m,iatm)
                     term01 = fuind(2,iatm)*u1*v0
     &                           + fuind(3,iatm)*u0*v1
                     term11 = fuind(1,iatm)*u0*v0
                     term02 = fuinp(2,iatm)*u1*v0
     &                           + fuinp(3,iatm)*u0*v1
                     term12 = fuinp(1,iatm)*u0*v0
                     do ii = abound(1), abound(2)
                        i = ii
                        m = i + offsetx
                        if (i .lt. 1)  i = i + nfft1
                        t0 = thetai1(1,m,iatm)
                        t1 = thetai1(2,m,iatm)
                        qgrid(1,i,j,k) = qgrid(1,i,j,k) + term01*t0
     &                                      + term11*t1
                        qgrid(2,i,j,k) = qgrid(2,i,j,k) + term02*t0
     &                                      + term12*t1
                     end do
                  end do
               end do
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine grid_disp  --  put dispersion sites on PME grid  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "grid_disp" places the damped dispersion coefficients onto
c     the particle mesh Ewald grid
c
c     note the main loop does not need to be an OpenMP reduction
c     since a given qgrid element is always part of the same chunk,
c     and the code runs faster without use of a reduction
c
c
      subroutine grid_disp
      use atoms
      use disp
      use chunks
      use pme
      implicit none
      integer i,j,k,m
      integer ii,jj,kk
      integer ichk,isite,iatm
      integer offsetx,offsety
      integer offsetz
      integer cid(3)
      integer nearpt(3)
      integer abound(6)
      integer cbound(6)
      real*8 v0,u0,t0
      real*8 term
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(ndisp,idisp,csix,pmetable,
!$OMP& nfft1,nfft2,nfft3,nchunk,nchk1,nchk2,nchk3,ngrd1,ngrd2,
!$OMP& ngrd3,nlpts,nrpts,igrid,grdoff,thetai1,thetai2,thetai3)
!$OMP& shared(qgrid)
!$OMP DO
c
c     zero out the particle mesh Ewald grid
c
      do k = 1, nfft3
         do j = 1, nfft2
            do i = 1, nfft1
               qgrid(1,i,j,k) = 0.0d0
               qgrid(2,i,j,k) = 0.0d0
            end do
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP DO
c
c     put the dispersion sites onto the grid
c
      do ichk = 1, nchunk
         cid(1) = mod(ichk-1,nchk1)
         cid(2) = mod(((ichk-1-cid(1))/nchk1),nchk2)
         cid(3) = mod((ichk-1)/(nchk1*nchk2),nchk3)
         cbound(1) = cid(1)*ngrd1 + 1
         cbound(2) = cbound(1) + ngrd1 - 1
         cbound(3) = cid(2)*ngrd2 + 1
         cbound(4) = cbound(3) + ngrd2 - 1
         cbound(5) = cid(3)*ngrd3 + 1
         cbound(6) = cbound(5) + ngrd3 - 1
         do isite = 1, ndisp
            iatm = idisp(isite)
            if (pmetable(iatm,ichk) .eq. 1) then
               nearpt(1) = igrid(1,iatm) + grdoff
               nearpt(2) = igrid(2,iatm) + grdoff
               nearpt(3) = igrid(3,iatm) + grdoff
               abound(1) = nearpt(1) - nlpts
               abound(2) = nearpt(1) + nrpts
               abound(3) = nearpt(2) - nlpts
               abound(4) = nearpt(2) + nrpts
               abound(5) = nearpt(3) - nlpts
               abound(6) = nearpt(3) + nrpts
               call adjust (offsetx,nfft1,nchk1,abound(1),
     &                         abound(2),cbound(1),cbound(2))
               call adjust (offsety,nfft2,nchk2,abound(3),
     &                         abound(4),cbound(3),cbound(4))
               call adjust (offsetz,nfft3,nchk3,abound(5),
     &                         abound(6),cbound(5),cbound(6))
               do kk = abound(5), abound(6)
                  k = kk
                  m = k + offsetz
                  if (k .lt. 1)  k = k + nfft3
                  v0 = thetai3(1,m,iatm) * csix(iatm)
                  do jj = abound(3), abound(4)
                     j = jj
                     m = j + offsety
                     if (j .lt. 1)  j = j + nfft2
                     u0 = thetai2(1,m,iatm)
                     term = v0 * u0
                     do ii = abound(1), abound(2)
                        i = ii
                        m = i + offsetx
                        if (i .lt. 1)  i = i + nfft1
                        t0 = thetai1(1,m,iatm)
                        qgrid(1,i,j,k) = qgrid(1,i,j,k) + term*t0
                     end do
                  end do
               end do
            end if
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine adjust  --  alter site bounds for the PME grid  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "adjust" modifies site bounds on the PME grid and returns
c     an offset into the B-spline coefficient arrays
c
c
      subroutine adjust (offset,nfft,nchk,amin,amax,cmin,cmax)
      implicit none
      integer offset
      integer nfft,nchk
      integer amin,amax
      integer cmin,cmax
c
c
c     modify grid offset and bounds for site at edge of chunk
c
      offset = 0
      if (nchk .ne. 1) then
         if (amin.lt.cmin .or. amax.gt.cmax) then
            if (amin.lt.1 .or. amax.gt.nfft) then
               if (cmin .eq. 1) then
                  offset = 1 - amin
                  amin = 1
               else if (cmax .eq. nfft) then
                  amax = nfft
                  amin = amin + nfft
               end if
            else
               if (cmin .gt. amin) then
                  offset = cmin - amin
                  amin = cmin
               else
                  amax = cmax
               end if
            end if
         end if
      end if
      offset = offset + 1 - amin
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine fphi_pchg  --  charge potential and field  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "fphi_pchg" extracts the partial charge potential and field
c     from the particle mesh Ewald grid
c
c
      subroutine fphi_pchg (fphi)
      use charge
      use pme
      implicit none
      integer i,j,k
      integer isite,iatm
      integer i0,j0,k0
      integer it1,it2,it3
      integer igrd0,jgrd0,kgrd0
      real*8 v0,v1
      real*8 u0,u1
      real*8 t0,t1,tq
      real*8 tu00,tu10,tu01
      real*8 tuv000,tuv100
      real*8 tuv010,tuv001
      real*8 fphi(4,*)
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nion,iion,igrid,bsorder,
!$OMP& nfft1,nfft2,nfft3,thetai1,thetai2,thetai3,qgrid,fphi)
!$OMP DO
c
c     get partial charge potential and field at each site
c
      do isite = 1, nion
         iatm = iion(isite)
         igrd0 = igrid(1,iatm)
         jgrd0 = igrid(2,iatm)
         kgrd0 = igrid(3,iatm)
         tuv000 = 0.0d0
         tuv001 = 0.0d0
         tuv010 = 0.0d0
         tuv100 = 0.0d0
         k0 = kgrd0
         do it3 = 1, bsorder
            k0 = k0 + 1
            k = k0 + 1 + (nfft3-isign(nfft3,k0))/2
            v0 = thetai3(1,it3,iatm)
            v1 = thetai3(2,it3,iatm)
            tu00 = 0.0d0
            tu10 = 0.0d0
            tu01 = 0.0d0
            j0 = jgrd0
            do it2 = 1, bsorder
               j0 = j0 + 1
               j = j0 + 1 + (nfft2-isign(nfft2,j0))/2
               u0 = thetai2(1,it2,iatm)
               u1 = thetai2(2,it2,iatm)
               t0 = 0.0d0
               t1 = 0.0d0
               i0 = igrd0
               do it1 = 1, bsorder
                  i0 = i0 + 1
                  i = i0 + 1 + (nfft1-isign(nfft1,i0))/2
                  tq = qgrid(1,i,j,k)
                  t0 = t0 + tq*thetai1(1,it1,iatm)
                  t1 = t1 + tq*thetai1(2,it1,iatm)
               end do
               tu00 = tu00 + t0*u0
               tu10 = tu10 + t1*u0
               tu01 = tu01 + t0*u1
            end do
            tuv000 = tuv000 + tu00*v0
            tuv100 = tuv100 + tu10*v0
            tuv010 = tuv010 + tu01*v0
            tuv001 = tuv001 + tu00*v1
         end do
         fphi(1,iatm) = tuv000
         fphi(2,iatm) = tuv100
         fphi(3,iatm) = tuv010
         fphi(4,iatm) = tuv001
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine fphi_mpole  --  multipole potential and field  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "fphi_mpole" extracts the permanent multipole potential and
c     field from the particle mesh Ewald grid
c
c
      subroutine fphi_mpole (fphi)
      use mpole
      use pme
      implicit none
      integer i,j,k
      integer isite,iatm
      integer i0,j0,k0
      integer it1,it2,it3
      integer igrd0,jgrd0,kgrd0
      real*8 v0,v1,v2,v3
      real*8 u0,u1,u2,u3
      real*8 t0,t1,t2,t3,tq
      real*8 tu00,tu10,tu01,tu20,tu11
      real*8 tu02,tu21,tu12,tu30,tu03
      real*8 tuv000,tuv100,tuv010,tuv001
      real*8 tuv200,tuv020,tuv002,tuv110
      real*8 tuv101,tuv011,tuv300,tuv030
      real*8 tuv003,tuv210,tuv201,tuv120
      real*8 tuv021,tuv102,tuv012,tuv111
      real*8 fphi(20,*)
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,igrid,bsorder,
!$OMP& nfft1,nfft2,nfft3,thetai1,thetai2,thetai3,qgrid,fphi)
!$OMP DO
c
c     get permanent multipole potential and field at each site
c
      do isite = 1, npole
         iatm = ipole(isite)
         igrd0 = igrid(1,iatm)
         jgrd0 = igrid(2,iatm)
         kgrd0 = igrid(3,iatm)
         tuv000 = 0.0d0
         tuv001 = 0.0d0
         tuv010 = 0.0d0
         tuv100 = 0.0d0
         tuv200 = 0.0d0
         tuv020 = 0.0d0
         tuv002 = 0.0d0
         tuv110 = 0.0d0
         tuv101 = 0.0d0
         tuv011 = 0.0d0
         tuv300 = 0.0d0
         tuv030 = 0.0d0
         tuv003 = 0.0d0
         tuv210 = 0.0d0
         tuv201 = 0.0d0
         tuv120 = 0.0d0
         tuv021 = 0.0d0
         tuv102 = 0.0d0
         tuv012 = 0.0d0
         tuv111 = 0.0d0
         k0 = kgrd0
         do it3 = 1, bsorder
            k0 = k0 + 1
            k = k0 + 1 + (nfft3-isign(nfft3,k0))/2
            v0 = thetai3(1,it3,iatm)
            v1 = thetai3(2,it3,iatm)
            v2 = thetai3(3,it3,iatm)
            v3 = thetai3(4,it3,iatm)
            tu00 = 0.0d0
            tu10 = 0.0d0
            tu01 = 0.0d0
            tu20 = 0.0d0
            tu11 = 0.0d0
            tu02 = 0.0d0
            tu30 = 0.0d0
            tu21 = 0.0d0
            tu12 = 0.0d0
            tu03 = 0.0d0
            j0 = jgrd0
            do it2 = 1, bsorder
               j0 = j0 + 1
               j = j0 + 1 + (nfft2-isign(nfft2,j0))/2
               u0 = thetai2(1,it2,iatm)
               u1 = thetai2(2,it2,iatm)
               u2 = thetai2(3,it2,iatm)
               u3 = thetai2(4,it2,iatm)
               t0 = 0.0d0
               t1 = 0.0d0
               t2 = 0.0d0
               t3 = 0.0d0
               i0 = igrd0
               do it1 = 1, bsorder
                  i0 = i0 + 1
                  i = i0 + 1 + (nfft1-isign(nfft1,i0))/2
                  tq = qgrid(1,i,j,k)
                  t0 = t0 + tq*thetai1(1,it1,iatm)
                  t1 = t1 + tq*thetai1(2,it1,iatm)
                  t2 = t2 + tq*thetai1(3,it1,iatm)
                  t3 = t3 + tq*thetai1(4,it1,iatm)
               end do
               tu00 = tu00 + t0*u0
               tu10 = tu10 + t1*u0
               tu01 = tu01 + t0*u1
               tu20 = tu20 + t2*u0
               tu11 = tu11 + t1*u1
               tu02 = tu02 + t0*u2
               tu30 = tu30 + t3*u0
               tu21 = tu21 + t2*u1
               tu12 = tu12 + t1*u2
               tu03 = tu03 + t0*u3
            end do
            tuv000 = tuv000 + tu00*v0
            tuv100 = tuv100 + tu10*v0
            tuv010 = tuv010 + tu01*v0
            tuv001 = tuv001 + tu00*v1
            tuv200 = tuv200 + tu20*v0
            tuv020 = tuv020 + tu02*v0
            tuv002 = tuv002 + tu00*v2
            tuv110 = tuv110 + tu11*v0
            tuv101 = tuv101 + tu10*v1
            tuv011 = tuv011 + tu01*v1
            tuv300 = tuv300 + tu30*v0
            tuv030 = tuv030 + tu03*v0
            tuv003 = tuv003 + tu00*v3
            tuv210 = tuv210 + tu21*v0
            tuv201 = tuv201 + tu20*v1
            tuv120 = tuv120 + tu12*v0
            tuv021 = tuv021 + tu02*v1
            tuv102 = tuv102 + tu10*v2
            tuv012 = tuv012 + tu01*v2
            tuv111 = tuv111 + tu11*v1
         end do
         fphi(1,iatm) = tuv000
         fphi(2,iatm) = tuv100
         fphi(3,iatm) = tuv010
         fphi(4,iatm) = tuv001
         fphi(5,iatm) = tuv200
         fphi(6,iatm) = tuv020
         fphi(7,iatm) = tuv002
         fphi(8,iatm) = tuv110
         fphi(9,iatm) = tuv101
         fphi(10,iatm) = tuv011
         fphi(11,iatm) = tuv300
         fphi(12,iatm) = tuv030
         fphi(13,iatm) = tuv003
         fphi(14,iatm) = tuv210
         fphi(15,iatm) = tuv201
         fphi(16,iatm) = tuv120
         fphi(17,iatm) = tuv021
         fphi(18,iatm) = tuv102
         fphi(19,iatm) = tuv012
         fphi(20,iatm) = tuv111
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine fphi_uind  --  induced potential and field  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "fphi_uind" extracts the induced dipole potential and field
c     from the particle mesh Ewald grid
c
c
      subroutine fphi_uind (fdip_phi1,fdip_phi2,fdip_sum_phi)
      use mpole
      use pme
      implicit none
      integer i,j,k
      integer isite,iatm
      integer i0,j0,k0
      integer it1,it2,it3
      integer igrd0,jgrd0,kgrd0
      real*8 v0,v1,v2,v3
      real*8 u0,u1,u2,u3
      real*8 t0,t1,t2,t3
      real*8 t0_1,t0_2,t1_1,t1_2
      real*8 t2_1,t2_2,tq_1,tq_2
      real*8 tu00,tu10,tu01,tu20,tu11
      real*8 tu02,tu30,tu21,tu12,tu03
      real*8 tu00_1,tu01_1,tu10_1
      real*8 tu00_2,tu01_2,tu10_2
      real*8 tu20_1,tu11_1,tu02_1
      real*8 tu20_2,tu11_2,tu02_2
      real*8 tuv100_1,tuv010_1,tuv001_1
      real*8 tuv100_2,tuv010_2,tuv001_2
      real*8 tuv200_1,tuv020_1,tuv002_1
      real*8 tuv110_1,tuv101_1,tuv011_1
      real*8 tuv200_2,tuv020_2,tuv002_2
      real*8 tuv110_2,tuv101_2,tuv011_2
      real*8 tuv000,tuv100,tuv010,tuv001
      real*8 tuv200,tuv020,tuv002,tuv110
      real*8 tuv101,tuv011,tuv300,tuv030
      real*8 tuv003,tuv210,tuv201,tuv120
      real*8 tuv021,tuv102,tuv012,tuv111
      real*8 fdip_phi1(10,*)
      real*8 fdip_phi2(10,*)
      real*8 fdip_sum_phi(20,*)
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(npole,ipole,igrid,bsorder,
!$OMP& nfft1,nfft2,nfft3,thetai1,thetai2,thetai3,qgrid,fdip_phi1,
!$OMP& fdip_phi2,fdip_sum_phi)
!$OMP DO
c
c     get induced dipole potential and field at each site
c
      do isite = 1, npole
         iatm = ipole(isite)
         igrd0 = igrid(1,iatm)
         jgrd0 = igrid(2,iatm)
         kgrd0 = igrid(3,iatm)
         tuv100_1 = 0.0d0
         tuv010_1 = 0.0d0
         tuv001_1 = 0.0d0
         tuv200_1 = 0.0d0
         tuv020_1 = 0.0d0
         tuv002_1 = 0.0d0
         tuv110_1 = 0.0d0
         tuv101_1 = 0.0d0
         tuv011_1 = 0.0d0
         tuv100_2 = 0.0d0
         tuv010_2 = 0.0d0
         tuv001_2 = 0.0d0
         tuv200_2 = 0.0d0
         tuv020_2 = 0.0d0
         tuv002_2 = 0.0d0
         tuv110_2 = 0.0d0
         tuv101_2 = 0.0d0
         tuv011_2 = 0.0d0
         tuv000 = 0.0d0
         tuv001 = 0.0d0
         tuv010 = 0.0d0
         tuv100 = 0.0d0
         tuv200 = 0.0d0
         tuv020 = 0.0d0
         tuv002 = 0.0d0
         tuv110 = 0.0d0
         tuv101 = 0.0d0
         tuv011 = 0.0d0
         tuv300 = 0.0d0
         tuv030 = 0.0d0
         tuv003 = 0.0d0
         tuv210 = 0.0d0
         tuv201 = 0.0d0
         tuv120 = 0.0d0
         tuv021 = 0.0d0
         tuv102 = 0.0d0
         tuv012 = 0.0d0
         tuv111 = 0.0d0
         k0 = kgrd0
         do it3 = 1, bsorder
            k0 = k0 + 1
            k = k0 + 1 + (nfft3-isign(nfft3,k0))/2
            v0 = thetai3(1,it3,iatm)
            v1 = thetai3(2,it3,iatm)
            v2 = thetai3(3,it3,iatm)
            v3 = thetai3(4,it3,iatm)
            tu00_1 = 0.0d0
            tu01_1 = 0.0d0
            tu10_1 = 0.0d0
            tu20_1 = 0.0d0
            tu11_1 = 0.0d0
            tu02_1 = 0.0d0
            tu00_2 = 0.0d0
            tu01_2 = 0.0d0
            tu10_2 = 0.0d0
            tu20_2 = 0.0d0
            tu11_2 = 0.0d0
            tu02_2 = 0.0d0
            tu00 = 0.0d0
            tu10 = 0.0d0
            tu01 = 0.0d0
            tu20 = 0.0d0
            tu11 = 0.0d0
            tu02 = 0.0d0
            tu30 = 0.0d0
            tu21 = 0.0d0
            tu12 = 0.0d0
            tu03 = 0.0d0
            j0 = jgrd0
            do it2 = 1, bsorder
               j0 = j0 + 1
               j = j0 + 1 + (nfft2-isign(nfft2,j0))/2
               u0 = thetai2(1,it2,iatm)
               u1 = thetai2(2,it2,iatm)
               u2 = thetai2(3,it2,iatm)
               u3 = thetai2(4,it2,iatm)
               t0_1 = 0.0d0
               t1_1 = 0.0d0
               t2_1 = 0.0d0
               t0_2 = 0.0d0
               t1_2 = 0.0d0
               t2_2 = 0.0d0
               t3 = 0.0d0
               i0 = igrd0
               do it1 = 1, bsorder
                  i0 = i0 + 1
                  i = i0 + 1 + (nfft1-isign(nfft1,i0))/2
                  tq_1 = qgrid(1,i,j,k)
                  tq_2 = qgrid(2,i,j,k)
                  t0_1 = t0_1 + tq_1*thetai1(1,it1,iatm)
                  t1_1 = t1_1 + tq_1*thetai1(2,it1,iatm)
                  t2_1 = t2_1 + tq_1*thetai1(3,it1,iatm)
                  t0_2 = t0_2 + tq_2*thetai1(1,it1,iatm)
                  t1_2 = t1_2 + tq_2*thetai1(2,it1,iatm)
                  t2_2 = t2_2 + tq_2*thetai1(3,it1,iatm)
                  t3 = t3 + (tq_1+tq_2)*thetai1(4,it1,iatm)
               end do
               tu00_1 = tu00_1 + t0_1*u0
               tu10_1 = tu10_1 + t1_1*u0
               tu01_1 = tu01_1 + t0_1*u1
               tu20_1 = tu20_1 + t2_1*u0
               tu11_1 = tu11_1 + t1_1*u1
               tu02_1 = tu02_1 + t0_1*u2
               tu00_2 = tu00_2 + t0_2*u0
               tu10_2 = tu10_2 + t1_2*u0
               tu01_2 = tu01_2 + t0_2*u1
               tu20_2 = tu20_2 + t2_2*u0
               tu11_2 = tu11_2 + t1_2*u1
               tu02_2 = tu02_2 + t0_2*u2
               t0 = t0_1 + t0_2
               t1 = t1_1 + t1_2
               t2 = t2_1 + t2_2
               tu00 = tu00 + t0*u0
               tu10 = tu10 + t1*u0
               tu01 = tu01 + t0*u1
               tu20 = tu20 + t2*u0
               tu11 = tu11 + t1*u1
               tu02 = tu02 + t0*u2
               tu30 = tu30 + t3*u0
               tu21 = tu21 + t2*u1
               tu12 = tu12 + t1*u2
               tu03 = tu03 + t0*u3
            end do
            tuv100_1 = tuv100_1 + tu10_1*v0
            tuv010_1 = tuv010_1 + tu01_1*v0
            tuv001_1 = tuv001_1 + tu00_1*v1
            tuv200_1 = tuv200_1 + tu20_1*v0
            tuv020_1 = tuv020_1 + tu02_1*v0
            tuv002_1 = tuv002_1 + tu00_1*v2
            tuv110_1 = tuv110_1 + tu11_1*v0
            tuv101_1 = tuv101_1 + tu10_1*v1
            tuv011_1 = tuv011_1 + tu01_1*v1
            tuv100_2 = tuv100_2 + tu10_2*v0
            tuv010_2 = tuv010_2 + tu01_2*v0
            tuv001_2 = tuv001_2 + tu00_2*v1
            tuv200_2 = tuv200_2 + tu20_2*v0
            tuv020_2 = tuv020_2 + tu02_2*v0
            tuv002_2 = tuv002_2 + tu00_2*v2
            tuv110_2 = tuv110_2 + tu11_2*v0
            tuv101_2 = tuv101_2 + tu10_2*v1
            tuv011_2 = tuv011_2 + tu01_2*v1
            tuv000 = tuv000 + tu00*v0
            tuv100 = tuv100 + tu10*v0
            tuv010 = tuv010 + tu01*v0
            tuv001 = tuv001 + tu00*v1
            tuv200 = tuv200 + tu20*v0
            tuv020 = tuv020 + tu02*v0
            tuv002 = tuv002 + tu00*v2
            tuv110 = tuv110 + tu11*v0
            tuv101 = tuv101 + tu10*v1
            tuv011 = tuv011 + tu01*v1
            tuv300 = tuv300 + tu30*v0
            tuv030 = tuv030 + tu03*v0
            tuv003 = tuv003 + tu00*v3
            tuv210 = tuv210 + tu21*v0
            tuv201 = tuv201 + tu20*v1
            tuv120 = tuv120 + tu12*v0
            tuv021 = tuv021 + tu02*v1
            tuv102 = tuv102 + tu10*v2
            tuv012 = tuv012 + tu01*v2
            tuv111 = tuv111 + tu11*v1
         end do
         fdip_phi1(1,iatm) = 0.0d0
         fdip_phi1(2,iatm) = tuv100_1
         fdip_phi1(3,iatm) = tuv010_1
         fdip_phi1(4,iatm) = tuv001_1
         fdip_phi1(5,iatm) = tuv200_1
         fdip_phi1(6,iatm) = tuv020_1
         fdip_phi1(7,iatm) = tuv002_1
         fdip_phi1(8,iatm) = tuv110_1
         fdip_phi1(9,iatm) = tuv101_1
         fdip_phi1(10,iatm) = tuv011_1
         fdip_phi2(1,iatm) = 0.0d0
         fdip_phi2(2,iatm) = tuv100_2
         fdip_phi2(3,iatm) = tuv010_2
         fdip_phi2(4,iatm) = tuv001_2
         fdip_phi2(5,iatm) = tuv200_2
         fdip_phi2(6,iatm) = tuv020_2
         fdip_phi2(7,iatm) = tuv002_2
         fdip_phi2(8,iatm) = tuv110_2
         fdip_phi2(9,iatm) = tuv101_2
         fdip_phi2(10,iatm) = tuv011_2
         fdip_sum_phi(1,iatm) = tuv000
         fdip_sum_phi(2,iatm) = tuv100
         fdip_sum_phi(3,iatm) = tuv010
         fdip_sum_phi(4,iatm) = tuv001
         fdip_sum_phi(5,iatm) = tuv200
         fdip_sum_phi(6,iatm) = tuv020
         fdip_sum_phi(7,iatm) = tuv002
         fdip_sum_phi(8,iatm) = tuv110
         fdip_sum_phi(9,iatm) = tuv101
         fdip_sum_phi(10,iatm) = tuv011
         fdip_sum_phi(11,iatm) = tuv300
         fdip_sum_phi(12,iatm) = tuv030
         fdip_sum_phi(13,iatm) = tuv003
         fdip_sum_phi(14,iatm) = tuv210
         fdip_sum_phi(15,iatm) = tuv201
         fdip_sum_phi(16,iatm) = tuv120
         fdip_sum_phi(17,iatm) = tuv021
         fdip_sum_phi(18,iatm) = tuv102
         fdip_sum_phi(19,iatm) = tuv012
         fdip_sum_phi(20,iatm) = tuv111
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine cmp_to_fmp  --  transformation of multipoles  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "cmp_to_fmp" transforms the atomic multipoles from Cartesian
c     to fractional coordinates
c
c
      subroutine cmp_to_fmp (cmp,fmp)
      use mpole
      implicit none
      integer i,j,k,ii
      real*8 ctf(10,10)
      real*8 cmp(10,*)
      real*8 fmp(10,*)
c
c
c     find the matrix to convert Cartesian to fractional
c
      call cart_to_frac (ctf)
c
c     apply the transformation to get the fractional multipoles
c
      do ii = 1, npole
         i = ipole(ii)
         fmp(1,i) = ctf(1,1) * cmp(1,i)
         do j = 2, 4
            fmp(j,i) = 0.0d0
            do k = 2, 4
               fmp(j,i) = fmp(j,i) + ctf(j,k)*cmp(k,i)
            end do
         end do
         do j = 5, 10
            fmp(j,i) = 0.0d0
            do k = 5, 10
               fmp(j,i) = fmp(j,i) + ctf(j,k)*cmp(k,i)
            end do
         end do
      end do
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine cart_to_frac  --  Cartesian to fractional  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "cart_to_frac" computes a transformation matrix to convert
c     a multipole object in Cartesian coordinates to fractional
c
c     note the multipole components are stored in the condensed
c     order (m,dx,dy,dz,qxx,qyy,qzz,qxy,qxz,qyz)
c
c
      subroutine cart_to_frac (ctf)
      use boxes
      use pme
      implicit none
      integer i,j,k,m
      integer i1,i2
      integer qi1(6)
      integer qi2(6)
      real*8 a(3,3)
      real*8 ctf(10,10)
      data qi1  / 1, 2, 3, 1, 1, 2 /
      data qi2  / 1, 2, 3, 2, 3, 3 /
c
c
c     set the reciprocal vector transformation matrix
c
      do i = 1, 3
         a(1,i) = dble(nfft1) * recip(i,1)
         a(2,i) = dble(nfft2) * recip(i,2)
         a(3,i) = dble(nfft3) * recip(i,3)
      end do
c
c     get the Cartesian to fractional conversion matrix
c
      do i = 1, 10
         do j = 1, 10
            ctf(j,i) = 0.0d0
         end do
      end do
      ctf(1,1) = 1.0d0
      do i = 2, 4
         do j = 2, 4
            ctf(i,j) = a(i-1,j-1)
         end do
      end do
      do i1 = 1, 3
         k = qi1(i1)
         do i2 = 1, 6
            i = qi1(i2)
            j = qi2(i2)
            ctf(i1+4,i2+4) = a(k,i) * a(k,j)
         end do
      end do
      do i1 = 4, 6
         k = qi1(i1)
         m = qi2(i1)
         do i2 = 1, 6
            i = qi1(i2)
            j = qi2(i2)
            ctf(i1+4,i2+4) = a(k,i)*a(m,j) + a(k,j)*a(m,i)
         end do
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine fphi_to_cphi  --  transformation of potential  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "fphi_to_cphi" transforms the reciprocal space potential from
c     fractional to Cartesian coordinates
c
c
      subroutine fphi_to_cphi (fphi,cphi)
      use mpole
      implicit none
      integer i,j,k,ii
      real*8 ftc(10,10)
      real*8 cphi(10,*)
      real*8 fphi(20,*)
c
c
c     find the matrix to convert fractional to Cartesian
c
      call frac_to_cart (ftc)
c
c     apply the transformation to get the Cartesian potential
c
      do ii = 1, npole
         i = ipole(ii)
         cphi(1,i) = ftc(1,1) * fphi(1,i)
         do j = 2, 4
            cphi(j,i) = 0.0d0
            do k = 2, 4
               cphi(j,i) = cphi(j,i) + ftc(j,k)*fphi(k,i)
            end do
         end do
         do j = 5, 10
            cphi(j,i) = 0.0d0
            do k = 5, 10
               cphi(j,i) = cphi(j,i) + ftc(j,k)*fphi(k,i)
            end do
         end do
      end do
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine frac_to_cart  --  fractional to Cartesian  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "frac_to_cart" computes a transformation matrix to convert
c     a multipole object in fraction coordinates to Cartesian
c
c     note the multipole components are stored in the condensed
c     order (m,dx,dy,dz,qxx,qyy,qzz,qxy,qxz,qyz)
c
c
      subroutine frac_to_cart (ftc)
      use boxes
      use pme
      implicit none
      integer i,j,k,m
      integer i1,i2
      integer qi1(6)
      integer qi2(6)
      real*8 a(3,3)
      real*8 ftc(10,10)
      data qi1  / 1, 2, 3, 1, 1, 2 /
      data qi2  / 1, 2, 3, 2, 3, 3 /
c
c
c     set the reciprocal vector transformation matrix
c
      do i = 1, 3
         a(i,1) = dble(nfft1) * recip(i,1)
         a(i,2) = dble(nfft2) * recip(i,2)
         a(i,3) = dble(nfft3) * recip(i,3)
      end do
c
c     get the fractional to Cartesian conversion matrix
c
      do i = 1, 10
         do j = 1, 10
            ftc(j,i) = 0.0d0
         end do
      end do
      ftc(1,1) = 1.0d0
      do i = 2, 4
         do j = 2, 4
            ftc(i,j) = a(i-1,j-1)
         end do
      end do
      do i1 = 1, 3
         k = qi1(i1)
         do i2 = 1, 3
            i = qi1(i2)
            ftc(i1+4,i2+4) = a(k,i) * a(k,i)
         end do
         do i2 = 4, 6
            i = qi1(i2)
            j = qi2(i2)
            ftc(i1+4,i2+4) = 2.0d0 * a(k,i) * a(k,j)
         end do
      end do
      do i1 = 4, 6
         k = qi1(i1)
         m = qi2(i1)
         do i2 = 1, 3
            i = qi1(i2)
            ftc(i1+4,i2+4) = a(k,i) * a(m,i)
         end do
         do i2 = 4, 6
            i = qi1(i2)
            j = qi2(i2)
            ftc(i1+4,i2+4) = a(k,i)*a(m,j) + a(m,i)*a(k,j)
         end do
      end do
      return
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2006 by Michael Schnieders & Jay W. Ponder  ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  routines below implement dummy versions of the APBS   ##
c     ##  calls required for Tinker to interface with the APBS  ##
c     ##  Poisson-Boltzmann solver package from Nathan Baker    ##
c     ##                                                        ##
c     ############################################################
c
c     ##############################
c     ##                          ##
c     ##  subroutine apbsinitial  ##
c     ##                          ##
c     ##############################
c
c
      subroutine apbsinitial (dime,grid,gcent,cgrid,cgcent,fgrid,
     &                        fgcent,pdie,sdie,srad,swin,sdens,
     &                        kelvin,ionn,ionc,ionq,ionr,pbtyp,
     &                        pbtyplen,pbsoln,pbsolnlen,bcfl,
     &                        bcfllen,chgm,chgmlen,srfm,srfmlen)
      use iounit
      implicit none
      integer dime(*)
      integer ionn
      integer ionq(*)
      integer pbtyplen
      integer pbsolnlen
      integer bcfllen
      integer chgmlen
      integer srfmlen
      real*8 grid(*)
      real*8 gcent(*)
      real*8 cgrid(*)
      real*8 cgcent(*)
      real*8 fgrid(*)
      real*8 fgcent(*)
      real*8 pdie
      real*8 sdie
      real*8 srad
      real*8 swin
      real*8 sdens
      real*8 kelvin
      real*8 ionc(*)
      real*8 ionr(*)
      character*(*) pbtyp
      character*(*) pbsoln
      character*(*) bcfl
      character*(*) chgm
      character*(*) srfm
c
c
c     exit with an error message if APBS calculation is attempted
c
      write (iout,10)
   10 format (/,' APBSINITIAL  --  APBS Not Supported by This',
     &           ' Tinker Version')
      call fatal
      return
      end
c
c
c     #############################
c     ##                         ##
c     ##  subroutine apbsempole  ##
c     ##                         ##
c     #############################
c
c
      subroutine apbsempole (n,pos,rsolv,pbpole,pbe,apbe,pbep,pbfp,pbtp)
      implicit none
      integer n
      real*8 pos(*)
      real*8 rsolv(*)
      real*8 pbpole(*)
      real*8 pbe
      real*8 apbe(*)
      real*8 pbep(*)
      real*8 pbfp(*)
      real*8 pbtp(*)
      return
      end
c
c
c     #############################
c     ##                         ##
c     ##  subroutine apbsinduce  ##
c     ##                         ##
c     #############################
c
c
      subroutine apbsinduce (indpole,pbeuind)
      implicit none
      real*8 indpole(*)
      real*8 pbeuind(*)
      return
      end
c
c
c     ###############################
c     ##                           ##
c     ##  subroutine apbsnlinduce  ##
c     ##                           ##
c     ###############################
c
c
      subroutine apbsnlinduce (inppole,pbeuinp)
      implicit none
      real*8 inppole(*)
      real*8 pbeuinp(*)
      return
      end
c
c
c     ###################################
c     ##                               ##
c     ##  subroutine pbdirectpolforce  ##
c     ##                               ##
c     ###################################
c
c
      subroutine pbdirectpolforce (indpole,inppole,directf,directt)
      implicit none
      real*8 indpole(*)
      real*8 inppole(*)
      real*8 directf(*)
      real*8 directt(*)
      return
      end
c
c
c     ###################################
c     ##                               ##
c     ##  subroutine pbmutualpolforce  ##
c     ##                               ##
c     ###################################
c
c
      subroutine pbmutualpolforce (indpole,inppole,mutualf)
      implicit none
      real*8 indpole(*)
      real*8 inppole(*)
      real*8 mutualf(*)
      return
      end
c
c
c     ############################
c     ##                        ##
c     ##  subroutine apbsfinal  ##
c     ##                        ##
c     ############################
c
c
      subroutine apbsfinal
      implicit none
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module polar  --  polarization & induced dipole moments  ##        
c     ##                                                           ##
c     ###############################################################
c
c
c     npolar    total number of polarizable sites in the system
c     ipolar    number of the atom for each polarizable site
c     jpolar    index into polarization parameter matrix for each atom
c     polarity  dipole polarizability for each atom site (Ang**3)
c     thole     Thole polarization damping value for each atom
c     tholed    Thole direct polarization damping value for each atom
c     pdamp     value of polarizability scale factor for each atom
c     thlval    Thole damping parameter value for each atom type pair
c     thdval    alternate Thole direct damping value for atom type pair
c     udir      direct induced dipole components for each atom site
c     udirp     direct induced dipoles in field used for energy terms
c     udirs     direct GK or PB induced dipoles for each atom site
c     udirps    direct induced dipoles in field used for GK or PB energy
c     uind      mutual induced dipole components for each atom site
c     uinp      mutual induced dipoles in field used for energy terms
c     uinds     mutual GK or PB induced dipoles for each atom site
c     uinps     mutual induced dipoles in field used for GK or PB energy
c     uexact    exact SCF induced dipoles to full numerical precision
c     douind    flag to allow induced dipoles at each atom site
c
c
      module polar
      implicit none
      integer npolar
      integer, allocatable :: ipolar(:)
      integer, allocatable :: jpolar(:)
      real*8, allocatable :: polarity(:)
      real*8, allocatable :: thole(:)
      real*8, allocatable :: tholed(:)
      real*8, allocatable :: pdamp(:)
      real*8, allocatable :: thlval(:,:)
      real*8, allocatable :: thdval(:,:)
      real*8, allocatable :: udir(:,:)
      real*8, allocatable :: udirp(:,:)
      real*8, allocatable :: udirs(:,:)
      real*8, allocatable :: udirps(:,:)
      real*8, allocatable :: uind(:,:)
      real*8, allocatable :: uinp(:,:)
      real*8, allocatable :: uinds(:,:)
      real*8, allocatable :: uinps(:,:)
      real*8, allocatable :: uexact(:,:)
      logical, allocatable :: douind(:)
      save
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 2001 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  program polarize  --  compute the molecular polarizability  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "polarize" computes the molecular polarizability by applying
c     an external field along each axis followed by diagonalization
c     of the resulting polarizability tensor
c
c
      program polarize
      use atoms
      use inform
      use iounit
      use molcul
      use mpole
      use polar
      use polpot
      use potent
      implicit none
      integer i,ii
      real*8 addu,malpha
      real*8 external
      real*8 exfield(3)
      real*8 umol(3)
      real*8 umol0(3)
      real*8 dalpha(3)
      real*8 alpha(3,3)
      real*8 valpha(3,3)
      character*40 fstr
c
c
c     get the coordinates and required force field parameters
c
      call initial
      call getxyz
      call attach
      call field
      call cutoffs
      call katom
      call molecule
      call kmpole
      call kpolar
      call kchgtrn
      call mutate
c
c     sum atomic polarizabilities to get additive molecular value
c
      if (.not. use_polar) then
         write (iout,10)
   10    format (/,' POLARIZE  --  Dipole Polarizability',
     &              ' is Not in Use')
         call fatal
      end if
      addu = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         addu = polarity(i) + addu
      end do
      fstr = ' Additive Total Polarizability :    '
      if (nmol .eq. 1)  fstr = ' Additive Molecular Polarizability :'
      if (digits .ge. 8) then
         write (iout,20)  fstr(1:36),addu
   20    format (/,a36,f20.8)
      else if (digits .ge. 6) then
         write (iout,30)  fstr(1:36),addu
   30    format (/,a36,f18.6)
      else
         write (iout,40)  fstr(1:36),addu
   40    format (/,a36,f16.4)
      end if
c
c     find induced dipoles in absence of an external field
c
      do i = 1, 3
         exfield(i) = 0.0d0
      end do
      call moluind (exfield,umol0)
c
c     compute each column of the polarizability tensor
c
      external = 0.01d0
      exfield(1) = external
      exfield(2) = 0.0d0
      exfield(3) = 0.0d0
      call moluind (exfield,umol)
      alpha(1,1) = (umol(1)-umol0(1)) / exfield(1)
      alpha(2,1) = (umol(2)-umol0(2)) / exfield(1)
      alpha(3,1) = (umol(3)-umol0(3)) / exfield(1)
      exfield(1) = 0.0d0
      exfield(2) = external
      exfield(3) = 0.0d0
      call moluind (exfield,umol)
      alpha(1,2) = (umol(1)-umol0(1)) / exfield(2)
      alpha(2,2) = (umol(2)-umol0(2)) / exfield(2)
      alpha(3,2) = (umol(3)-umol0(3)) / exfield(2)
      exfield(1) = 0.0d0
      exfield(2) = 0.0d0
      exfield(3) = external
      call moluind (exfield,umol)
      alpha(1,3) = (umol(1)-umol0(1)) / exfield(3)
      alpha(2,3) = (umol(2)-umol0(2)) / exfield(3)
      alpha(3,3) = (umol(3)-umol0(3)) / exfield(3)
c
c     print out the full polarizability tensor
c
      fstr = ' Total Polarizability Tensor :    '
      if (nmol .eq. 1)  fstr = ' Molecular Polarizability Tensor :'
      write (iout,50)  fstr(1:34)
   50 format (/,a34,/)
      if (digits .ge. 8) then
         write (iout,60)  alpha(1,1),alpha(1,2),alpha(1,3),
     &                    alpha(2,1),alpha(2,2),alpha(2,3),
     &                    alpha(3,1),alpha(3,2),alpha(3,3)
   60    format (13x,3f17.8,/,13x,3f17.8,/,13x,3f17.8)
      else if (digits .ge. 6) then
         write (iout,70)  alpha(1,1),alpha(1,2),alpha(1,3),
     &                    alpha(2,1),alpha(2,2),alpha(2,3),
     &                    alpha(3,1),alpha(3,2),alpha(3,3)
   70    format (13x,3f15.6,/,13x,3f15.6,/,13x,3f15.6)
      else
         write (iout,80)  alpha(1,1),alpha(1,2),alpha(1,3),
     &                    alpha(2,1),alpha(2,2),alpha(2,3),
     &                    alpha(3,1),alpha(3,2),alpha(3,3)
   80    format (13x,3f13.4,/,13x,3f13.4,/,13x,3f13.4)
      end if
c
c     diagonalize the tensor and get molecular polarizability
c
      call jacobi (3,alpha,dalpha,valpha)
      fstr = ' Polarizability Tensor Eigenvalues :'
      write (iout,90)  fstr(1:36)
   90 format (/,a36,/)
      if (digits .ge. 8) then
         write (iout,100)  dalpha(1),dalpha(2),dalpha(3)
  100    format (13x,3f17.8)
      else if (digits .ge. 6) then
         write (iout,110)  dalpha(1),dalpha(2),dalpha(3)
  110    format (13x,3f15.6)
      else
         write (iout,120)  dalpha(1),dalpha(2),dalpha(3)
  120    format (13x,3f13.4)
      end if
      malpha = (dalpha(1)+dalpha(2)+dalpha(3)) / 3.0d0
      fstr = ' Interactive Total Polarizability :    '
      if (nmol .eq. 1)  fstr = ' Interactive Molecular Polarizability :'
      if (digits .ge. 8) then
         write (iout,130)  fstr(1:39),malpha
  130    format (/,a39,f17.8)
      else if (digits .ge. 6) then
         write (iout,140)  fstr(1:39),malpha
  140    format (/,a39,f15.6)
      else
         write (iout,150)  fstr(1:39),malpha
  150    format (/,a39,f13.4)
      end if
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine moluind  --  molecular induced dipole in field  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "moluind" computes the molecular induced dipole components
c     in the presence of an external electric field
c
c
      subroutine moluind (exfield,umol)
      use atoms
      use inform
      use iounit
      use mpole
      use polar
      use polopt
      use polpcg
      use polpot
      use units
      implicit none
      integer i,j,k
      integer ii,iter
      integer maxiter
      real*8 eps,epsold
      real*8 polmin
      real*8 a,b,sum,term
      real*8 norm,exmax
      real*8 umol(3)
      real*8 exfield(3)
      real*8, allocatable :: poli(:)
      real*8, allocatable :: field(:,:)
      real*8, allocatable :: fieldp(:,:)
      real*8, allocatable :: rsd(:,:)
      real*8, allocatable :: zrsd(:,:)
      real*8, allocatable :: conj(:,:)
      real*8, allocatable :: vec(:,:)
      real*8, allocatable :: usum(:,:)
      logical header,done
      logical dodfield
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (poli(n))
      allocate (field(3,n))
      allocate (fieldp(3,n))
      allocate (rsd(3,n))
      allocate (zrsd(3,n))
      allocate (conj(3,n))
      allocate (vec(3,n))
c
c     check for chiral multipoles and rotate to global frame
c
      call chkpole
      call rotpole ('MPOLE')
c
c     zero out the value of the field at each site
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            field(j,i) = 0.0d0
            fieldp(j,i) = 0.0d0
         end do
      end do
c
c     get the electrostatic field due to permanent multipoles
c
      dodfield = .true.
      if (dodfield)  call dfield0a (field,fieldp)
c
c     set induced dipoles to polarizability times direct field
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            udir(j,i) = polarity(i) * field(j,i)
         end do
      end do
c
c     increment induced dipoles to account for external field
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            udir(j,i) = udir(j,i) + polarity(i)*exfield(j)
            uind(j,i) = udir(j,i)
         end do
      end do
c
c     get induced dipoles via the OPT extrapolation method
c
      if (poltyp .eq. 'OPT') then
         do ii = 1, npole
            i = ipole(ii)
            if (douind(i)) then
               do j = 1, 3
                  uopt(0,j,i) = udir(j,i)
               end do
            end if
         end do
         do k = 1, optorder
            optlevel = k - 1
            call ufield0a (field,fieldp)
            do ii = 1, npole
               i = ipole(ii)
               if (douind(i)) then
                  do j = 1, 3
                     uopt(k,j,i) = polarity(i) * field(j,i)
                     uind(j,i) = uopt(k,j,i)
                  end do
               end if
            end do
         end do
         allocate (usum(3,n))
         do ii = 1, npole
            i = ipole(ii)
            if (douind(i)) then
               do j = 1, 3
                  uind(j,i) = 0.0d0
                  usum(j,i) = 0.0d0
                  do k = 0, optorder
                     usum(j,i) = usum(j,i) + uopt(k,j,i)
                     uind(j,i) = uind(j,i) + copt(k)*usum(j,i)
                  end do
               end do
            end if
         end do
         deallocate (usum)
      end if
c
c     compute mutual induced dipole moments via CG algorithm
c
      if (poltyp .eq. 'MUTUAL') then
         done = .false.
         maxiter = 500
         iter = 0
         polmin = 0.00000001d0
         eps = 100.0d0
         call ufield0a (field,fieldp)
         do ii = 1, npole
            i = ipole(ii)
            poli(i) = max(polmin,polarity(i))
            do j = 1, 3
               rsd(j,i) = field(j,i)
               zrsd(j,i) = rsd(j,i) * poli(i)
               conj(j,i) = zrsd(j,i)
            end do
         end do
c
c     iterate the mutual induced dipoles and check convergence
c
         do while (.not. done)
            iter = iter + 1
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  vec(j,i) = uind(j,i)
                  uind(j,i) = conj(j,i)
               end do
            end do
            call ufield0a (field,fieldp)
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  uind(j,i) = vec(j,i)
                  vec(j,i) = conj(j,i)/poli(i) - field(j,i)
               end do
            end do
            a = 0.0d0
            sum = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  a = a + conj(j,i)*vec(j,i)
                  sum = sum + rsd(j,i)*zrsd(j,i)
               end do
            end do
            if (a .ne. 0.0d0)  a = sum / a
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  uind(j,i) = uind(j,i) + a*conj(j,i)
                  rsd(j,i) = rsd(j,i) - a*vec(j,i)
               end do
            end do
            b = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  zrsd(j,i) = rsd(j,i) * poli(i)
                  b = b + rsd(j,i)*zrsd(j,i)
               end do
            end do
            if (sum .ne. 0.0d0)  b = b / sum
            eps = 0.0d0
            do ii = 1, npole
               i = ipole(ii)
               do j = 1, 3
                  conj(j,i) = zrsd(j,i) + b*conj(j,i)
                  eps = eps + rsd(j,i)*rsd(j,i)
               end do
            end do
            eps = debye * sqrt(eps/dble(npolar))
            epsold = eps
            if (debug) then
               if (iter .eq. 1) then
                  write (iout,10)
   10             format (/,' Determination of Induced Dipole',
     &                       ' Moments :',
     &                    //,4x,'Iter',8x,'RMS Change (Debye)',/)
               end if
               write (iout,20)  iter,eps
   20          format (i8,7x,f16.10)
            end if
            if (eps .lt. poleps)  done = .true.
            if (eps .gt. epsold)  done = .true.
            if (iter .ge. politer)  done = .true.
c
c     apply a "peek" iteration to the mutual induced dipoles
c
            if (done) then
               do ii = 1, npole
                  i = ipole(ii)
                  if (douind(i)) then
                     term = pcgpeek * poli(i)
                     do j = 1, 3
                        uind(j,i) = uind(j,i) + term*rsd(j,i)
                     end do
                  end if
               end do
            end if
         end do
c
c     print a warning if induced dipoles failed to converge
c
         if (iter.ge.maxiter .or. eps.gt.epsold) then
            write (iout,30)
   30       format (/,' MOLUIND  --  Warning, Induced Dipoles',
     &                 ' are not Converged')
            call fatal
         end if
      end if
c
c     sum up the total molecular induced dipole components
c
      do j = 1, 3
         umol(j) = 0.0d0
      end do
      do ii = 1, npole
         i = ipole(ii)
         umol(1) = umol(1) + uind(1,i)
         umol(2) = umol(2) + uind(2,i)
         umol(3) = umol(3) + uind(3,i)
      end do
c
c     print out a list of the final induced dipole moments
c
      if (verbose) then
         exmax = max(exfield(1),exfield(2),exfield(3))
         if (dodfield .or. exmax.ne.0.0d0) then
            write (iout,40)  (exfield(j),j=1,3)
   40       format (/,' Applied External Field :',//,13x,3f13.4)
            header = .true.
            do ii = 1, npole
               i = ipole(ii)
               if (polarity(i) .ne. 0.0d0) then
                  if (header) then
                     header = .false.
                     write (iout,50)
   50                format (/,' Induced Dipole Moments (Debye) :')
                     write (iout,60)
   60                format (/,4x,'Atom',15x,'X',12x,'Y',12x,'Z',
     &                          11x,'Total',/)
                  end if
                  norm = sqrt(uind(1,i)**2+uind(2,i)**2+uind(3,i)**2)
                  write (iout,70)  i,(debye*uind(j,i),j=1,3),
     &                             debye*norm
   70             format (i8,5x,3f13.4,1x,f13.4)
               end if
            end do
         end if
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (poli)
      deallocate (field)
      deallocate (fieldp)
      deallocate (rsd)
      deallocate (zrsd)
      deallocate (conj)
      deallocate (vec)
      return
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2000 by P. Bagossi, P. Ren & Jay W. Ponder  ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  program poledit  --  manipulate atomic multipole values  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "poledit" provides for the modification and manipulation
c     of polarizable atomic multipole electrostatic models
c
c
      program poledit
      use iounit
      use potent
      implicit none
      integer nmode,mode
      integer idma,ichg,imbis
      integer freeunit
      logical exist,query
      character*240 string
c
c
c     get the desired type of coordinate file modification
c
      call initial
      nmode = 5
      mode = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  mode
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' The Tinker Multipole Editing Utility Can :',
     &           //,4x,'(1) Use Multipoles from Stone GDMA Output',
     &           /,4x,'(2) Use Multipoles from Multiwfn MBIS Output',
     &           /,4x,'(3) Perform Setup Without Multipole Values',
     &           /,4x,'(4) Alter Local Coordinate Frame Definitions',
     &           /,4x,'(5) Remove the Intramolecular Polarization')
         do while (mode.lt.1 .or. mode.gt.nmode)
            mode = 0
            write (iout,30)
   30       format (/,' Enter the Number of the Desired Choice :  ',$)
            read (input,40,err=50,end=50)  mode
   40       format (i10)
   50       continue
         end do
      end if
c
c     perform the desired multipole manipulation operation
c
      if (mode .eq. 1) then
         idma = freeunit ()
         use_mpole = .true.
         use_polar = .true.
         call readgdma (idma)
         call field
         call molsetup
         call setframe
         call rotframe
         call setpolar
         call setpgrp
         call alterpol
         call avgpole
         call prtpole
      else if (mode .eq. 2) then
         ichg = freeunit ()
         imbis = freeunit ()
         use_mpole = .true.
         use_polar = .true.
         call readmbis (ichg,imbis)
         call field
         call molsetup
         call setframe
         call rotframe
         call setpolar
         call setpgrp
         call alterpol
         call avgpole
         call prtpole
      else if (mode .eq. 3) then
         use_mpole = .true.
         use_polar = .true.
         call getxyz
         call attach
         call field
         call katom
         call kmpole
         call initpole
         call molsetup
         call setframe
         call rotframe
         call setpolar
         call setpgrp
         call alterpol
         call avgpole
         call prtpole
      else if (mode .eq. 4) then
         call getxyz
         call attach
         call field
         call katom
         call kmpole
         call kpolar
         call kchgtrn
         call fixframe
         call prtpole
      else if (mode .eq. 5) then
         call getxyz
         call attach
         call field
         call katom
         call kmpole
         call kpolar
         call kchgtrn
         call alterpol
         call avgpole
         call prtpole
      end if
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine initpole  --  initialize multipole parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "initpole" sets all atomic multipole parameter values to an
c     initial value of zero
c
c
      subroutine initpole
      use atoms
      use mpole
      integer i
c
c
c     zero out atomic multipole parameter values
c
      do i = 1, n
         ipole(i) = 0
         zaxis(i) = 0
         xaxis(i) = 0
         yaxis(i) = 0
         do j = 1, 13
            pole(j,i) = 0.0d0
            rpole(j,i) = 0.0d0
            mono0(i) = 0.0d0
         end do
         polaxe(i) = '        '
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine molsetup  --  set molecule for polarization  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "molsetup" generates trial parameters needed to perform
c     polarizable multipole calculations on a structure read
c     from distributed multipole analysis output
c
c
      subroutine molsetup
      use atomid
      use atoms
      use couple
      use files
      use kpolr
      use mpole
      use polar
      use ptable
      implicit none
      integer i,j
      integer atn,size
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 ri,rij,dij
      real*8, allocatable :: rad(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (rad(n))
c
c     set base atomic radii from covalent radius values
c
      do i = 1, n
         rad(i) = 0.76d0
         atn = atomic(i)
         if (atn .ne. 0)  rad(i) = covrad(atn)
         if (atn .eq. 1) then
            rad(i) = 1.25d0 * rad(i)
         else if (atn .eq. 9) then
            rad(i) = 1.25d0 * rad(i)
         else
            rad(i) = 1.15d0 * rad(i)
         end if
      end do
c
c     assign atom connectivities based on interatomic distances
c
      do i = 1, n
         n12(i) = 0
         do j = 1, maxval
            i12(j,i) = 0
         end do
      end do
      do i = 1, n-1
         xi = x(i)
         yi = y(i)
         zi = z(i)
         ri = rad(i)
         do j = i+1, n
            xr = x(j) - xi
            yr = y(j) - yi
            zr = z(j) - zi
            rij = ri + rad(j)
            dij = sqrt(xr*xr + yr*yr + zr*zr)
            if (dij .lt. rij) then
               n12(i) = n12(i) + 1
               i12(n12(i),i) = j
               n12(j) = n12(j) + 1
               i12(n12(j),j) = i
            end if
         end do
      end do
      do i = 1, n
         call sort (n12(i),i12(1,i))
      end do
c
c     find the bonds, angles, torsions and small rings
c
      call attach
      call bonds
      call angles
      call torsions
      call bitors
      call rings
c
c     perform deallocation of some local arrays
c
      deallocate (rad)
c
c     assign unique atom types and set the valence values
c
      size = min(24,leng)
      do i = 1, n
         type(i) = i
         class(i) = i
         valnum(i) = n12(i)
         story(i) = filename(1:size)
      end do
c
c     assign the standard atomic weight by atomic number
c
      do i = 1, n
         mass(i) = 1.0d0
         atn = atomic(i)
         if (atn .ne. 0)  mass(i) = atmass(atn)
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(ipole))  allocate (ipole(n))
      if (.not. allocated(polsiz))  allocate (polsiz(n))
      if (.not. allocated(pollist))  allocate (pollist(n))
c
c     set atomic multipole sites and polarizability indices
c
      npole = n
      npolar = n
      do i = 1, n
         ipole(i) = i
         polsiz(i) = 13
         pollist(i) = i
      end do
c
c     zero out polarization group membership by atom type
c
      do i = 1, maxtyp
         do j = 1, maxval
            pgrp(j,i) = 0
         end do
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine setframe  --  define local coordinate frames  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "setframe" assigns a local coordinate frame at each atomic
c     multipole site using high priority connected atoms along axes
c
c
      subroutine setframe
      use atomid
      use atoms
      use couple
      use iounit
      use mpole
      implicit none
      integer i,j,m,ii
      integer ia,ib,ic,id
      integer ka,kb,kc,ki
      integer mab,mac,mbc
      integer mad,mbd,mcd
      integer mabc,mabd
      integer macd,mbcd
      integer priority
      real*8 geometry
      logical exist,query
      logical change
      logical noinvert
      logical planar
      logical pyramid
      logical chkarom
      character*240 record
      character*240 string
      external chkarom
c
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(zaxis))  allocate (zaxis(n))
      if (.not. allocated(xaxis))  allocate (xaxis(n))
      if (.not. allocated(yaxis))  allocate (yaxis(n))
      if (.not. allocated(polaxe))  allocate (polaxe(n))
c
c     initialize the local frame type and defining atoms
c
      do i = 1, n
         polaxe(i) = 'None'
         zaxis(i) = 0
         xaxis(i) = 0
         yaxis(i) = 0
      end do
c
c     set true if pyramidal trivalent nitrogen cannot invert
c
      noinvert = .true.
c
c     assign the local frame definition for an isolated atom
c
      do ii = 1, npole
         i = ipole(ii)
         j = n12(i)
         if (j .eq. 0) then
            polaxe(i) = 'None'
            zaxis(i) = 0
            xaxis(i) = 0
            yaxis(i) = 0
c
c     assign the local frame definition for a monovalent atom
c
         else if (j .eq. 1) then
            ia = i12(1,i)
            polaxe(i) = 'Z-Only'
            zaxis(i) = ia
            xaxis(i) = 0
            yaxis(i) = 0
            call frame13 (i,ia,noinvert)
c
c     assign the local frame definition for a divalent atom
c
         else if (j .eq. 2) then
            ia = i12(1,i)
            ib = i12(2,i)
            ki = atomic(i)
            yaxis(i) = 0
            m = priority (i,ia,ib,0)
            if (ki .eq. 6) then
               polaxe(i) = 'Z-Only'
               zaxis(i) = m
               if (m .eq. 0)  zaxis(i) = ia
               xaxis(i) = 0
            else if (m .eq. ia) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = ia
               xaxis(i) = ib
            else if (m .eq. ib) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = ib
               xaxis(i) = ia
            else
               polaxe(i) = 'Bisector'
               zaxis(i) = ia
               xaxis(i) = ib
            end if
c
c     assign the local frame definition for a trivalent atom
c
         else if (j .eq. 3) then
            ia = i12(1,i)
            ib = i12(2,i)
            ic = i12(3,i)
            ki = atomic(i)
            ka = atomic(ia)
            kb = atomic(ib)
            kc = atomic(ic)
            mab = priority (i,ia,ib,0)
            mac = priority (i,ia,ic,0)
            mbc = priority (i,ib,ic,0)
            mabc = priority (i,ia,ib,ic)
            planar = (abs(geometry(ic,i,ia,ib)) .gt. 170.0d0)
            pyramid = (abs(geometry(ic,i,ia,ib)) .lt. 135.0d0)
            if (ki .eq. 7) then
               if (chkarom(i))  pyramid = .false.
               if (chkarom(ia))  pyramid = .false.
               if (chkarom(ib))  pyramid = .false.
               if (chkarom(ic))  pyramid = .false.
            end if
            pyramid = (pyramid .and. noinvert)
            if (mabc .eq. 0) then
               polaxe(i) = 'None'
               zaxis(i) = 0
               xaxis(i) = 0
               yaxis(i) = 0
               if (ki.eq.7 .and. pyramid) then
                  polaxe(i) = '3-Fold'
                  zaxis(i) = ia
                  xaxis(i) = ib
                  yaxis(i) = ic
               else if (ki.eq.15 .or. ki.eq.16) then
                  polaxe(i) = '3-Fold'
                  zaxis(i) = ia
                  xaxis(i) = ib
                  yaxis(i) = ic
               end if
            else if (mab.eq.0 .and. (planar.or.kb.ge.kc)) then
               polaxe(i) = 'Bisector'
               zaxis(i) = ia
               xaxis(i) = ib
               yaxis(i) = 0
               if (ki.eq.7 .and. pyramid) then
                  polaxe(i) = 'Z-Bisect'
                  zaxis(i) = ic
                  xaxis(i) = ia
                  yaxis(i) = ib
               else if (ki.eq.15 .or. ki.eq.16) then
                  polaxe(i) = 'Z-Bisect'
                  zaxis(i) = ic
                  xaxis(i) = ia
                  yaxis(i) = ib
               end if
            else if (mac.eq.0 .and. (planar.or.ka.ge.kb)) then
               polaxe(i) = 'Bisector'
               zaxis(i) = ia
               xaxis(i) = ic
               yaxis(i) = 0
               if (ki.eq.7 .and. pyramid) then
                  polaxe(i) = 'Z-Bisect'
                  zaxis(i) = ib
                  xaxis(i) = ia
                  yaxis(i) = ic
               else if (ki.eq.15 .or. ki.eq.16) then
                  polaxe(i) = 'Z-Bisect'
                  zaxis(i) = ib
                  xaxis(i) = ia
                  yaxis(i) = ic
               end if
            else if (mbc.eq.0 .and. (planar.or.kc.ge.ka)) then
               polaxe(i) = 'Bisector'
               zaxis(i) = ib
               xaxis(i) = ic
               yaxis(i) = 0
               if (ki.eq.7 .and. pyramid) then
                  polaxe(i) = 'Z-Bisect'
                  zaxis(i) = ia
                  xaxis(i) = ib
                  yaxis(i) = ic
               else if (ki.eq.15 .or. ki.eq.16) then
                  polaxe(i) = 'Z-Bisect'
                  zaxis(i) = ia
                  xaxis(i) = ib
                  yaxis(i) = ic
               end if
            else if (mabc .eq. ia) then
               polaxe(i) = 'Z-Only'
               zaxis(i) = ia
               xaxis(i) = 0
               yaxis(i) = 0
               if (ki.eq.7 .and. pyramid) then
                  polaxe(i) = 'Z-Bisect'
                  xaxis(i) = ib
                  yaxis(i) = ic
               else if (ki.eq.15 .or. ki.eq.16) then
                  polaxe(i) = 'Z-Bisect'
                  xaxis(i) = ib
                  yaxis(i) = ic
               else if (mbc .eq. ib) then
                  polaxe(i) = 'Z-then-X'
                  xaxis(i) = ib
               else if (mbc .eq. ic) then
                  polaxe(i) = 'Z-then-X'
                  xaxis(i) = ic
               else if (ki .eq. 6) then
                  polaxe(i) = 'Z-then-X'
                  xaxis(i) = ib
               else if (ki.eq.7 .and. .not.pyramid) then
                  polaxe(i) = 'Z-then-X'
                  xaxis(i) = ib
               else
                  call frame13 (i,ia,noinvert)
               end if
            else if (mabc .eq. ib) then
               polaxe(i) = 'Z-Only'
               zaxis(i) = ib
               xaxis(i) = 0
               yaxis(i) = 0
               if (ki.eq.7 .and. pyramid) then
                  polaxe(i) = 'Z-Bisect'
                  xaxis(i) = ia
                  yaxis(i) = ic
               else if (ki.eq.15 .or. ki.eq.16) then
                  polaxe(i) = 'Z-Bisect'
                  xaxis(i) = ia
                  yaxis(i) = ic
               else if (mac .eq. ia) then
                  polaxe(i) = 'Z-then-X'
                  xaxis(i) = ia
               else if (mac .eq. ic) then
                  polaxe(i) = 'Z-then-X'
                  xaxis(i) = ic
               else if (ki .eq. 6) then
                  polaxe(i) = 'Z-then-X'
                  xaxis(i) = ia
               else if (ki.eq.7 .and. .not.pyramid) then
                  polaxe(i) = 'Z-then-X'
                  xaxis(i) = ia
               else
                  call frame13 (i,ib,noinvert)
               end if
            else if (mabc .eq. ic) then
               polaxe(i) = 'Z-Only'
               zaxis(i) = ic
               xaxis(i) = 0
               yaxis(i) = 0
               if (ki.eq.7 .and. pyramid) then
                  polaxe(i) = 'Z-Bisect'
                  xaxis(i) = ia
                  yaxis(i) = ib
               else if (ki.eq.15 .or. ki.eq.16) then
                  polaxe(i) = 'Z-Bisect'
                  xaxis(i) = ia
                  yaxis(i) = ib
               else if (mab .eq. ia) then
                  polaxe(i) = 'Z-then-X'
                  xaxis(i) = ia
               else if (mab .eq. ib) then
                  polaxe(i) = 'Z-then-X'
                  xaxis(i) = ib
               else if (ki .eq. 6) then
                  polaxe(i) = 'Z-then-X'
                  xaxis(i) = ia
               else if (ki.eq.7 .and. .not.pyramid) then
                  polaxe(i) = 'Z-then-X'
                  xaxis(i) = ia
               else
                  call frame13 (i,ic,noinvert)
               end if
            end if
c
c     assign the local frame definition for a tetravalent atom
c
         else if (j .eq. 4) then
            ia = i12(1,i)
            ib = i12(2,i)
            ic = i12(3,i)
            id = i12(4,i)
            mab = priority (i,ia,ib,0)
            mac = priority (i,ia,ic,0)
            mbc = priority (i,ib,ic,0)
            mad = priority (i,ia,id,0)
            mbd = priority (i,ib,id,0)
            mcd = priority (i,ic,id,0)
            mabc = priority (i,ia,ib,ic)
            mabd = priority (i,ia,ib,id)
            macd = priority (i,ia,ic,id)
            mbcd = priority (i,ib,ic,id)
            if (mabc.eq.0 .and. mbcd.eq.0) then
               polaxe(i) = 'None'
               zaxis(i) = 0
               xaxis(i) = 0
               yaxis(i) = 0
            else if (mabc.eq.ia .and. mabd.eq.ia) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = ia
               yaxis(i) = 0
               if (mbcd .ne. 0) then
                  xaxis(i) = mbcd
               else
                  call frame13 (i,ia,noinvert)
               end if
            else if (mabc.eq.ib .and. mabd.eq.ib) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = ib
               yaxis(i) = 0
               if (macd .ne. 0) then
                  xaxis(i) = macd
               else
                  call frame13 (i,ib,noinvert)
               end if
            else if (mabc.eq.ia .and. macd.eq.ia) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = ia
               yaxis(i) = 0
               if (mbcd .ne. 0) then
                  xaxis(i) = mbcd
               else
                  call frame13 (i,ia,noinvert)
               end if
            else if (mabc.eq.ic .and. macd.eq.ic) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = ic
               yaxis(i) = 0
               if (mabd .ne. 0) then
                  xaxis(i) = mabd
               else
                  call frame13 (i,ic,noinvert)
               end if
            else if (mabc.eq.ib .and. mbcd.eq.ib) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = ib
               yaxis(i) = 0
               if (macd .ne. 0) then
                  xaxis(i) = macd
               else
                  call frame13 (i,ib,noinvert)
               end if
            else if (mabc.eq.ic .and. mbcd.eq.ic) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = ic
               yaxis(i) = 0
               if (mabd .ne. 0) then
                  xaxis(i) = mabd
               else
                  call frame13 (i,ic,noinvert)
               end if
            else if (mabd.eq.ia .and. macd.eq.ia) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = ia
               yaxis(i) = 0
               if (mbcd .ne. 0) then
                  xaxis(i) = mbcd
               else
                  call frame13 (i,ia,noinvert)
               end if
            else if (mabd.eq.id .and. macd.eq.id) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = id
               yaxis(i) = 0
               if (mabc .ne. 0) then
                  xaxis(i) = mabc
               else
                  call frame13 (i,id,noinvert)
               end if
            else if (mabd.eq.ib .and. mbcd.eq.ib) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = ib
               yaxis(i) = 0
               if (macd .ne. 0) then
                  xaxis(i) = macd
               else
                  call frame13 (i,ib,noinvert)
               end if
            else if (mabd.eq.id .and. mbcd.eq.id) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = id
               yaxis(i) = 0
               if (mabc .ne. 0) then
                  xaxis(i) = mabc
               else
                  call frame13 (i,id,noinvert)
               end if
            else if (macd.eq.ic .and. mbcd.eq.ic) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = ic
               yaxis(i) = 0
               if (mabd .ne. 0) then
                  xaxis(i) = mabd
               else
                  call frame13 (i,ic,noinvert)
               end if
            else if (macd.eq.id .and. mbcd.eq.id) then
               polaxe(i) = 'Z-then-X'
               zaxis(i) = id
               yaxis(i) = 0
               if (mabc .ne. 0) then
                  xaxis(i) = mabc
               else
                  call frame13 (i,id,noinvert)
               end if
            else if (mbcd .eq. 0) then
               polaxe(i) = 'Z-Only'
               zaxis(i) = ia
               xaxis(i) = 0
               yaxis(i) = 0
               call frame13 (i,ia,noinvert)
            else if (macd .eq. 0) then
               polaxe(i) = 'Z-Only'
               zaxis(i) = ib
               xaxis(i) = 0
               yaxis(i) = 0
               call frame13 (i,ib,noinvert)
            else if (mabd .eq. 0) then
               polaxe(i) = 'Z-Only'
               zaxis(i) = ic
               xaxis(i) = 0
               yaxis(i) = 0
               call frame13 (i,ic,noinvert)
            else if (mabc .eq. 0) then
               polaxe(i) = 'Z-Only'
               zaxis(i) = id
               xaxis(i) = 0
               yaxis(i) = 0
               call frame13 (i,id,noinvert)
            else if (mab.eq.0 .and. mcd.eq.0) then
               if (mac .eq. ia) then
                  polaxe(i) = 'Bisector'
                  zaxis(i) = ia
                  xaxis(i) = ib
                  yaxis(i) = 0
               else if (mac .eq. ic) then
                  polaxe(i) = 'Bisector'
                  zaxis(i) = ic
                  xaxis(i) = id
                  yaxis(i) = 0
               end if
            else if (mac.eq.0 .and. mbd.eq.0) then
               if (mab .eq. ia) then
                  polaxe(i) = 'Bisector'
                  zaxis(i) = ia
                  xaxis(i) = ic
                  yaxis(i) = 0
               else if (mab .eq. ib) then
                  polaxe(i) = 'Bisector'
                  zaxis(i) = ib
                  xaxis(i) = id
                  yaxis(i) = 0
               end if
            else if (mad.eq.0 .and. mbc.eq.0) then
               if (mab .eq. ia) then
                  polaxe(i) = 'Bisector'
                  zaxis(i) = ia
                  xaxis(i) = id
                  yaxis(i) = 0
               else if (mab .eq. ib) then
                  polaxe(i) = 'Bisector'
                  zaxis(i) = ib
                  xaxis(i) = ic
                  yaxis(i) = 0
               end if
            else if (mab .eq. 0) then
               polaxe(i) = 'Z-Bisect'
               zaxis(i) = mcd
               xaxis(i) = ia
               yaxis(i) = ib
            else if (mac .eq. 0) then
               polaxe(i) = 'Z-Bisect'
               zaxis(i) = mbd
               xaxis(i) = ia
               yaxis(i) = ic
            else if (mad .eq. 0) then
               polaxe(i) = 'Z-Bisect'
               zaxis(i) = mbc
               xaxis(i) = ia
               yaxis(i) = id
            else if (mbc .eq. 0) then
               polaxe(i) = 'Z-Bisect'
               zaxis(i) = mad
               xaxis(i) = ib
               yaxis(i) = ic
            else if (mbd .eq. 0) then
               polaxe(i) = 'Z-Bisect'
               zaxis(i) = mac
               xaxis(i) = ib
               yaxis(i) = id
            else if (mcd .eq. 0) then
               polaxe(i) = 'Z-Bisect'
               zaxis(i) = mab
               xaxis(i) = ic
               yaxis(i) = id
            end if
         end if
      end do
c
c     list the local frame definition for each multipole site
c
      write (iout,10)
   10 format (/,' Local Frame Definition for Multipole Sites :')
      write (iout,20)
   20 format (/,5x,'Atom',5x,'Name',6x,'Axis Type',5x,'Z Axis',
     &           2x,'X Axis',2x,'Y Axis',/)
      do ii = 1, npole
         i = ipole(ii)
         write (iout,30)  i,name(i),polaxe(i),zaxis(i),
     &                    xaxis(i),yaxis(i)
   30    format (i8,6x,a3,7x,a8,2x,3i8)
      end do
c
c     allow the user to manually alter local coordinate frames
c
      change = .false.
      query = .true.
      i = -1
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=40,end=40)  i
         if (i .eq. 0)  query = .false.
      end if
   40 continue
      do while (query)
         i = 0
         ia = 0
         ib = 0
         ic = 0
         write (iout,50)
   50    format (/,' Enter Altered Local Frame Definition',
     &              ' [<Enter>=Exit] :  ',$)
         read (input,60)  record
   60    format (a240)
         read (record,*,err=70,end=70)  i,ia,ib,ic
   70    continue
         if (i .eq. 0) then
            query = .false.
         else
            change = .true.
            if (ia .eq. 0)  polaxe(i)= 'None'
            if (ia.ne.0 .and. ib.eq.0)  polaxe(i) = 'Z-Only'
            if (ia.gt.0 .and. ib.gt.0)  polaxe(i) = 'Z-then-X'
            if (ia.lt.0 .or. ib.lt.0)  polaxe(i) = 'Bisector'
            if (ib.lt.0 .and. ic.lt.0)  polaxe(i) = 'Z-Bisect'
            if (max(ia,ib,ic) .lt. 0)  polaxe(i) = '3-Fold'
            zaxis(i) = abs(ia)
            xaxis(i) = abs(ib)
            yaxis(i) = abs(ic)
         end if
      end do
c
c     repeat local frame list if definitions were altered
c
      if (change) then
         write (iout,80)
   80    format (/,' Local Frame Definition for Multipole Sites :')
         write (iout,90)
   90    format (/,5x,'Atom',5x,'Name',6x,'Axis Type',5x,'Z Axis',
     &              2x,'X Axis',2x,'Y Axis',/)
         do ii = 1, npole
            i = ipole(ii)
            write (iout,100)  i,name(i),polaxe(i),zaxis(i),
     &                        xaxis(i),yaxis(i)
  100       format (i8,6x,a3,7x,a8,2x,3i8)
         end do
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine frame13  --  set local axis via 1-3 attachments  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "frame13" finds local coordinate frame defining atoms in cases
c     where the use of 1-3 connected atoms is required
c
c
      subroutine frame13 (i,ia,noinvert)
      use atomid
      use couple
      use mpole
      implicit none
      integer i,j,ia
      integer ib,ic,id
      integer ka,m
      integer priority
      real*8 geometry
      logical noinvert
      logical monoval
      logical pyramid
      logical chkarom
      external chkarom
c
c
c     initialize 1-2 and 1-3 connected atoms
c
      ib = 0
      ic = 0
      id = 0
      ka = atomic(ia)
      monoval = (n12(i) .eq. 1)
c
c     get atoms directly adjacent to the primary connected atom
c
      do j = 1, n12(ia)
         m = i12(j,ia)
         if (m .ne. i) then
            if (ib .eq. 0) then
               ib = m
            else if (ic .eq. 0) then
               ic = m
            else if (id .eq. 0) then
               id = m
            end if
         end if
      end do
c
c     case with no atoms attached 1-3 through primary connection
c
      if (n12(ia) .eq. 1) then
         polaxe(i) = 'Z-Only'
         zaxis(i) = ia
         xaxis(i) = 0
         yaxis(i) = 0
c
c     only one atom is attached 1-3 through primary connection
c
      else if (n12(ia) .eq. 2) then
         polaxe(i) = 'Z-then-X'
         zaxis(i) = ia
         xaxis(i) = ib
         yaxis(i) = 0
         if (ka .eq. 6) then
            polaxe(i) = 'Z-Only'
            xaxis(i) = 0
         end if
c
c     two atoms are attached 1-3 through primary connection
c
      else if (n12(ia) .eq. 3) then
         polaxe(i) = 'Z-Only'
         zaxis(i) = ia
         xaxis(i) = 0
         yaxis(i) = 0
         pyramid = (abs(geometry(i,ia,ib,ic)) .lt. 135.0d0)
         if (ka .eq. 7) then
            if (chkarom(i))  pyramid = .false.
            if (chkarom(ia))  pyramid = .false.
            if (chkarom(ib))  pyramid = .false.
            if (chkarom(ic))  pyramid = .false.
         end if
         pyramid = (pyramid .and. noinvert)
         m = priority (ia,ib,ic,0)
         if (ka.eq.7 .and. pyramid .and. monoval) then
            polaxe(i) = 'Z-Bisect'
            xaxis(i) = ib
            yaxis(i) = ic
         else if ((ka.eq.15.or.ka.eq.16) .and. monoval) then
            polaxe(i) = 'Z-Bisect'
            xaxis(i) = ib
            yaxis(i) = ic
         else if (m .ne. 0) then
            polaxe(i) = 'Z-then-X'
            xaxis(i) = m
         else if (ka .eq. 6) then
            polaxe(i) = 'Z-then-X'
            xaxis(i) = ib
         else if (ka.eq.7 .and. .not.pyramid) then
            polaxe(i) = 'Z-then-X'
            xaxis(i) = ib
         end if
c
c     three atoms are attached 1-3 through primary connection
c
      else if (n12(ia) .eq. 4) then
         polaxe(i) = 'Z-Only'
         zaxis(i) = ia
         xaxis(i) = 0
         yaxis(i) = 0
         m = priority (ia,ib,ic,id)
         if (m .ne. 0) then
            polaxe(i) = 'Z-then-X'
            xaxis(i) = m
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function priority  --  atom priority for axis assignment  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "priority" decides which of a set of connected atoms should
c     have highest priority in construction of a local coordinate
c     frame and returns its atom number; if all atoms are of equal
c     priority then zero is returned
c
c
      function priority (i,ia,ib,ic)
      use atomid
      use couple
      implicit none
      integer i,j
      integer nlink
      integer ia,ib,ic
      integer ja,jb,jc
      integer ka,kb,kc
      integer ma,mb,mc
      integer priority
c
c
c     get info on sites to consider for priority assignment
c
      priority = 0
      nlink = 0
      if (ia .gt. 0) then
         nlink = nlink + 1
         ja = n12(ia)
         ka = atomic(ia)
      end if
      if (ib .gt. 0) then
         nlink = nlink + 1
         jb = n12(ib)
         kb = atomic(ib)
      end if
      if (ic .gt. 0) then
         nlink = nlink + 1
         jc = n12(ic)
         kc = atomic(ic)
      end if
c
c     for only one linked atom, it has the highest priority
c
      if (nlink .eq. 1) then
         priority = ia
      end if
c
c     for two linked atoms, find the one with highest priority
c
      if (nlink .eq. 2) then
         if (ka .gt. kb) then
            priority = ia
         else if (kb .gt. ka) then
            priority = ib
         else
            if (ja .lt. jb) then
               priority = ia
            else if (jb .lt. ja) then
               priority = ib
            else
               ma = 0
               mb = 0
               do j = 1, ja
                  ma = ma + atomic(i12(j,ia))
                  mb = mb + atomic(i12(j,ib))
               end do
               if (ma .gt. mb) then
                  priority = ia
               else if (mb .gt. ma) then
                  priority = ib
               else
                  ma = 0
                  mb = 0
                  do j = 1, n13(ia)
                     ma = ma + atomic(i13(j,ia))
                  end do
                  do j = 1, n13(ib)
                     mb = mb + atomic(i13(j,ib))
                  end do
                  if (ma .gt. mb) then
                     priority = ia
                  else if (mb .gt. ma) then
                     priority = ib
                  else
                     ma = 0
                     mb = 0
                     do j = 1, n14(ia)
                        ma = ma + atomic(i14(j,ia))
                     end do
                     do j = 1, n14(ib)
                        mb = mb + atomic(i14(j,ib))
                     end do
                     if (ma .gt. mb) then
                        priority = ia
                     else if (mb .gt. ma) then
                        priority = ib
                     else
                        ma = 0
                        mb = 0
                        do j = 1, n15(ia)
                           ma = ma + atomic(i15(j,ia))
                        end do
                        do j = 1, n15(ib)
                           mb = mb + atomic(i15(j,ib))
                        end do
                        if (ma .gt. mb) then
                           priority = ia
                        else if (mb .gt. ma) then
                           priority = ib
                        else
                           priority = 0
                        end if
                     end if
                  end if
               end if
            end if
         end if
      end if
c
c     for three linked atoms, find the one with highest priority
c
      if (nlink .eq. 3) then
         if (ka.gt.kb .and. ka.gt.kc) then
            priority = ia
         else if (kb.gt.ka .and. kb.gt.kc) then
            priority = ib
         else if (kc.gt.ka .and. kc.gt.kb) then
            priority = ic
         else if (ka.eq.kb .and. kc.lt.ka) then
            if (ja .lt. jb) then
               priority = ia
            else if (jb .lt. ja) then
               priority = ib
            else
               ma = 0
               mb = 0
               do j = 1, ja
                  ma = ma + atomic(i12(j,ia))
                  mb = mb + atomic(i12(j,ib))
               end do
               if (ma .gt. mb) then
                  priority = ia
               else if (mb .gt. ma) then
                  priority = ib
               else
                  ma = 0
                  mb = 0
                  do j = 1, n13(ia)
                     ma = ma + atomic(i13(j,ia))
                  end do
                  do j = 1, n13(ib)
                     mb = mb + atomic(i13(j,ib))
                  end do
                  if (ma .gt. mb) then
                     priority = ia
                  else if (mb .gt. ma) then
                     priority = ib
                  else
                     ma = 0
                     mb = 0
                     do j = 1, n14(ia)
                        ma = ma + atomic(i14(j,ia))
                     end do
                     do j = 1, n14(ib)
                        mb = mb + atomic(i14(j,ib))
                     end do
                     if (ma .gt. mb) then
                        priority = ia
                     else if (mb .gt. ma) then
                        priority = ib
                     else
                        ma = 0
                        mb = 0
                        do j = 1, n15(ia)
                           ma = ma + atomic(i15(j,ia))
                        end do
                        do j = 1, n15(ib)
                           mb = mb + atomic(i15(j,ib))
                        end do
                        if (ma .gt. mb) then
                           priority = ia
                        else if (mb .gt. ma) then
                           priority = ib
                        else
                           priority = ic
                        end if
                     end if
                  end if
               end if
            end if
         else if (ka.eq.kc .and. kb.lt.kc) then
            if (ja .lt. jc) then
               priority = ia
            else if (jc .lt. ja) then
               priority = ic
            else
               ma = 0
               mc = 0
               do j = 1, ja
                  ma = ma + atomic(i12(j,ia))
                  mc = mc + atomic(i12(j,ic))
               end do
               if (ma .gt. mc) then
                  priority = ia
               else if (mc .gt. ma) then
                  priority = ic
               else
                  ma = 0
                  mc = 0
                  do j = 1, n13(ia)
                     ma = ma + atomic(i13(j,ia))
                  end do
                  do j = 1, n13(ic)
                     mc = mc + atomic(i13(j,ic))
                  end do
                  if (ma .gt. mc) then
                     priority = ia
                  else if (mc .gt. ma) then
                     priority = ic
                  else
                     ma = 0
                     mc = 0
                     do j = 1, n14(ia)
                        ma = ma + atomic(i14(j,ia))
                     end do
                     do j = 1, n14(ic)
                        mc = mc + atomic(i14(j,ic))
                     end do
                     if (ma .gt. mc) then
                        priority = ia
                     else if (mc .gt. ma) then
                        priority = ic
                     else
                        ma = 0
                        mc = 0
                        do j = 1, n15(ia)
                           ma = ma + atomic(i15(j,ia))
                        end do
                        do j = 1, n15(ic)
                           mc = mc + atomic(i15(j,ic))
                        end do
                        if (ma .gt. mc) then
                           priority = ia
                        else if (mc .gt. ma) then
                           priority = ic
                        else
                           priority = ib
                        end if
                     end if
                  end if
               end if
            end if
         else if (kb.eq.kc .and. ka.lt.kb) then
            if (jb .lt. jc) then
               priority = ib
            else if (jc .lt. jb) then
               priority = ic
            else
               mb = 0
               mc = 0
               do j = 1, jb
                  mb = mb + atomic(i12(j,ib))
                  mc = mc + atomic(i12(j,ic))
               end do
               if (mb .gt. mc) then
                  priority = ib
               else if (mc .gt. mb) then
                  priority = ic
               else
                  mb = 0
                  mc = 0
                  do j = 1, n13(ib)
                     mb = mb + atomic(i13(j,ib))
                  end do
                  do j = 1, n13(ic)
                     mc = mc + atomic(i13(j,ic))
                  end do
                  if (mb .gt. mc) then
                     priority = ia
                  else if (mc .gt. mb) then
                     priority = ic
                  else
                     mb = 0
                     mc = 0
                     do j = 1, n14(ib)
                        mb = mb + atomic(i14(j,ib))
                     end do
                     do j = 1, n14(ic)
                        mc = mc + atomic(i14(j,ic))
                     end do
                     if (mb .gt. mc) then
                        priority = ia
                     else if (mc .gt. mb) then
                        priority = ic
                     else
                        mb = 0
                        mc = 0
                        do j = 1, n15(ib)
                           mb = mb + atomic(i15(j,ib))
                        end do
                        do j = 1, n15(ic)
                           mc = mc + atomic(i15(j,ic))
                        end do
                        if (mb .gt. mc) then
                           priority = ia
                        else if (mc .gt. mb) then
                           priority = ic
                        else
                           priority = ia
                        end if
                     end if
                  end if
               end if
            end if
         else
            if (ja.gt.jb.and.ja.gt.jc) then
               priority = ia
            else if (jb.gt.ja .and. jb.gt.jc) then
               priority = ib
            else if (jc.gt.ja .and. jc.gt.jb) then
               priority = ic
            else if (ja.lt.jb .and. ja.lt.jc) then
               priority = ia
            else if (jb.lt.ja .and. jb.lt.jc) then
               priority = ib
            else if (jc.lt.ja .and. jc.lt.jb) then
               priority = ic
            else
               ma = 0
               mb = 0
               mc = 0
               do j = 1, ja
                  ma = ma + atomic(i12(j,ia))
                  mb = mb + atomic(i12(j,ib))
                  mc = mc + atomic(i12(j,ic))
               end do
               if (ma.gt.mb .and. ma.gt.mc) then
                  priority = ia
               else if (mb.gt.ma .and. mb.gt.mc) then
                  priority = ib
               else if (mc.gt.ma .and. mc.gt.mb) then
                  priority = ic
               else if (ma.lt.mb .and. ma.lt.mc) then
                  priority = ia
               else if (mb.lt.ma .and. mb.lt.mc) then
                  priority = ib
               else if (mc.lt.ma .and. mc.lt.mb) then
                  priority = ic
               else
                  ma = 0
                  mb = 0
                  mc = 0
                  do j = 1, n13(ia)
                     ma = ma + atomic(i13(j,ia))
                  end do
                  do j = 1, n13(ib)
                     mb = mb + atomic(i13(j,ib))
                  end do
                  do j = 1, n13(ic)
                     mc = mc + atomic(i13(j,ic))
                  end do
                  if (ma.gt.mb .and. ma.gt.mc) then
                     priority = ia
                  else if (mb.gt.ma .and. mb.gt.mc) then
                     priority = ib
                  else if (mc.gt.ma .and. mc.gt.mb) then
                     priority = ic
                  else if (ma.lt.mb .and. ma.lt.mc) then
                     priority = ia
                  else if (mb.lt.ma .and. mb.lt.mc) then
                     priority = ib
                  else if (mc.lt.ma .and. mc.lt.mb) then
                     priority = ic
                  else
                     ma = 0
                     mb = 0
                     mc = 0
                     do j = 1, n14(ia)
                        ma = ma + atomic(i14(j,ia))
                     end do
                     do j = 1, n14(ib)
                        mb = mb + atomic(i14(j,ib))
                     end do
                     do j = 1, n14(ic)
                        mc = mc + atomic(i14(j,ic))
                     end do
                     if (ma.gt.mb .and. ma.gt.mc) then
                        priority = ia
                     else if (mb.gt.ma .and. mb.gt.mc) then
                        priority = ib
                     else if (mc.gt.ma .and. mc.gt.mb) then
                        priority = ic
                     else if (ma.lt.mb .and. ma.lt.mc) then
                        priority = ia
                     else if (mb.lt.ma .and. mb.lt.mc) then
                        priority = ib
                     else if (mc.lt.ma .and. mc.lt.mb) then
                        priority = ic
                     else
                        ma = 0
                        mb = 0
                        mc = 0
                        do j = 1, n15(ia)
                           ma = ma + atomic(i15(j,ia))
                        end do
                        do j = 1, n15(ib)
                           mb = mb + atomic(i15(j,ib))
                        end do
                        do j = 1, n15(ic)
                           mc = mc + atomic(i15(j,ic))
                        end do
                        if (ma.gt.mb .and. ma.gt.mc) then
                           priority = ia
                        else if (mb.gt.ma .and. mb.gt.mc) then
                           priority = ib
                        else if (mc.gt.ma .and. mc.gt.mb) then
                           priority = ic
                        else if (ma.lt.mb .and. ma.lt.mc) then
                           priority = ia
                        else if (mb.lt.ma .and. mb.lt.mc) then
                           priority = ib
                        else if (mc.lt.ma .and. mc.lt.mb) then
                           priority = ic
                        else
                           priority = 0
                        end if
                     end if
                  end if
               end if
            end if
         end if
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine rotframe  --  convert multipoles to local frame  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "rotframe" takes the global multipole moments and rotates them
c     into the local coordinate frame defined at each atomic site
c
c
      subroutine rotframe
      use atomid
      use atoms
      use inform
      use iounit
      use mpole
      use units
      implicit none
      integer i,j,ii
      integer ia,ib,ic,id
      integer xaxe,yaxe,zaxe
      real*8 xad,yad,zad
      real*8 xbd,ybd,zbd
      real*8 xcd,ycd,zcd
      real*8 c1,c2,c3,vol
      logical check
c
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(pole))  allocate (pole(maxpole,n))
      if (.not. allocated(rpole))  allocate (rpole(maxpole,n))
c
c     rotate the multipoles from global frame to local frame
c
      call rotrpole ('MPOLE')
c
c     check the sign of multipole components at chiral sites;
c     note "yaxis" sign is not flipped based on signed volume
c
      do ii = 1, npole
         check = .true.
         i = ipole(ii)
         if (polaxe(i) .ne. 'Z-then-X')  check = .false.
         if (yaxis(i) .eq. 0)  check = .false.
         if (check) then
            ia = i
            ib = zaxis(i)
            ic = xaxis(i)
            id = yaxis(i)
            xad = x(ia) - x(id)
            yad = y(ia) - y(id)
            zad = z(ia) - z(id)
            xbd = x(ib) - x(id)
            ybd = y(ib) - y(id)
            zbd = z(ib) - z(id)
            xcd = x(ic) - x(id)
            ycd = y(ic) - y(id)
            zcd = z(ic) - z(id)
            c1 = ybd*zcd - zbd*ycd
            c2 = ycd*zad - zcd*yad
            c3 = yad*zbd - zad*ybd
            vol = xad*c1 + xbd*c2 + xcd*c3
            if (vol .lt. 0.0d0) then
               pole(3,i) = -pole(3,i)
               pole(6,i) = -pole(6,i)
               pole(8,i) = -pole(8,i)
               pole(10,i) = -pole(10,i)
               pole(12,i) = -pole(12,i)
            end if
         end if
      end do
c
c     convert dipole and quadrupole moments back to atomic units
c
      do ii = 1, npole
         i = ipole(ii)
         rpole(1,i) = pole(1,i)
         do j = 2, 4
            rpole(j,i) = pole(j,i) / bohr
         end do
         do j = 5, 13
            rpole(j,i) = 3.0d0 * pole(j,i) / bohr**2
         end do
      end do
c
c     print the local frame Cartesian atomic multipoles
c
      if (verbose) then
         write (iout,10)
   10    format (/,' Local Frame Cartesian Multipole Moments :')
         do i = 1, n
            ii = pollist(i)
            if (ii .eq. 0) then
               write (iout,20)  i,name(i),atomic(i)
   20          format (/,' Atom:',i8,9x,'Name:',3x,a3,7x,
     &                    'Atomic Number:',i8)
               write (iout,30)
   30          format (/,' No Atomic Multipole Moments for this Site')
            else
               zaxe = zaxis(i)
               xaxe = xaxis(i)
               yaxe = yaxis(i)
               if (yaxe .lt. 0)  yaxe = -yaxe
               write (iout,40)  i,name(i),atomic(i)
   40          format (/,' Atom:',i8,9x,'Name:',3x,a3,
     &                    7x,'Atomic Number:',i8)
               write (iout,50)  polaxe(i),zaxe,xaxe,yaxe
   50          format (/,' Local Frame:',12x,a8,6x,3i8)
               write (iout,60)  rpole(1,i)
   60          format (/,' Charge:',10x,f15.5)
               write (iout,70)  rpole(2,i),rpole(3,i),rpole(4,i)
   70          format (' Dipole:',10x,3f15.5)
               write (iout,80)  rpole(5,i)
   80          format (' Quadrupole:',6x,f15.5)
               write (iout,90)  rpole(8,i),rpole(9,i)
   90          format (18x,2f15.5)
               write (iout,100)  rpole(11,i),rpole(12,i),rpole(13,i)
  100          format (18x,3f15.5)
            end if
         end do
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine fixframe  --  alter the local frame definition  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "fixframe" is a service routine that alters the local frame
c     definition for specified atoms
c
c
      subroutine fixframe
      use atomid
      use atoms
      use couple
      use files
      use keys
      use kpolr
      use iounit
      use mpole
      use polar
      use units
      implicit none
      integer i,j,k
      integer ii,kk
      integer ia,ib,ic
      integer xaxe
      integer yaxe
      integer zaxe
      real*8 eps,ci,ck
      real*8 big,sum
      logical query,change
      character*240 record
c
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     list the local frame definition for each multipole site
c
      write (iout,10)
   10 format (/,' Local Frame Definition for Multipole Sites :')
      write (iout,20)
   20 format (/,5x,'Atom',5x,'Name',6x,'Axis Type',5x,'Z Axis',2x,
     &          'X Axis',2x,'Y Axis',/)
      do i = 1, n
         ii = pollist(i)
         if (ii .eq. 0) then
            write (iout,30)  i,name(i)
   30       format (i8,6x,a3,10x,'--',11x,'--',6x,'--',6x,'--')
         else
            zaxe = zaxis(i)
            xaxe = xaxis(i)
            yaxe = yaxis(i)
            if (yaxe .lt. 0)  yaxe = -yaxe
            write (iout,40)  i,name(i),polaxe(i),zaxe,xaxe,yaxe
   40       format (i8,6x,a3,7x,a8,2x,3i8)
         end if
      end do
c
c     allow the user to manually alter local coordinate frames
c
      query = .true.
      change = .false.
      do while (query)
         i = 0
         ia = 0
         ib = 0
         ic = 0
         write (iout,50)
   50    format (/,' Enter Altered Local Frame Definition',
     &              ' [<Enter>=Exit] :  ',$)
         read (input,60)  record
   60    format (a240)
         read (record,*,err=70,end=70)  i,ia,ib,ic
   70    continue
         if (i .eq. 0) then
            query = .false.
         else
            change = .true.
            if (ia .eq. 0)  polaxe(i) = 'None'
            if (ia.ne.0 .and. ib.eq.0)  polaxe(i) = 'Z-Only'
            if (ia.gt.0 .and. ib.gt.0)  polaxe(i) = 'Z-then-X'
            if (ia.lt.0  .or. ib.lt.0)  polaxe(i) = 'Bisector'
            if (ib.lt.0 .and. ic.lt.0)  polaxe(i) = 'Z-Bisect'
            if (max(ia,ib,ic)  .lt. 0)  polaxe(i) = '3-Fold'
            zaxis(i) = abs(ia)
            xaxis(i) = abs(ib)
            yaxis(i) = abs(ic)
         end if
      end do
c
c     repeat local frame list if definitions were altered
c
      if (change) then
         write (iout,80)
   80    format (/,' Local Frame Definition for Multipole Sites :')
         write (iout,90)
   90    format (/,5x,'Atom',5x,'Name',6x,'Axis Type',5x,'Z Axis',2x,
     &             'X Axis',2x,'Y Axis',/)
         do ii = 1, npole
            i = ipole(ii)
            zaxe = zaxis(i)
            xaxe = xaxis(i)
            yaxe = yaxis(i)
            if (yaxe .lt. 0)  yaxe = -yaxe
            write (iout,100)  i,name(i),polaxe(i),zaxe,xaxe,yaxe
  100       format (i8,6x,a3,7x,a8,2x,3i8)
         end do
      end if
c
c     rotate the multipoles from global frame to local frame
c
      call rotrpole ('MPOLE')
c
c     check the sign of multipole components at chiral sites
c
      call chkpole
c
c     convert dipole and quadrupole moments back to atomic units
c
      do ii = 1, npole
         i = ipole(ii)
         pole(1,i) = pole(1,i)
         do j = 2, 4
            pole(j,i) = pole(j,i) / bohr
         end do
         do j = 5, 13
            pole(j,i) = 3.0d0 * pole(j,i) / bohr**2
         end do
      end do
c
c     regularize the multipole moments to desired precision
c
      eps = 0.00001d0
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 13
            pole(j,i) = dble(nint(pole(j,i)/eps)) * eps
         end do
      end do
c
c     enforce integer net charge over atomic multipoles
c
      j = 0
      big = 0.0d0
      sum = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         sum = sum + pole(1,i)
         ci = abs(pole(1,i))
         if (ci .gt. big) then
            do kk = 1, npole
               k = ipole(kk)
               ck = abs(pole(1,k))
               if (i.ne.k .and. ci.eq.ck)  goto 110
            end do
            j = i
            big = ci
  110       continue
         end if
      end do
      sum = sum - dble(nint(sum))
      if (j .ne. 0)  pole(1,j) = pole(1,j) - sum
c
c     enforce traceless quadrupole at each multipole site
c
      do ii = 1, npole
         i = ipole(ii)
         sum = pole(5,i) + pole(9,i) + pole(13,i)
         big = max(abs(pole(5,i)),abs(pole(9,i)),abs(pole(13,i)))
         k = 0
         if (big .eq. abs(pole(5,i)))  k = 5
         if (big .eq. abs(pole(9,i)))  k = 9
         if (big .eq. abs(pole(13,i)))  k = 13
         if (pole(9,i) .eq. pole(13,i))  k = 5
         if (pole(5,i) .eq. pole(13,i))  k = 9
         if (pole(5,i) .eq. pole(9,i))  k = 13
         if (k .ne. 0)  pole(k,i) = pole(k,i) - sum
      end do
c
c     print the altered local frame atomic multipole values
c
      write (iout,120)
  120 format (/,' Multipoles With Altered Local Frame Definition :')
      do i = 1, n
         ii = pollist(i)
         if (ii .eq. 0) then
            write (iout,130)  i,name(i),atomic(i)
  130       format (/,' Atom:',i8,9x,'Name:',3x,a3,7x,
     &                 'Atomic Number:',i8)
            write (iout,140)
  140       format (/,' No Atomic Multipole Moments for this Site')
         else
            zaxe = zaxis(i)
            xaxe = xaxis(i)
            yaxe = yaxis(i)
            if (yaxe .lt. 0)  yaxe = -yaxe
            write (iout,150)  i,name(i),atomic(i)
  150       format (/,' Atom:',i8,9x,'Name:',3x,a3,
     &                 7x,'Atomic Number:',i8)
            write (iout,160)  polaxe(i),zaxe,xaxe,yaxe
  160       format (/,' Local Frame:',12x,a8,6x,3i8)
            write (iout,170)  pole(1,i)
  170       format (/,' Charge:',10x,f15.5)
            write (iout,180)  pole(2,i),pole(3,i),pole(4,i)
  180       format (' Dipole:',10x,3f15.5)
            write (iout,190)  pole(5,i)
  190       format (' Quadrupole:',6x,f15.5)
            write (iout,200)  pole(8,i),pole(9,i)
  200       format (18x,2f15.5)
            write (iout,210)  pole(11,i),pole(12,i),pole(13,i)
  210       format (18x,3f15.5)
         end if
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine setpolar  --  define the polarization model  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "setpolar" assigns atomic polarizabilities, Thole damping or
c     charge penetration parameters, and allows user modification
c
c     note this routine contains directly coded scale factors, and
c     Thole and charge penetration values for atom types that should
c     be updated if the default force field values are modified
c
c
      subroutine setpolar
      use atomid
      use atoms
      use chgpen
      use couple
      use fields
      use iounit
      use mplpot
      use mpole
      use polar
      use polpot
      implicit none
      integer i,j,k,m
      integer ii,jj
      integer atn,next
      real*8 pol,thl,thld
      real*8 pel,pal
      real*8 sixth
      logical exist,query
      logical change
      logical aromatic
      logical chkarom
      character*1 answer
      character*240 record
      character*240 string
      external chkarom
c
c
c     allow the user to select the polarization model
c
      forcefield = 'AMOEBA'
      use_thole = .true.
      use_tholed = .false.
      use_chgpen = .false.
      dpequal = .false.
      query = .true.
      answer = ' '
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  answer
         call upcase (answer)
         if (answer.eq.'A' .or. answer .eq. 'P' .or.
     &          answer.eq.'H')  query = .false.
      end if
   10 continue
      if (query) then
         answer = 'A'
         write (iout,20)
   20    format (/,' Choose the AMOEBA, AMOEBA+ or HIPPO',
     &              ' Model ([A], P or H) : ', $)
         read (input,30)  record
   30    format (a240)
         next = 1
         call gettext (record,answer,next)
         call upcase (answer)
      end if
      if (answer .eq. 'P') then
         forcefield = 'APLUS'
         use_tholed = .true.
         use_thole = .false.
         dpequal = .true.
      else if (answer .eq. 'H') then
         forcefield = 'HIPPO'
         use_thole = .false.
         use_chgpen = .true.
         dpequal = .true.
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(polarity))  allocate (polarity(n))
      if (.not. allocated(thole))  allocate (thole(n))
      if (.not. allocated(tholed))  allocate (tholed(n))
      if (.not. allocated(pdamp))  allocate (pdamp(n))
      if (.not. allocated(pcore))  allocate (pcore(n))
      if (.not. allocated(pval))  allocate (pval(n))
      if (.not. allocated(palpha))  allocate (palpha(n))
c
c     zero out the polarization and charge penetration values
c
      do i = 1, n
         polarity(i) = 0.0d0
         thole(i) = 0.0d0
         tholed(i) = 0.0d0
         pdamp(i) = 0.0d0
         pcore(i) = 0.0d0
         pval(i) = 0.0d0
         palpha(i) = 0.0d0
      end do
c
c     set multipole and polarization scale factors for AMOEBA
c
      if (forcefield .eq. 'AMOEBA') then
         m2scale = 0.0d0
         m3scale = 0.0d0
         m4scale = 0.4d0
         m5scale = 0.8d0
         p2scale = 0.0d0
         p3scale = 0.0d0
         p4scale = 1.0d0
         p5scale = 1.0d0
         p2iscale = 0.0d0
         p3iscale = 0.0d0
         p4iscale = 0.5d0
         p5iscale = 1.0d0
         d1scale = 0.0d0
         d2scale = 1.0d0
         d3scale = 1.0d0
         d4scale = 1.0d0
         u1scale = 1.0d0
         u2scale = 1.0d0
         u3scale = 1.0d0
         u4scale = 1.0d0
      end if
c
c     set multipole and polarization scale factors for AMOEBA+ 
c
      if (forcefield .eq. 'APLUS') then
         m2scale = 0.0d0
         m3scale = 0.0d0
         m4scale = 0.5d0
         m5scale = 1.0d0
         p2scale = 0.0d0
         p3scale = 0.0d0
         p4scale = 0.5d0
         p5scale = 0.5d0
         p2iscale = 0.0d0
         p3iscale = 0.0d0
         p4iscale = 0.5d0
         p5iscale = 0.5d0
         d1scale = 0.0d0
         d2scale = 0.0d0
         d3scale = 0.5d0
         d4scale = 0.5d0
         u1scale = 1.0d0
         u2scale = 1.0d0
         u3scale = 1.0d0
         u4scale = 1.0d0
      end if
c
c     set multipole and polarization scale factors for HIPPO
c
      if (forcefield .eq. 'HIPPO') then
         m2scale = 0.0d0
         m3scale = 0.0d0
         m4scale = 0.4d0
         m5scale = 0.8d0
         p2scale = 0.0d0
         p3scale = 0.5d0
         p4scale = 1.0d0
         p5scale = 1.0d0
         p2iscale = 0.0d0
         p3iscale = 0.0d0
         p4iscale = 0.0d0
         p5iscale = 0.5d0
         d1scale = 0.0d0
         d2scale = 1.0d0
         d3scale = 1.0d0
         d4scale = 1.0d0
         u1scale = 1.0d0
         u2scale = 1.0d0
         u3scale = 1.0d0
         u4scale = 1.0d0
         w2scale = 0.2d0
         w3scale = 1.0d0
         w4scale = 1.0d0
         w5scale = 1.0d0
      end if
c
c     assign atomic polarizabilities for AMOEBA and AMOEBA+ model
c
      if (forcefield.eq.'AMOEBA' .or. forcefield.eq.'APLUS') then
         do i = 1, n
            thole(i) = 0.39d0
            if (forcefield .eq. 'APLUS')  tholed(i) = 0.70d0
            atn = atomic(i)
            if (atn .eq. 1) then
               polarity(i) = 0.496d0
            else if (atn .eq. 5) then
               polarity(i) = 1.600d0
            else if (atn .eq. 6) then
               polarity(i) = 1.334d0
            else if (atn .eq. 7) then
               polarity(i) = 1.073d0
            else if (atn .eq. 8) then
               polarity(i) = 0.837d0
            else if (atn .eq. 9) then
               polarity(i) = 0.507d0
            else if (atn .eq. 14) then
               polarity(i) = 3.640d0
            else if (atn .eq. 15) then
               polarity(i) = 1.828d0
            else if (atn .eq. 16) then
               polarity(i) = 3.300d0
            else if (atn .eq. 17) then
               polarity(i) = 2.500d0
            else if (atn .eq. 35) then
               polarity(i) = 3.595d0
            else if (atn .eq. 53) then
               polarity(i) = 5.705d0
            end if
         end do
c
c     alter polarizabilities for alkene/aromatic carbon and hydrogen
c
         do i = 1, n
            atn = atomic(i)
            if (atn .eq. 1) then
               j = i12(1,i)
               if (atomic(j).eq.6 .and. n12(j).eq.3) then
                  polarity(i) = 0.696d0
                  do k = 1, n12(j)
                     m = i12(k,j)
                     if (atomic(m).eq.8 .and. n12(m).eq.1) then
                        polarity(i) = 0.494d0
                     end if
                  end do
               end if
            else if (atn .eq. 6) then
               if (n12(i) .eq. 3) then
                  polarity(i) = 1.75d0
                  do j = 1, n12(i)
                     k = i12(j,i)
                     if (atomic(k).eq.8 .and. n12(k).eq.1) then
                        polarity(i) = 1.334d0
                     end if
                  end do
               end if
            end if
         end do
      end if
c
c     assign default atom-based parameters for HIPPO model
c
      if (forcefield .eq. 'HIPPO') then
         do i = 1, n
            atn = atomic(i)
            if (atn .eq. 1) then
               pcore(i) = 1.0d0
               polarity(i) = 0.373d0
               palpha(i) = 4.3225d0
               k = atomic(i12(1,i))
               if (k .eq. 6) then
                  do j = 1, n13(i)
                     m = atomic(i13(j,i))
                     if ((atomic(m).ne.6.or.n12(m).ne.4)
     &                     .and. atomic(m).ne.1)  goto 40
                  end do
                  do j = 1, n14(i)
                     m = i14(j,i)
                     if ((atomic(m).ne.6.or.n12(m).ne.4)
     &                     .and. atomic(m).ne.1)  goto 40
                  end do
                  polarity(i) = 0.504d0
                  palpha(i) = 4.9530d0
   40             continue
                  aromatic = chkarom (i)
                  if (aromatic) then
                     polarity(i) = 0.1106d0
                     palpha(i) = 4.9530d0
                  end if
               else if (k .eq. 7) then
                  polarity(i) = 0.005d0
                  palpha(i) = 5.5155d0
               else if (k .eq. 8) then
                  polarity(i) = 0.3698d0
                  palpha(i) = 4.7441d0
               else if (k .eq. 16) then
                  polarity(i) = 0.2093d0
                  palpha(i) = 4.3952d0
               end if
            else if (atn .eq. 5) then
               pcore(i) = 3.0d0
               polarity(i) = 1.6d0
               palpha(i) = 0.0d0      !! missing parameter
            else if (atn .eq. 6) then
               pcore(i) = 4.0d0
               polarity(i) = 0.9354d0
               palpha(i) = 4.5439d0
               do j = 1, n12(i)
                  k = i12(j,i)
                  if ((atomic(k).ne.6.or.n12(k).ne.4)
     &                  .and. atomic(k).ne.1)  goto 50
               end do
               do j = 1, n13(i)
                  k = atomic(i13(j,i))
                  if ((atomic(k).ne.6.or.n12(k).ne.4)
     &                  .and. atomic(k).ne.1)  goto 50
               end do
               polarity(i) = 0.755d0
               palpha(i) = 4.2998d0
   50          continue
               if (n12(i) .eq. 3) then
                  do j = 1, n12(i)
                     k = i12(j,i)
                     if (atomic(k).eq.6 .and. n12(k).eq.3) then
                        polarity(i) = 1.9384d0
                        palpha(i) = 3.5491d0
                     end if
                  end do
                  do j = 1, n12(i)
                     k = i12(j,i)
                     if (atomic(k).eq.8 .and. n12(k).eq.1) then
                        polarity(i) = 0.6577d0
                        palpha(i) = 5.9682d0
                     end if
                  end do
               end if
               if (chkarom(i)) then
                  polarity(i) = 1.5624d0
                  palpha(i) = 3.8056d0
                  do j = 1, n12(i)
                     k = atomic(i12(j,i))
                     if (k.ne.6 .and. k.ne.1) then
                        polarity(i) = 1.2811d0
                        palpha(i) = 3.8066d0
                     end if
                  end do
               end if
               if (n12(i) .eq. 2) then
                  polarity(i) = 0.9354d0    !! generic value
                  palpha(i) = 4.5439d0      !! generic value
               end if
            else if (atn .eq. 7) then
               pcore(i) = 5.0d0
               polarity(i) = 1.4289d0
               palpha(i) = 3.9882d0
               if (n12(i) .eq. 3) then
                  do j = 1, n12(i)
                     k = i12(j,i)
                     if (atomic(k).eq.6 .and. n12(k).eq.3) then
                        polarity(i) = 1.4545d0
                        palpha(i) = 3.9413d0
                     end if
                  end do
               end if
               if (chkarom(i)) then
                  polarity(i) = 1.3037d0
                  palpha(i) = 3.9434d0
               end if
            else if (atn .eq. 8) then
               pcore(i) = 6.0d0
               polarity(i) = 0.6645d0
               palpha(i) = 4.7004d0
               if (n12(i) .eq. 1) then
                  k = i12(1,i)
                  if (atomic(k).eq.6 .and. n12(k).eq.3) then
                     polarity(i) = 1.4266d0
                     palpha(i) = 4.2263d0
                     do j = 1, n13(i)
                        m = i13(j,i)
                        if (atomic(m).eq.8 .and. n12(m).eq.1) then
                           polarity(i) = 1.8809d0
                           palpha(i) = 4.0355d0
                        end if
                     end do
                  end if
                  if (atomic(k) .eq. 15) then
                     jj = 0
                     do j = 1, n12(k)
                        m = i12(j,k)
                        if (atomic(m).eq.8 .and. n12(m).eq.1) then
                           jj = jj + 1
                        end if
                     end do
                     if (jj .eq. 1) then
                        polarity(i) = 1.0d0
                        palpha(i) = 4.3312d0
                     else
                        polarity(i) = 1.0d0
                        palpha(i) = 4.4574d0
                     end if
                  end if
               end if
            else if (atn .eq. 9) then
               pcore(i) = 7.0d0
               polarity(i) = 0.5d0
               palpha(i) = 5.5080d0
            else if (atn .eq. 15) then
               pcore(i) = 5.0d0
               polarity(i) = 1.8d0
               palpha(i) = 2.8130d0
            else if (atn .eq. 16) then
               pcore(i) = 6.0d0
               polarity(i) = 3.1967d0
               palpha(i) = 3.3620d0
               if (n12(i) .gt. 2) then
                  polarity(i) = 2.458d0
                  palpha(i) = 2.7272d0
               end if
            else if (atn .eq. 17) then
               pcore(i) = 7.0d0
               polarity(i) = 2.366d0
               palpha(i) = 3.6316d0
            else if (atn .eq. 35) then
               pcore(i) = 7.0d0
               polarity(i) = 3.4458d0
               palpha(i) = 3.2008d0
            else if (atn .eq. 53) then
               pcore(i) = 7.0d0
               polarity(i) = 5.5d0
               palpha(i) = 0.0d0      !! missing parameter
            end if
         end do
      end if
c
c     set valence electrons from number of core electrons
c
      do i = 1, n
         pval(i) = pole(1,i) - pcore(i)
      end do
c
c     compute the Thole polarizability damping values
c
      sixth = 1.0d0 / 6.0d0
      do i = 1, n
         if (thole(i) .eq. 0.0d0) then
            pdamp(i) = 0.0d0
         else
            pdamp(i) = polarity(i)**sixth
         end if
      end do
c
c     list the polarizability and charge penetration values
c
      write (iout,60)
   60 format (/,' Polarizability Parameters for Multipole Sites :')
      if (use_thole) then
         write (iout,70)
   70    format (/,5x,'Atom',5x,'Name',7x,'Polarize',10x,'Thole',/)
      else if (use_tholed) then
         write (iout,80)
   80    format (/,5x,'Atom',5x,'Name',7x,'Polarize',10x,'Thole',
     &             9x,'TholeD',/)
      else if (use_chgpen) then
         write (iout,90)
   90    format (/,5x,'Atom',5x,'Name',7x,'Polarize',11x,'Core',
     &              5x,'Valence',8x,'Damp',/)
      end if
      do i = 1, n
         ii = pollist(i)
         if (use_thole) then
            if (ii .eq. 0) then
               write (iout,100)  i,name(i)
  100          format (i8,6x,a3,12x,'--',13x,'--')
            else
               write (iout,110)  i,name(i),polarity(i),thole(i)
  110          format (i8,6x,a3,4x,f12.4,3x,f12.4)
            end if
         else if (use_tholed) then
            if (ii .eq. 0) then
               write (iout,120)  i,name(i)
  120          format (i8,6x,a3,12x,'--',13x,'--', 13x, '--')
            else
               write (iout,130) i,name(i),polarity(i),
     &                          thole(i),tholed(i)
  130          format (i8,6x,a3,4x,f12.4,3x,f12.4,3x,f12.4)
            end if
         else if (use_chgpen) then
            if (ii .eq. 0) then
               write (iout,140)  i,name(i)
  140          format (i8,6x,a3,12x,'--',13x,'--',10x,'--',10x,'--')
            else
               write (iout,150)  i,name(i),polarity(i),pcore(i),
     &                           pval(i),palpha(i)
  150          format (i8,6x,a3,4x,f12.4,3x,3f12.4)
            end if
         end if
      end do
c
c     allow the user to manually alter polarizability values
c
      change = .false.
      query = .true.
      i = -1
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=160,end=160)  i
         if (i .eq. 0)  query = .false.
      end if
  160 continue
      do while (query)
         i = 0
         if (use_thole) then
            pol = 0.0d0
            thl = 0.39d0
            write (iout,170)
  170       format (/,' Enter Atom Number, Polarizability & Thole',
     &                 ' Value :  ',$)
            read (input,180)  record
  180       format (a240)
            read (record,*,err=190,end=190)  i,pol,thl
  190       continue
            if (i .ne. 0) then
               if (pol .eq. 0.0d0)  pol = polarity(i)
               if (thl .eq. 0.0d0)  thl = thole(i)
            end if
         else if (use_tholed) then
            pol = 0.0d0
            thl = 0.39d0
            thld = 0.70d0
            write (iout,200)
  200       format (/,' Enter Atom Number, Polarizability, Thole',
     &                 ' & TholeD Values :  ',$)
            read (input,210)  record
  210       format (a240)
            read (record,*,err=220,end=220)  i,pol,thl,thld
  220       continue
            if (i .ne. 0) then
               if (pol .eq. 0.0d0)  pol = polarity(i)
               if (thl .eq. 0.0d0)  thl = thole(i)
               if (thld .eq. 0.0d0)  thld = tholed(i)
            end if
         else if (use_chgpen) then
            pol = 0.0d0
            pel = 0.0d0
            pal = 0.0d0
            write (iout,230)
  230       format (/,' Enter Atom Number, Polarize, Core & Damp',
     &                 ' Value :  ',$)
            read (input,240)  record
  240       format (a240)
            read (record,*,err=250,end=250)  i,pol,pel,pal
  250       continue
            if (i .ne. 0) then
               if (pol .eq. 0.0d0)  pol = polarity(i)
               if (pel .eq. 0.0d0)  pel = pcore(i)
               if (pal .eq. 0.0d0)  pal = palpha(i)
            end if
         end if
         if (i .eq. 0) then
            query = .false.
         else
            change = .true.
            polarity(i) = pol
            if (use_thole) then
               thole(i) = thl
               pdamp(i) = polarity(i)**sixth
            else if (use_tholed) then
               thole(i) = thl
               tholed(i) = thld
               pdamp(i) = polarity(i)**sixth
            else if (use_chgpen) then
               pcore(i) = pel
               palpha(i) = pal
               pval(i) = pole(1,i) - pcore(i)
            end if
         end if
      end do
c
c     repeat polarizability values if parameters were altered
c
      if (change) then
         write (iout,260)
  260    format (/,' Atomic Polarizabilities for Multipole Sites :')
         if (use_thole) then
            write (iout,270)
  270       format (/,5x,'Atom',5x,'Name',7x,'Polarize',10x,'Thole',/)
         else if (use_tholed) then
            write (iout,280)
  280       format (/,5x,'Atom',5x,'Name',7x,'Polarize',10x,'Thole',
     &                 10x,'TholeD',/)
         else if (use_chgpen) then
            write (iout,290)
  290       format (/,5x,'Atom',5x,'Name',7x,'Polarize',4x,'Core Chg',
     &                 8x,'Damp',/)
         end if
         do i = 1, n
            ii = pollist(i)
            if (use_thole) then
               if (ii .eq. 0) then
                  write (iout,300)  i,name(i)
  300             format (i8,6x,a3,12x,'--',13x,'--')
               else
                  write (iout,310)  i,name(i),polarity(i),thole(i)
  310             format (i8,6x,a3,4x,f12.4,3x,f12.4)
               end if
            else if (use_tholed) then
               if (ii .eq. 0) then
                  write (iout,320)  i,name(i)
  320             format (i8,6x,a3,12x,'--',13x,'--',13x,'--')
               else
                  write (iout,330)  i,name(i),polarity(i),
     &                              thole(i),tholed(i)
  330             format (i8,6x,a3,4x,f12.4,3x,f12.4,f12.4)
               end if
            else if (use_chgpen) then
               if (ii .eq. 0) then
                  write (iout,340)  i,name(i)
  340             format (i8,6x,a3,12x,'--',13x,'--',10x,'--')
               else
                  write (iout,350)  i,name(i),polarity(i),pcore(i),
     &                              palpha(i)
  350             format (i8,6x,a3,4x,f12.4,3x,2f12.4)
               end if
            end if
         end do
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine setpgrp  --  define the polarization groups  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "setpgrp" chooses the polarization groups as defined by bonds
c     separating groups, and allows user modification of the groups
c
c
      subroutine setpgrp
      use atomid
      use atoms
      use bndstr
      use couple
      use iounit
      use kpolr
      use ring
      implicit none
      integer i,j,k,m
      integer mode
      integer ia,ib,ic
      integer ita,itb,itc
      integer ata,atb
      integer n12a,n12b
      logical exist,query
      logical chkarom,split
      logical aroma,aromb
      character*240 record
      character*240 string
c
c
c     get the desired type of coordinate file modification
c
      mode = -1
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  mode
         if (mode.ge.1 .and. mode.le.2)  query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' Choose Method for Division into Polarization',
     &              ' Groups :',
     &           //,4x,'(1) Put All Atoms in One Polarization Group',
     &           /,4x,'(2) Separate into Groups at Rotatable Bonds',
     &           /,4x,'(3) Manual Entry of Bonds Separating Groups')
         do while (mode.lt.1 .or. mode.gt.3)
            mode = 0
            write (iout,30)
   30       format (/,' Enter the Number of the Desired Choice',
     &                 ' [1] :  ',$)
            read (input,40,err=50,end=50)  mode
   40       format (i10)
            if (mode .le. 0)  mode = 1
   50       continue
         end do
      end if
c
c     initialize by placing all atoms in one polarization group
c
      do i = 1, n
         do j = 1, n12(i)
            pgrp(j,i) = i12(j,i)
         end do
      end do
c
c     separate into polarization groups at rotatable bonds
c
      if (mode .eq. 2) then
         call bonds
         do k = 1, nbond
            ia = ibnd(1,k)
            ib = ibnd(2,k)
            n12a = n12(ia)
            n12b = n12(ib)
            ata = atomic(ia)
            atb = atomic(ib)
            ita = 10*ata + n12a
            itb = 10*atb + n12b
            aroma = chkarom(ia)
            aromb = chkarom(ib)
            split = .true.
c
c     remove bonds involving univalent atoms
c
            if (min(n12a,n12b) .le. 1)  split = .false.
c
c     remove bonds internal to aromatic ring
c
            if (aroma .and. aromb) then
               do i = 1, nring5
                  m = 0
                  do j = 1, 5
                     if (iring5(j,i) .eq. ia)  m = m + 1
                     if (iring5(j,i) .eq. ib)  m = m + 1
                  end do
                  if (m .eq. 2)  split = .false.
               end do
               do i = 1, nring6
                  m = 0
                  do j = 1, 6
                     if (iring6(j,i) .eq. ia)  m = m + 1
                     if (iring6(j,i) .eq. ib)  m = m + 1
                  end do
                  if (m .eq. 2)  split = .false.
               end do
            end if
c
c     remove bonds with sp-hybridized carbon atom
c
            if (ita.eq.62 .or. itb.eq.62)  split = .false.
c
c     remove the C=C bond of terminal alkene
c
            if (ita.eq.63 .and. .not.aroma .and.
     &             itb.eq.63 .and. .not.aromb) then
               split = .false.
               do i = 1, n12a
                  ic = i12(i,ia)
                  if (ic .ne. ib) then
                     itc = 10*atomic(ic) + n12(ic)
                     if (itc.eq.63 .or. itc.eq.73 .or.
     &                   itc.eq.72 .or. itc.eq.81) then
                        split = .true.
                     end if
                  end if
               end do
               if (split) then
                  split = .false.
                  do i = 1, n12b
                     ic = i12(i,ib)
                     if (ic .ne. ia) then
                        itc = 10*atomic(ic) + n12(ic)
                        if (itc.eq.63 .or. itc.eq.72 .or.
     &                      itc.eq.73 .or. itc.eq.81) then
                           split = .true.
                        end if
                     end if
                  end do
               end if
            end if
c
c     remove the C-O bonds of alcohol and ether
c
            if (ita.eq.82 .and. itb.eq.64) then
               do i = 1, n12a
                  ic = i12(i,ia)
                  if (ic .ne. ib) then
                     itc = 10*atomic(ic) + n12(ic)
                     if (itc.eq.11 .or. itc.eq.64)  split = .false.
                  end if
               end do
            else if (itb.eq.82 .and. ita.eq.64) then
               do i = 1, n12b
                  ic = i12(i,ib)
                  if (ic .ne. ia) then
                     itc = 10*atomic(ic) + n12(ic)
                     if (itc.eq.11 .or. itc.eq.64)  split = .false.
                  end if
               end do
            end if
c
c     remove the C-O bonds of carboxylic acid and ester
c
            if (ita.eq.82 .and. itb.eq.63) then
               do i = 1, n12b
                  ic = i12(i,ib)
                  itc = 10*atomic(ic) + n12(ic)
                  if (itc .eq. 81)  split = .false.
                  if (aromb)  split = .false.
               end do
            else if (itb.eq.82 .and. ita.eq.63) then
               do i = 1, n12a
                  ic = i12(i,ia)
                  itc = 10*atomic(ic) + n12(ic)
                  if (itc .eq. 81)  split = .false.
                  if (aroma)  split = .false.
               end do
            end if
c
c     remove the C-N bonds of alkyl amine
c
            if (ita.eq.73 .and. itb.eq.64) then
               m = 0
               do i = 1, n12a
                  ic = i12(i,ia)
                  if (ic .ne. ib) then
                     itc = 10*atomic(ic) + n12(ic)
                     if (itc.eq.11 .or. itc.eq.64)  m = m + 1
                  end if
               end do
               if (m .eq. 2)  split = .false.
            else if (itb.eq.73 .and. ita.eq.64) then
               m = 0
               do i = 1, n12b
                  ic = i12(i,ib)
                  if (ic .ne. ia) then
                     itc = 10*atomic(ic) + n12(ic)
                     if (itc.eq.11 .or. itc.eq.64)  m = m + 1
                  end if
               end do
               if (m .eq. 2)  split = .false.
            end if
c
c     remove the C-N bonds of amide, urea, amidine and guanidinium
c
            if (ita.eq.73 .and. itb.eq.63) then
               do i = 1, n12b
                  ic = i12(i,ib)
                  if (ic .ne. ia) then
                     itc = 10*atomic(ic) + n12(ic)
                     if (itc .eq. 81)  split = .false.
                     if (itc .eq. 73)  split = .false.
                  end if
               end do
            else if (itb.eq.73 .and. ita.eq.63) then
               do i = 1, n12a
                  ic = i12(i,ia)
                  if (ic .ne. ib) then
                     itc = 10*atomic(ic) + n12(ic)
                     if (itc .eq. 81)  split = .false.
                     if (itc .eq. 73)  split = .false.
                  end if
               end do
            end if
c
c     remove any P-X and S-X bonds with X = N or O
c
            if (ata.eq.15 .or. ata.eq.16) then
               if (atb.eq.7 .or. atb.eq.8)  split = .false.
            else if (atb.eq.15 .or. atb.eq.16) then
               if (ata.eq.7 .or. ata.eq.8)  split = .false.
            end if
c
c     modify membership to split groups at allowed bonds
c
            if (split) then
               do i = 1, n12a
                  if (pgrp(i,ia) .eq. ib) then
                     do j = i+1, n12a
                        pgrp(j-1,ia) = pgrp(j,ia)
                     end do
                     pgrp(n12a,ia) = 0
                  end if
               end do
               do i = 1, n12b
                  if (pgrp(i,ib) .eq. ia) then
                     do j = i+1, n12b
                        pgrp(j-1,ib) = pgrp(j,ib)
                     end do
                     pgrp(n12b,ib) = 0
                  end if
               end do
            end if
         end do
c
c     allow modification of polarization group one bond at a time
c
      else if (mode .eq. 3) then
         write (iout,60)
   60    format (/,' All atoms are placed initially into one',
     &              ' polarization group;',
     &           /,' This can be modified by entering a series',
     &              ' of bonded atom pairs',
     &           /,' that separate the molecule into distinct',
     &              ' polarization groups')
c
c     get the bonds that separate the polarization groups
c
         query = .true.
         i = -1
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=70,end=70)  i
            if (i .eq. 0)  query = .false.
         end if
   70    continue
         do while (query)
            ia = 0
            ib = 0
            write (iout,80)
   80       format (/,' Enter a Bond between Polarization Groups',
     &                 ' [<Enter>=Exit] :  ',$)
            read (input,90)  record
   90       format (a240)
            read (record,*,err=100,end=100)  ia,ib
  100       continue
            if (ia.eq.0 .or. ib.eq.0) then
               query = .false.
            else
               do i = 1, n12(ia)
                  if (pgrp(i,ia) .eq. ib) then
                     do j = i+1, n12(ia)
                        pgrp(j-1,ia) = pgrp(j,ia)
                     end do
                     pgrp(n12(ia),ia) = 0
                  end if
               end do
               do i = 1, n12(ib)
                  if (pgrp(i,ib) .eq. ia) then
                     do j = i+1, n12(ib)
                        pgrp(j-1,ib) = pgrp(j,ib)
                     end do
                     pgrp(n12(ib),ib) = 0
                  end if
               end do
            end if
         end do
      end if
c
c     find the polarization groups and their connectivities
c
      call polargrp
c
c     list the polarization group for each multipole site
c
      write (iout,110)
  110 format (/,' Polarization Groups for Multipole Sites :')
      write (iout,120)
  120 format (/,5x,'Atom',5x,'Name',7x,'Polarization Group',
     &           ' Definition',/)
      do i = 1, n
         k = 0
         do j = 1, maxval
            if (pgrp(j,i) .ne. 0)  k = j
         end do
         write (iout,130)  i,name(i),(pgrp(j,i),j=1,k)
  130    format (i8,6x,a3,8x,20i6)
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  function chkarom  --  check for atom in aromatic ring  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "chkatom" tests for the presence of a specified atom as a
c     member of an aromatic ring
c
c
      function chkarom (iatom)
      use atomid
      use couple
      use ring
      implicit none
      integer i,j,k
      integer iatom
      logical chkarom
      logical member
      logical trigonal
c
c
c     determine membership in 5-membered aromatic ring
c
      chkarom = .false.
      do i = 1, nring5
         trigonal = .true.
         member = .false.
         do j = 1, 5
            k = iring5(j,i)
            if (k .eq. iatom)  member = .true.
            if (atomic(k).eq.6 .and. n12(k).ne.3)  trigonal = .false.
            if (atomic(k).eq.7 .and. n12(k).eq.4)  trigonal = .false.
         end do
         if (member .and. trigonal)  chkarom = .true.
      end do
c
c     determine membership in 6-membered aromatic ring
c
      do i = 1, nring6
         trigonal = .true.
         member = .false.
         do j = 1, 6
            k = iring6(j,i)
            if (k .eq. iatom)  member = .true.
            if (atomic(k).eq.6 .and. n12(k).ne.3)  trigonal = .false.
            if (atomic(k).eq.7 .and. n12(k).eq.4)  trigonal = .false.
         end do
         if (member .and. trigonal)  chkarom = .true.
      end do
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine alterpol  --  alter multipoles for polarization  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "alterpol" finds an output set of atomic multipole parameters
c     which when used with an intergroup polarization model will
c     give the same electrostatic potential around the molecule as
c     the input set of multipole parameters with all atoms in one
c     polarization group
c
c     for example, the input parameters could be from a distributed
c     multipole analysis of a molecular wavefunction and the output
c     will be the multipole moments that achieve the same potential
c     in the presence of intergroup (intramolecular) polarization
c
c
      subroutine alterpol
      use atomid
      use atoms
      use inform
      use iounit
      use mpole
      use polar
      use units
      implicit none
      integer i,j,ii
      integer xaxe
      integer yaxe
      integer zaxe
c
c
c     compute induced dipoles to be removed from QM multipoles
c
      call interpol
c
c     remove intergroup induced dipoles from atomic multipoles
c
      do ii = 1, npole
         i = ipole(ii)
         pole(2,i) = pole(2,i) - uind(1,i)
         pole(3,i) = pole(3,i) - uind(2,i)
         pole(4,i) = pole(4,i) - uind(3,i)
      end do
c
c     convert dipole and quadrupole moments back to atomic units
c
      do ii = 1, npole
         i = ipole(ii)
         rpole(1,i) = pole(1,i)
         do j = 2, 4
            rpole(j,i) = pole(j,i) / bohr
         end do
         do j = 5, 13
            rpole(j,i) = 3.0d0 * pole(j,i) / bohr**2
         end do
      end do
c
c     print multipoles with intergroup polarization removed
c
      if (verbose) then
         write (iout,10)
   10    format (/,' Multipoles after Removal of Intergroup',
     &              ' Polarization :')
         do i = 1, n
            ii = pollist(i)
            if (ii .eq. 0) then
               write (iout,20)  i,name(i),atomic(i)
   20          format (/,' Atom:',i8,9x,'Name:',3x,a3,
     &                    7x,'Atomic Number:',i8)
               write (iout,30)
   30          format (/,' No Atomic Multipole Moments for this Site')
            else
               zaxe = zaxis(i)
               xaxe = xaxis(i)
               yaxe = yaxis(i)
               if (yaxe .lt. 0)  yaxe = -yaxe
               write (iout,40)  i,name(i),atomic(i)
   40          format (/,' Atom:',i8,9x,'Name:',3x,a3,
     &                    7x,'Atomic Number:',i8)
               write (iout,50)  polaxe(i),zaxe,xaxe,yaxe
   50          format (/,' Local Frame:',12x,a8,6x,3i8)
               write (iout,60)  rpole(1,i)
   60          format (/,' Charge:',10x,f15.5)
               write (iout,70)  rpole(2,i),rpole(3,i),rpole(4,i)
   70          format (' Dipole:',10x,3f15.5)
               write (iout,80)  rpole(5,i)
   80          format (' Quadrupole:',6x,f15.5)
               write (iout,90)  rpole(8,i),rpole(9,i)
   90          format (18x,2f15.5)
               write (iout,100)  rpole(11,i),rpole(12,i),rpole(13,i)
  100          format (18x,3f15.5)
            end if
         end do
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine interpol  --  get intergroup induced dipoles  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "interpol" computes intergroup induced dipole moments for use
c     during removal of intergroup polarization
c
c     note only DIRECT and MUTUAL polarization models are available;
c     the analytical OPT and TCG methods are treated as MUTUAL
c
c
      subroutine interpol
      use atoms
      use iounit
      use mplpot
      use mpole
      use polar
      use polpot
      use units
      implicit none
      integer i,j,k
      integer ii,iter
      integer maxiter
      integer trimtext
      real*8 eps,epsold
      real*8 polmin,norm
      real*8 a,b,sum,term
      real*8 utmp(3)
      real*8 rmt(3,3)
      real*8, allocatable :: poli(:)
      real*8, allocatable :: field(:,:)
      real*8, allocatable :: rsd(:,:)
      real*8, allocatable :: zrsd(:,:)
      real*8, allocatable :: conj(:,:)
      real*8, allocatable :: vec(:,:)
      logical done
      logical planar
      character*5 truth
c
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(uind))  allocate (uind(3,n))
c
c     perform dynamic allocation of some local arrays
c
      allocate (poli(n))
      allocate (field(3,n))
      allocate (rsd(3,n))
      allocate (zrsd(3,n))
      allocate (conj(3,n))
      allocate (vec(3,n))
c
c     rotate the multipole components into the global frame
c
      call rotpole ('MPOLE')
c
c     compute induced dipoles as polarizability times field
c
      call dfieldi (field)
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            uind(j,i) = polarity(i) * field(j,i)
         end do
      end do
c
c     for direct-only models set mutual scale factors to zero
c
      if (poltyp .eq. 'DIRECT') then
         u1scale = 0.0d0
         u2scale = 0.0d0
         u3scale = 0.0d0
         u4scale = 0.0d0
      end if
c
c     print the electrostatic and polarization scale factors
c
      write (iout,10)
   10 format (/,' Electrostatic and Polarization Scale Factors :',
     &        //,20x,'1-2',9x,'1-3',9x,'1-4',9x,'1-5',/)
      write (iout,20)  m2scale,m3scale,m4scale,m5scale
   20 format (' M-Scale:',3x,4f12.4)
      write (iout,30)  p2scale,p3scale,p4scale,p5scale
   30 format (' P-Inter:',3x,4f12.4)
      write (iout,40)  p2iscale,p3iscale,p4iscale,p5iscale
   40 format (' P-Intra:',3x,4f12.4)
      write (iout,50)  w2scale,w3scale,w4scale,w5scale
   50 format (' W-Scale:',3x,4f12.4)
      write (iout,60)
   60 format (/,20x,'1-1',9x,'1-2',9x,'1-3',9x,'1-4',/)
      write (iout,70)  d1scale,d2scale,d3scale,d4scale
   70 format (' D-Scale:',3x,4f12.4)
      write (iout,80)  u1scale,u2scale,u3scale,u4scale
   80 format (' U-Scale:',3x,4f12.4)
      truth = 'False'
      if (use_thole)  truth = 'True'
      write (iout,90)  truth(1:trimtext(truth))
   90 format (/,' Use Thole Damping:',11x,a)
      truth = 'False'
      if (use_tholed)  truth = 'True'
      write (iout,100)  truth(1:trimtext(truth))
  100 format (' Use TholeD Damping:',10x,a)
      truth = 'False'
      if (use_chgpen)  truth = 'True'
      write (iout,110)  truth(1:trimtext(truth))
  110 format (' Charge Penetration:',10x,a)
      truth = 'False'
      if (dpequal)  truth = 'True'
      write (iout,120)  truth(1:trimtext(truth))
  120 format (' Set D Equal to P:',12x,a)
c
c     set tolerances for computation of mutual induced dipoles
c
      done = .false.
      maxiter = 100
      iter = 0
      polmin = 0.00000001d0
      eps = 100.0d0
c
c     compute intergroup induced dipole moments via CG algorithm
c
      call ufieldi (field)
      do ii = 1, npole
         i = ipole(ii)
         poli(i) = max(polmin,polarity(i))
         do j = 1, 3
            rsd(j,i) = field(j,i)
            zrsd(j,i) = rsd(j,i) * poli(i)
            conj(j,i) = zrsd(j,i)
         end do
      end do
c
c     conjugate gradient iteration of intergroup induced dipoles
c
      do while (.not. done)
         iter = iter + 1
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               vec(j,i) = uind(j,i)
               uind(j,i) = conj(j,i)
            end do
         end do
         call ufieldi (field)
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               uind(j,i) = vec(j,i)
               vec(j,i) = conj(j,i)/poli(i) - field(j,i)
            end do
         end do
         a = 0.0d0
         sum = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               a = a + conj(j,i)*vec(j,i)
               sum = sum + rsd(j,i)*zrsd(j,i)
            end do
         end do
         if (a .ne. 0.0d0)  a = sum / a
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               uind(j,i) = uind(j,i) + a*conj(j,i)
               rsd(j,i) = rsd(j,i) - a*vec(j,i)
            end do
         end do
         b = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               zrsd(j,i) = rsd(j,i) * poli(i)
               b = b + rsd(j,i)*zrsd(j,i)
            end do
         end do
         if (sum .ne. 0.0d0)  b = b / sum
         eps = 0.0d0
         do ii = 1, npole
            i = ipole(ii)
            do j = 1, 3
               conj(j,i) = zrsd(j,i) + b*conj(j,i)
               eps = eps + rsd(j,i)*rsd(j,i)
            end do
         end do
c
c     check the convergence of the intergroup induced dipoles
c
         eps = debye * sqrt(eps/dble(npolar))
         epsold = eps
         if (iter .eq. 1) then
            write (iout,130)
  130       format (/,' Determination of Intergroup Induced',
     &                 ' Dipoles :',
     &              //,4x,'Iter',8x,'RMS Change (Debye)',/)
         end if
         write (iout,140)  iter,eps
  140    format (i8,7x,f16.10)
         if (eps .lt. poleps)  done = .true.
         if (eps .gt. epsold)  done = .true.
         if (iter .ge. maxiter)  done = .true.
c
c     apply a "peek" iteration to the intergroup induced dipoles
c
         if (done) then
            do ii = 1, npole
               i = ipole(ii)
               term = poli(i)
               do j = 1, 3
                  uind(j,i) = uind(j,i) + term*rsd(j,i)
               end do
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (poli)
      deallocate (field)
      deallocate (rsd)
      deallocate (zrsd)
      deallocate (conj)
      deallocate (vec)
c
c     terminate the calculation if dipoles failed to converge
c
      if (eps .gt. poleps) then
         write (iout,150)
  150    format (/,' INTERPOL  --  Warning, Induced Dipoles',
     &              ' are not Converged')
         call prterr
         call fatal
      end if
c
c     rotate the induced dipoles into local coordinate frame
c
      do ii = 1, npole
         i = ipole(ii)
         call rotmat (i,rmt,planar)
         call invert (3,rmt)
         do j = 1, 3
            utmp(j) = 0.0d0
            do k = 1, 3
               utmp(j) = utmp(j) + uind(k,i)*rmt(j,k)
            end do
         end do
         do j = 1, 3
            uind(j,i) = utmp(j)
         end do
      end do
c
c     print out a list of the final induced dipole moments
c
      write (iout,160)
  160 format (/,' Local Frame Intergroup Induced Dipole Moments',
     &           ' (Debye) :')
      write (iout,170)
  170 format (/,4x,'Atom',14x,'X',11x,'Y',11x,'Z',9x,'Total',/)
      do ii = 1, npole
         i = ipole(ii)
         norm = sqrt(uind(1,i)**2+uind(2,i)**2+uind(3,i)**2)
         write (iout,180)  i,(debye*uind(j,i),j=1,3),debye*norm
  180    format (i8,5x,4f12.4)
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine dfieldi  --  find permanent multipole field  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "dfieldi" computes the electrostatic field due to permanent
c     multipole moments
c
c
      subroutine dfieldi (field)
      use atoms
      use chgpen
      use couple
      use mplpot
      use mpole
      use polar
      use polgrp
      use polpot
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xr,yr,zr
      real*8 r,r2,rr3,rr5,rr7
      real*8 rr3i,rr5i,rr7i
      real*8 rr3k,rr5k,rr7k
      real*8 ci,dix,diy,diz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,dkr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 damp,expdamp
      real*8 scale3,scale5
      real*8 scale7
      real*8 pdi,pti,ptdi
      real*8 pgamma
      real*8 fid(3),fkd(3)
      real*8 dmpi(7),dmpk(7)
      real*8, allocatable :: dscale(:)
      real*8 field(3,*)
c
c
c     zero out the induced dipole and the field at each site
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            uind(j,i) = 0.0d0
            field(j,i) = 0.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (dscale(n))
c
c     set array needed to scale atom and group interactions
c
      do i = 1, n
         dscale(i) = 1.0d0
      end do
c
c     find the electrostatic field due to permanent multipoles
c
      do ii = 1, npole-1
         i = ipole(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         if (use_thole) then
            pdi = pdamp(i)
            pti = thole(i)
         else if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               dscale(i12(j,i)) = p2scale
               do k = 1, np11(i)
                  if (i12(j,i) .eq. ip11(k,i))
     &               dscale(i12(j,i)) = p2iscale
               end do
            end do
            do j = 1, n13(i)
               dscale(i13(j,i)) = p3scale
               do k = 1, np11(i)
                  if (i13(j,i) .eq. ip11(k,i))
     &               dscale(i13(j,i)) = p3iscale
               end do
            end do
            do j = 1, n14(i)
               dscale(i14(j,i)) = p4scale
               do k = 1, np11(i)
                  if (i14(j,i) .eq. ip11(k,i))
     &               dscale(i14(j,i)) = p4iscale
               end do
            end do
            do j = 1, n15(i)
               dscale(i15(j,i)) = p5scale
               do k = 1, np11(i)
                  if (i15(j,i) .eq. ip11(k,i))
     &               dscale(i15(j,i)) = p5iscale
               end do
            end do
         else
            do j = 1, np11(i)
               dscale(ip11(j,i)) = d1scale
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = d2scale
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = d3scale
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = d4scale
            end do
         end if
c
c     evaluate higher-numbered sites with the original site
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - x(i)
            yr = y(k) - y(i)
            zr = z(k) - z(i)
            r2 = xr*xr + yr* yr + zr*zr
            r = sqrt(r2)
            ck = rpole(1,k)
            dkx = rpole(2,k)
            dky = rpole(3,k)
            dkz = rpole(4,k)
            qkxx = rpole(5,k)
            qkxy = rpole(6,k)
            qkxz = rpole(7,k)
            qkyy = rpole(9,k)
            qkyz = rpole(10,k)
            qkzz = rpole(13,k)
c
c     intermediates involving moments and separation distance
c
            dir = dix*xr + diy*yr + diz*zr
            qix = qixx*xr + qixy*yr + qixz*zr
            qiy = qixy*xr + qiyy*yr + qiyz*zr
            qiz = qixz*xr + qiyz*yr + qizz*zr
            qir = qix*xr + qiy*yr + qiz*zr
            dkr = dkx*xr + dky*yr + dkz*zr
            qkx = qkxx*xr + qkxy*yr + qkxz*zr
            qky = qkxy*xr + qkyy*yr + qkyz*zr
            qkz = qkxz*xr + qkyz*yr + qkzz*zr
            qkr = qkx*xr + qky*yr + qkz*zr
c
c     find the field components for Thole polarization damping
c
            if (use_thole) then
               damp = pdi * pdamp(k)
               scale3 = 1.0d0
               scale5 = 1.0d0
               scale7 = 1.0d0
               if (damp .ne. 0.0d0) then
                  pgamma = min(pti,thole(k))
                  damp = pgamma * (r/damp)**3
                  if (damp .lt. 50.0d0) then
                     expdamp = exp(-damp)
                     scale3 = 1.0d0 - expdamp
                     scale5 = 1.0d0 - expdamp*(1.0d0+damp)
                     scale7 = 1.0d0 - expdamp*(1.0d0+damp
     &                                   +0.6d0*damp**2)
                  end if
               end if
               rr3 = scale3 / (r*r2)
               rr5 = 3.0d0 * scale5 / (r*r2*r2)
               rr7 = 15.0d0 * scale7 / (r*r2*r2*r2)
               fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                     - rr3*dkx + 2.0d0*rr5*qkx
               fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                     - rr3*dky + 2.0d0*rr5*qky
               fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                     - rr3*dkz + 2.0d0*rr5*qkz
               fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir)
     &                     - rr3*dix - 2.0d0*rr5*qix
               fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir)
     &                     - rr3*diy - 2.0d0*rr5*qiy
               fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir)
     &                     - rr3*diz - 2.0d0*rr5*qiz
c
c     find the field components for Direct polarization damping
c
            else if (use_tholed) then
               damp = pdi * pdamp(k)
               scale3 = 1.0d0
               scale5 = 1.0d0
               scale7 = 1.0d0
               if (damp .ne. 0.0d0) then
                  pgamma = min(ptdi,tholed(k))
                  damp = pgamma * (r/damp)**(1.5d0)
                  if (damp .lt. 50.0d0) then
                     expdamp = exp(-damp)
                     scale3 = 1.0d0 - expdamp
                     scale5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp)
                     scale7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp
     &                                   +0.15d0*damp**2)
                  end if
               end if
               rr3 = scale3 / (r*r2)
               rr5 = 3.0d0 * scale5 / (r*r2*r2)
               rr7 = 15.0d0 * scale7 / (r*r2*r2*r2)
               fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                     - rr3*dkx + 2.0d0*rr5*qkx
               fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                     - rr3*dky + 2.0d0*rr5*qky
               fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                     - rr3*dkz + 2.0d0*rr5*qkz
               fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir)
     &                     - rr3*dix - 2.0d0*rr5*qix
               fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir)
     &                     - rr3*diy - 2.0d0*rr5*qiy
               fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir)
     &                     - rr3*diz - 2.0d0*rr5*qiz
c
c     find the field components for charge penetration damping
c
            else if (use_chgpen) then
               corek = pcore(k)
               valk = pval(k)
               alphak = palpha(k)
               call dampdir (r,alphai,alphak,dmpi,dmpk)
               rr3 = 1.0d0 / (r*r2)
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr3i = dmpi(3) * rr3
               rr5i = dmpi(5) * rr5
               rr7i = dmpi(7) * rr7
               rr3k = dmpk(3) * rr3
               rr5k = dmpk(5) * rr5
               rr7k = dmpk(7) * rr7
               fid(1) = -xr*(rr3*corek + rr3k*valk
     &                     - rr5k*dkr + rr7k*qkr)
     &                     - rr3k*dkx + 2.0d0*rr5k*qkx
               fid(2) = -yr*(rr3*corek + rr3k*valk
     &                     - rr5k*dkr + rr7k*qkr)
     &                     - rr3k*dky + 2.0d0*rr5k*qky
               fid(3) = -zr*(rr3*corek + rr3k*valk
     &                     - rr5k*dkr + rr7k*qkr)
     &                     - rr3k*dkz + 2.0d0*rr5k*qkz
               fkd(1) = xr*(rr3*corei + rr3i*vali
     &                     + rr5i*dir + rr7i*qir)
     &                     - rr3i*dix - 2.0d0*rr5i*qix
               fkd(2) = yr*(rr3*corei + rr3i*vali
     &                     + rr5i*dir + rr7i*qir)
     &                     - rr3i*diy - 2.0d0*rr5i*qiy
               fkd(3) = zr*(rr3*corei + rr3i*vali
     &                     + rr5i*dir + rr7i*qir)
     &                     - rr3i*diz - 2.0d0*rr5i*qiz
            end if
            do j = 1, 3
               field(j,i) = field(j,i) + fid(j)*dscale(k)
               field(j,k) = field(j,k) + fkd(j)*dscale(k)
            end do
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            do j = 1, n12(i)
               dscale(i12(j,i)) = 1.0d0
            end do
            do j = 1, n13(i)
               dscale(i13(j,i)) = 1.0d0
            end do
            do j = 1, n14(i)
               dscale(i14(j,i)) = 1.0d0
            end do
            do j = 1, n15(i)
               dscale(i15(j,i)) = 1.0d0
            end do
         else
            do j = 1, np11(i)
               dscale(ip11(j,i)) = 1.0d0
            end do
            do j = 1, np12(i)
               dscale(ip12(j,i)) = 1.0d0
            end do
            do j = 1, np13(i)
               dscale(ip13(j,i)) = 1.0d0
            end do
            do j = 1, np14(i)
               dscale(ip14(j,i)) = 1.0d0
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (dscale)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine ufieldi  --  find induced intergroup field  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "ufieldi" computes the electrostatic field due to intergroup
c     induced dipole moments
c
c     literature reference:
c
c     P. Ren and J. W. Ponder, "Consistent Treatment of Inter- and
c     Intramolecular Polarization in Molecular Mechanics Calculations",
c     Journal of Computational Chemistry, 23, 1497-1506 (2002)
c
c
      subroutine ufieldi (field)
      use atoms
      use chgpen
      use couple
      use mplpot
      use mpole
      use polar
      use polgrp
      use polpot
      implicit none
      integer i,j,k
      integer ii,kk
      real*8 xr,yr,zr
      real*8 r,r2,rr3,rr5
      real*8 uix,uiy,uiz
      real*8 ukx,uky,ukz
      real*8 uir,ukr
      real*8 corei,corek
      real*8 vali,valk
      real*8 alphai,alphak
      real*8 damp,expdamp
      real*8 scale3,scale5
      real*8 pdi,pti,pgamma
      real*8 fiu(3),fku(3)
      real*8 dmpik(5)
      real*8, allocatable :: dscale(:)
      real*8, allocatable :: pscale(:)
      real*8, allocatable :: uscale(:)
      real*8, allocatable :: wscale(:)
      real*8, allocatable :: gscale(:)
      real*8 field(3,*)
c
c
c     zero out the value of the field at each site
c
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 3
            field(j,i) = 0.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (dscale(n))
      allocate (pscale(n))
      allocate (uscale(n))
      allocate (wscale(n))
      allocate (gscale(n))
c
c     set arrays needed to scale atom and group interactions
c
      do i = 1, n
         dscale(i) = 1.0d0
         pscale(i) = 1.0d0
         uscale(i) = 1.0d0
         wscale(i) = 1.0d0
         gscale(i) = 0.0d0
      end do
c
c     find the electrostatic field due to induced dipoles
c
      do ii = 1, npole-1
         i = ipole(ii)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         if (use_thole .or. use_tholed) then
            pdi = pdamp(i)
            pti = thole(i)
         else if (use_chgpen) then
            corei = pcore(i)
            vali = pval(i)
            alphai = palpha(i)
         end if
c
c     set exclusion coefficients for connected atoms
c
         if (dpequal) then
            if (use_chgpen) then
               do j = 1, n12(i)
                  gscale(i12(j,i)) = w2scale - p2scale
                  do k = 1, np11(i)
                     if (i12(j,i) .eq. ip11(k,i))
     &                  gscale(i12(j,i)) = w2scale - p2iscale
                  end do
               end do
               do j = 1, n13(i)
                  gscale(i13(j,i)) = w3scale - p3scale
                  do k = 1, np11(i)
                     if (i13(j,i) .eq. ip11(k,i))
     &                  gscale(i13(j,i)) = w3scale - p3iscale
                  end do
               end do
               do j = 1, n14(i)
                  gscale(i14(j,i)) = w4scale - p4scale
                  do k = 1, np11(i)
                     if (i14(j,i) .eq. ip11(k,i))
     &                  gscale(i14(j,i)) = w4scale - p4iscale
                  end do
               end do
               do j = 1, n15(i)
                  gscale(i15(j,i)) = w5scale - p5scale
                  do k = 1, np11(i)
                     if (i15(j,i) .eq. ip11(k,i))
     &                  gscale(i15(j,i)) = w5scale - p5iscale
                  end do
               end do
            else
               do j = 1, n12(i)
                  pscale(i12(j,i)) = p2scale
                  do k = 1, np11(i)
                     if (i12(j,i) .eq. ip11(k,i))
     &                  pscale(i12(j,i)) = p2iscale
                  end do
               end do
               do j = 1, n13(i)
                  pscale(i13(j,i)) = p3scale
                  do k = 1, np11(i)
                     if (i13(j,i) .eq. ip11(k,i))
     &                  pscale(i13(j,i)) = p3iscale
                  end do
               end do
               do j = 1, n14(i)
                  pscale(i14(j,i)) = p4scale
                  do k = 1, np11(i)
                     if (i14(j,i) .eq. ip11(k,i))
     &                  pscale(i14(j,i)) = p4iscale
                  end do
               end do
               do j = 1, n15(i)
                  pscale(i15(j,i)) = p5scale
                  do k = 1, np11(i)
                     if (i15(j,i) .eq. ip11(k,i))
     &                  pscale(i15(j,i)) = p5iscale
                  end do
               end do
               do j = 1, np11(i)
                  uscale(ip11(j,i)) = u1scale
               end do
               do j = 1, np12(i)
                  uscale(ip12(j,i)) = u2scale
               end do
               do j = 1, np13(i)
                  uscale(ip13(j,i)) = u3scale
               end do
               do j = 1, np14(i)
                  uscale(ip14(j,i)) = u4scale
               end do
               do j = ii+1, npole
                  k = ipole(j)
                  gscale(k) = uscale(k) - pscale(k)
               end do
            end if
         else
            if (use_chgpen) then
               do j = 1, n12(i)
                  wscale(i12(j,i)) = w2scale
               end do
               do j = 1, n13(i)
                  wscale(i13(j,i)) = w3scale
               end do
               do j = 1, n14(i)
                  wscale(i14(j,i)) = w4scale
               end do
               do j = 1, n15(i)
                  wscale(i15(j,i)) = w5scale
               end do
               do j = 1, np11(i)
                  dscale(ip11(j,i)) = d1scale
               end do
               do j = 1, np12(i)
                  dscale(ip12(j,i)) = d2scale
               end do
               do j = 1, np13(i)
                  dscale(ip13(j,i)) = d3scale
               end do
               do j = 1, np14(i)
                  dscale(ip14(j,i)) = d4scale
               end do
               do j = ii+1, npole
                  k = ipole(j)
                  gscale(k) = wscale(k) - dscale(k)
               end do
            else
               do j = 1, np11(i)
                  gscale(ip11(j,i)) = u1scale - d1scale
               end do
               do j = 1, np12(i)
                  gscale(ip12(j,i)) = u2scale - d2scale
               end do
               do j = 1, np13(i)
                  gscale(ip13(j,i)) = u3scale - d3scale
               end do
               do j = 1, np14(i)
                  gscale(ip14(j,i)) = u4scale - d4scale
               end do
            end if
         end if
c
c     evaluate higher-numbered sites with the original site
c
         do kk = ii+1, npole
            k = ipole(kk)
            xr = x(k) - x(i)
            yr = y(k) - y(i)
            zr = z(k) - z(i)
            r2 = xr*xr + yr* yr + zr*zr
            r = sqrt(r2)
            ukx = uind(1,k)
            uky = uind(2,k)
            ukz = uind(3,k)
c
c     intermediates involving moments and separation distance
c
            uir = xr*uix + yr*uiy + zr*uiz
            ukr = xr*ukx + yr*uky + zr*ukz
c
c     find the field components for Thole polarization damping
c
            if (use_thole .or. use_tholed) then
               scale3 = 1.0d0
               scale5 = 1.0d0
               damp = pdi * pdamp(k)
               if (damp .ne. 0.0d0) then
                  pgamma = min(pti,thole(k))
                  damp = pgamma * (r/damp)**3
                  if (damp .lt. 50.0d0) then
                     expdamp = exp(-damp)
                     scale3 = 1.0d0 - expdamp
                     scale5 = 1.0d0 - expdamp*(1.0d0+damp)
                  end if
               end if
c
c     find the field components for charge penetration damping
c
            else if (use_chgpen) then
               corek = pcore(k)
               valk = pval(k)
               alphak = palpha(k)
               call dampmut (r,alphai,alphak,dmpik)
               scale3 = dmpik(3)
               scale5 = dmpik(5)
            end if
            rr3 = -scale3 / (r*r2)
            rr5 = 3.0d0 * scale5 / (r*r2*r2)
            fiu(1) = rr3*ukx + rr5*ukr*xr
            fiu(2) = rr3*uky + rr5*ukr*yr
            fiu(3) = rr3*ukz + rr5*ukr*zr
            fku(1) = rr3*uix + rr5*uir*xr
            fku(2) = rr3*uiy + rr5*uir*yr
            fku(3) = rr3*uiz + rr5*uir*zr
            do j = 1, 3
               field(j,i) = field(j,i) + fiu(j)*gscale(k)
               field(j,k) = field(j,k) + fku(j)*gscale(k)
            end do
         end do
c
c     reset exclusion coefficients for connected atoms
c
         if (dpequal) then
            if (use_chgpen) then
               do j = 1, n12(i)
                  gscale(i12(j,i)) = 0.0d0
               end do
               do j = 1, n13(i)
                  gscale(i13(j,i)) = 0.0d0
               end do
               do j = 1, n14(i)
                  gscale(i14(j,i)) = 0.0d0
               end do
               do j = 1, n15(i)
                  gscale(i15(j,i)) = 0.0d0
               end do
            else
               do j = 1, np11(i)
                  uscale(ip11(j,i)) = 1.0d0
                  gscale(ip11(j,i)) = 0.0d0
               end do
               do j = 1, np12(i)
                  uscale(ip12(j,i)) = 1.0d0
                  gscale(ip12(j,i)) = 0.0d0
               end do
               do j = 1, np13(i)
                  uscale(ip13(j,i)) = 1.0d0
                  gscale(ip13(j,i)) = 0.0d0
               end do
               do j = 1, np14(i)
                  uscale(ip14(j,i)) = 1.0d0
                  gscale(ip14(j,i)) = 0.0d0
               end do
               do j = 1, n12(i)
                  pscale(i12(j,i)) = 1.0d0
                  gscale(i12(j,i)) = 0.0d0
               end do
               do j = 1, n13(i)
                  pscale(i13(j,i)) = 1.0d0
                  gscale(i13(j,i)) = 0.0d0
               end do
               do j = 1, n14(i)
                  pscale(i14(j,i)) = 1.0d0
                  gscale(i14(j,i)) = 0.0d0
               end do
               do j = 1, n15(i)
                  pscale(i15(j,i)) = 1.0d0
                  gscale(i15(j,i)) = 0.0d0
               end do
            end if
         else
            if (use_chgpen) then
               do j = 1, np11(i)
                  dscale(ip11(j,i)) = 1.0d0
                  gscale(ip11(j,i)) = 0.0d0
               end do
               do j = 1, np12(i)
                  dscale(ip12(j,i)) = 1.0d0
                  gscale(ip12(j,i)) = 0.0d0
               end do
               do j = 1, np13(i)
                  dscale(ip13(j,i)) = 1.0d0
                  gscale(ip13(j,i)) = 0.0d0
               end do
               do j = 1, np14(i)
                  dscale(ip14(j,i)) = 1.0d0
                  gscale(ip14(j,i)) = 0.0d0
               end do
               do j = 1, n12(i)
                  wscale(i12(j,i)) = 1.0d0
                  gscale(i12(j,i)) = 0.0d0
               end do
               do j = 1, n13(i)
                  wscale(i13(j,i)) = 1.0d0
                  gscale(i13(j,i)) = 0.0d0
               end do
               do j = 1, n14(i)
                  wscale(i14(j,i)) = 1.0d0
                  gscale(i14(j,i)) = 0.0d0
               end do
               do j = 1, n15(i)
                  wscale(i15(j,i)) = 1.0d0
                  gscale(i15(j,i)) = 0.0d0
               end do
            else
               do j = 1, np11(i)
                  gscale(ip11(j,i)) = 0.0d0
               end do
               do j = 1, np12(i)
                  gscale(ip12(j,i)) = 0.0d0
               end do
               do j = 1, np13(i)
                  gscale(ip13(j,i)) = 0.0d0
               end do
               do j = 1, np14(i)
                  gscale(ip14(j,i)) = 0.0d0
               end do
            end if
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (dscale)
      deallocate (pscale)
      deallocate (uscale)
      deallocate (wscale)
      deallocate (gscale)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine avgpole  --  condense multipole atom types  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "avgpole" condenses the number of multipole atom types based
c     upon atoms equivalent through 1-6 connectivity, and allowing
c     user modification of sets of equivalent atoms
c
c
      subroutine avgpole
      use atomid
      use atoms
      use couple
      use iounit
      use kpolr
      use mpole
      use sizes
      implicit none
      integer i,j,k,m
      integer ii,it
      integer in,jn,kn
      integer ni,nati
      integer nj,natj
      integer k2,k4
      integer size,numtyp
      integer nlist,nave
      integer tmin,tmax
      integer xaxe,yaxe,zaxe
      integer, allocatable :: ci(:)
      integer, allocatable :: cj(:)
      integer, allocatable :: list(:)
      integer, allocatable :: tsort(:)
      integer, allocatable :: pkey(:)
      integer, allocatable :: pgrt(:,:)
      real*8 pave(13)
      logical done,header,exist
      logical query,condense
      logical keep,match,diff
      logical useframe,symm
      logical yzero,xyzero
      character*1 answer
      character*4 pa,pb,pc,pd
      character*16 ptlast
      character*16, allocatable :: pt(:)
      character*240 record
      character*240 string
c
c
c     check for user requested reduction of equivalent types
c
      condense = .true.
      answer = 'Y'
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  answer
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' Condense Symmetric Atoms to Equivalent Types',
     &              ' [Y] :  ',$)
         read (input,30)  answer
   30    format (a1)
      end if
      call upcase (answer)
      if (answer .eq. 'N')  condense = .false.
c
c     perform dynamic allocation of some local arrays
c
      if (condense) then
         allocate (ci(n))
         allocate (cj(n))
         size = 40
         allocate (list(max(n,size)))
c
c     condense groups of equivalent atoms to the same atom type
c
         header = .true.
         do i = 1, n
            list(i) = 0
         end do
         do i = 1, n-1
            nati = n12(i) + n13(i) + n14(i) + n15(i)
            ni = nati
            m = 0
            do k = 1, n12(i)
               in = i12(k,i)
               m = m + 1
               ci(m) = 2000 + 10*atomic(in) + n12(in)
            end do
            do k = 1, n13(i)
               in = i13(k,i)
               m = m + 1
               ci(m) = 3000 + 10*atomic(in) + n12(in)
            end do
            do k = 1, n14(i)
               in = i14(k,i)
               m = m + 1
               ci(m) = 4000 + 10*atomic(in) + n12(in)
            end do
            do k = 1, n15(i)
               in = i15(k,i)
               m = m + 1
               ci(m) = 5000 + 10*atomic(in) + n12(in)
            end do
            do k = 1, n15(i)
               kn = i15(k,i)
               do k2 = 1, n12(kn)
                  in = i12(k2,kn)
                  keep = .true.
                  do k4 = 1, n14(i)
                     if (in .eq. i14(k4,i))  keep = .false.
                  end do
                  if (keep) then
                     ni = ni + 1
                     m = m + 1
                     ci(m) = 6000 * 10*atomic(in) + n12(in)
                  end if
               end do
            end do
            call sort (ni,ci)
            do j = i+1, n
               if (atomic(i) .eq. atomic(j)) then
                  natj = n12(j) + n13(j) + n14(j) + n15(j)
                  if (natj .eq. nati) then
                     nj = natj
                     m = 0
                     do k = 1, n12(j)
                        jn = i12(k,j)
                        m = m + 1
                        cj(m) = 2000 + 10*atomic(jn) + n12(jn)
                     end do
                     do k = 1, n13(j)
                        jn = i13(k,j)
                        m = m + 1
                        cj(m) = 3000 + 10*atomic(jn) + n12(jn)
                     end do
                     do k = 1, n14(j)
                        jn = i14(k,j)
                        m = m + 1
                        cj(m) = 4000 + 10*atomic(jn) + n12(jn)
                     end do
                     do k = 1, n15(j)
                        jn = i15(k,j)
                        m = m + 1
                        cj(m) = 5000 + 10*atomic(jn) + n12(jn)
                     end do
                     do k = 1, n15(j)
                        kn = i15(k,j)
                        do k2 = 1, n12(kn)
                           jn = i12(k2,kn)
                           keep = .true.
                           do k4 = 1, n14(j)
                              if (jn .eq. i14(k4,j))  keep = .false.
                           end do
                           if (keep) then
                              nj = nj + 1
                              m = m + 1
                              cj(m) = 6000 * 10*atomic(jn) + n12(jn)
                           end if
                        end do
                     end do
                     call sort (nj,cj)
                     match = .true.
                     do k = 1, ni
                        if (ci(k) .ne. cj(k)) then
                           match = .false.
                           goto 40
                        end if
   40                   continue
                     end do
                     if (match) then
                        tmin = min(type(i),type(j))
                        tmax = max(type(i),type(j))
                        do k = 1, n
                           if (type(k) .eq. tmax)  type(k) = tmin
                        end do
                        if (list(i).eq.0 .or. list(j).eq.0) then
                           if (header) then
                              header = .false.
                              write (iout,50)
   50                         format (/,' Equivalent Atoms Assigned',
     &                                   ' the Same Atom Type :',/)
                           end if
                           write (iout,60)  i,j
   60                      format (' Atoms',i6,2x,'and',i6,2x,
     &                                'Set to Equivalent Atom Types')
                           list(i) = 1
                           list(j) = 1
                        end if
                     end if
                  end if
               end if
            end do
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (ci)
         deallocate (cj)
c
c     perform dynamic allocation of some local arrays
c
         allocate (tsort(n))
         allocate (pkey(n))
         allocate (pt(n))
c
c     count the number of distinct atom types in the system
c
         numtyp = 0
         do i = 1, n
            numtyp = max(numtyp,type(i))
         end do
c
c     query for more atom sets to condense to a single type
c
         done = .false.
         do while (.not. done)
            do i = 1, size
               list(i) = 0
            end do
            write (iout,70)
   70       format (/,' Enter Sets of Equivalent or Different',
     &                 ' Atoms [<Enter>=Exit] :  ',$)
            read (input,80)  record
   80       format (a240)
            read (record,*,err=90,end=90)  (list(i),i=1,size)
   90       continue
c
c     add or remove the equivalence of specified sets of atoms
c
            diff = .false.
            nlist = 1
            if (list(1) .ne. 0)  k = type(list(1))
            do while (list(nlist) .ne. 0)
               if (type(list(nlist)) .ne. k)  diff = .true.
               nlist = nlist + 1
            end do
            nlist = nlist - 1
            if (nlist .eq. 0) then
               done = .true.
            else if (diff) then
               tmin = n + 1
               do i = 1, nlist
                  tmin = min(tmin,type(list(i)))
               end do
               do i = 1, nlist
                  k = type(list(i))
                  if (k .ne. tmin) then
                     tmax = k
                     do k = 1, n
                        if (type(k) .eq. tmax)  type(k) = tmin
                     end do
                  end if
               end do
            else
               do i = 1, nlist
                  numtyp = numtyp + 1
                  type(list(i)) = numtyp
               end do
            end if
         end do
c
c     renumber the atom types to give consecutive ordering
c
         do i = 1, n
            tsort(i) = 0
         end do
         m = 0
         do i = 1, n
            k = type(i)
            if (tsort(k) .eq. 0) then
               tsort(k) = i
               m = m + 1
               type(i) = m
            else
               type(i) = type(tsort(k))
            end if
         end do
c
c     set the atom class equal to the atom type for each atom
c
         do i = 1, n
            class(i) = type(i)
         end do
c
c     print the atoms, atom types and local frame definitions
c
         write (iout,100)
  100    format (/,' Atom Type and Local Frame Definition',
     &              ' for Each Atom :',
     &           //,5x,'Atom',4x,'Type',6x,'Local Frame',10x,
     &              'Frame Defining Atoms',/)
         do ii = 1, npole
            i = ipole(ii)
            write (iout,110)  i,type(i),polaxe(i),zaxis(i),
     &                        xaxis(i),yaxis(i)
  110       format (2i8,9x,a8,6x,3i8)
         end do
c
c     identify atoms with the same atom type number, or find
c     atoms with equivalent local frame defining atom types
c
         useframe = .false.
         do ii = 1, npole
            i = ipole(ii)
            it = type(i)
            zaxe = 0
            xaxe = 0
            yaxe = 0
            if (useframe) then
               if (zaxis(i) .ne. 0)  zaxe = type(zaxis(i))
               if (xaxis(i) .ne. 0)  xaxe = type(xaxis(i))
               if (yaxis(i) .ne. 0)  yaxe = type(yaxis(i))
            end if
            size = 4
            call numeral (it,pa,size)
            call numeral (zaxe,pb,size)
            call numeral (xaxe,pc,size)
            call numeral (yaxe,pd,size)
            pt(ii) = pa//pb//pc//pd
         end do
         call sort7 (npole,pt,pkey)
c
c     average the multipole values at equivalent atom sites
c
         nave = 1
         ptlast = '                '
         do ii = 1, npole
            i = pkey(ii)
            if (pt(ii) .eq. ptlast) then
               nave = nave + 1
               do j = 1, 13
                  pave(j) = pave(j) + pole(j,i)
               end do
               if (ii .eq. npole) then
                  do j = 1, 13
                     pave(j) = pave(j) / dble(nave)
                  end do
                  do k = 1, nave
                     m = pkey(ii-k+1)
                     do j = 1, 13
                        pole(j,m) = pave(j)
                     end do
                  end do
               end if
            else
               if (nave .ne. 1) then
                  do j = 1, 13
                     pave(j) = pave(j) / dble(nave)
                  end do
                  do k = 1, nave
                     m = pkey(ii-k)
                     do j = 1, 13
                        pole(j,m) = pave(j)
                     end do
                  end do
               end if
               nave = 1
               do j = 1, 13
                  pave(j) = pole(j,i)
               end do
               ptlast = pt(ii)
            end if
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (list)
         deallocate (tsort)
         deallocate (pkey)
         deallocate (pt)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (pgrt(maxval,n))
c
c     set polarization groups over the condensed atom types
c
      do i = 1, n
         do j = 1, maxval
            pgrt(j,i) = 0
         end do
      end do
      do i = 1, npole
         it = type(ipole(i))
         k = 0
         do j = 1, maxval
            if (pgrp(j,i) .ne. 0) then
               k = j
               pgrp(j,it) = type(pgrp(j,i))
            else
               pgrp(j,it) = 0
            end if
         end do
         call sort8 (k,pgrp(1,it))
         do j = 1, k
            do m = 1, maxval
               if (pgrt(m,it) .eq. 0) then
                  pgrt(m,it) = pgrp(j,it)
                  goto 120
               end if
            end do
  120       continue
         end do
      end do
      do i = 1, npole
         it = type(ipole(i))
         do j = 1, maxval
            pgrp(j,it) = pgrt(j,it)
            if (pgrp(j,it) .ne. 0)  k = j
         end do
         call sort8 (k,pgrp(1,it))
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (pgrt)
c
c     regularize the multipole moments to standardized values
c
      call fixpole
c
c     check for user requested zeroing of moments by symmetry
c
      symm = .true.
      answer = 'Y'
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=130,end=130)  answer
         query = .false.
      end if
  130 continue
      if (query) then
         write (iout,140)
  140    format (/,' Remove Multipole Components Zeroed by',
     &              ' Symmetry [Y] :  ',$)
         read (input,150)  answer
  150    format (a1)
      end if
      call upcase (answer)
      if (answer .eq. 'N')  symm = .false.
c
c     remove multipole components that are zero by symmetry
c
      if (symm) then
         do ii = 1, npole
            i = ipole(ii)
            xyzero = .false.
            yzero = .false.
            if (polaxe(i) .eq. 'Bisector')  xyzero = .true.
            if (polaxe(i) .eq. 'Z-Bisect')  yzero = .true.
            if (polaxe(i) .eq. 'Z-then-X') then
               if (yaxis(i) .eq. 0)  yzero = .true.
            end if
            if (polaxe(i) .eq. 'None') then
               do j = 2, 13
                  pole(j,i) = 0.0d0
               end do
            end if
            if (polaxe(i) .eq. 'Z-Only') then
               pole(2,i) = 0.0d0
               pole(3,i) = 0.0d0
               pole(5,i) = -0.5d0 * pole(13,i)
               pole(6,i) = 0.0d0
               pole(7,i) = 0.0d0
               pole(8,i) = 0.0d0
               pole(9,i) = pole(5,i)
               pole(10,i) = 0.0d0
               pole(11,i) = 0.0d0
               pole(12,i) = 0.0d0
            end if
            if (xyzero) then
               pole(2,i) = 0.0d0
               pole(3,i) = 0.0d0
               pole(6,i) = 0.0d0
               pole(7,i) = 0.0d0
               pole(8,i) = 0.0d0
               pole(10,i) = 0.0d0
               pole(11,i) = 0.0d0
               pole(12,i) = 0.0d0
            end if
            if (yzero) then
               pole(3,i) = 0.0d0
               pole(6,i) = 0.0d0
               pole(8,i) = 0.0d0
               pole(10,i) = 0.0d0
               pole(12,i) = 0.0d0
            end if
         end do
      end if
c
c     print the final multipole values for force field use
c
      write (iout,160)
  160 format (/,' Final Atomic Multipole Moments after',
     &           ' Regularization :')
      do i = 1, n
         ii = pollist(i)
         if (ii .eq. 0) then
            write (iout,170)  i,name(i),atomic(i)
  170       format (/,' Atom:',i8,9x,'Name:',3x,a3,
     &                 7x,'Atomic Number:',i8)
            write (iout,180)
  180       format (/,' No Atomic Multipole Moments for this Site')
         else
            zaxe = zaxis(i)
            xaxe = xaxis(i)
            yaxe = yaxis(i)
            if (yaxe .lt. 0)  yaxe = -yaxe
            write (iout,190)  i,name(i),atomic(i)
  190       format (/,' Atom:',i8,9x,'Name:',3x,a3,
     &                 7x,'Atomic Number:',i8)
            write (iout,200)  polaxe(i),zaxe,xaxe,yaxe
  200       format (/,' Local Frame:',12x,a8,6x,3i8)
            write (iout,210)  pole(1,i)
  210       format (/,' Charge:',10x,f15.5)
            write (iout,220)  pole(2,i),pole(3,i),pole(4,i)
  220       format (' Dipole:',10x,3f15.5)
            write (iout,230)  pole(5,i)
  230       format (' Quadrupole:',6x,f15.5)
            write (iout,240)  pole(8,i),pole(9,i)
  240       format (18x,2f15.5)
            write (iout,250)  pole(11,i),pole(12,i),pole(13,i)
  250       format (18x,3f15.5)
         end if
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine fixpole  --  regularize the multipole moments  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "fixpole" performs unit conversion of the multipole components,
c     rounds moments to desired precision, and enforces integer net
c     charge and traceless quadrupoles
c
c
      subroutine fixpole
      use atoms
      use mpole
      use units
      implicit none
      integer i,j,k,m
      integer ii,it,ktype
      integer, allocatable :: equiv(:)
      real*8 eps,sum,big
      real*8 ival,kval
c
c
c     convert dipole and quadrupole moments to atomic units
c
      do ii = 1, npole
         i = ipole(ii)
         pole(1,i) = pole(1,i)
         do j = 2, 4
            pole(j,i) = pole(j,i) / bohr
         end do
         do j = 5, 13
            pole(j,i) = 3.0d0 * pole(j,i) / bohr**2
         end do
      end do
c
c     regularize multipole moments to desired precision
c
      eps = 0.00001d0
      do ii = 1, npole
         i = ipole(ii)
         do j = 1, 13
            pole(j,i) = dble(nint(pole(j,i)/eps)) * eps
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (equiv(maxtyp))
c
c     enforce integer net charge over atomic multipoles
c
      do i = 1, maxtyp
         equiv(i) = 0
      end do
      ktype = 0
      sum = 0.0d0
      do ii = 1, npole
         i = ipole(ii)
         it = type(ipole(i))
         equiv(it) = equiv(it) + 1
         sum = sum + pole(1,i)
      end do
      sum = sum - dble(nint(sum))
      k = nint(abs(sum)/eps)
      do j = 1, k
         m = k / j
         if (k .eq. m*j) then
            do ii = 1, npole
               i = ipole(ii)
               it = type(i)
               if (equiv(it) .eq. m) then
                  ival = abs(pole(1,i))
                  if (ktype .eq. 0) then
                     ktype = it
                     kval = ival
                  else if (ival .gt. kval) then
                     ktype = it
                     kval = ival
                  end if
               end if
            end do
         end if
         if (ktype .ne. 0)  goto 10
      end do
   10 continue
      if (ktype .ne. 0) then
         sum = sum / dble(m)
         do ii = 1, npole
            i = ipole(ii)
            it = type(i)
            if (it .eq. ktype)  pole(1,i) = pole(1,i) - sum
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (equiv)
c
c     enforce traceless quadrupole at each multipole site
c
      do ii = 1, npole
         i = ipole(ii)
         sum = pole(5,i) + pole(9,i) + pole(13,i)
         big = max(abs(pole(5,i)),abs(pole(9,i)),abs(pole(13,i)))
         k = 0
         if (big .eq. abs(pole(5,i)))  k = 5
         if (big .eq. abs(pole(9,i)))  k = 9
         if (big .eq. abs(pole(13,i)))  k = 13
         if (k .ne. 0)  pole(k,i) = pole(k,i) - sum
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine prtpole  --  create file with final multipoles  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "prtpole" creates a coordinates file, and a key file with
c     atomic multipoles corrected for intergroup polarization
c
c
      subroutine prtpole
      use atoms
      use atomid
      use chgpen
      use files
      use keys
      use kpolr
      use mplpot
      use mpole
      use polar
      use polpot
      use sizes
      use units
      implicit none
      integer i,j,k
      integer ii,it
      integer ixyz,ikey
      integer size,atlast
      integer xaxe,yaxe,zaxe
      integer freeunit,trimtext
      integer, allocatable :: at(:)
      integer, allocatable :: atkey(:)
      integer, allocatable :: ptkey(:)
      character*4 pa,pb,pc,pd
      character*16 ptlast
      character*16, allocatable :: pt(:)
      character*240 keyfile
      character*240 record
c
c
c     create a file with coordinates and connectivities
c
      ixyz = freeunit ()
      call prtxyz (ixyz)
c
c     output some definitions and parameters to a keyfile
c
      ikey = freeunit ()
      keyfile = filename(1:leng)//'.key'
      call version (keyfile,'new')
      open (unit=ikey,file=keyfile,status='new')
c
c     copy the contents of any previously existing keyfile
c
      do i = 1, nkey
         record = keyline(i)
         size = trimtext (record)
         write (ikey,10)  record(1:size)
   10    format (a)
      end do
      if (nkey .ne. 0) then
         write (ikey,20)
   20    format ()
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (at(npole))
      allocate (atkey(npole))
      allocate (pt(npole))
      allocate (ptkey(npole))
c
c     locate the equivalently defined atom type sites
c
      do ii = 1, npole
         i = ipole(ii)
         at(ii) = type(i)
      end do
      call sort3 (npole,at,atkey)
c
c     output the atom definitions to the keyfile as appropriate
c
      atlast = 0
      do ii = 1, npole
         i = atkey(ii)
         it = type(i)
         if (it .ne. atlast) then
            atlast = it
            write (ikey,30)  type(i),class(i),name(i),story(i),
     &                       atomic(i),mass(i),valnum(i)
   30       format ('atom',6x,2i5,4x,a3,3x,'"',a20,'"',i10,f10.3,i5)
         end if
      end do
      if (npole .ne. 0) then
         write (ikey,40)
   40    format ()
      end if
c
c     locate the equivalently defined multipole sites
c
      do ii = 1, npole
         i = ipole(ii)
         it = type(i)
         zaxe = 0
         xaxe = 0
         yaxe = 0
         if (zaxis(i) .ne. 0)  zaxe = type(zaxis(i))
         if (xaxis(i) .ne. 0)  xaxe = type(xaxis(i))
         if (yaxis(i) .ne. 0)  yaxe = type(yaxis(i))
         size = 4
         call numeral (it,pa,size)
         call numeral (zaxe,pb,size)
         call numeral (xaxe,pc,size)
         call numeral (yaxe,pd,size)
         pt(ii) = pa//pb//pc//pd
      end do
      call sort7 (npole,pt,ptkey)
c
c     output the local frame multipole values to the keyfile
c
      ptlast = '                '
      do ii = 1, npole
         i = ptkey(ii)
         it = type(ipole(i))
         if (pt(ii) .ne. ptlast) then
            ptlast = pt(ii)
            zaxe = 0
            xaxe = 0
            yaxe = 0
            if (zaxis(i) .ne. 0)  zaxe = type(zaxis(i))
            if (xaxis(i) .ne. 0)  xaxe = type(xaxis(i))
            if (yaxis(i) .ne. 0)  yaxe = type(yaxis(i))
            if (polaxe(i) .eq. 'None') then
               write (ikey,50)  it,pole(1,i)
   50          format ('multipole',1x,i5,21x,f11.5)
            else if (polaxe(i) .eq. 'Z-Only') then
               write (ikey,60)  it,zaxe,pole(1,i)
   60          format ('multipole',1x,2i5,16x,f11.5)
            else if (polaxe(i) .eq. 'Z-then-X') then
               if (yaxis(i) .eq. 0) then
                  write (ikey,70)  it,zaxe,xaxe,pole(1,i)
   70             format ('multipole',1x,3i5,11x,f11.5)
               else
                  write (ikey,80)  it,zaxe,xaxe,yaxe,pole(1,i)
   80             format ('multipole',1x,4i5,6x,f11.5)
               end if
            else if (polaxe(i) .eq. 'Bisector') then
               if (yaxis(i) .eq. 0) then
                  write (ikey,90)  it,-zaxe,-xaxe,pole(1,i)
   90             format ('multipole',1x,3i5,11x,f11.5)
               else
                  write (ikey,100)  it,-zaxe,-xaxe,yaxe,pole(1,i)
  100             format ('multipole',1x,4i5,6x,f11.5)
               end if
            else if (polaxe(i) .eq. 'Z-Bisect') then
               write (ikey,110)  it,zaxe,-xaxe,-yaxe,pole(1,i)
  110          format ('multipole',1x,4i5,6x,f11.5)
            else if (polaxe(i) .eq. '3-Fold') then
               write (ikey,120)  it,-zaxe,-xaxe,-yaxe,pole(1,i)
  120          format ('multipole',1x,4i5,6x,f11.5)
            end if
            write (ikey,130)  pole(2,i),pole(3,i),pole(4,i)
  130       format (36x,3f11.5)
            write (ikey,140)  pole(5,i)
  140       format (36x,f11.5)
            write (ikey,150)  pole(8,i),pole(9,i)
  150       format (36x,2f11.5)
            write (ikey,160)  pole(11,i),pole(12,i),pole(13,i)
  160       format (36x,3f11.5)
         end if
      end do
c
c     output any charge penetration parameters to the keyfile
c
      if (use_chgpen) then
         if (n .ne. 0) then
            write (ikey,170)
  170       format ()
         end if
         atlast = 0
         do ii = 1, npole
            i = atkey(ii)
            it = class(i)
            if (it .ne. atlast) then
               atlast = it
               write (ikey,180)  it,pcore(i),palpha(i)
  180          format ('chgpen',9x,i5,5x,2f11.4)
            end if
         end do
      end if
c
c     output the polarizability parameters to the keyfile
c
      if (n .ne. 0) then
         write (ikey,190)
  190    format ()
      end if
      atlast = 0
      do ii = 1, npole
         i = atkey(ii)
         it = type(i)
         if (it .ne. atlast) then
            atlast = it
            k = 0
            do j = 1, maxval
               if (pgrp(j,it) .ne. 0)  k = j
            end do
            call sort8 (k,pgrp(1,it))
            if (use_thole) then
               write (ikey,200)  it,polarity(i),thole(i),
     &                           (pgrp(j,it),j=1,k)
  200          format ('polarize',7x,i5,5x,2f11.4,2x,20i5)
            else if (use_tholed) then
               write (ikey,210)  it,polarity(i),thole(i),tholed(i),
     &                           (pgrp(j,it),j=1,k)
  210          format ('polarize',7x,i5,5x,3f11.4,2x,20i5)
            else if (use_chgpen) then
               write (ikey,220)  it,polarity(i),(pgrp(j,it),j=1,k)
  220          format ('polarize',7x,i5,5x,f11.4,6x,20i7)
            end if
         end if
      end do
      close (unit=ikey)
c
c     perform deallocation of some local arrays
c
      deallocate (at)
      deallocate (atkey)
      deallocate (pt)
      deallocate (ptkey)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2001  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module polgrp  --  polarization group connectivity lists   ##
c     ##                                                             ##
c     #################################################################
c
c
c     maxp11   maximum number of atoms in a polarization group
c     maxp12   maximum number of atoms in groups 1-2 to an atom
c     maxp13   maximum number of atoms in groups 1-3 to an atom
c     maxp14   maximum number of atoms in groups 1-4 to an atom
c
c     np11     number of atoms in polarization group of each atom
c     np12     number of atoms in groups 1-2 to each atom
c     np13     number of atoms in groups 1-3 to each atom
c     np14     number of atoms in groups 1-4 to each atom
c     ip11     atom numbers of atoms in same group as each atom
c     ip12     atom numbers of atoms in groups 1-2 to each atom
c     ip13     atom numbers of atoms in groups 1-3 to each atom
c     ip14     atom numbers of atoms in groups 1-4 to each atom
c
c
      module polgrp
      implicit none
      integer maxp11,maxp12
      integer maxp13,maxp14
      parameter (maxp11=200)
      parameter (maxp12=200)
      parameter (maxp13=200)
      parameter (maxp14=200)
      integer, allocatable :: np11(:)
      integer, allocatable :: np12(:)
      integer, allocatable :: np13(:)
      integer, allocatable :: np14(:)
      integer, allocatable :: ip11(:,:)
      integer, allocatable :: ip12(:,:)
      integer, allocatable :: ip13(:,:)
      integer, allocatable :: ip14(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2018  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module polopt  --  induced dipoles for OPT extrapolation  ##        
c     ##                                                            ##
c     ################################################################
c
c
c     maxopt    maximum order for OPT induced dipole extrapolation
c
c     optorder  highest coefficient order for OPT dipole extrapolation
c     optlevel  current OPT order for reciprocal potential and field
c     copt      coefficients for OPT total induced dipole moments
c     copm      coefficients for OPT incremental induced dipole moments
c     uopt      OPT induced dipole components at each multipole site
c     uoptp     OPT induced dipoles in field used for energy terms
c     uopts     OPT GK or PB induced dipoles at each multipole site
c     uoptps    OPT induced dipoles in field used for GK or PB energy
c     fopt      OPT fractional reciprocal potentials at multipole sites
c     foptp     OPT fractional reciprocal potentials for energy terms
c
c
      module polopt
      implicit none
      integer maxopt
      parameter (maxopt=6)
      integer optorder
      integer optlevel
      real*8, allocatable :: copt(:)
      real*8, allocatable :: copm(:)
      real*8, allocatable :: uopt(:,:,:)
      real*8, allocatable :: uoptp(:,:,:)
      real*8, allocatable :: uopts(:,:,:)
      real*8, allocatable :: uoptps(:,:,:)
      real*8, allocatable :: fopt(:,:,:)
      real*8, allocatable :: foptp(:,:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2013  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module polpcg  --  induced dipoles via the PCG solver  ##
c     ##                                                         ##
c     #############################################################
c
c
c     mindex    index into preconditioner inverse for PCG solver
c     pcgpeek   value of acceleration factor for PCG peek step
c     minv      preconditioner inverse for induced dipole PCG solver
c     pcgprec   flag to allow use of preconditioner with PCG solver
c     pcgguess  flag to use initial PCG based on direct field
c
c
      module polpcg
      implicit none
      integer, allocatable :: mindex(:)
      real*8 pcgpeek
      real*8, allocatable :: minv(:)
      logical pcgprec
      logical pcgguess
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module polpot  --  polarization functional form details  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     politer      maximum number of induced dipole SCF iterations
c     poleps       induced dipole convergence criterion (rms Debye/atom)
c     p2scale      scale factor for 1-2 polarization energy interactions
c     p3scale      scale factor for 1-3 polarization energy interactions
c     p4scale      scale factor for 1-4 polarization energy interactions
c     p5scale      scale factor for 1-5 polarization energy interactions
c     p2iscale     scale factor for 1-2 intragroup polarization energy
c     p3iscale     scale factor for 1-3 intragroup polarization energy
c     p4iscale     scale factor for 1-4 intragroup polarization energy
c     p5iscale     scale factor for 1-5 intragroup polarization energy
c     d1scale      scale factor for intra-group direct induction
c     d2scale      scale factor for 1-2 group direct induction
c     d3scale      scale factor for 1-3 group direct induction
c     d4scale      scale factor for 1-4 group direct induction
c     u1scale      scale factor for intra-group mutual induction
c     u2scale      scale factor for 1-2 group mutual induction
c     u3scale      scale factor for 1-3 group mutual induction
c     u4scale      scale factor for 1-4 group mutual induction
c     w2scale      scale factor for 1-2 induced dipole interactions
c     w3scale      scale factor for 1-3 induced dipole interactions
c     w4scale      scale factor for 1-4 induced dipole interactions
c     w5scale      scale factor for 1-5 induced dipole interactions
c     uaccel       acceleration factor for induced dipole SCF iterations
c     polprt       flag to print summary of induced dipole iterations
c     dpequal      flag to set dscale values equal to pscale values
c     use_thole    flag to use Thole damped polarization interactions
c     use_tholed   flag to use alternate Thole for direct polarization
c     use_expol    flag to use damped exchange polarization correction
c     scrtyp       type of exchange polarization (S2U, S2 or G)
c     poltyp       type of polarization (MUTUAL, DIRECT, OPT or TCG)
c
c
      module polpot
      implicit none
      integer politer
      real*8 poleps
      real*8 p2scale,p3scale
      real*8 p4scale,p5scale
      real*8 p2iscale,p3iscale
      real*8 p4iscale,p5iscale
      real*8 d1scale,d2scale
      real*8 d3scale,d4scale
      real*8 u1scale,u2scale
      real*8 u3scale,u4scale
      real*8 w2scale,w3scale
      real*8 w4scale,w5scale
      real*8 uaccel
      logical polprt
      logical dpequal
      logical use_thole
      logical use_tholed
      logical use_expol
      character*3 scrtyp
      character*6 poltyp
      save
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 2018 by Zhi Wang and Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module poltcg  --  induced dipoles via the TCG solver  ##
c     ##                                                         ##
c     #############################################################
c
c
c     tcgorder   total number of TCG iterations to be used
c     tcgnab     number of mutual induced dipole components
c     tcgpeek    value of acceleration factor for TCG peek step
c     uad        left-hand side mutual induced d-dipoles
c     uap        left-hand side mutual induced p-dipoles
c     ubd        right-hand side mutual induced d-dipoles
c     ubp        right-hand side mutual induced p-dipoles
c     tcgguess   flag to use initial TCG based on direct field
c
c
      module poltcg
      implicit none
      integer tcgorder
      integer tcgnab
      real*8 tcgpeek
      real*8, allocatable :: uad(:,:,:)
      real*8, allocatable :: uap(:,:,:)
      real*8, allocatable :: ubd(:,:,:)
      real*8, allocatable :: ubp(:,:,:)
      logical tcgguess
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2001  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine polymer  --  check for an infinite polymer  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "polymer" tests for the presence of an infinite polymer
c     extending across periodic boundaries
c
c
      subroutine polymer
      use atoms
      use bndstr
      use bound
      use boxes
      use iounit
      use keys
      implicit none
      integer i,j,next
      integer ia,ib
      real*8 xr,yr,zr
      real*8 xab,yab,zab
      real*8 eps,delta
      real*8 xlimit
      real*8 ylimit
      real*8 zlimit
      real*8 maximage
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set defaults of infinite polymer usage and cutoff distance
c
      use_polymer = .false.
      polycut = 5.5d0
c
c     get any keywords containing infinite polymer cutoff parameters
c
      do j = 1, nkey
         next = 1
         record = keyline(j)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:15) .eq. 'POLYMER-CUTOFF ') then
            string = record(next:240)
            read (string,*,err=10,end=10)  polycut
   10       continue
         end if
      end do
c
c     see if any bond connections require a minimum image
c
      if (use_bounds) then
         eps = 0.0001d0
         do i = 1, nbond
            ia = ibnd(1,i)
            ib = ibnd(2,i)
            xab = x(ia) - x(ib)
            yab = y(ia) - y(ib)
            zab = z(ia) - z(ib)
            xr = xab
            yr = yab
            zr = zab
            call image (xr,yr,zr)
            delta = abs(xr-xab) + abs(yr-yab) + abs(zr-zab)
            if (delta .gt. eps) then
               use_polymer = .true.
               goto 20
            end if
         end do
   20    continue
      end if
c
c     find the maximum sphere radius inscribed in periodic box
c
      if (use_polymer) then
         if (orthogonal) then
            xlimit = xbox2
            ylimit = ybox2
            zlimit = zbox2
         else if (monoclinic) then
            xlimit = xbox2 * beta_sin
            ylimit = ybox2
            zlimit = zbox2 * beta_sin
         else if (triclinic) then
            xlimit = xbox2 * beta_sin * gamma_sin
            ylimit = ybox2 * gamma_sin
            zlimit = zbox2 * beta_sin
         else if (octahedron) then
            xlimit = (sqrt(3.0d0)/4.0d0) * xbox
            ylimit = xlimit
            zlimit = xlimit
         else if (dodecadron) then
            xlimit = xbox2
            ylimit = xlimit
            zlimit = xlimit
         end if
         maximage = min(xlimit,ylimit,zlimit)
c
c     check for too large or small an infinite polymer cutoff
c
         if (polycut .gt. maximage) then
            write (iout,30)
   30       format (/,' POLYMER  --  Image Conflicts for Infinite',
     &                 ' Polymer in Small Cell')
            call fatal
         else if (polycut .lt. 5.5d0) then
            write (iout,40)
   40       format (/,' POLYMER  --  Warning, Infinite Polymer',
     &                 ' Cutoff may be Too Small')
         end if
      end if
c
c     set square of cutoff distance for use with nonbonded terms
c
      polycut2 = polycut * polycut
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module potent  --  usage of potential energy components  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     use_bond    logical flag governing use of bond stretch potential
c     use_angle   logical flag governing use of angle bend potential
c     use_strbnd  logical flag governing use of stretch-bend potential
c     use_urey    logical flag governing use of Urey-Bradley potential
c     use_angang  logical flag governing use of angle-angle cross term
c     use_opbend  logical flag governing use of out-of-plane bend term
c     use_opdist  logical flag governing use of out-of-plane distance
c     use_improp  logical flag governing use of improper dihedral term
c     use_imptor  logical flag governing use of improper torsion term
c     use_tors    logical flag governing use of torsional potential
c     use_pitors  logical flag governing use of pi-system torsion term
c     use_strtor  logical flag governing use of stretch-torsion term
c     use_angtor  logical flag governing use of angle-torsion term
c     use_tortor  logical flag governing use of torsion-torsion term
c     use_vdw     logical flag governing use of van der Waals potential
c     use_repel   logical flag governing use of Pauli repulsion term
c     use_disp    logical flag governing use of dispersion potential
c     use_charge  logical flag governing use of charge-charge potential
c     use_chgdpl  logical flag governing use of charge-dipole potential
c     use_dipole  logical flag governing use of dipole-dipole potential
c     use_mpole   logical flag governing use of multipole potential
c     use_polar   logical flag governing use of polarization term
c     use_chgtrn  logical flag governing use of charge transfer term
c     use_chgflx  logical flag governing use of charge flux term
c     use_rxnfld  logical flag governing use of reaction field term
c     use_solv    logical flag governing use of continuum solvation term
c     use_metal   logical flag governing use of ligand field term
c     use_geom    logical flag governing use of geometric restraints
c     use_extra   logical flag governing use of extra potential term
c     use_born    logical flag governing use of Born radii values
c     use_orbit   logical flag governing use of pisystem computation
c     use_mutate  logical flag governing use of hybrid potential terms
c
c
      module potent
      implicit none
      logical use_bond,use_angle
      logical use_strbnd,use_urey
      logical use_angang,use_opbend
      logical use_opdist,use_improp
      logical use_imptor,use_tors
      logical use_pitors,use_strtor
      logical use_angtor,use_tortor
      logical use_vdw,use_repel
      logical use_disp,use_charge
      logical use_chgdpl,use_dipole
      logical use_mpole,use_polar
      logical use_chgtrn,use_chgflx
      logical use_rxnfld,use_solv
      logical use_metal,use_geom
      logical use_extra,use_born
      logical use_orbit,use_mutate
      save
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 2008 by C. Wu, Zhifeng Jing & Jay Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  program potential  --  electrostatic potential utility  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "potential" calculates the electrostatic potential for a
c     molecule at a set of grid points; optionally compares to a
c     target potential or optimizes electrostatic parameters
c
c
      program potential
      use atoms
      use charge
      use files
      use inform
      use iounit
      use keys
      use mpole
      use neigh
      use potent
      use potfit
      use titles
      use units
      implicit none
      integer i,j,k
      integer ixyz,ipot
      integer igrd,icub
      integer next,mode
      integer nvar,nmodel
      integer nresid
      integer numkey
      integer maxpgrd
      integer nglist,nflist
      integer freeunit
      integer trimtext
      integer, allocatable :: glist(:)
      integer, allocatable :: flist(:)
      real*8 xi,yi,zi,pot
      real*8 x0,y0,z0
      real*8 xx0,xy0,xz0
      real*8 yy0,yz0,zz0
      real*8 grdmin
      real*8, allocatable :: xx(:)
      real*8, allocatable :: xlo(:)
      real*8, allocatable :: xhi(:)
      real*8, allocatable :: gc(:)
      real*8, allocatable :: presid(:)
      real*8, allocatable :: pjac(:,:)
      logical exist,query
      logical dogrid,docube
      logical domodel,dopair
      logical dotarget,dofit
      logical dofull
      logical, allocatable :: tmpchg(:)
      logical, allocatable :: tmppol(:)
      logical, allocatable :: tmpcpen(:)
      character*1 answer,ax
      character*20 keyword
      character*240 record
      character*240 string
      character*240 xyzfile
      character*240 xyz2file
      character*240 potfile
      character*240 gridfile
      character*240 cubefile
      external fitrsd
      external potwrt
c
c
c     setup the computation and assign some default values
c
      call initial
      nmodel = 1
      dogrid = .false.
      docube = .false.
      domodel = .false.
      dopair = .false.
      dotarget = .false.
      dofit = .false.
      resptyp = 'ORIG'
      wresp = 1.0d0
c
c     perform dynamic allocation of some global arrays
c
      maxpgrd = 100000
      allocate (ipgrid(maxpgrd,maxref))
      allocate (pgrid(3,maxpgrd,maxref))
      allocate (epot(2,maxpgrd,maxref))
c
c     initialize target molecular dipole and quadrupole values
c
      use_dpl = .false.
      use_qpl = .false.
      fit_mpl = .true.
      fit_dpl = .true.
      fit_qpl = .true.
      fit_chgpen = .true.
      do i = 1, maxref
         xdpl0(i) = 0.0d0
         ydpl0(i) = 0.0d0
         zdpl0(i) = 0.0d0
         xxqpl0(i) = 0.0d0
         xyqpl0(i) = 0.0d0
         xzqpl0(i) = 0.0d0
         yyqpl0(i) = 0.0d0
         yzqpl0(i) = 0.0d0
         zzqpl0(i) = 0.0d0
      end do
c
c     find electrostatic potential manipulation to perform
c
      mode = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  mode
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' The Tinker Electrostatic Potential Utility Can :',
     &           //,4x,'(1) Create Grid Points for Computing Potential',
     &           /,4x,'(2) Get QM Potential from a Gaussian CUBE File',
     &           /,4x,'(3) Calculate the Model Potential for a System',
     &           /,4x,'(4) Compare Two Model Potentials for a System',
     &           /,4x,'(5) Compare a Model Potential to a Target Grid',
     &           /,4x,'(6) Fit Electrostatic Parameters to Target Grid')
         do while (mode.lt.1 .or. mode.gt.6)
            mode = 0
            write (iout,30)
   30       format (/,' Enter the Number of the Desired Choice :  ',$)
            read (input,40,err=50,end=50)  mode
   40       format (i10)
   50       continue
         end do
      end if
      if (mode .eq. 1) then
         dogrid = .true.
      else if (mode .eq. 2) then
         docube = .true.
      else if (mode .eq. 3) then
         domodel = .true.
      else if (mode .eq. 4) then
         nmodel = 2
         dopair = .true.
      else if (mode .eq. 5) then
         dotarget = .true.
      else if (mode .eq. 6) then
         dotarget = .true.
         dofit = .true.
      end if
c
c     read electrostatic potential from a Gaussian CUBE file
c
      if (docube) then
         call nextarg (cubefile,exist)
         if (exist) then
            call basefile (cubefile)
            call suffix (cubefile,'cube','old')
            inquire (file=cubefile,exist=exist)
         end if
         do while (.not. exist)
            write (iout,60)
   60       format (/,' Enter the Gaussian CUBE File Name :  ',$)
            read (input,70)  cubefile
   70       format (a240)
            call basefile (cubefile)
            call suffix (cubefile,'cube','old')
            inquire (file=cubefile,exist=exist)
         end do
         icub = freeunit ()
         open (unit=icub,file=cubefile,status ='old')
         rewind (unit=icub)
         read (icub,80)  title
   80    format (1x,a240)
         ltitle = trimtext (title)
         read (icub,90)
   90    format ()
         read (icub,100)  n
  100    format (i5)
         read (icub,110)  npgrid(1)
  110    format (i5)
         do i = 1, n+2
            read (icub,120)
  120       format ()
         end do
         do i = 1, npgrid(1)
            read (icub,130)  record
  130       format (a240)
            read (record,*)  xi,yi,zi,pot
            pgrid(1,i,1) = xi
            pgrid(2,i,1) = yi
            pgrid(3,i,1) = zi
            epot(1,i,1) = hartree * pot
         end do
         close (unit=icub)
c
c     write the electrostatic potential to a Tinker POT file
c
         potfile = filename(1:leng)
         call suffix (potfile,'pot','new')
         ipot = freeunit ()
         open (unit=ipot,file=potfile,status ='new')
         rewind (unit=ipot)
         write (ipot,140)  npgrid(1),title(1:ltitle)
  140    format (i8,2x,a)
         do i = 1, npgrid(1)
            xi = pgrid(1,i,1)
            yi = pgrid(2,i,1)
            zi = pgrid(3,i,1)
            pot = epot(1,i,1)
            write (ipot,150)  i,xi,yi,zi,pot
  150       format (i8,3x,3f12.6,2x,f12.4)
         end do
         close (unit=ipot)
         write (iout,160)  potfile(1:trimtext(potfile))
  160    format (/,' Electrostatic Potential Written To :  ',a)
         goto 410
      end if
c
c     read the first structure and setup atom definitions
c
      call getxyz
      call field
      call katom
c
c     reopen the structure file and get all the structures
c
      ixyz = freeunit ()
      xyzfile = filename
      call suffix (xyzfile,'xyz','old')
      open (unit=ixyz,file=xyzfile,status ='old')
      rewind (unit=ixyz)
      call readxyz (ixyz)
      nconf = 0
      namax = n
      do while (.not. abort)
         nconf = nconf + 1
         call makeref (nconf)
         call readxyz (ixyz)
         namax = max(namax,n)
      end do
      close (unit=ixyz)
      if (nconf .gt. 1) then
         write (iout,170)  nconf
  170    format (/,' Structures Used for Potential Analysis :',3x,i16)
      end if
c
c     perform dynamic allocation of some global arrays
c
      allocate (gatm(namax))
      allocate (fatm(namax))
      allocate (fxdpl(namax))
      allocate (fydpl(namax))
      allocate (fzdpl(namax))
c
c     perform dynamic allocation of some local arrays
c
      allocate (glist(namax))
      allocate (flist(namax))
c
c     set defaults for the active grid atoms and fit atoms
c
      nglist = 0
      nflist = 0
      ngatm = namax
      nfatm = namax
      do i = 1, namax
         glist(i) = 0
         flist(i) = 0
         gatm(i) = .true.
         fatm(i) = .true.
         fxdpl(i) = .true.
         fydpl(i) = .true.
         fzdpl(i) = .true.
      end do
c
c     get control parameters and target values from keyfile
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:16) .eq. 'POTENTIAL-ATOMS ') then
            read (string,*,err=180,end=180)  (glist(k),k=nglist+1,namax)
  180       continue
            do while (glist(nglist+1) .ne. 0)
               nglist = nglist + 1
               glist(nglist) = max(-namax,min(namax,glist(nglist)))
            end do
         else if (keyword(1:14) .eq. 'POTENTIAL-FIT ') then
            read (string,*,err=190,end=190)  (flist(k),k=nflist+1,namax)
  190       continue
            do while (flist(nflist+1) .ne. 0)
               nflist = nflist + 1
               flist(nflist) = max(-namax,min(namax,flist(nflist)))
            end do
         else if (keyword(1:9) .eq. 'RESPTYPE ') then
            call getword (record,resptyp,next)
            call upcase (resptyp)
         else if (keyword(1:12) .eq. 'RESP-WEIGHT ') then
            read (string,*,err=200,end=200)  wresp
  200       continue
         else if (keyword(1:13) .eq. 'FIX-MONOPOLE ') then
            fit_mpl = .false.
         else if (keyword(1:11) .eq. 'FIX-DIPOLE ') then
            fit_dpl = .false.
         else if (keyword(1:16) .eq. 'FIX-ATOM-DIPOLE ') then
            read (string,*,err=210,end=210)  k,ax
            call upcase (ax)
  210       continue
            if (ax .eq. 'X') then
               fxdpl(k) = .false.
            else if (ax .eq. 'Y') then
               fydpl(k) = .false.
            else if (ax .eq. 'Z') then
               fzdpl(k) = .false.
            end if
         else if (keyword(1:15) .eq. 'FIX-QUADRUPOLE ') then
            fit_qpl = .false.
         else if (keyword(1:11) .eq. 'FIX-CHGPEN ') then
            fit_chgpen = .false.
         else if (keyword(1:14) .eq. 'TARGET-DIPOLE ') then
            use_dpl = .true.
            k = 1
            read (string,*,err=220,end=220)  x0,y0,z0,k
  220       continue
            xdpl0(k) = x0
            ydpl0(k) = y0
            zdpl0(k) = z0
         else if (keyword(1:18) .eq. 'TARGET-QUADRUPOLE ') then
            use_qpl = .true.
            k = 1
            read (string,*,err=230,end=230)  xx0,xy0,xz0,yy0,yz0,zz0,k
  230       continue
            xxqpl0(k) = xx0
            xyqpl0(k) = xy0
            xzqpl0(k) = xz0
            yyqpl0(k) = yy0
            yzqpl0(k) = yz0
            zzqpl0(k) = zz0
         end if
      end do
c
c     set active grid atoms to only those marked for use
c
      i = 1
      do while (glist(i) .ne. 0)
         if (i .eq. 1) then
            ngatm = 0
            do k = 1, namax
               gatm(k) = .false.
            end do
         end if
         if (glist(i) .gt. 0) then
            k = glist(i)
            if (.not. gatm(k)) then
               gatm(k) = .true.
               ngatm = ngatm + 1
            end if
            i = i + 1
         else
            do k = abs(glist(i)), abs(glist(i+1))
               if (.not. gatm(k)) then
                  gatm(k) = .true.
                  ngatm = ngatm + 1
               end if
            end do
            i = i + 2
         end if
      end do
c
c     set active fitting atoms to only those marked for use
c
      i = 1
      do while (flist(i) .ne. 0)
         if (i .eq. 1) then
            nfatm = 0
            do k = 1, namax
               fatm(k) = .false.
            end do
         end if
         if (flist(i) .gt. 0) then
            k = flist(i)
            if (.not. fatm(k)) then
               fatm(k) = .true.
               nfatm = nfatm + 1
            end if
            i = i + 1
         else
            do k = abs(flist(i)), abs(flist(i+1))
               if (.not. fatm(k)) then
                  fatm(k) = .true.
                  nfatm = nfatm + 1
               end if
            end do
            i = i + 2
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (glist)
      deallocate (flist)
c
c     generate potential grid based on the molecular surface
c
      if (.not. dotarget) then
         do i = 1, nconf
            call getref (i)
            call potgrid (i)
         end do
      end if
c
c     get name of optional second structure for comparison
c
      if (dopair) then
         call nextarg (xyz2file,exist)
         if (exist) then
            call basefile (xyz2file)
            call suffix (xyz2file,'xyz','old')
            inquire (file=xyz2file,exist=exist)
         end if
         do while (.not. exist)
            write (iout,240)
  240       format (/,' Enter Name of Second Coordinate File :  ',$)
            read (input,250)  xyz2file
  250       format (a240)
            call basefile (xyz2file)
            call suffix (xyz2file,'xyz','old')
            inquire (file=xyz2file,exist=exist)
         end do
      end if
c
c     get optional file with grid points and target potential
c
      if (dotarget) then
         call nextarg (potfile,exist)
         if (exist) then
            call basefile (potfile)
            call suffix (potfile,'pot','old')
            inquire (file=potfile,exist=exist)
         end if
         do while (.not. exist)
            write (iout,260)
  260       format (/,' Enter Target Grid/Potential File Name :  ',$)
            read (input,270)  potfile
  270       format (a240)
            call basefile (potfile)
            call suffix (potfile,'pot','old')
            inquire (file=potfile,exist=exist)
         end do
      end if
c
c     decide whether to output potential at each grid point
c
      dofull = .false.
      if (domodel .or. dopair .or. dotarget) then
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,280)
  280       format (/,' Output Potential Value at Each Grid Point',
     &                 ' [N] :  ',$)
            read (input,290)  record
  290       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  dofull = .true.
      end if
c
c     read grid points where potential will be computed
c
      if (dotarget) then
         ipot = freeunit ()
         open (unit=ipot,file=potfile,status='old')
         rewind (unit=ipot)
         do i = 1, nconf
            call getref (i)
            call readpot (ipot,i)
         end do
         close (unit=ipot)
      end if
c
c     output the number of potential grid points to be used
c
      do i = 1, nconf
         if (i .eq. 1) then
            write (iout,300)
  300       format ()
         end if
         if (npgrid(i) .gt. maxpgrd) then
            write (iout,310)
  310       format (' POTENTIAL  --  Too many Grid Points;',
     &                 ' Increase MAXGRID')
            call fatal
         else if (nconf .eq. 1) then
            write (iout,320)  npgrid(1)
  320       format (' Electrostatic Potential Grid Points :',6x,i16)
         else
            write (iout,330)  i,npgrid(i)
  330       format (' Potential Grid Points for Structure',i4,' :',
     &                 2x,i16)
         end if
      end do
c
c     output grid points at which to compute QM potential
c
      if (dogrid) then
         igrd = freeunit ()
         gridfile = filename(1:leng)
         call suffix (gridfile,'grid','new')
         open (unit=igrd,file=gridfile,status='new')
         do j = 1, nconf
            do i = 1, npgrid(j)
               xi = pgrid(1,i,j)
               yi = pgrid(2,i,j)
               zi = pgrid(3,i,j)
               write (igrd,340)  xi,yi,zi
  340          format (3f15.8)
            end do
         end do
         close (unit=igrd)
         write (iout,350)  gridfile(1:trimtext(gridfile))
  350    format (/,' Gaussian CUBEGEN Input Written To :   ',a)
         write (iout,360)
  360    format (/,' Next, run the Gaussian CUBEGEN program; for',
     &              ' example:',
     &           //,' cubegen 0 potential=MP2 FILE.fchk FILE.cube',
     &              ' -5 h < FILE.grid',
     &           //,' Replace FILE with base file name and MP2 with',
     &              ' density label;',
     &           /,' After CUBEGEN, rerun Tinker POTENTIAL program',
     &              ' using Option 2')
      end if
c
c     get termination criterion for fitting as RMS gradient
c
      if (dofit) then
         grdmin = -1.0d0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=370,end=370)  grdmin
  370    continue
         if (grdmin .le. 0.0d0) then
            write (iout,380)
  380       format (/,' Enter RMS Gradient Termination Criterion',
     &                 ' [0.01] :  ',$)
            read (input,390)  grdmin
  390       format (f20.0)
         end if
         if (grdmin .le. 0.0d0)  grdmin = 0.01d0
      end if
c
c     print the parameter restraint value to be used in fitting
c
      if (dofit) then
         write (iout,400)  wresp
  400    format (/,' Electrostatic Parameter Restraint Value :',f18.4)
      end if
c
c     setup the potential computation for alternative models
c
      if (.not. dogrid) then
         do k = 1, nmodel
            ixyz = freeunit ()
            if (k .eq. 1) then
               call basefile (xyzfile)
               open (unit=ixyz,file=xyzfile,status='old')
            else
               call basefile (xyz2file)
               open (unit=ixyz,file=xyz2file,status='old')
            end if
            rewind (unit=ixyz)
            do j = 1, nconf
               call readxyz (ixyz)
               call makeref (j)
            end do
            close (unit=ixyz)
c
c     get potential for each structure and print statistics
c
            do j = 1, nconf
               call getref (j)
               call field
               call setelect
               if (use_chgflx) then
                  call alterchg
               end if
               if (use_mpole) then
                  call chkpole
                  call rotpole ('MPOLE')
               end if
               if (use_polar) then
                  domlst = .true.
                  doulst = .true.
                  call nblist
                  call induce
               end if
!$OMP          PARALLEL default(private) shared(j,k,npgrid,pgrid,epot)
!$OMP          DO
               do i = 1, npgrid(j)
                  xi = pgrid(1,i,j)
                  yi = pgrid(2,i,j)
                  zi = pgrid(3,i,j)
                  call potpoint (xi,yi,zi,pot)
                  epot(k,i,j) = pot
               end do
!$OMP          END DO
!$OMP          END PARALLEL
            end do
         end do
         call potstat (dofull,domodel,dopair,dotarget)
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (dofit) then
         allocate (fit0(12*namax*nconf))
         allocate (fchg(maxtyp))
         allocate (fpol(13,maxtyp))
         allocate (fcpen(maxclass))
         allocate (fitchg(maxtyp))
         allocate (fitpol(maxtyp))
         allocate (fitcpen(maxclass))
         allocate (vchg(namax,nconf))
         allocate (vpol(13,namax,nconf))
         allocate (vcpen(namax,nconf))
         allocate (varpot(12*namax*nconf))
c
c     perform dynamic allocation of some local arrays
c
         allocate (xx(12*namax*nconf))
         allocate (xlo(12*namax*nconf))
         allocate (xhi(12*namax*nconf))
         allocate (tmpchg(maxtyp))
         allocate (tmppol(maxtyp))
         allocate (tmpcpen(maxclass))
c
c     zero the keyfile length to avoid parameter reprocessing
c
         numkey = nkey
         nkey = 0
c
c     set residual count and optimization parameters with bounds
c
         do j = 1, maxtyp
            fitchg(j) = .false.
            fitpol(j) = .false.
         end do
         do j = 1, maxclass
            fitcpen(j) = .false.
         end do
         nvar = 0
         nresid = 0
         do j = 1, nconf
            call getref (j)
            call setelect
            call setvars (j)
            call prmvar (nvar,xx,j)
            nresid = nresid + npgrid(j)
            if (fit_mpl)  nresid = nresid + 1
            if (use_dpl)  nresid = nresid + 3
            if (use_qpl)  nresid = nresid + 5
         end do
         nresid = nresid + nvar
         do j = 1, nvar
            fit0(j) = xx(j)
            xlo(j) = xx(j) - 1000.0d0
            xhi(j) = xx(j) + 1000.0d0
         end do
c
c     perform dynamic allocation of some local arrays
c
         allocate (gc(nvar))
         allocate (presid(nresid))
         allocate (pjac(nresid,nvar))
c
c     perform potential fit via least squares optimization
c
         nkey = numkey
         call square (nvar,nresid,xlo,xhi,xx,presid,gc,pjac,
     &                      grdmin,fitrsd,potwrt)
         nkey = 0
c
c     set the final electrostatic parameter values
c
         nvar = 0
         do j = 1, maxtyp
            fitchg(j) = .false.
            fitpol(j) = .false.
         end do
         do j = 1, maxclass
            fitcpen(j) = .false.
         end do
         do j = 1, nconf
            call getref (j)
            call setelect
            next = nvar
            do k = 1, maxtyp
               tmpchg(k) = fitchg(k)
               tmppol(k) = fitpol(k)
            end do
            do k = 1, maxclass
               tmpcpen(k) = fitcpen(k)
            end do
            call varprm (nvar,xx,j)
            nvar = next
            do k = 1, maxtyp
               fitchg(k) = tmpchg(k)
               fitpol(k) = tmppol(k)
            end do
            do k = 1, maxclass
               fitcpen(k) = tmpcpen(k)
            end do
            call prmvar (nvar,xx,j)
         end do
c
c     get potential for each structure and print statistics
c
         nvar = 0
         do j = 1, maxtyp
            fitchg(j) = .false.
            fitpol(j) = .false.
         end do
         do j = 1, maxclass
            fitcpen(j) = .false.
         end do
         do j = 1, nconf
            call getref (j)
            call setelect
            call varprm (nvar,xx,j)
            call prmvar (nvar,xx,j)
            if (use_mpole) then
               call chkpole
               call rotpole ('MPOLE')
            end if
            if (use_polar) then
               domlst = .true.
               doulst = .true.
               call nblist
               call induce
            end if
!$OMP       PARALLEL default(private) shared(j,npgrid,pgrid,epot)
!$OMP       DO
            do i = 1, npgrid(j)
               xi = pgrid(1,i,j)
               yi = pgrid(2,i,j)
               zi = pgrid(3,i,j)
               call potpoint (xi,yi,zi,pot)
               epot(1,i,j) = pot
            end do
!$OMP       END DO
!$OMP       END PARALLEL
         end do
         call prtfit
         call potstat (dofull,domodel,dopair,dotarget)
c
c     perform deallocation of some local arrays
c
         deallocate (xx)
         deallocate (xlo)
         deallocate (xhi)
         deallocate (presid)
         deallocate (gc)
         deallocate (pjac)
         deallocate (tmpchg)
         deallocate (tmppol)
         deallocate (tmpcpen)
      end if
c
c     perform any final tasks before program exit
c
  410 continue
      call final
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine readpot  --  get and assign potential grid  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "readpot" gets a set of grid points and target electrostatic
c     potential values from an external file
c
c
      subroutine readpot (ipot,iconf)
      use atoms
      use katoms
      use potfit
      use ptable
      implicit none
      integer i,j,k
      integer ipot,iconf
      integer npoint,atn
      real*8 xi,yi,zi
      real*8 big,small
      real*8 r2,dist
      real*8, allocatable :: rad(:)
      character*240 record
c
c
c     read the grid points and target potential from a file
c
      npoint = 0
      read (ipot,10,err=20,end=20)  record
   10 format (a240)
      read (record,*,err=20,end=20)  npoint
   20 continue
      do i = 1, npoint
         pgrid(1,i,iconf) = 0.0d0
         pgrid(2,i,iconf) = 0.0d0
         pgrid(3,i,iconf) = 0.0d0
         epot(2,i,iconf) = 0.0d0
         read (ipot,30,err=40,end=40)  record
   30    format (a240)
         read (record,*,err=40,end=40)  k,(pgrid(j,i,iconf),j=1,3),
     &                                  epot(2,i,iconf)
   40    continue
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (rad(n))
c
c     set base atomic radii from consensus vdw values
c
      do i = 1, n
         rad(i) = 0.0d0
         atn = atmnum(type(i))
         if (atn .ne. 0)  rad(i) = vdwrad(atn)
         if (rad(i) .eq. 0.0d0)  rad(i) = 1.7d0
      end do
c
c     assign each grid point to atom on molecular surface
c
      big = 1000.0d0
      do i = 1, npoint
         small = big
         xi = pgrid(1,i,iconf)
         yi = pgrid(2,i,iconf)
         zi = pgrid(3,i,iconf)
         do k = 1, n
            r2 = (xi-x(k))**2 + (yi-y(k))**2 + (zi-z(k))**2
            dist = sqrt(r2) - rad(k)
            if (dist .lt. small) then
               small = dist
               ipgrid(i,iconf) = k
            end if
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (rad)
c
c     use potential grid points only for active grid atoms
c
      k = 0
      do i = 1, npoint
         if (gatm(ipgrid(i,iconf))) then
            k = k + 1
            ipgrid(k,iconf) = ipgrid(i,iconf)
            pgrid(1,k,iconf) = pgrid(1,i,iconf)
            pgrid(2,k,iconf) = pgrid(2,i,iconf)
            pgrid(3,k,iconf) = pgrid(3,i,iconf)
            epot(2,k,iconf) = epot(2,i,iconf)
         end if
      end do
      npgrid(iconf) = k
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine potgrid  --  generate shells of grid points  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "potgrid" generates electrostatic potential grid points in
c     radially distributed shells based on the molecular surface
c
c
      subroutine potgrid (iconf)
      use atoms
      use iounit
      use katoms
      use keys
      use math
      use potfit
      use ptable
      implicit none
      integer i,j,k,m
      integer iconf,next
      integer npoint,nshell
      integer maxdot
      integer ndot,atn
      real*8 r2,rfactor
      real*8 roffset
      real*8 spacing
      real*8 density
      real*8 round
      real*8 xi,yi,zi
      real*8 xj,yj,zj
      real*8 xr,yr,zr
      real*8, allocatable :: rad(:)
      real*8, allocatable :: rad2(:)
      real*8, allocatable :: dot(:,:)
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set default values for grid point generation parameters
c
      npoint = 0
      nshell = 4
      maxdot = 50000
      spacing = 0.35d0
      density = 4.0d0 * pi / spacing**2
      rfactor = 1.0d0
      roffset = 1.0d0
      round = 0.000001d0
c
c     check for keywords containing any altered parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:17) .eq. 'POTENTIAL-SHELLS ') then
            read (string,*,err=10,end=10)  nshell
         else if (keyword(1:18) .eq. 'POTENTIAL-SPACING ') then
            read (string,*,err=10,end=10)  spacing
            density = 4.0d0 * pi / spacing**2
         else if (keyword(1:17) .eq. 'POTENTIAL-FACTOR ') then
            read (string,*,err=10,end=10)  rfactor
         else if (keyword(1:17) .eq. 'POTENTIAL-OFFSET ') then
            read (string,*,err=10,end=10)  roffset
         end if
   10    continue
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (rad(n))
      allocate (rad2(n))
c
c     get modified atomic radii from consensus vdw values
c
      do i = 1, n
         atn = atmnum(type(i))
         rad(i) = vdwrad(atn)
         if (rad(i) .eq. 0.0d0)  rad(i) = 1.7d0
         rad(i) = rfactor*rad(i) + roffset
         rad2(i) = rad(i) * rad(i)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (dot(3,maxdot))
c
c     find points on each of the molecular surface shells
c
      do m = 1, nshell
         if (m .ne. 1) then
            do i = 1, n
               rad(i) = rad(i) + spacing
               rad2(i) = rad(i) * rad(i)
            end do
         end if
         do i = 1, n
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ndot = int(density*rad2(i))
            if (ndot .gt. maxdot) then
               write (iout,20)
   20          format (/,' POTGRID  --  Too many Surface Grid',
     &                    ' Points; Increase MAXDOT')
               call fatal
            end if
            call sphere (ndot,dot)
            do j = 1, ndot
               xj = xi + rad(i)*dot(1,j)
               yj = yi + rad(i)*dot(2,j)
               zj = zi + rad(i)*dot(3,j)
               xj = dble(nint(xj/round)) * round
               yj = dble(nint(yj/round)) * round
               zj = dble(nint(zj/round)) * round
               do k = 1, i-1
                  xr = xj - x(k)
                  yr = yj - y(k)
                  zr = zj - z(k)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .lt. rad2(k))  goto 30
               end do
               do k = i+1, n
                  xr = xj - x(k)
                  yr = yj - y(k)
                  zr = zj - z(k)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .lt. rad2(k))  goto 30
               end do
               npoint = npoint + 1
               ipgrid(npoint,iconf) = i
               pgrid(1,npoint,iconf) = xj
               pgrid(2,npoint,iconf) = yj
               pgrid(3,npoint,iconf) = zj
   30          continue
            end do
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (rad)
      deallocate (rad2)
      deallocate (dot)
c
c     use potential grid points only for active grid atoms
c
      k = npoint
      npoint = 0
      do i = 1, k
         if (gatm(ipgrid(i,iconf))) then
            npoint = npoint + 1
            ipgrid(npoint,iconf) = ipgrid(i,iconf)
            pgrid(1,npoint,iconf) = pgrid(1,i,iconf)
            pgrid(2,npoint,iconf) = pgrid(2,i,iconf)
            pgrid(3,npoint,iconf) = pgrid(3,i,iconf)
         end if
      end do
      npgrid(iconf) = npoint
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine setelect  --  assign electrostatic parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "setelect" assigns partial charge, bond dipole and atomic
c     multipole parameters for the current structure, as needed
c     for computation of the electrostatic potential
c
c
      subroutine setelect
      use potent
      implicit none
c
c
c     get connectivity info and make parameter assignments
c
      call attach
      call active
      call bonds
      call angles
      call torsions
      call bitors
      call rings
      call cutoffs
      call katom
      call kcharge
      call kdipole
      call kmpole
      call kpolar
      call kchgtrn
      call kchgflx
c
c     bond and angle parameters are needed if using charge flux
c
      if (use_chgflx) then
         call kbond
         call kangle
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine setvars  --  find nonzero parameters for atoms  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "setvars" finds and stores nonzero partial charge, atomic
c     multipole and charge penetration parameters for each atom of
c     the current structure
c
c
      subroutine setvars (iconf)
      use atoms
      use charge
      use chgpen
      use mplpot
      use mpole
      use potent
      use potfit
      implicit none
      integer i,j,ii
      integer iconf
c
c
c     initialize use of electrostatic parameter types for atoms
c
      do i = 1, n
         vchg(i,iconf) = .false.
         do j = 1, 13
            vpol(j,i,iconf) = .false.
         end do
         vcpen(i,iconf) = .false.
      end do
c
c     set nonzero partial charges as fitting variables
c
      do ii = 1, nion
         i = iion(ii)
         if (use_chgflx) then
            if (pchg0(i) .ne. 0.0d0) then
               vchg(i,iconf) = .true.
            end if
         else
            if (pchg(i) .ne. 0.0d0) then
               vchg(i,iconf) = .true.
            end if
         end if
      end do
c
c     set nonzero atomic multipoles as fitting variables
c
      do ii = 1, npole
         i = ipole(ii)
         if (use_chgflx) then
            if (mono0(i) .ne. 0.0d0) then
               vpol(1,i,iconf) = .true.
            end if
         else
            if (pole(1,i) .ne. 0.0d0) then
               vpol(1,i,iconf) = .true.
            end if
         end if
         do j = 2, 13
            if (pole(j,i) .ne. 0.0d0) then
               vpol(j,i,iconf) = .true.
            end if
         end do
      end do
c
c     set nonzero charge penetration values as fitting variables
c
      if (use_chgpen) then
         do ii = 1, npole
            i = ipole(ii)
            if (palpha(i) .ne. 0.0d0) then
               vcpen(i,iconf) = .true.
            end if
         end do
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine potpoint  --  electrostatic potential at point  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "potpoint" calculates the electrostatic potential at a grid
c     point "i" as the total electrostatic interaction energy of
c     the system with a positive charge located at the grid point
c
c
      subroutine potpoint (xi,yi,zi,pot)
      use atoms
      use charge
      use chgpen
      use chgpot
      use dipole
      use mplpot
      use mpole
      use polar
      use potent
      use units
      implicit none
      integer k,kk,k1,k2
      real*8 e,ei,pot
      real*8 ec,ed,em,ep
      real*8 xi,yi,zi
      real*8 xk,yk,zk
      real*8 xr,yr,zr
      real*8 r,r2,dotk
      real*8 rk2,rkr3
      real*8 rr1,rr3,rr5
      real*8 rr1k,rr3k,rr5k
      real*8 corek,valk
      real*8 alphak
      real*8 f,fi,ci,ck
      real*8 dkx,dky,dkz
      real*8 ukx,uky,ukz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 qkx,qky,qkz
      real*8 dkr,qkr,ukr
      real*8 dmpk(5)
c
c
c     zero out charge, dipole and multipole potential terms
c
      ec = 0.0d0
      ed = 0.0d0
      em = 0.0d0
      ep = 0.0d0
c
c     set charge of probe site and electrostatic constants
c
      f = electric / dielec
      ci = 1.0d0
      fi = f * ci
c
c     calculate the charge contribution to the potential
c
      do kk = 1, nion
         k = iion(kk)
         xr = x(k) - xi
         yr = y(k) - yi
         zr = z(k) - zi
         r2 = xr*xr + yr* yr + zr*zr
         r = sqrt(r2)
         e = fi * pchg(k) / r
         ec = ec + e
      end do
c
c     calculate the bond dipole contribution to the potential
c
      do kk = 1, ndipole
         k1 = idpl(1,kk)
         k2 = idpl(2,kk)
         xk = x(k2) - x(k1)
         yk = y(k2) - y(k1)
         zk = z(k2) - z(k1)
         xr = x(k1) + xk*sdpl(kk) - xi
         yr = y(k1) + yk*sdpl(kk) - yi
         zr = z(k1) + zk*sdpl(kk) - zi
         r2 = xr*xr + yr* yr + zr*zr
         rk2 = xk*xk + yk*yk + zk*zk
         rkr3 = sqrt(rk2*r2) * r2
         dotk = xk*xr + yk*yr + zk*zr
         e = (fi/debye) * bdpl(kk) * dotk / rkr3
         ed = ed + e
      end do
c
c     calculate the multipole contribution to the potential
c
      do kk = 1, npole
         k = ipole(kk)
         xr = x(k) - xi
         yr = y(k) - yi
         zr = z(k) - zi
         r2 = xr*xr + yr* yr + zr*zr
         r = sqrt(r2)
         ck = rpole(1,k)
         dkx = rpole(2,k)
         dky = rpole(3,k)
         dkz = rpole(4,k)
         qkxx = rpole(5,k)
         qkxy = rpole(6,k)
         qkxz = rpole(7,k)
         qkyy = rpole(9,k)
         qkyz = rpole(10,k)
         qkzz = rpole(13,k)
         if (use_polar) then
            ukx = uind(1,k)
            uky = uind(2,k)
            ukz = uind(3,k)
         else
            ukx = 0.0d0
            uky = 0.0d0
            ukz = 0.0d0
         end if
c
c     construct some common multipole and distance values
c
         qkx = qkxx*xr + qkxy*yr + qkxz*zr
         qky = qkxy*xr + qkyy*yr + qkyz*zr
         qkz = qkxz*xr + qkyz*yr + qkzz*zr
         dkr = dkx*xr + dky*yr + dkz*zr
         qkr = qkx*xr + qky*yr + qkz*zr
         ukr = ukx*xr + uky*yr + ukz*zr
         rr1 = 1.0d0 / r
         rr3 = rr1 / r2
         rr5 = 3.0d0 * rr3 / r2
c
c     compute the potential contributions for this site
c
         if (use_chgpen) then
            corek = pcore(k)
c           valk = pval(k)
            valk = -corek + rpole(1,k)
            alphak = palpha(k)
            call damppot (r,alphak,dmpk)
            rr1k = dmpk(1) * rr1
            rr3k = dmpk(3) * rr3
            rr5k = dmpk(5) * rr5
            e = corek*rr1 + valk*rr1k - dkr*rr3k + qkr*rr5k
         else
            e = ck*rr1 - dkr*rr3 + qkr*rr5
         end if
         ei = -ukr * rr3
c
c     increment the overall multipole and polarization terms
c
         e = fi * e
         ei = fi * ei
         em = em + e
         ep = ep + ei
      end do
c
c     potential is sum of all interactions with probe site
c
      pot = ec + ed + em + ep
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine fitrsd  --  residual values for potential fit  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "fitrsd" computes residuals for electrostatic potential fitting
c     including total charge restraints, dipole and quadrupole moment
c     targets, and restraints on initial parameter values
c
c
      subroutine fitrsd (nvar,nresid,xx,resid)
      use atoms
      use keys
      use moment
      use mpole
      use neigh
      use potent
      use potfit
      use units
      implicit none
      integer i,j,nvar
      integer nresid
      integer npoint
      integer iresid
      integer numkey
      real*8 xi,yi,zi
      real*8 pot,pval
      real*8 tscale,cscale
      real*8 pscale,rscale
      real*8 rconf,ratio
      real*8 dterm,qterm
      real*8 xx(*)
      real*8 resid(*)
      character*6 mode
c
c
c     initialize least squares residuals and scaling factors
c
      npoint = 0
      do j = 1, nconf
         npoint = npoint + npgrid(j)
      end do
      do j = 1, nresid
         resid(j) = 0.0d0
      end do
      tscale = 300.0d0
      cscale = 10000.0d0
      pscale = 10.0d0
c
c     set electrostatic potential weight vs. parameter restraints
c
      rconf = dble(nconf)
      ratio = dble(npoint) / dble(nvar*nconf)
      rscale = 2.2d0 * sqrt(wresp) * rconf * sqrt(ratio)
c     rscale = 0.18d0 * sqrt(wresp) * rconf * ratio
c     rscale = 0.015d0 * sqrt(wresp) * rconf * sqrt(ratio**3)
c
c     initialize counters for parameters and residual components
c
      nvar = 0
      iresid = 0
      do j = 1, maxtyp
         fitchg(j) = .false.
         fitpol(j) = .false.
      end do
      do j = 1, maxclass
         fitcpen(j) = .false.
      end do
c
c     zero the keyfile length to avoid parameter reprocessing
c
      numkey = nkey
      nkey = 0
c
c     find least squares residuals via loop over conformations
c
      do j = 1, nconf
         call getref (j)
         call setelect
         call varprm (nvar,xx,j)
         if (use_mpole)  call rotpole ('MPOLE')
         if (use_polar) then
            domlst = .true.
            doulst = .true.
            call nblist
            call induce
         end if
c
c     get residuals due to potential error over grid points
c
!$OMP    PARALLEL default(private)
!$OMP&    shared(j,npgrid,pgrid,epot,iresid,resid,rconf)
!$OMP    DO
         do i = 1, npgrid(j)
            xi = pgrid(1,i,j)
            yi = pgrid(2,i,j)
            zi = pgrid(3,i,j)
            call potpoint (xi,yi,zi,pot)
            epot(1,i,j) = pot
            resid(iresid+i) = epot(1,i,j) - epot(2,i,j)
         end do
!$OMP    END DO
!$OMP    END PARALLEL
         iresid = iresid + npgrid(j)
c
c     find moments if they contribute to the overall residual
c
         if (fit_mpl .or. use_dpl .or. use_qpl) then
            mode = 'FULL'
            call moments (mode)
         end if
c
c     get residual due to total molecular charge restraint
c
         if (fit_mpl) then
            iresid = iresid + 1
            resid(iresid) = (netchg-dble(nint(netchg))) * cscale
         end if
c
c     get residuals from dipole and quadrupole target violations
c
         if (use_dpl) then
            resid(iresid+1) = (xdpl-xdpl0(j)) * tscale
            resid(iresid+2) = (ydpl-ydpl0(j)) * tscale
            resid(iresid+3) = (zdpl-zdpl0(j)) * tscale
            iresid = iresid + 3
         end if
         if (use_qpl) then
            resid(iresid+1) = (xxqpl-xxqpl0(j)) * tscale
            resid(iresid+2) = (xyqpl-xyqpl0(j)) * tscale
            resid(iresid+3) = (xzqpl-xzqpl0(j)) * tscale
            resid(iresid+4) = (yyqpl-yyqpl0(j)) * tscale
            resid(iresid+5) = (yzqpl-yzqpl0(j)) * tscale
            resid(iresid+6) = (zzqpl-zzqpl0(j)) * tscale
            iresid = iresid + 6
         end if
      end do
c
c     scaling factors for dipole and quadrupole residuals
c
      dterm = 1.0d0
      qterm = 1.0d0
c     dterm = 1.0d0 / bohr
c     qterm = 3.0d0 / bohr**2
c
c     get residuals due to restraints on parameter values
c
      do i = 1, nvar
         iresid = iresid + 1
         if (varpot(i) .ne. 'CHGPEN') then
            if (resptyp .eq. 'ORIG') then
               resid(iresid) = (xx(i)-fit0(i)) * rscale
            else if (resptyp .eq. 'ZERO') then
               resid(iresid) = xx(i) * rscale
            else
               resid(iresid) = 0.0d0
            end if
            if (varpot(i) .eq. 'DIPOLE') then
               resid(iresid) = resid(iresid) / dterm
            else if (varpot(i) .eq. 'QUADPL') then
               resid(iresid) = resid(iresid) / qterm
            end if
         end if
         if (varpot(i) .eq. 'CHGPEN') then
            pval = max(xx(i)-6.5d0,2.5d0-xx(i),0.0d0)
            resid(iresid) = pval * pscale
         end if
      end do
c
c     reset the keyfile length to its original value
c
      nkey = numkey
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine varprm  --  optimization to electrostatics  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "varprm" copies the current optimization values into the
c     corresponding electrostatic potential energy parameters
c
c
      subroutine varprm (nvar,xx,iconf)
      use atomid
      use atoms
      use charge
      use chgpen
      use mplpot
      use mpole
      use potent
      use potfit
      use units
      implicit none
      integer i,j,ii
      integer it,ic
      integer nvar,iconf
      real*8 dterm,qterm
      real*8 xx(*)
      logical done
c
c
c     translate optimization values back to partial charges
c
      do ii = 1, nion
         done = .true.
         i = iion(ii)
         it = type(i)
         if (fatm(i))  done = .false.
         if (.not. done) then
            if (fitchg(it)) then
               done = .true.
               if (use_chgflx) then
                  pchg0(i) = fchg(it)
               else
                  pchg(i) = fchg(it)
               end if
            end if
         end if
         if (.not. done) then
            fitchg(it) = .true.
            if (use_chgflx) then
               if (vchg(i,iconf)) then
                  nvar = nvar + 1
                  pchg0(i) = xx(nvar)
               end if
               fchg(it) = pchg0(i)
            else
               if (vchg(i,iconf)) then
                  nvar = nvar + 1
                  pchg(i) = xx(nvar)
               end if
               fchg(it) = pchg(i)
            end if
         end if
      end do
c
c     conversion factors for dipole and quadrupole moments
c
      dterm = bohr
      qterm = bohr**2 / 3.0d0
c
c     translate optimization values back to atomic multipoles
c
      do ii = 1, npole
         done = .true.
         i = ipole(ii)
         it = type(i)
         if (fatm(i))  done = .false.
         if (.not. done) then
            if (fitpol(it)) then
               done = .true.
               if (use_chgflx) then
                  mono0(i) = fpol(1,it)
               else
                  pole(1,i) = fpol(1,it)
               end if
               do j = 2, 13
                  pole(j,i) = fpol(j,it)
               end do
            end if
         end if
         if (.not. done) then
            if (use_chgflx) then
               if (fit_mpl .and. vpol(1,i,iconf)) then
                  nvar = nvar + 1
                  mono0(i) = xx(nvar)
               end if
            else
               if (fit_mpl .and. vpol(1,i,iconf)) then
                  nvar = nvar + 1
                  pole(1,i) = xx(nvar)
               end if
            end if
            if (fit_dpl .and. vpol(2,i,iconf) .and. fxdpl(i)) then
               nvar = nvar + 1
               pole(2,i) = dterm * xx(nvar)
            end if
            if (fit_dpl .and. vpol(3,i,iconf) .and. fydpl(i)) then
               nvar = nvar + 1
               pole(3,i) = dterm * xx(nvar)
            end if
            if (fit_dpl .and. vpol(4,i,iconf) .and. fzdpl(i)) then
               nvar = nvar + 1
               pole(4,i) = dterm * xx(nvar)
            end if
            if (fit_qpl .and. vpol(5,i,iconf)) then
               if (polaxe(i) .ne. 'Z-Only') then
                  nvar = nvar + 1
                  pole(5,i) = qterm * xx(nvar)
               end if
            end if
            if (fit_qpl .and. vpol(6,i,iconf)) then
               nvar = nvar + 1
               pole(6,i) = qterm * xx(nvar)
               pole(8,i) = qterm * xx(nvar)
            end if
            if (fit_qpl .and. vpol(7,i,iconf)) then
               nvar = nvar + 1
               pole(7,i) = qterm * xx(nvar)
               pole(11,i) = qterm * xx(nvar)
            end if
            if (fit_qpl .and. vpol(9,i,iconf)) then
               if (polaxe(i) .ne. 'Z-Only') then
                  nvar = nvar + 1
                  pole(9,i) = qterm * xx(nvar)
               end if
            end if
            if (fit_qpl .and. vpol(10,i,iconf)) then
               nvar = nvar + 1
               pole(10,i) = qterm * xx(nvar)
               pole(12,i) = qterm * xx(nvar)
            end if
            if (fit_qpl .and. vpol(13,i,iconf)) then
               if (polaxe(i) .eq. 'Z-Only') then
                  nvar = nvar + 1
                  pole(13,i) = qterm * xx(nvar)
                  pole(5,i) = -0.5d0 * pole(13,i)
                  pole(9,i) = pole(5,i)
               else
                  pole(13,i) = -pole(5,i) - pole(9,i)
               end if
            end if
            fitpol(it) = .true.
            if (use_chgflx) then
               fpol(1,it) = mono0(i)
            else
               fpol(1,it) = pole(1,i)
            end if
            do j = 2, 13
               fpol(j,it) = pole(j,i)
            end do
         end if
      end do
c
c     translate optimization values back to charge penetration
c
      if (use_chgpen) then
         do ii = 1, npole
            done = .true.
            i = ipole(ii)
            ic = class(i)
            if (fatm(i))  done = .false.
            if (.not. done) then
               if (fitcpen(ic)) then
                  done = .true.
                  palpha(i) = fcpen(ic)
               end if
            end if
            if (.not. done) then
               if (fit_chgpen .and. vcpen(i,iconf)) then
                  nvar = nvar + 1
                  palpha(i) = xx(nvar)
               end if
               fitcpen(ic) = .true.
               fcpen(ic) = palpha(i)
            end if
         end do
      end if
c
c     check chiral multipoles and rotate into global frame
c
      if (use_mpole) then
         call chkpole
         call rotpole ('MPOLE')
      end if
c
c     modify partial charges and monopoles for charge flux
c
      if (use_chgflx)  call alterchg
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine prmvar  --  electrostatics to optimization  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "prmvar" determines the optimization values from the
c     corresponding electrostatic potential energy parameters
c
c
      subroutine prmvar (nvar,xx,iconf)
      use atomid
      use atoms
      use charge
      use chgpen
      use iounit
      use mplpot
      use mpole
      use potent
      use potfit
      use units
      implicit none
      integer i,j,k,m
      integer ii,it,ic
      integer ktype
      integer nvar,iconf
      integer, allocatable :: equiv(:)
      real*8 dterm,qterm
      real*8 eps,sum,big
      real*8 ival,kval
      real*8 xx(*)
      logical done
      character*18 prmtyp
c
c
c     conversion factors for dipole and quadrupole moments
c
      dterm = 1.0d0 / bohr
      qterm = 3.0d0 / bohr**2
c
c     regularize charges, monopoles and diagonal quadrupoles
c
      eps = 0.00001d0
      do ii = 1, nion
         i = iion(ii)
         pchg(i) = dble(nint(pchg(i)/eps)) * eps
         pchg0(i) = dble(nint(pchg0(i)/eps)) * eps
      end do
      do ii = 1, npole
         i = ipole(ii)
         pole(1,i) = dble(nint(pole(1,i)/eps)) * eps
         pole(5,i) = dble(nint(qterm*pole(5,i)/eps)) * eps/qterm
         pole(9,i) = dble(nint(qterm*pole(9,i)/eps)) * eps/qterm
         pole(13,i) = dble(nint(qterm*pole(13,i)/eps)) * eps/qterm
         mono0(i) = dble(nint(mono0(i)/eps)) * eps
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (equiv(maxtyp))
c
c     enforce integer net charge over partial charges
c
      ktype = 0
      kval = 0
      sum = 0.0d0
      do i = 1, maxtyp
         equiv(i) = 0
      end do
      do ii = 1, nion
         i = iion(ii)
         it = type(i)
         equiv(it) = equiv(it) + 1
         if (use_chgflx) then
            sum = sum + pchg0(i)
         else
            sum = sum + pchg(i)
         end if
      end do
      sum = sum - dble(nint(sum))
      k = nint(abs(sum)/eps)
      do j = 1, k
         m = k / j
         if (k .eq. m*j) then
            do ii = 1, nion
               i = iion(ii)
               it = type(i)
               if (equiv(it) .eq. m) then
                  if (use_chgflx) then
                     ival = abs(pchg0(i))
                  else
                     ival = abs(pchg(i))
                  end if
                  if (ktype .eq. 0) then
                     ktype = it
                     kval = ival
                  else if (ival .gt. kval) then
                     ktype = it
                     kval = ival
                  end if
               end if
            end do
         end if
         if (ktype .ne. 0)  goto 10
      end do
   10 continue
      if (ktype .ne. 0) then
         sum = sum / dble(m)
         do ii = 1, nion
            i = iion(ii)
            it = type(i)
            if (it .eq. ktype) then
               if (use_chgflx) then
                  pchg0(i) = pchg0(i) - sum
                  fchg(it) = pchg0(i)
               else
                  pchg(i) = pchg(i) - sum
                  fchg(it) = pchg(i)
               end if
            end if
         end do
      end if
c
c     enforce integer net charge over atomic monopoles
c
      ktype = 0
      kval = 0
      sum = 0.0d0
      do i = 1, maxtyp
         equiv(i) = 0
      end do
      do ii = 1, npole
         i = ipole(ii)
         it = type(i)
         equiv(it) = equiv(it) + 1
         if (use_chgflx) then
            sum = sum + mono0(i)
         else
            sum = sum + pole(1,i)
         end if
      end do
      sum = sum - dble(nint(sum))
      k = nint(abs(sum)/eps)
      do j = 1, k
         m = k / j
         if (k .eq. m*j) then
            do ii = 1, npole
               i = ipole(ii)
               it = type(i)
               if (equiv(it) .eq. m) then
                  if (use_chgflx) then
                     ival = abs(mono0(i))
                  else
                     ival = abs(pole(1,i))
                  end if
                  if (ktype .eq. 0) then
                     ktype = it
                     kval = ival
                  else if (ival .gt. kval) then
                     ktype = it
                     kval = ival
                  end if
               end if
            end do
         end if
         if (ktype .ne. 0)  goto 20
      end do
   20 continue
      if (ktype .ne. 0) then
         sum = sum / dble(m)
         do ii = 1, npole
            i = ipole(ii)
            it = type(i)
            if (it .eq. ktype) then
               if (use_chgflx) then
                  mono0(i) = mono0(i) - sum
                  fpol(1,it) = mono0(i)
               else
                  pole(1,i) = pole(1,i) - sum
                  fpol(1,it) = pole(1,i)
               end if
            end if
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (equiv)
c
c     enforce traceless quadrupole at each multipole site
c
      do ii = 1, npole
         i = ipole(ii)
         sum = pole(5,i) + pole(9,i) + pole(13,i)
         big = max(abs(pole(5,i)),abs(pole(9,i)),abs(pole(13,i)))
         k = 0
         if (big .eq. abs(pole(5,i)))  k = 5
         if (big .eq. abs(pole(9,i)))  k = 9
         if (big .eq. abs(pole(13,i)))  k = 13
         if (k .ne. 0) then
            it = type(ipole(i))
            pole(k,i) = pole(k,i) - sum
            fpol(k,it) = pole(k,i)
         end if
      end do
c
c     list active atoms when not all are used in optimization
c
      if (nconf.eq.1 .and. nfatm.ne.n) then
         write (iout,30)
   30    format (/,' Atomic Parameters Included in Potential Fitting :',
     &           //,3x,'Atom',10x,'Atom Name',6x,'Atom Type/Class',
     &              6x,'Parameters',/)
         do ii = 1, nion
            i = iion(ii)
            if (fatm(i)) then
               it = type(i)
               prmtyp = 'Partial Charge'
               write (iout,40)  i,name(i),it,prmtyp
   40          format (i6,15x,a3,7x,i6,' Type',11x,a)
            end if
         end do
         do ii = 1, npole
            i = ipole(ii)
            if (fatm(i)) then
               it = type(i)
               prmtyp = 'Atomic Multipoles'
               write (iout,50)  i,name(i),it,prmtyp
   50          format (i6,15x,a3,7x,i6,' Type',11x,a)
            end if
         end do
         if (fit_chgpen) then
            do ii = 1, npole
               i = ipole(ii)
               if (fatm(i)) then
                  ic = class(i)
                  prmtyp = 'Charge Penetration'
                  write (iout,60)  i,name(i),ic,prmtyp
   60             format (i6,15x,a3,7x,i6,' Class',10x,a)
               end if
            end do
         end if
      end if
c
c     print header information for electrostatic parameters
c
      if (nvar .eq. 0) then
         write (iout,70)
   70    format (/,' Potential Fitting of Electrostatic Parameters :',
     &           //,1x,'Parameter',5x,'Atom Type/Class',6x,'Category',
     &              10x,'Value',9x,'Fixed',/)
      end if
c
c     get optimization parameters from partial charge values
c
      do ii = 1, nion
         done = .true.
         i = iion(ii)
         it = type(i)
         if (fatm(i))  done = .false.
         if (.not. done) then
            if (fitchg(it))  done = .true.
            fitchg(it) = .true.
         end if
         if (.not. done) then
            if (vchg(i,iconf)) then
               nvar = nvar + 1
               varpot(nvar) = 'CHARGE'
               if (use_chgflx) then
                  xx(nvar) = pchg0(i)
               else
                  xx(nvar) = pchg(i)
               end if
               write (iout,80)  nvar,it,'Charge  ',xx(nvar)
   80          format (i6,7x,i8,' Type',10x,a8,4x,f12.5)
            else
               write (iout,90)  it,'Charge  ',pchg0(i)
   90          format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X')
            end if
         end if
      end do
c
c     get optimization parameters from atomic multipole values
c
      do ii = 1, npole
         done = .true.
         i = ipole(ii)
         it = type(i)
         if (fatm(i))  done = .false.
         if (.not. done) then
            if (fitpol(it))  done = .true.
            fitpol(it) = .true.
         end if
         if (.not. done) then
            if (fit_mpl .and. vpol(1,i,iconf)) then
               nvar = nvar + 1
               varpot(nvar) = 'MONOPL'
               if (use_chgflx) then
                  xx(nvar) = mono0(i)
               else
                  xx(nvar) = pole(1,i)
               end if
               write (iout,100)  nvar,it,'Monopole',xx(nvar)
  100          format (i6,7x,i8,' Type',10x,a8,4x,f12.5)
            else
               write (iout,110)  it,'Monopole',mono0(i)
  110          format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X')
            end if
            if (fit_dpl .and. vpol(2,i,iconf) .and. fxdpl(i)) then
               nvar = nvar + 1
               varpot(nvar) = 'DIPOLE'
               xx(nvar) = dterm * pole(2,i)
               write (iout,120)  nvar,it,'X-Dipole',xx(nvar)
  120          format (i6,7x,i8,' Type',10x,a8,4x,f12.5)
            else
               write (iout,130)  it,'X-Dipole',dterm*pole(2,i)
  130          format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X')
            end if
            if (fit_dpl .and. vpol(3,i,iconf) .and. fydpl(i)) then
               nvar = nvar + 1
               varpot(nvar) = 'DIPOLE'
               xx(nvar) = dterm * pole(3,i)
               write (iout,140)  nvar,it,'Y-Dipole',xx(nvar)
  140          format (i6,7x,i8,' Type',10x,a8,4x,f12.5)
            else
               write (iout,150)  it,'Y-Dipole',dterm*pole(3,i)
  150          format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X')
            end if
            if (fit_dpl .and. vpol(4,i,iconf) .and. fzdpl(i)) then
               nvar = nvar + 1
               varpot(nvar) = 'DIPOLE'
               xx(nvar) = dterm * pole(4,i)
               write (iout,160)  nvar,it,'Z-Dipole',xx(nvar)
  160          format (i6,7x,i8,' Type',10x,a8,4x,f12.5)
            else
               write (iout,170)  it,'Z-Dipole',dterm*pole(4,i)
  170          format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X')
            end if
            if (fit_qpl .and. vpol(5,i,iconf)) then
               if (polaxe(i) .ne. 'Z-Only') then
                  nvar = nvar + 1
                  varpot(nvar) = 'QUADPL'
                  xx(nvar) = qterm * pole(5,i)
                  write (iout,180)  nvar,it,'XX-Quad ',xx(nvar)
  180             format (i6,7x,i8,' Type',10x,a8,4x,f12.5)
               else
                  write (iout,190)    it,'XX-Quad ',qterm*pole(5,i)
  190             format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5)
               end if
            else
               write (iout,200)  it,'XX-Quad ',qterm*pole(5,i)
  200          format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X')
            end if
            if (fit_qpl .and. vpol(6,i,iconf)) then
               nvar = nvar + 1
               varpot(nvar) = 'QUADPL'
               xx(nvar) = qterm * pole(6,i)
               write (iout,210)  nvar,it,'XY-Quad ',xx(nvar)
  210          format (i6,7x,i8,' Type',10x,a8,4x,f12.5)
            else
               write (iout,220)  it,'XY-Quad ',qterm*pole(6,i)
  220          format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X')
            end if
            if (fit_qpl .and. vpol(7,i,iconf)) then
               nvar = nvar + 1
               varpot(nvar) = 'QUADPL'
               xx(nvar) = qterm * pole(7,i)
               write (iout,230)  nvar,it,'XZ-Quad ',xx(nvar)
  230          format (i6,7x,i8,' Type',10x,a8,4x,f12.5)
            else
               write (iout,240)  it,'XZ-Quad ',qterm*pole(7,i)
  240          format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X')
            end if
            if (fit_qpl .and. vpol(9,i,iconf)) then
               if (polaxe(i) .ne. 'Z-Only') then
                  nvar = nvar + 1
                  varpot(nvar) = 'QUADPL'
                  xx(nvar) = qterm * pole(9,i)
                  write (iout,250)  nvar,it,'YY-Quad ',xx(nvar)
  250             format (i6,7x,i8,' Type',10x,a8,4x,f12.5)
               else
                  write (iout,260)  it,'YY-Quad ',qterm*pole(9,i)
  260             format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5)
               end if
            else
               write (iout,270)  it,'YY-Quad ',qterm*pole(9,i)
  270          format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X')
            end if
            if (fit_qpl .and. vpol(10,i,iconf)) then
               nvar = nvar + 1
               varpot(nvar) = 'QUADPL'
               xx(nvar) = qterm * pole(10,i)
               write (iout,280)  nvar,it,'YZ-Quad ',xx(nvar)
  280          format (i6,7x,i8,' Type',10x,a8,4x,f12.5)
            else
               write (iout,290)  it,'YZ-Quad ',qterm*pole(10,i)
  290          format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X')
            end if
            if (fit_qpl .and. vpol(13,i,iconf)) then
               if (polaxe(i) .eq. 'Z-Only') then
                  nvar = nvar + 1
                  varpot(nvar) = 'QUADPL'
                  xx(nvar) = qterm * pole(13,i)
                  write (iout,300)  nvar,it,'ZZ-Quad ',xx(nvar)
  300             format (i6,7x,i8,' Type',10x,a8,4x,f12.5)
               else
                  write (iout,310)  it,'ZZ-Quad ',qterm*pole(13,i)
  310             format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5)
               end if
            else
               write (iout,320)  it,'ZZ-Quad ',qterm*pole(13,i)
  320          format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X')
            end if
         end if
      end do
c
c     get optimization parameters from charge penetration values
c
      if (use_chgpen) then
         do ii = 1, npole
            done = .true.
            i = ipole(ii)
            ic = class(i)
            if (fatm(i))  done = .false.
            if (.not. done) then
               if (fitcpen(ic))  done = .true.
               fitcpen(ic) = .true.
            end if
            if (.not. done) then
               if (fit_chgpen .and. vcpen(i,iconf)) then
                  nvar = nvar + 1
                  varpot(nvar) = 'CHGPEN'
                  xx(nvar) = palpha(i)
                  write (iout,330)  nvar,ic,'ChgPen  ',xx(nvar)
  330             format (i6,7x,i8,' Class',9x,a8,4x,f12.5)
               else
                  write (iout,340)  ic,'ChgPen  ',palpha(i)
  340             format (4x,'--',7x,i8,' Class',9x,a8,4x,f12.5,10x,'X')
               end if
            end if
         end do
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine potstat  --  electrostatic potential statistics  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "potstat" computes and prints statistics for the electrostatic
c     potential over a set of grid points
c
c
      subroutine potstat (dofull,domodel,dopair,dotarget)
      use atoms
      use files
      use iounit
      use potfit
      use refer
      use titles
      implicit none
      integer i,j,k
      integer ipot,npoint
      integer freeunit
      integer trimtext
      integer, allocatable :: natm(:)
      real*8 xi,yi,zi
      real*8 pave1,pave2
      real*8 mave1,mave2
      real*8 tave,uave,rmsd
      real*8, allocatable :: patm1(:)
      real*8, allocatable :: patm2(:)
      real*8, allocatable :: rmsa(:)
      logical dofull,domodel
      logical dopair,dotarget
      character*240 potfile
c
c
c     output potential values for each model at each point
c
      if (dofull) then
         if (domodel) then
            ipot = freeunit ()
            potfile = filename(1:leng)//'.pot'
            call version (potfile,'new')
            open (unit=ipot,file=potfile,status='new')
         end if
         do j = 1, nconf
            if (nconf .eq. 1) then
               write (iout,10)
   10          format (/,' Electrostatic Potential at Each Grid',
     &                    ' Point :',
     &                 /,8x,'(Kcal/mole per unit charge)')
            else
               write (iout,20)  j
   20          format (/,' Electrostatic Potential at Grid Points',
     &                    ' for Structure',i4,' :',
     &                 /,12x,'(Kcal/mole per unit charge)')
            end if
            if (dotarget) then
               write (iout,30)
   30          format (/,3x,'Point',15x,'XYZ-Coordinates',15x,
     &                    'Potential',5x,'Target',/)
            else if (dopair) then
               write (iout,40)
   40          format (/,3x,'Point',15x,'XYZ-Coordinates',13x,
     &                    'Potential 1',3x,'Potential 2',/)
            else if (domodel) then
               write (iout,50)
   50          format (/,3x,'Point',15x,'XYZ-Coordinates',14x,
     &                    'Potential',/)
               write (ipot,60)  npgrid(j),title(1:ltitle)
   60          format (i8,2x,a)
            end if
            do i = 1, npgrid(j)
               xi = pgrid(1,i,j)
               yi = pgrid(2,i,j)
               zi = pgrid(3,i,j)
               if (dotarget .or. dopair) then
                  write (iout,70)  i,xi,yi,zi,epot(1,i,j),epot(2,i,j)
   70             format (i8,3x,3f12.6,2x,2f12.4)
               else if (domodel) then
                  write (iout,80)  i,xi,yi,zi,epot(1,i,j)
   80             format (i8,3x,3f12.6,2x,f12.4)
                  write (ipot,90)  i,xi,yi,zi,epot(1,i,j)
   90             format (i8,3x,3f12.6,2x,f12.4)
               end if
            end do
         end do
         if (domodel) then
            close (unit=ipot)
            write (iout,100)  potfile(1:trimtext(potfile))
  100       format (/,' Electrostatic Potential Written To :  ',a)
         end if
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (natm(namax))
      allocate (patm1(namax))
      allocate (patm2(namax))
      allocate (rmsa(namax))
c
c     find average electrostatic potential around each atom
c
      write (iout,110)
  110 format (/,' Average Electrostatic Potential over Atoms :',
     &        /,6x,'(Kcal/mole per unit charge)')
      if (dotarget) then
         write (iout,120)
  120    format (/,3x,'Structure',3x,'Atom',6x,'Points',
     &              6x,'Potential',8x,'Target',8x,'RMS Diff',/)
      else if (dopair) then
         write (iout,130)
  130    format (/,3x,'Structure',3x,'Atom',6x,'Points',
     &              5x,'Potential 1',4x,'Potential 2',6x,'RMS Diff',/)
      else if (domodel) then
         write (iout,140)
  140    format (/,3x,'Structure',3x,'Atom',5x,'Points',
     &              6x,'Potential',/)
      end if
      do j = 1, nconf
         call getref (j)
         do i = 1, n
            natm(i) = 0
            patm1(i) = 0.0d0
            patm2(i) = 0.0d0
            rmsa(i) = 0.0d0
         end do
         do i = 1, npgrid(j)
            k = ipgrid(i,j)
            natm(k) = natm(k) + 1
            patm1(k) = patm1(k) + epot(1,i,j)
            patm2(k) = patm2(k) + epot(2,i,j)
            rmsa(k) = rmsa(k) + (epot(1,i,j)-epot(2,i,j))**2
         end do
         do i = 1, n
            if (natm(i) .ne. 0) then
               patm1(i) = patm1(i) / dble(natm(i))
               patm2(i) = patm2(i) / dble(natm(i))
               rmsa(i) = sqrt(rmsa(i)/dble(natm(i)))
            end if
            if (gatm(i)) then
               if (dotarget .or. dopair) then
                  write (iout,150)  j,i,natm(i),patm1(i),
     &                              patm2(i),rmsa(i)
  150             format (2i9,3x,i9,3x,f12.4,3x,f12.4,3x,f12.4)
               else if (domodel) then
                  write (iout,160)  j,i,natm(i),patm1(i)
  160             format (2i9,3x,i9,3x,f12.4)
               end if
            end if
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (natm)
      deallocate (patm1)
      deallocate (patm2)
      deallocate (rmsa)
c
c     overall averages for the sets of electrostatic potentials
c
      npoint = 0
      pave1 = 0.0d0
      pave2 = 0.0d0
      mave1 = 0.0d0
      mave2 = 0.0d0
      tave = 0.0d0
      uave = 0.0d0
      rmsd = 0.0d0
      do j = 1, nconf
         npoint = npoint + npgrid(j)
         do i = 1, npgrid(j)
            pave1 = pave1 + epot(1,i,j)
            pave2 = pave2 + epot(2,i,j)
            mave1 = mave1 + abs(epot(1,i,j))
            mave2 = mave2 + abs(epot(2,i,j))
            tave = tave + epot(1,i,j) - epot(2,i,j)
            uave = uave + abs(epot(1,i,j)-epot(2,i,j))
            rmsd = rmsd + (epot(1,i,j)-epot(2,i,j))**2
         end do
      end do
      pave1 = pave1 / dble(npoint)
      pave2 = pave2 / dble(npoint)
      mave1 = mave1 / dble(npoint)
      mave2 = mave2 / dble(npoint)
      tave = tave / dble(npoint)
      uave = uave / dble(npoint)
      rmsd = sqrt(rmsd/dble(npoint))
      if (dopair) then
         write (iout,170)  pave1,mave1
  170    format (/,' Electrostatic Potential over all Grid Points :',
     &           //,' Average Potential Value for Model 1 :',10x,f12.4,
     &           /,' Average Potential Magnitude for Model 1 :',
     &              6x,f12.4)
      else
         write (iout,180)  pave1,mave1
  180    format (/,' Electrostatic Potential over all Grid Points :',
     &           //,' Average Potential Value for Model :',12x,f12.4,
     &           /,' Average Potential Magnitude for Model :',8x,f12.4)
      end if
      if (dotarget) then
         write (iout,190)  pave2,mave2,tave,uave,rmsd
  190    format (' Average Potential Value for Target :',11x,f12.4,
     &           /,' Average Potential Magnitude for Target :',7x,f12.4,
     &           //,' Average Signed Potential Difference :',10x,f12.4,
     &           /,' Average Unsigned Potential Difference :',8x,f12.4,
     &           /,' Root Mean Square Potential Difference :',8x,f12.4)
      else if (dopair) then
         write (iout,200)  pave2,mave2,tave,uave,rmsd
  200    format (' Average Potential Value for Model 2 :',10x,f12.4,
     &           /,' Average Potential Magnitude for Model 2 :',
     &              6x,f12.4,
     &           //,' Average Signed Potential Difference :',10x,f12.4,
     &           /,' Average Unsigned Potential Difference :',8x,f12.4,
     &           /,' Root Mean Square Potential Difference :',8x,f12.4)
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine prtfit  --  create file with optimal parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "prtfit" makes a key file containing results from fitting a
c     charge or multipole model to an electrostatic potential grid
c
c
      subroutine prtfit
      use atomid
      use atoms
      use charge
      use chgpen
      use files
      use keys
      use mpole
      use potfit
      use units
      implicit none
      integer i,j,k,m
      integer ii,it,ic
      integer ix,iy,iz
      integer ikey,size
      integer ntot
      integer freeunit
      integer trimtext
      real*8 dterm,qterm
      logical done,header
      character*4 pa,pb,pc,pd
      character*16, allocatable :: pt(:)
      character*240 keyfile
      character*240 record
c
c
c     reread the contents of any previously existing keyfile
c
      call getkey
c
c     open a new keyfile to contain the optimized parameters
c
      ikey = freeunit ()
      keyfile = filename(1:leng)//'.key'
      call version (keyfile,'new')
      open (unit=ikey,file=keyfile,status='new')
c
c     copy the contents of any previously existing keyfile
c
      do i = 1, nkey
         record = keyline(i)
         size = trimtext (record)
         write (ikey,10)  record(1:size)
   10    format (a)
      end do
c
c     zero the keyfile length to avoid parameter reprocessing
c
      nkey = 0
c
c     output optimized partial charge values to the keyfile
c
      header = .true.
      do i = 1, maxtyp
         fitchg(i) = .false.
      end do
      do k = 1, nconf
         call getref (k)
         call setelect
         do ii = 1, nion
            done = .true.
            i = iion(ii)
            it = type(i)
            if (fatm(i))  done = .false.
            if (.not. done) then
               if (fitchg(it))  done = .true.
               fitchg(it) = .true.
            end if
            if (.not. done) then
               pchg(i) = fchg(it)
               if (header) then
                  header = .false.
                  write (ikey,20)
   20             format (/,'#',/,'# Charges from Electrostatic',
     &                       ' Potential Fitting',/,'#',/)
               end if
               write (ikey,30)  it,pchg(i)
   30          format ('charge',4x,i5,10x,f11.4)
            end if
         end do
      end do
c
c     conversion factors for dipole and quadrupole moments
c
      dterm = 1.0d0 / bohr
      qterm = 3.0d0 / bohr**2
c
c     get total atoms in all structures used in the fitting
c
      ntot = 0
      do k = 1, nconf
         call getref(k)
         ntot = ntot + n
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (pt(ntot))
c
c     initialize atom type and local frame defining strings
c
      do i = 1, ntot
         pt(i) = '                '
      end do
c
c     output optimized atomic multipole values to the keyfile
c
      header = .true.
      m = 0
      do k = 1, nconf
         call getref (k)
         call setelect
         do ii = 1, npole
            done = .true.
            i = ipole(ii)
            it = type(i)
            if (fatm(i))  done = .false.
            if (.not. done) then
               iz = zaxis(i)
               ix = xaxis(i)
               iy = yaxis(i)
               if (iz .ne. 0)  iz = type(iz)
               if (ix .ne. 0)  ix = type(ix)
               if (iy .ne. 0)  iy = type(abs(iy))
               size = 4
               call numeral (it,pa,size)
               call numeral (iz,pb,size)
               call numeral (ix,pc,size)
               call numeral (iy,pd,size)
               m = m + 1
               pt(m) = pa//pb//pc//pd
               do j = 1, m-1
                  if (pt(m) .eq. pt(j)) then
                     done = .true.
                     goto 40
                  end if
               end do
   40          continue
            end if
            if (.not. done) then
               if (header) then
                  header = .false.
                  write (ikey,50)
   50             format (/,'#',/,'# Multipoles from Electrostatic',
     &                       ' Potential Fitting',/,'#',/)
               end if
               pole(1,i) = fpol(1,it)
               do j = 2, 4
                  pole(j,i) = dterm * fpol(j,it)
               end do
               do j = 5, 13
                  pole(j,i) = qterm * fpol(j,it)
               end do
               if (polaxe(i) .eq. 'None') then
                  write (ikey,60)  it,pole(1,i)
   60             format ('multipole',1x,i5,21x,f11.5)
               else if (polaxe(i) .eq. 'Z-Only') then
                  write (ikey,70)  it,iz,pole(1,i)
   70             format ('multipole',1x,2i5,16x,f11.5)
               else if (polaxe(i) .eq. 'Z-then-X') then
                  if (yaxis(i) .eq. 0) then
                     write (ikey,80)  it,iz,ix,pole(1,i)
   80                format ('multipole',1x,3i5,11x,f11.5)
                  else
                     if (yaxis(i) .lt. 0) then
                        pole(3,i) = -pole(3,i)
                        pole(6,i) = -pole(6,i)
                        pole(8,i) = -pole(8,i)
                        pole(10,i) = -pole(10,i)
                        pole(12,i) = -pole(12,i)
                     end if
                     write (ikey,90)  it,iz,ix,iy,pole(1,i)
   90                format ('multipole',1x,4i5,6x,f11.5)
                  end if
               else if (polaxe(i) .eq. 'Bisector') then
                  if (yaxis(i) .eq. 0) then
                     write (ikey,100)  it,-iz,-ix,pole(1,i)
  100                format ('multipole',1x,3i5,11x,f11.5)
                  else
                     write (ikey,110)  it,-iz,-ix,iy,pole(1,i)
  110                format ('multipole',1x,4i5,6x,f11.5)
                  end if
               else if (polaxe(i) .eq. 'Z-Bisect') then
                  write (ikey,120)  it,iz,-ix,-iy,pole(1,i)
  120             format ('multipole',1x,4i5,6x,f11.5)
               else if (polaxe(i) .eq. '3-Fold') then
                  write (ikey,130)  it,-iz,-ix,-iy,pole(1,i)
  130             format ('multipole',1x,4i5,6x,f11.5)
               end if
               write (ikey,140)  pole(2,i),pole(3,i),pole(4,i)
  140          format (36x,3f11.5)
               write (ikey,150)  pole(5,i)
  150          format (36x,f11.5)
               write (ikey,160)  pole(8,i),pole(9,i)
  160          format (36x,2f11.5)
               write (ikey,170)  pole(11,i),pole(12,i),pole(13,i)
  170          format (36x,3f11.5)
            end if
         end do
      end do
c
c     output optimized charge penetration values to the keyfile
c
      if (fit_chgpen) then
         header = .true.
         do i = 1, maxclass
            fitcpen(i) = .false.
         end do
         do k = 1, nconf
            call getref (k)
            call setelect
            do ii = 1, npole
               done = .true.
               i = ipole(ii)
               ic = class(i)
               if (fatm(i))  done = .false.
               if (.not. done) then
                  if (fitcpen(ic))  done = .true.
                  fitcpen(ic) = .true.
               end if
               if (.not. done) then
                  palpha(i) = fcpen(ic)
                  if (header) then
                     header = .false.
                     write (ikey,180)
  180                format (/,'#',/,'# Charge Penetration from',
     &                          ' Electrostatic Potential Fitting',
     &                       /,'#',/)
                  end if
                  write (ikey,190)  ic,pcore(i),palpha(i)
  190             format ('chgpen',9x,i5,5x,f11.4,f11.5)
               end if
            end do
         end do
      end if
      close (unit=ikey)
c
c     perform deallocation of some local arrays
c
      deallocate (pt)
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine potwrt  --  least squares output routine  ##
c     ##                                                       ##
c     ###########################################################
c
c
      subroutine potwrt (niter,nresid,xx,gs,resid)
      implicit none
      integer niter
      integer nresid
      real*8 xx(*)
      real*8 gs(*)
      real*8 resid(*)
c
c
c     information to be printed at each least squares iteration
c
      return
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 2008 by Chuanjie Wu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module potfit  --  values for electrostatic potential fit  ##
c     ##                                                             ##
c     #################################################################
c
c
c     nconf       total number of configurations to be analyzed
c     namax       maximum number of atoms in the largest configuration
c     ngatm       total atom number with active potential grid points
c     nfatm       total atom number in electrostatic potential fit
c     npgrid      total number of electrostatic potential grid points
c     ipgrid      atom associated with each potential grid point
c     wresp       weight used to restrain electrostatic parameters
c     xdpl0       target x-component of total dipole moment
c     ydpl0       target y-component of total dipole moment
c     zdpl0       target z-component of total dipole moment
c     xxqpl0      target xx-component of total quadrupole moment
c     xyqpl0      target xy-component of total quadrupole moment
c     xzqpl0      target xz-component of total quadrupole moment
c     yyqpl0      target yy-component of total quadrupole moment
c     yzqpl0      target yz-component of total quadrupole moment
c     zzqpl0      target zz-component of total quadrupole moment
c     fit0        initial value of each parameter used in potential fit      
c     fchg        partial charges by atom type during potential fit
c     fpol        atomic multipoles by atom type during potential fit
c     fcpen       charge penetration by atom type during potential fit
c     pgrid       Cartesian coordinates of potential grid points
c     epot        values of electrostatic potential at grid points
c     use_dpl     flag to include total dipole in potential fit
c     use_qpl     flag to include total quadrupole in potential fit
c     fit_mpl     flag for atomic monopoles to vary in potential fit
c     fit_dpl     flag for atomic dipoles to vary in potential fit
c     fit_qpl     flag for atomic quadrupoles to vary in potential fit
c     fit_chgpen  flag for atomic quadrupoles to vary in potential fit
c     fitchg      flag marking atom types used in partial charge fit
c     fitpol      flag marking atom types used in atomic multipole fit
c     fitcpen     flag marking atom types used in charge penetration
c     gatm        flag to use potential grid points around each atom
c     fatm        flag to use each atom in electrostatic potential fit
c     fxdpl       flag to use each atom x-dipole in electrostatic fit
c     fydpl       flag to use each atom y-dipole in electrostatic fit
c     fzdpl       flag to use each atom z-dipole in electrostatic fit
c     vchg        flag for partial charge at each atom in fitting
c     vpol        flag for atomic multipoles at each atom in fitting
c     vcpen       flag for charge penetration at each atom in fitting
c     resptyp     electrostatic restraint target (ORIG, ZERO or NONE)
c     varpot      descriptive name for each variable in potential fit
c
c
      module potfit
      use sizes
      implicit none
      integer nconf,namax
      integer ngatm,nfatm
      integer npgrid(maxref)
      integer, allocatable :: ipgrid(:,:)
      real*8 wresp
      real*8 xdpl0(maxref)
      real*8 ydpl0(maxref)
      real*8 zdpl0(maxref)
      real*8 xxqpl0(maxref)
      real*8 xyqpl0(maxref)
      real*8 xzqpl0(maxref)
      real*8 yyqpl0(maxref)
      real*8 yzqpl0(maxref)
      real*8 zzqpl0(maxref)
      real*8, allocatable :: fit0(:)
      real*8, allocatable :: fchg(:)
      real*8, allocatable :: fpol(:,:)
      real*8, allocatable :: fcpen(:)
      real*8, allocatable :: pgrid(:,:,:)
      real*8, allocatable :: epot(:,:,:)
      logical use_dpl,use_qpl
      logical fit_mpl,fit_dpl
      logical fit_qpl,fit_chgpen
      logical, allocatable :: fitchg(:)
      logical, allocatable :: fitpol(:)
      logical, allocatable :: fitcpen(:)
      logical, allocatable :: gatm(:)
      logical, allocatable :: fatm(:)
      logical, allocatable :: fxdpl(:)
      logical, allocatable :: fydpl(:)
      logical, allocatable :: fzdpl(:)
      logical, allocatable :: vchg(:,:)
      logical, allocatable :: vpol(:,:,:)
      logical, allocatable :: vcpen(:,:)
      character*4 resptyp
      character*6, allocatable :: varpot(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2020  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine predict  --  induced dipole prediction values  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "predict" checks for use of methods for predicting induced
c     dipoles, extrapolation coefficients and IELSCF parameters
c
c
      subroutine predict
      use atoms
      use ielscf
      use keys
      use uprior
      implicit none
      integer i,j,k
      integer next
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set defaults for use of induced dipole prediction
c
      use_pred = .false.
      use_ielscf = .false.
      polpred = '    '
      maxualt = 0
      nualt = 0
c
c     get keywords containing induced dipole prediction options
c
      do j = 1, nkey
         next = 1
         record = keyline(j)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:14) .eq. 'POLAR-PREDICT ') then
            call getword (record,polpred,next)
            call upcase (polpred)
            use_pred = .true.
            if (polpred .eq. '    ') then
               polpred = 'ASPC'
            else if (polpred .eq. 'IEL ') then
               use_pred = .false.
               use_ielscf = .true.
            end if
         else if (keyword(1:8) .eq. 'IEL-SCF ') then
            use_ielscf = .true.
         end if
      end do
c
c     set always stable predictor-corrector (ASPC) coefficients
c
      if (polpred .eq. 'ASPC') then
         maxualt = 17
         aspc(1) = 62.0d0 / 17.0d0
         aspc(2) = -310.0d0 / 51.0d0
         aspc(3) = 2170.0d0 / 323.0d0
         aspc(4) = -2329.0d0 / 400.0d0
         aspc(5) = 1701.0d0 / 409.0d0
         aspc(6) = -806.0d0 / 323.0d0
         aspc(7) = 1024.0d0 / 809.0d0
         aspc(8) = -479.0d0 / 883.0d0
         aspc(9) = 257.0d0 / 1316.0d0
         aspc(10) = -434.0d0 / 7429.0d0
         aspc(11) = 191.0d0 / 13375.0d0
         aspc(12) = -62.0d0 / 22287.0d0
         aspc(13) = 3.0d0 / 7217.0d0
         aspc(14) = -3.0d0 / 67015.0d0
         aspc(15) = 2.0d0 / 646323.0d0
         aspc(16) = -1.0d0 / 9694845.0d0
         aspc(17) = 0.0d0
      end if
c
c     set the 6th-order Gear predictor binomial coefficients
c
      if (polpred .eq. 'GEAR') then
         maxualt = 7
         gear(1) = 6.0d0
         gear(2) = -15.0d0
         gear(3) = 20.0d0
         gear(4) = -15.0d0
         gear(5) = 6.0d0
         gear(6) = -1.0d0
         gear(7) = 0.0d0
      end if
c
c     set maximum storage size for least squares prediction
c
      if (polpred .eq. 'LSQR') then
         maxualt = 6
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (use_pred) then
         if (allocated(udalt))  deallocate (udalt)
         if (allocated(upalt))  deallocate (upalt)
         if (allocated(usalt))  deallocate (usalt)
         if (allocated(upsalt))  deallocate (upsalt)
         if (use_pred) then
            allocate (udalt(maxualt,3,n))
            allocate (upalt(maxualt,3,n))
            allocate (usalt(maxualt,3,n))
            allocate (upsalt(maxualt,3,n))
         end if
      end if
c
c     initialize prior values of induced dipole moments
c
      if (use_pred) then
        do i = 1, n
            do j = 1, 3
               do k = 1, maxualt
                  udalt(k,j,i) = 0.0d0
                  upalt(k,j,i) = 0.0d0
                  usalt(k,j,i) = 0.0d0
                  upsalt(k,j,i) = 0.0d0
               end do
            end do
         end do
      end if
c
c     initialize inertial extended Lagrangian method
c
      if (use_ielscf)  call auxinit
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine auxinit  --  setup auxiliary dipoles for IELSCF  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "auxinit" initializes auxiliary variables and settings for
c     inertial extended Lagrangian induced dipole prediction
c
c     literature reference:
c
c     A. Albaugh, O. Demerdash, and T. Head-Gordon, "An Efficient and
c     Stable Hybrid Extended Lagrangian/Self-Consistent Field Scheme
c     for Solving Classical Mutual Induction", Journal of Chemical
c     Physics, 143, 174104 (2015)
c
c
      subroutine auxinit
      use atomid
      use atoms
      use ielscf
      use keys
      use polar
      implicit none
      integer i,j,next
      real*8 speed
      real*8 weight
      real*8 maxwell
      real*8 vec(3)
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set defaults for auxiliary thermostat control variables
c
      nfree_aux = 3 * npolar
      kelvin_aux = 100000.0d0
      tautemp_aux = 0.1d0
c
c     check for keywords containing auxiliary thermostat values
c 
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:13) .eq. 'AUX-TAUTEMP ') then
            read (string,*,err=10,end=10)  tautemp_aux
         else if (keyword(1:9) .eq. 'AUX-TEMP ') then
            read (string,*,err=10,end=10)  kelvin_aux
         end if
   10    continue
      end do
c
c     perform dynamic allocation of some global arrays
c 
      allocate (uaux(3,n))
      allocate (vaux(3,n))
      allocate (aaux(3,n))
      allocate (upaux(3,n))
      allocate (vpaux(3,n))
      allocate (apaux(3,n))
c
c     set auxiliary dipole values equal to induced dipoles
c
      use_ielscf = .false.
      call induce
      use_ielscf = .true.
      do i = 1, n
         do j = 1, 3
            uaux(j,i) = uind(j,i)
            upaux(j,i) = uinp(j,i)
         end do
      end do
c
c     set velocities and accelerations for auxiliary dipoles
c
      do i = 1, n
         weight = 1.0d0
         speed = maxwell (weight,kelvin_aux)
         call ranvec (vec)
         do j = 1, 3
            vaux(j,i) = speed * vec(j)
            aaux(j,i) = 0.0d0
            vpaux(j,i) = vaux(j,i)
            apaux(j,i) = 0.0d0
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine pressure  --  application of scaling barostats  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "pressure" uses the internal virial to find the pressure
c     in a periodic box and maintains a constant desired pressure
c     via a scaling barostat method
c
c
      subroutine pressure (dt,ekin,pres,stress)
      use bath
      use boxes
      use bound
      use math
      use units
      use virial
      implicit none
      integer i,j
      real*8 dt,pres
      real*8 factor
      real*8 ekin(3,3)
      real*8 stress(3,3)
c
c
c     only necessary if periodic boundaries are in use
c
      if (.not. use_bounds)  return
c
c     calculate the stress tensor for anisotropic systems
c
      factor = prescon / volbox
      do i = 1, 3
         do j = 1, 3
            stress(j,i) = factor * (2.0d0*ekin(j,i)-vir(j,i))
         end do
      end do
c
c     set isotropic pressure to the average of tensor diagonal
c
      pres = third * (stress(1,1)+stress(2,2)+stress(3,3))
c
c     use the desired barostat to maintain constant pressure
c
      if (isobaric) then
         if (barostat .eq. 'BERENDSEN')  call pscale (dt,pres,stress)
         if (barostat .eq. 'BUSSI')  call pscale (dt,pres,stress)
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine pressure2  --  apply the Monte Carlo barostat  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "pressure2" applies box size and coordinate moves to maintain
c     constant desired pressure via a Monte Carlo barostat
c
c
      subroutine pressure2 (epot,temp)
      use bath
      use bound
      implicit none
      real*8 epot,temp
c
c
c     only necessary if periodic boundaries are in use
c
      if (.not. use_bounds)  return
c
c     use the desired barostat to maintain constant pressure
c
      if (isobaric) then
         if (barostat .eq. 'MONTECARLO')  call pmonte (epot,temp)
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine pscale  --  Berendsen & Bussi scaling barostats  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "pscale" implements the Berendsen and Bussi barostats by scaling
c     the box dimensions, coordinates and momenta via coupling to an
c     external constant pressure bath
c
c     literature references:
c
c     H. J. C. Berendsen, J. P. M. Postma, W. F. van Gunsteren,
c     A. DiNola and J. R. Hauk, "Molecular Dynamics with Coupling
c     to an External Bath", Journal of Chemical Physics, 81,
c     3684-3690 (1984)
c
c     M. Bernetti and G. Bussi, "Pressure Control Using Stochastic
c     Cell Rescaling", Journal of Chemical Physics, 153, 114107 (2020)
c
c     V. Del Tatto, "A Fully Anisotropic Formulation of Stochastic
c     Cell Rescaling", arXiv, 2111.06403v1 (2021)
c
c     original code for anisotropic pressure coupling by Guido Raos,
c     Dipartimento di Chimica, Politecnico di Milano, Italy, May 2006
c
c
      subroutine pscale (dt,pres,stress)
      use atomid
      use atoms
      use bath
      use boxes
      use group
      use math
      use mdstuf
      use moldyn
      use rgddyn
      use units
      use usage
      implicit none
      integer i,j,k
      integer start,stop
      real*8 dt,pres,weigh
      real*8 eps,deps,term
      real*8 kt,betat,dw
      real*8 scale,scalei
      real*8 scalexy,scalez
      real*8 normal,cosine
      real*8 tension
      real*8 xcm,xmove
      real*8 ycm,ymove
      real*8 zcm,zmove
      real*8 stress(3,3)
      real*8 hbox(3,3)
      real*8 ascale(3,3)
      external normal
c
c
c     find the isotropic scale factor for pressure control
c
      if (prestyp .eq. 'ISOTROPIC') then
         if (barostat .eq. 'BERENDSEN') then
            eps = third * (compress*dt/taupres)
            scale = 1.0d0 + eps*(pres-atmsph)
         else if (barostat .eq. 'BUSSI') then
            kt = gasconst * kelvin
            betat = prescon * compress
            dw = normal ()
            eps = (compress*dt/taupres) * (pres-atmsph)
            deps = sqrt(2.0d0*kt*betat*dt/(volbox*taupres))
            scale = exp(third*(eps+deps*dw))
         end if
c
c     modify the current periodic box dimension values
c
         xbox = xbox * scale
         ybox = ybox * scale
         zbox = zbox * scale
c
c     propagate the new box dimensions to other lattice values
c
         call lattice
c
c     couple to pressure bath via atom scaling in Cartesian space
c
         if (integrate .ne. 'RIGIDBODY') then
            do i = 1, nuse
               k = iuse(i)
               x(k) = x(k) * scale
               y(k) = y(k) * scale
               z(k) = z(k) * scale
            end do
            if (barostat .eq. 'BUSSI') then
               do i = 1, nuse
                  k = iuse(i)
                  do j = 1, 3
                     v(j,k) = v(j,k) / scale
                  end do
               end do
            end if
c
c     couple to pressure bath via center of mass of rigid bodies
c
         else
            scalei = scale - 1.0d0
            do i = 1, ngrp
               start = igrp(1,i)
               stop = igrp(2,i)
               xcm = 0.0d0
               ycm = 0.0d0
               zcm = 0.0d0
               do j = start, stop
                  k = kgrp(j)
                  weigh = mass(k)
                  xcm = xcm + x(k)*weigh
                  ycm = ycm + y(k)*weigh
                  zcm = zcm + z(k)*weigh
               end do
               xmove = scalei * xcm/grpmass(i)
               ymove = scalei * ycm/grpmass(i)
               zmove = scalei * zcm/grpmass(i)
               do j = start, stop
                  k = kgrp(j)
                  x(k) = x(k) + xmove
                  y(k) = y(k) + ymove
                  z(k) = z(k) + zmove
               end do
               if (barostat .eq. 'BUSSI') then
                  do j = 1, 3
                     vcm(j,i) = vcm(j,i) / scale
                     wcm(j,i) = wcm(j,i) / scale
                  end do
               end if
            end do
         end if
c
c     find the semi-isotropic scale factors for pressure control
c
      else if (prestyp .eq. 'SEMIISO') then
         if (barostat .eq. 'BERENDSEN') then
            tension = 0.0d0
            eps = third * (compress*dt/taupres)
            term = 0.5d0*(stress(1,1)+stress(2,2))
     &                + (tension/zbox) - atmsph
            scalexy = 1.0d0 + eps*term
            term = stress(3,3) - atmsph
            scalez = 1.0d0 + eps*term
         else if (barostat .eq. 'BUSSI') then
            tension = 0.0d0
            kt = gasconst * kelvin
            betat = prescon * compress
            dw = normal ()
            eps = compress * dt / taupres
            deps = sqrt(2.0d0*kt*betat*dt/(volbox*taupres))
            term = 0.5d0*(stress(1,1)+stress(2,2))
     &                + (tension/zbox) - atmsph
            scalexy = exp(third*(eps*term+deps*dw))
            dw = normal ()
            term = stress(3,3) - atmsph
            scalez = exp(third*(eps*term+deps*dw))
         end if
c
c     modify the current periodic box dimension values
c
         xbox = xbox * scalexy
         ybox = ybox * scalexy
         zbox = zbox * scalez
c
c     propagate the new box dimensions to other lattice values
c
         call lattice
c
c     couple to pressure bath via atom scaling in Cartesian space
c
         if (integrate .ne. 'RIGIDBODY') then
            do i = 1, nuse
               k = iuse(i)
               x(k) = x(k) * scalexy
               y(k) = y(k) * scalexy
               z(k) = z(k) * scalez
            end do
            if (barostat .eq. 'BUSSI') then
               do i = 1, nuse
                  k = iuse(i)
                  v(1,k) = v(1,k) / scalexy
                  v(2,k) = v(2,k) / scalexy
                  v(3,k) = v(3,k) / scalez
               end do
            end if
c
c     couple to pressure bath via center of mass of rigid bodies
c
         else
            do i = 1, ngrp
               start = igrp(1,i)
               stop = igrp(2,i)
               xcm = 0.0d0
               ycm = 0.0d0
               zcm = 0.0d0
               do j = start, stop
                  k = kgrp(j)
                  weigh = mass(k)
                  xcm = xcm + x(k)*weigh
                  ycm = ycm + y(k)*weigh
                  zcm = zcm + z(k)*weigh
               end do
               xmove = (scalexy-1.0d0) * xcm/grpmass(i)
               ymove = (scalexy-1.0d0) * ycm/grpmass(i)
               zmove = (scalez-1.0d0) * zcm/grpmass(i)
               do j = start, stop
                  k = kgrp(j)
                  x(k) = x(k) + xmove
                  y(k) = y(k) + ymove
                  z(k) = z(k) + zmove
               end do
               if (barostat .eq. 'BUSSI') then
                  vcm(j,i) = vcm(1,i) / scalexy
                  vcm(2,i) = vcm(2,i) / scalexy
                  vcm(3,i) = vcm(3,i) / scalez
                  wcm(1,i) = wcm(1,i) / scalexy
                  wcm(2,i) = wcm(2,i) / scalexy
                  wcm(3,i) = wcm(3,i) / scalez
               end if
            end do
         end if
c
c     find the anisotropic scale factors for pressure control
c
      else if (prestyp .eq. 'ANISO') then
         if (barostat .eq. 'BERENDSEN') then
            eps = third * (compress*dt/taupres)
            do i = 1, 3
               do j = 1, 3
                  if (j. eq. i) then
                     ascale(j,i) = 1.0d0 + eps*(stress(j,i)-atmsph)
                  else
                     ascale(j,i) = eps * stress(j,i)
                  end if
               end do
            end do
         else if (barostat .eq. 'BUSSI') then
            kt = gasconst * kelvin
            betat = prescon * compress
            eps = third * (compress*dt/taupres)
            deps = sqrt(third2*kt*betat*dt/(volbox*taupres))
            do i = 1, 3
               do j = 1, 3
                  dw = normal ()
                  if (j .eq. i) then
                     term = stress(j,i) - atmsph + prescon*kt/volbox
                     ascale(j,i) = 1.0d0 + eps*term + deps*dw
                  else
c                    ascale(j,i) = eps*stress(j,i) + deps*dw
                     ascale(j,i) = eps * stress(j,i)
                  end if
               end do
            end do
         end if
c
c     modify the current periodic box dimension values
c
         do i = 1, 3
            do j = 1, 3
               hbox(j,i) = 0.0d0
               do k = 1, 3
                  hbox(j,i) = hbox(j,i) + ascale(j,k)*lvec(i,k)
               end do
            end do
         end do
         xbox = sqrt(hbox(1,1)**2 + hbox(2,1)**2 + hbox(3,1)**2)
         ybox = sqrt(hbox(1,2)**2 + hbox(2,2)**2 + hbox(3,2)**2)
         zbox = sqrt(hbox(1,3)**2 + hbox(2,3)**2 + hbox(3,3)**2)
         if (monoclinic) then
            cosine = (hbox(1,1)*hbox(1,3) + hbox(2,1)*hbox(2,3)
     &                  + hbox(3,1)*hbox(3,3)) / (xbox*zbox)
            beta = radian * acos(cosine)
         else if (triclinic) then
            cosine = (hbox(1,2)*hbox(1,3) + hbox(2,2)*hbox(2,3)
     &                  + hbox(3,2)*hbox(3,3)) / (ybox*zbox)
            alpha = radian * acos(cosine)
            cosine = (hbox(1,1)*hbox(1,3) + hbox(2,1)*hbox(2,3)
     &                  + hbox(3,1)*hbox(3,3)) / (xbox*zbox)
            beta = radian * acos(cosine)
            cosine = (hbox(1,1)*hbox(1,2) + hbox(2,1)*hbox(2,2)
     &                  + hbox(3,1)*hbox(3,2)) / (xbox*ybox)
            gamma = radian * acos(cosine)
         end if
c
c     propagate the new box dimensions to other lattice values
c
         call lattice
c
c     couple to pressure bath via atom scaling in Cartesian space
c
         if (integrate .ne. 'RIGIDBODY') then
            do i = 1, nuse
               k = iuse(i)
               x(k) = x(k)*ascale(1,1) + y(k)*ascale(1,2)
     &                   + z(k)*ascale(1,3)
               y(k) = x(k)*ascale(2,1) + y(k)*ascale(2,2)
     &                   + z(k)*ascale(2,3)
               z(k) = x(k)*ascale(3,1) + y(k)*ascale(3,2)
     &                   + z(k)*ascale(3,3)
            end do
            if (barostat .eq. 'BUSSI') then
               call invert (3,ascale)
               do i = 1, nuse
                  k = iuse(i)
                  v(1,k) = v(1,k)*ascale(1,1) + v(2,k)*ascale(1,2)
     &                        + v(3,k)*ascale(1,3)
                  v(2,k) = v(1,k)*ascale(2,1) + v(2,k)*ascale(2,2)
     &                        + v(3,k)*ascale(2,3)
                  v(3,k) = v(1,k)*ascale(3,1) + v(2,k)*ascale(3,2)
     &                        + v(3,k)*ascale(3,3)
               end do
            end if
c
c     couple to pressure bath via center of mass of rigid bodies
c
         else
            ascale(1,1) = ascale(1,1) - 1.0d0
            ascale(2,2) = ascale(2,2) - 1.0d0
            ascale(3,3) = ascale(3,3) - 1.0d0
            do i = 1, ngrp
               start = igrp(1,i)
               stop = igrp(2,i)
               xcm = 0.0d0
               ycm = 0.0d0
               zcm = 0.0d0
               do j = start, stop
                  k = kgrp(j)
                  weigh = mass(k)
                  xcm = xcm + x(k)*weigh
                  ycm = xcm + y(k)*weigh
                  zcm = xcm + z(k)*weigh
               end do
               xcm = xcm / grpmass(i)
               ycm = ycm / grpmass(i)
               zcm = zcm / grpmass(i)
               xmove = xcm*ascale(1,1) + ycm*ascale(1,2)
     &                    + zcm*ascale(1,3)
               ymove = xcm*ascale(2,1) + ycm*ascale(2,2)
     &                    + zcm*ascale(2,3)
               zmove = xcm*ascale(3,1) + ycm*ascale(3,2)
     &                    + zcm*ascale(3,3)
               do j = start, stop
                  k = kgrp(j)
                  x(k) = x(k) + xmove
                  y(k) = y(k) + ymove
                  z(k) = z(k) + zmove
               end do
               if (barostat .eq. 'BUSSI') then
                  call invert (3,ascale)
                  vcm(1,i) = vcm(1,i)*ascale(1,1) + vcm(2,i)*ascale(1,2)
     &                          + vcm(3,i)*ascale(1,3)
                  vcm(2,i) = vcm(1,i)*ascale(2,1) + vcm(2,i)*ascale(2,2)
     &                          + vcm(3,i)*ascale(2,3)
                  vcm(3,i) = vcm(1,i)*ascale(3,1) + vcm(2,i)*ascale(3,2)
     &                          + vcm(3,i)*ascale(3,3)
                  wcm(1,i) = wcm(1,i)*ascale(1,1) + wcm(2,i)*ascale(1,2)
     &                          + wcm(3,i)*ascale(1,3)
                  wcm(2,i) = wcm(1,i)*ascale(2,1) + wcm(2,i)*ascale(2,2)
     &                          + wcm(3,i)*ascale(2,3)
                  wcm(3,i) = wcm(1,i)*ascale(3,1) + wcm(2,i)*ascale(3,2)
     &                          + wcm(3,i)*ascale(3,3)
               end if
            end do
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine pmonte  --  Monte Carlo barostat volume moves  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "pmonte" implements a Monte Carlo barostat via random trial
c     changes in the box dimensions and coordinates
c
c     literature references:
c
c     J. Aqvist, P. Wennerstrom, M. Nervall, S. Bjelic, B. O. Brandsal,
c     "Molecular Dynamics Simulations of Water and Biomolecules with
c     a Monte Carlo Constant Pressure Algorithm", Chemical Physics
c     Letters, 384, 288-294 (2004)
c
c     D. Frenkel and B. Smit, "Understanding Molecular Simulation,
c     3rd Edition", Academic Press, San Diego, CA, 2023; Section 6.3
c
c     original version implemented by Alan Grossfield, January 2004;
c     anisotropic modification provided by Lee-Ping Wang, Stanford
c     University, March 2013
c
c
      subroutine pmonte (epot,temp)
      use atomid
      use atoms
      use bath
      use boxes
      use group
      use math
      use mdstuf
      use molcul
      use moldyn
      use units
      use usage
      implicit none
      integer i,j,k
      integer start,stop
      real*8 epot,temp,term
      real*8 energy,random
      real*8 expterm,weigh
      real*8 kt,step,scale
      real*8 eold,rnd6
      real*8 xcm,ycm,zcm
      real*8 volold,cosine
      real*8 dpot,dpv,dkin
      real*8 xmove,ymove,zmove
      real*8 xboxold,yboxold,zboxold
      real*8 alphaold,betaold,gammaold
      real*8 hbox(3,3)
      real*8 ascale(3,3)
      real*8, allocatable :: xold(:)
      real*8, allocatable :: yold(:)
      real*8, allocatable :: zold(:)
      logical dotrial
      logical isotropic
      logical idealgas
      external random
c
c
c     decide whether to attempt a box size change at this step
c
      dotrial = .false.
      if (random() .lt. 1.0d0/dble(voltrial))  dotrial = .true.
c
c     set constants and decide on type of trial box size change
c
      if (dotrial) then
         kt = gasconst * temp
         if (isothermal)  kt = gasconst * kelvin
         isotropic = .true.
         if (prestyp.eq.'ANISO' .and. random().gt.0.5d0) then
            isotropic = .false.
         end if
c
c     perform dynamic allocation of some local arrays
c
         allocate (xold(n))
         allocate (yold(n))
         allocate (zold(n))
c
c     save the system state prior to trial box size change
c
         xboxold = xbox
         yboxold = ybox
         zboxold = zbox
         alphaold = alpha
         betaold = beta
         gammaold = gamma
         volold = volbox
         eold = epot
         do i = 1, n
            xold(i) = x(i)
            yold(i) = y(i)
            zold(i) = z(i)
         end do
c
c     for the isotropic case, change the lattice lengths uniformly
c
         if (isotropic) then
            step = volmove * (2.0d0*random()-1.0d0)
            volbox = volbox + step
            scale = (volbox/volold)**third
            xbox = xbox * scale
            ybox = ybox * scale
            zbox = zbox * scale
            call lattice
            if (integrate .eq. 'RIGIDBODY') then
               scale = scale - 1.0d0
               do i = 1, ngrp
                  xcm = 0.0d0
                  ycm = 0.0d0
                  zcm = 0.0d0
                  start = igrp(1,i)
                  stop = igrp(2,i)
                  do j = start, stop
                     k = kgrp(j)
                     weigh = mass(k)
                     xcm = xcm + x(k)*weigh
                     ycm = ycm + y(k)*weigh
                     zcm = zcm + z(k)*weigh
                  end do
                  xmove = scale * xcm/grpmass(i)
                  ymove = scale * ycm/grpmass(i)
                  zmove = scale * zcm/grpmass(i)
                  do j = start, stop
                     k = kgrp(j)
                     x(k) = x(k) + xmove
                     y(k) = y(k) + ymove
                     z(k) = z(k) + zmove
                  end do
               end do
            else if (volscale .eq. 'MOLECULAR') then
               scale = scale - 1.0d0
               do i = 1, nmol
                  xcm = 0.0d0
                  ycm = 0.0d0
                  zcm = 0.0d0
                  start = imol(1,i)
                  stop = imol(2,i)
                  do j = start, stop
                     k = kmol(j)
                     weigh = mass(k)
                     xcm = xcm + x(k)*weigh
                     ycm = ycm + y(k)*weigh
                     zcm = zcm + z(k)*weigh
                  end do
                  xmove = scale * xcm/molmass(i)
                  ymove = scale * ycm/molmass(i)
                  zmove = scale * zcm/molmass(i)
                  do j = start, stop
                     k = kmol(j)
                     if (use(k)) then
                        x(k) = x(k) + xmove
                        y(k) = y(k) + ymove
                        z(k) = z(k) + zmove
                     end if
                  end do
               end do
            else
               do i = 1, nuse
                  k = iuse(i)
                  x(k) = x(k) * scale
                  y(k) = y(k) * scale
                  z(k) = z(k) * scale
               end do
            end if
c
c     for anisotropic case alter lattice angles, then scale lengths
c
         else
            rnd6 = 6.0d0*random()
            step = volmove * (2.0d0*random()-1.0d0)
            scale = (1.0d0+step/volold)**third
            ascale(1,1) = 1.0d0
            ascale(2,2) = 1.0d0
            ascale(3,3) = 1.0d0
            if (monoclinic .or. triclinic) then
               if (rnd6 .lt. 1.0d0) then
                  ascale(1,1) = scale
               else if (rnd6 .lt. 2.0d0) then
                  ascale(2,2) = scale
               else if (rnd6 .lt. 3.0d0) then
                  ascale(3,3) = scale
               else if (rnd6 .lt. 4.0d0) then
                  ascale(1,2) = scale - 1.0d0
                  ascale(2,1) = scale - 1.0d0
               else if (rnd6 .lt. 5.0d0) then
                  ascale(1,3) = scale - 1.0d0
                  ascale(3,1) = scale - 1.0d0
               else
                  ascale(2,3) = scale - 1.0d0
                  ascale(3,2) = scale - 1.0d0
               end if
            else
               if (rnd6 .lt. 2.0d0) then
                  ascale(1,1) = scale
               else if (rnd6 .lt. 4.0d0) then
                  ascale(2,2) = scale
               else
                  ascale(3,3) = scale
               end if
            end if
c
c     modify the current periodic box lattice angle values
c
            do i = 1, 3
               do j = 1, 3
                  hbox(j,i) = 0.0d0
                  do k = 1, 3
                     hbox(j,i) = hbox(j,i) + ascale(j,k)*lvec(i,k)
                  end do
               end do
            end do
            xbox = sqrt(hbox(1,1)**2 + hbox(2,1)**2 + hbox(3,1)**2)
            ybox = sqrt(hbox(1,2)**2 + hbox(2,2)**2 + hbox(3,2)**2)
            zbox = sqrt(hbox(1,3)**2 + hbox(2,3)**2 + hbox(3,3)**2)
            if (monoclinic) then
               cosine = (hbox(1,1)*hbox(1,3) + hbox(2,1)*hbox(2,3)
     &                     + hbox(3,1)*hbox(3,3)) / (xbox*zbox)
               beta = radian * acos(cosine)
            else if (triclinic) then
               cosine = (hbox(1,2)*hbox(1,3) + hbox(2,2)*hbox(2,3)
     &                     + hbox(3,2)*hbox(3,3)) / (ybox*zbox)
               alpha = radian * acos(cosine)
               cosine = (hbox(1,1)*hbox(1,3) + hbox(2,1)*hbox(2,3)
     &                     + hbox(3,1)*hbox(3,3)) / (xbox*zbox)
               beta = radian * acos(cosine)
               cosine = (hbox(1,1)*hbox(1,2) + hbox(2,1)*hbox(2,2)
     &                     + hbox(3,1)*hbox(3,2)) / (xbox*ybox)
               gamma = radian * acos(cosine)
            end if
c
c     find the new box dimensions and other lattice values
c
            call lattice
            scale = (volbox/volold)**third
            xbox = xbox * scale
            ybox = ybox * scale
            zbox = zbox * scale
            call lattice
c
c     scale the coordinates by groups, molecules or atoms
c
            if (integrate .eq. 'RIGIDBODY') then
               ascale(1,1) = ascale(1,1) - 1.0d0
               ascale(2,2) = ascale(2,2) - 1.0d0
               ascale(3,3) = ascale(3,3) - 1.0d0
               do i = 1, ngrp
                  xcm = 0.0d0
                  ycm = 0.0d0
                  zcm = 0.0d0
                  start = igrp(1,i)
                  stop = igrp(2,i)
                  do j = start, stop
                     k = kmol(j)
                     weigh = mass(k)
                     xcm = xcm + x(k)*weigh
                     ycm = ycm + y(k)*weigh
                     zcm = zcm + z(k)*weigh
                  end do
                  xcm = xcm / grpmass(i)
                  ycm = ycm / grpmass(i)
                  zcm = zcm / grpmass(i)
                  xmove = xcm*ascale(1,1) + ycm*ascale(1,2)
     &                       + zcm*ascale(1,3)
                  ymove = xcm*ascale(2,1) + ycm*ascale(2,2)
     &                       + zcm*ascale(2,3)
                  zmove = xcm*ascale(3,1) + ycm*ascale(3,2)
     &                       + zcm*ascale(3,3)
                  do j = start, stop
                     k = kgrp(j)
                     x(k) = x(k) + xmove
                     y(k) = y(k) + ymove
                     z(k) = z(k) + zmove
                  end do
               end do
            else if (volscale .eq. 'MOLECULAR') then
               ascale(1,1) = ascale(1,1) - 1.0d0
               ascale(2,2) = ascale(2,2) - 1.0d0
               ascale(3,3) = ascale(3,3) - 1.0d0
               do i = 1, nmol
                  xcm = 0.0d0
                  ycm = 0.0d0
                  zcm = 0.0d0
                  start = imol(1,i)
                  stop = imol(2,i)
                  do j = start, stop
                     k = kmol(j)
                     weigh = mass(k)
                     xcm = xcm + x(k)*weigh
                     ycm = ycm + y(k)*weigh
                     zcm = zcm + z(k)*weigh
                  end do
                  xcm = xcm / molmass(i)
                  ycm = ycm / molmass(i)
                  zcm = zcm / molmass(i)
                  xmove = xcm*ascale(1,1) + ycm*ascale(1,2)
     &                       + zcm*ascale(1,3)
                  ymove = xcm*ascale(2,1) + ycm*ascale(2,2)
     &                       + zcm*ascale(2,3)
                  zmove = xcm*ascale(3,1) + ycm*ascale(3,2)
     &                       + zcm*ascale(3,3)
                  do j = start, stop
                     k = kmol(j)
                     if (use(k)) then
                        x(k) = x(k) + xmove
                        y(k) = y(k) + ymove
                        z(k) = z(k) + zmove
                     end if
                  end do
               end do
            else
               do i = 1, nuse
                  k = iuse(i)
                  x(k) = x(k)*ascale(1,1) + y(k)*ascale(1,2)
     &                      + z(k)*ascale(1,3)
                  y(k) = x(k)*ascale(2,1) + y(k)*ascale(2,2)
     &                      + z(k)*ascale(2,3)
                  z(k) = x(k)*ascale(3,1) + y(k)*ascale(3,2)
     &                      + z(k)*ascale(3,3)
               end do
            end if
         end if
c
c     get the potential energy and PV work changes for trial move
c
         epot = energy ()
         dpot = epot - eold
         dpv = atmsph * (volbox-volold) / prescon
c
c     get the kinetic energy contribution for the trial move
c
         idealgas = .true.
c
c     estimate the kinetic energy change as an ideal gas term
c
         if (idealgas) then
            if (integrate .eq. 'RIGIDBODY') then
               dkin = dble(ngrp) * kt * log(volold/volbox)
            else if (volscale .eq. 'MOLECULAR') then
               dkin = dble(nmol) * kt * log(volold/volbox)
            else
               dkin = dble(nmol) * kt * log(volold/volbox)
c              dkin = dble(nuse) * kt * log(volold/volbox)
            end if
c
c     alternatively get the instantaneous kinetic energy change;
c     requires the prior step velocity, which is not available
c
         else
            dkin = 0.0d0
            do i = 1, nuse
               k = iuse(i)
               term = 1.5d0 * mass(k) / ekcal
               do j = 1, 3
c                 dkin = dkin + term*(v(j,k)**2-vold(j,k)**2)
               end do
            end do
            if (integrate .eq. 'RIGIDBODY') then
               dkin = dkin * dble(ngrp)/dble(nuse)
            else if (volscale .eq. 'MOLECULAR') then
               dkin = dkin * dble(nmol)/dble(nuse)
            else
               dkin = dkin * dble(nuse)/dble(nuse)
            end if
         end if
c
c     acceptance ratio from Epot change, Ekin change and PV work
c
         term = -(dpot+dpv+dkin) / kt
         expterm = exp(term)
c
c     reject the step, and restore values prior to trial change
c
         if (random() .gt. expterm) then
            epot = eold
            xbox = xboxold
            ybox = yboxold
            zbox = zboxold
            alpha = alphaold
            beta = betaold
            gamma = gammaold
            call lattice
            do i = 1, n
               x(i) = xold(i)
               y(i) = yold(i)
               z(i) = zold(i)
            end do
         end if
c
c     perform deallocation of some local arrays
c
         deallocate (xold)
         deallocate (yold)
         deallocate (zold)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2004  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  program prmedit  --  edit and renumber parameter files  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "prmedit" reformats an existing parameter file, and revises
c     type and class numbers based on the "atom" parameter ordering
c
c
      program prmedit
      use iounit
      implicit none
      integer iprm
      integer nmode,mode
      integer freeunit
      integer trimtext
      logical dotype,doclass
      logical exist,query
      character*240 prmfile
      character*240 string
c
c
c     read and store the original force field parameter file
c
      call initial
      call getprm
      nmode = 7
c
c     get the desired type of parameter file modification
c
      mode = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  mode
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' The Parameter Editing Facility can Provide :',
     &           //,4x,'(1) Format Individual Parameter Records',
     &           /,4x,'(2) Reorder Individual Parameter Records',
     &           /,4x,'(3) Renumber the Atom Types, and Reorder',
     &           /,4x,'(4) Renumber the Atom Classes, and Reorder',
     &           /,4x,'(5) Renumber Types and Classes, and Reorder',
     &           /,4x,'(6) Sort and Format Multipole Parameters',
     &           /,4x,'(7) Renumber and Format Biotype Parameters')
         do while (mode.lt.1 .or. mode.gt.nmode)
            mode = 0
            write (iout,30)
   30       format (/,' Enter the Number of the Desired Choice :  ',$)
            read (input,40,err=50,end=50)  mode
   40       format (i10)
   50       continue
         end do
      end if
c
c     set the renumbering operations to be performed
c
      dotype = .false.
      doclass = .false.
      if (mode .eq. 3)  dotype = .true.
      if (mode .eq. 4)  doclass = .true.
      if (mode .eq. 5) then
         dotype = .true.
         doclass = .true.
      end if
c
c     format records in the original parameter file
c
      if (mode .eq. 1) then
         iprm = freeunit ()
         prmfile = 'parameter.prm'
         call version (prmfile,'new')
         open (unit=iprm,file=prmfile,status='new')
         call prmform (iprm)
         write (iout,60)  prmfile(1:trimtext(prmfile))
   60    format (/,' Reformated Parameter File Written To :  ',a)
         close (unit=iprm)
      end if
c
c     reorder and renumber the original parameter file
c
      if (mode.ge.2 .and. mode.le.5) then
         iprm = freeunit ()
         prmfile = 'parameter.prm'
         call version (prmfile,'new')
         open (unit=iprm,file=prmfile,status='new')
         call prmorder (iprm,dotype,doclass)
         write (iout,70)  prmfile(1:trimtext(prmfile))
   70    format (/,' Renumbered Parameter File Written To :  ',a)
         close (unit=iprm)
      end if
c
c     sort the atomic multipole parameters by atom type
c
      if (mode .eq. 6) then
         iprm = freeunit ()
         prmfile = 'multipole.prm'
         call version (prmfile,'new')
         open (unit=iprm,file=prmfile,status='new')
         call polesort (iprm)
         write (iout,80)  prmfile(1:trimtext(prmfile))
   80    format (/,' Sorted Multipole Values Written To :  ',a)
         close (unit=iprm)
      end if
c
c     renumber and format any biotype parameter values
c
      if (mode .eq. 7) then
         iprm = freeunit ()
         prmfile = 'biotype.prm'
         call version (prmfile,'new')
         open (unit=iprm,file=prmfile,status='new')
         call biosort (iprm)
         write (iout,90)  prmfile(1:trimtext(prmfile))
   90    format (/,' Renumbered Biotype Values Written To :  ',a)
         close (unit=iprm)
      end if
      call final
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine prmform  --  reformat individual parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "prmform" formats each individual parameter record to conform
c     to a consistent text layout
c
c
      subroutine prmform (iprm)
      use angpot
      use bndpot
      use math
      use params
      use sizes
      use urypot
      implicit none
      integer i,j,iprm
      integer ia,ib,ic
      integer id,ie,itemp
      integer length,next
      integer trimtext
      integer atn,lig
      integer kg,kt
      integer nx,ny,nxy
      integer ft(6)
      integer ig(20)
      real*8 wght,temp
      real*8 rd,ep,rdn
      real*8 spr,apr,epr
      real*8 cdp,adp
      real*8 dl,fc,bd
      real*8 an1,an2,an3
      real*8 an,pr
      real*8 ba1,ba2
      real*8 ds,dk,vd,pt
      real*8 aa1,aa2,aa3
      real*8 bt1,bt2,bt3
      real*8 bt4,bt5,bt6
      real*8 bt7,bt8,bt9
      real*8 at1,at2,at3
      real*8 at4,at5,at6
      real*8 tx,ty,tf
      real*8 cg,dp,ps,pl
      real*8 pl1,pl2,pl3
      real*8 pel,pal
      real*8 pol,thl,thd
      real*8 ctrn,atrn
      real*8 cfb,cfa1,cfa2
      real*8 cfb1,cfb2
      real*8 el,iz,rp
      real*8 pbrd,csrd
      real*8 gkrd,snek
      real*8 ss,ts
      real*8 vt(6),st(6)
      character*3 sym
      character*20 keyword
      character*20 text
      character*24 note
      character*30 blank
      character*240 record
      character*240 string
c
c
c     reformat and print the various parameters
c
      i = 0
      blank = '                              '
      do while (i .lt. nprm)
         i = i + 1
         record = prmline(i)
         length = trimtext (record)
         next = 1
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:5) .eq. 'ATOM ') then
            ia = -1
            ib = -1
            sym = '   '
            note = '                        '
            atn = 0
            wght = 0.0d0
            lig = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call gettext (record,sym,next)
            call getstring (record,note,next)
            string = record(next:240)
            read (string,*,err=10,end=10)  atn,wght,lig
   10       continue
            length = trimtext(note)
            string = '"'//note(1:length)//'"'//blank
            if (ib .ge. 0) then
               write (iprm,20)  ia,ib,sym,string(1:26),atn,wght,lig
   20          format ('atom',6x,2i5,4x,a3,3x,a26,1x,i5,f10.3,i5)
            else if (ia .ge. 0) then
               write (iprm,30)  ia,sym,string(1:26),atn,wght,lig
   30          format ('atom',6x,i5,4x,a3,3x,a26,1x,i5,f10.3,i5)
            else
               write (iprm,40)  record(1:length)
   40          format (a)
            end if
         else if (keyword(1:4) .eq. 'VDW ') then
            ia = 0
            rd = 0.0d0
            ep = 0.0d0
            rdn = 0.0d0
            read (string,*,err=50,end=50)  ia,rd,ep,rdn
   50       continue
            if (rdn .eq. 0.0d0) then
               write (iprm,60)  ia,rd,ep
   60          format ('vdw',7x,i5,10x,2f11.4)
            else
               write (iprm,70)  ia,rd,ep,rdn
   70          format ('vdw',7x,i5,10x,2f11.4,f11.3)
            end if
         else if (keyword(1:6) .eq. 'VDW14 ') then
            ia = 0
            rd = 0.0d0
            ep = 0.0d0
            read (string,*,err=80,end=80)  ia,rd,ep
   80       continue
            write (iprm,90)  ia,rd,ep
   90       format ('vdw14',5x,i5,10x,2f11.4)
         else if (keyword(1:8) .eq. 'VDWPAIR ' .or.
     &            keyword(1:6) .eq. 'VDWPR ') then
            ia = 0
            ib = 0
            rd = 0.0d0
            ep = 0.0d0
            read (string,*,err=100,end=100)  ia,ib,rd,ep
  100       continue
            write (iprm,110)  ia,ib,rd,ep
  110       format ('vdwpair',3x,2i5,5x,2f11.4)
         else if (keyword(1:6) .eq. 'HBOND ') then
            ia = 0
            ib = 0
            rd = 0.0d0
            ep = 0.0d0
            read (string,*,err=120,end=120)  ia,ib,rd,ep
  120       continue
            write (iprm,130)  ia,ib,rd,ep
  130       format ('hbond',5x,2i5,5x,2f11.4)
         else if (keyword(1:10) .eq. 'REPULSION ') then
            ia = 0
            spr = 0.0d0
            apr = 0.0d0
            epr = 0.0d0
            read (string,*,err=140,end=140)  ia,spr,apr,epr
  140       continue
            write (iprm,150)  ia,spr,apr,epr
  150       format ('repulsion',6x,i5,5x,2f11.4,f11.3)
         else if (keyword(1:11) .eq. 'DISPERSION ') then
            ia = 0
            cdp = 0.0d0
            adp = 0.0d0
            read (string,*,err=160,end=160)  ia,cdp,adp
  160       continue
            write (iprm,170)  ia,cdp,adp
  170       format ('dispersion',5x,i5,5x,2f11.4)
         else if (keyword(1:5) .eq. 'BOND ') then
            ia = 0
            ib = 0
            fc = 0.0d0
            bd = 0.0d0
            read (string,*,err=180,end=180)  ia,ib,fc,bd
  180       continue
            if (ia .gt. ib) then
               itemp = ia
               ia = ib
               ib = itemp
            end if
            if (bndunit .lt. 10.0d0) then
               write (iprm,190)  ia,ib,fc,bd
  190          format ('bond',6x,2i5,5x,f11.2,f11.4)
            else
               write (iprm,200)  ia,ib,fc,bd
  200          format ('bond',6x,2i5,5x,f11.3,f11.4)
            end if
         else if (keyword(1:6) .eq. 'BOND5 ') then
            ia = 0
            ib = 0
            fc = 0.0d0
            bd = 0.0d0
            read (string,*,err=210,end=210)  ia,ib,fc,bd
  210       continue
            if (ia .gt. ib) then
               itemp = ia
               ia = ib
               ib = itemp
            end if
            if (bndunit .lt. 10.0d0) then
               write (iprm,220)  ia,ib,fc,bd
  220          format ('bond5',5x,2i5,5x,f11.2,f11.4)
            else
               write (iprm,230)  ia,ib,fc,bd
  230          format ('bond5',5x,2i5,5x,f11.3,f11.4)
            end if
         else if (keyword(1:6) .eq. 'BOND4 ') then
            ia = 0
            ib = 0
            fc = 0.0d0
            bd = 0.0d0
            read (string,*,err=240,end=240)  ia,ib,fc,bd
  240       continue
            if (ia .gt. ib) then
               itemp = ia
               ia = ib
               ib = itemp
            end if
            if (bndunit .lt. 10.0d0) then
               write (iprm,250)  ia,ib,fc,bd
  250          format ('bond4',5x,2i5,5x,f11.2,f11.4)
            else
               write (iprm,260)  ia,ib,fc,bd
  260          format ('bond4',5x,2i5,5x,f11.3,f11.4)
            end if
         else if (keyword(1:6) .eq. 'BOND3 ') then
            ia = 0
            ib = 0
            fc = 0.0d0
            bd = 0.0d0
            read (string,*,err=270,end=270)  ia,ib,fc,bd
  270       continue
            if (ia .gt. ib) then
               itemp = ia
               ia = ib
               ib = itemp
            end if
            if (bndunit .lt. 10.0d0) then
               write (iprm,280)  ia,ib,fc,bd
  280          format ('bond3',5x,2i5,5x,f11.2,f11.4)
            else
               write (iprm,290)  ia,ib,fc,bd
  290          format ('bond3',5x,2i5,5x,f11.3,f11.4)
            end if
         else if (keyword(1:9) .eq. 'ELECTNEG ') then
            ia = 0
            ib = 0
            ic = 0
            dl = 0.0d0
            read (string,*,err=300,end=300)  ia,ib,ic,dl
  300       continue
            write (iprm,310)  ia,ib,ic,dl
  310       format ('electneg',2x,3i5,11x,f11.4)
         else if (keyword(1:6) .eq. 'ANGLE ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            an2 = 0.0d0
            an3 = 0.0d0
            read (string,*,err=320,end=320)  ia,ib,ic,fc,an1,an2,an3
  320       continue
            if (ia .gt. ic) then
               itemp = ia
               ia = ic
               ic = itemp
            end if
            if (an2.eq.0.0d0 .and. an3.eq.0.0d0) then
               if (angunit .lt. 10.0d0/radian**2) then
                  write (iprm,330)  ia,ib,ic,fc,an1
  330             format ('angle',5x,3i5,f11.2,f11.2)
               else
                  write (iprm,340)  ia,ib,ic,fc,an1
  340             format ('angle',5x,3i5,f11.3,f11.2)
               end if
            else
               if (angunit .lt. 10.0d0/radian**2) then
                  write (iprm,350)  ia,ib,ic,fc,an1,an2,an3
  350             format ('angle',5x,3i5,f11.2,3f11.2)
               else
                  write (iprm,360)  ia,ib,ic,fc,an1,an2,an3
  360             format ('angle',5x,3i5,f11.3,3f11.2)
               end if
            end if
         else if (keyword(1:7) .eq. 'ANGLE5 ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            an2 = 0.0d0
            an3 = 0.0d0
            read (string,*,err=370,end=370)  ia,ib,ic,fc,an1,an2,an3
  370       continue
            if (ia .gt. ic) then
               itemp = ia
               ia = ic
               ic = itemp
            end if
            if (an2.eq.0.0d0 .and. an3.eq.0.0d0) then
               if (angunit .lt. 10.0d0/radian**2) then
                  write (iprm,380)  ia,ib,ic,fc,an1
  380             format ('angle5',4x,3i5,f11.2,f11.2)
               else
                  write (iprm,390)  ia,ib,ic,fc,an1
  390             format ('angle5',4x,3i5,f11.3,f11.2)
               end if
            else
               if (angunit .lt. 10.0d0/radian**2) then
                  write (iprm,400)  ia,ib,ic,fc,an1,an2,an3
  400             format ('angle5',4x,3i5,f11.2,3f11.2)
               else
                  write (iprm,410)  ia,ib,ic,fc,an1,an2,an3
  410             format ('angle5',4x,3i5,f11.3,3f11.2)
               end if
            end if
         else if (keyword(1:7) .eq. 'ANGLE4 ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            an2 = 0.0d0
            an3 = 0.0d0
            read (string,*,err=420,end=420)  ia,ib,ic,fc,an1,an2,an3
  420       continue
            if (ia .gt. ic) then
               itemp = ia
               ia = ic
               ic = itemp
            end if
            if (an2.eq.0.0d0 .and. an3.eq.0.0d0) then
               if (angunit .lt. 10.0d0/radian**2) then
                  write (iprm,430)  ia,ib,ic,fc,an1
  430             format ('angle4',4x,3i5,f11.2,f11.2)
               else
                  write (iprm,440)  ia,ib,ic,fc,an1
  440             format ('angle4',4x,3i5,f11.3,f11.2)
               end if
            else
               if (angunit .lt. 10.0d0/radian**2) then
                  write (iprm,450)  ia,ib,ic,fc,an1,an2,an3
  450             format ('angle4',4x,3i5,f11.2,3f11.2)
               else
                  write (iprm,460)  ia,ib,ic,fc,an1,an2,an3
  460             format ('angle4',4x,3i5,f11.3,3f11.2)
               end if
            end if
         else if (keyword(1:7) .eq. 'ANGLE3 ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            an2 = 0.0d0
            an3 = 0.0d0
            read (string,*,err=470,end=470)  ia,ib,ic,fc,an1,an2,an3
  470       continue
            if (ia .gt. ic) then
               itemp = ia
               ia = ic
               ic = itemp
            end if
            if (an2.eq.0.0d0 .and. an3.eq.0.0d0) then
               if (angunit .lt. 10.0d0/radian**2) then
                  write (iprm,480)  ia,ib,ic,fc,an1
  480             format ('angle3',4x,3i5,f11.2,f11.2)
               else
                  write (iprm,490)  ia,ib,ic,fc,an1
  490             format ('angle3',4x,3i5,f11.3,f11.2)
               end if
            else
               if (angunit .lt. 10.0d0/radian**2) then
                  write (iprm,500)  ia,ib,ic,fc,an1,an2,an3
  500             format ('angle3',4x,3i5,f11.2,3f11.2)
               else
                  write (iprm,510)  ia,ib,ic,fc,an1,an2,an3
  510             format ('angle3',4x,3i5,f11.3,3f11.2)
               end if
            end if
         else if (keyword(1:7) .eq. 'ANGLEP ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            an2 = 0.0d0
            an3 = 0.0d0
            read (string,*,err=520,end=520)  ia,ib,ic,fc,an1,an2,an3
  520       continue
            if (ia .gt. ic) then
               itemp = ia
               ia = ic
               ic = itemp
            end if
            if (an2.eq.0.0d0 .and. an3.eq.0.0d0) then
               if (angunit .lt. 10.0d0/radian**2) then
                  write (iprm,530)  ia,ib,ic,fc,an1
  530             format ('anglep',4x,3i5,f11.2,f11.2)
               else
                  write (iprm,540)  ia,ib,ic,fc,an1
  540             format ('anglep',4x,3i5,f11.3,f11.2)
               end if
            else
               if (angunit .lt. 10.0d0/radian**2) then
                  write (iprm,550)  ia,ib,ic,fc,an1,an2,an3
  550             format ('anglep',4x,3i5,f11.2,3f11.2)
               else
                  write (iprm,560)  ia,ib,ic,fc,an1,an2,an3
  560             format ('anglep',4x,3i5,f11.3,3f11.2)
               end if
            end if
         else if (keyword(1:7) .eq. 'ANGLEF ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an = 0.0d0
            pr = 0.0d0
            read (string,*,err=570,end=570)  ia,ib,ic,fc,an,pr
  570       continue
            if (ia .gt. ic) then
               itemp = ia
               ia = ic
               ic = itemp
            end if
            if (angunit .lt. 10.0d0/radian**2) then
               write (iprm,580)  ia,ib,ic,fc,an,pr
  580          format ('anglef',4x,3i5,f11.2,f11.2,f11.1)
            else
               write (iprm,590)  ia,ib,ic,fc,an,pr
  590          format ('anglef',4x,3i5,f11.3,f11.2,f11.1)
            end if
         else if (keyword(1:7) .eq. 'STRBND ') then
            ia = 0
            ib = 0
            ic = 0
            ba1 = 0.0d0
            ba2 = 0.0d0
            read (string,*,err=600,end=600)  ia,ib,ic,ba1,ba2
  600       continue
            if (ia .gt. ic) then
               itemp = ia
               ia = ic
               ic = itemp
               temp = ba1
               ba1 = ba2
               ba2 = temp
            end if
            if (stbnunit .lt. 10.0d0/radian) then
               write (iprm,610)  ia,ib,ic,ba1,ba2
  610          format ('strbnd',4x,3i5,2f11.2)
            else
               write (iprm,620)  ia,ib,ic,ba1,ba2
  620          format ('strbnd',4x,3i5,2f11.3)
            end if
         else if (keyword(1:9) .eq. 'UREYBRAD ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            ds = 0.0d0
            read (string,*,err=630,end=630)  ia,ib,ic,fc,ds
  630       continue
            if (ia .gt. ic) then
               itemp = ia
               ia = ic
               ic = itemp
            end if
            if (ureyunit .lt. 10.0d0) then
               write (iprm,640)  ia,ib,ic,fc,ds
  640          format ('ureybrad',2x,3i5,f11.2,f11.4)
            else
               write (iprm,650)  ia,ib,ic,fc,ds
  650          format ('ureybrad',2x,3i5,f11.3,f11.4)
            end if
         else if (keyword(1:7) .eq. 'ANGANG ') then
            ia = 0
            aa1 = 0.0d0
            aa2 = 0.0d0
            aa3 = 0.0d0
            read (string,*,err=660,end=660)  ia,aa1,aa2,aa3
  660       continue
            if (abs(aaunit) .lt. 10.0d0/radian**2) then
               write (iprm,670)  ia,aa1,aa2,aa3
  670          format ('angang',4x,i5,10x,3f11.2)
            else
               write (iprm,680)  ia,aa1,aa2,aa3
  680          format ('angang',4x,i5,10x,3f11.3)
            end if
         else if (keyword(1:7) .eq. 'OPBEND ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            fc = 0.0d0
            read (string,*,err=690,end=690)  ia,ib,ic,id,fc
  690       continue
            if (ic .gt. id) then
               itemp = ic
               ic = id
               id = itemp
            end if
            if (opbunit .lt. 10.0d0/radian**2) then
               write (iprm,700)  ia,ib,ic,id,fc
  700          format ('opbend',4x,4i5,6x,f11.2)
            else
               write (iprm,710)  ia,ib,ic,id,fc
  710          format ('opbend',4x,4i5,6x,f11.3)
            end if
         else if (keyword(1:7) .eq. 'OPDIST ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            fc = 0.0d0
            read (string,*,err=720,end=720)  ia,ib,ic,id,fc
  720       continue
            if (opdunit .lt. 10.0d0) then
               write (iprm,730)  ia,ib,ic,id,fc
  730          format ('opdist',4x,4i5,6x,f11.2)
            else
               write (iprm,740)  ia,ib,ic,id,fc
  740          format ('opdist',4x,4i5,6x,f11.3)
            end if
         else if (keyword(1:9) .eq. 'IMPROPER ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            dk = 0.0d0
            vd = 0.0d0
            read (string,*,err=750,end=750)  ia,ib,ic,id,dk,vd
  750       continue
            write (iprm,760)  ia,ib,ic,id,dk,vd
  760       format ('improper',2x,4i5,6x,2f11.2)
         else if (keyword(1:8) .eq. 'IMPTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do j = 1, 6
               vt(j) = 0.0d0
               st(j) = 0.0d0
               ft(j) = 0
            end do
            read (string,*,err=770,end=770)  ia,ib,ic,id,
     &                                       (vt(j),st(j),ft(j),j=1,6)
  770       continue
            kt = 0
            do j = 1, 6
               if (ft(j) .ne. 0) then
                  kt = j
               end if
            end do
            write (iprm,780)  ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt)
  780       format ('imptors',3x,4i5,6x,6(f11.3,f7.1,i3))
         else if (keyword(1:8) .eq. 'TORSION ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do j = 1, 6
               vt(j) = 0.0d0
               st(j) = 0.0d0
               ft(j) = 0
            end do
            read (string,*,err=790,end=790)  ia,ib,ic,id,
     &                                       (vt(j),st(j),ft(j),j=1,6)
  790       continue
            if (ib .gt. ic) then
               itemp = ib
               ib = ic
               ic = itemp
               itemp = ia
               ia = id
               id = itemp
            else if (ib.eq.ic .and. ia.gt.id) then
               itemp = ia
               ia = id
               id = itemp
            end if
            kt = 0
            do j = 1, 6
               if (ft(j) .ne. 0) then
                  kt = j
               end if
            end do
            if (kt.eq.3 .and. st(1).eq.0.0d0 .and. st(2).eq.180.0d0
     &                  .and. st(3).eq.0.0d0) then
               write (iprm,800)  ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt)
  800          format ('torsion',3x,4i5,3x,f8.3,f4.1,i2,
     &                    f8.3,f6.1,i2,f8.3,f4.1,i2)
            else if (kt .le. 2) then
               write (iprm,810)  ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt)
  810          format ('torsion',3x,4i5,6x,2(f11.3,f7.1,i3))
            else
               write (iprm,820)  ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt)
  820          format ('torsion',3x,4i5,3x,6(f8.3,f6.1,i2))
            end if
         else if (keyword(1:9) .eq. 'TORSION5 ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do j = 1, 6
               vt(j) = 0.0d0
               st(j) = 0.0d0
               ft(j) = 0
            end do
            read (string,*,err=830,end=830)  ia,ib,ic,id,
     &                                       (vt(j),st(j),ft(j),j=1,6)
  830       continue
            if (ib .gt. ic) then
               itemp = ib
               ib = ic
               ic = itemp
               itemp = ia
               ia = id
               id = itemp
            else if (ib.eq.ic .and. ia.gt.id) then
               itemp = ia
               ia = id
               id = itemp
            end if
            kt = 0
            do j = 1, 6
               if (ft(j) .ne. 0) then
                  kt = j
               end if
            end do
            if (kt.eq.3 .and. st(1).eq.0.0d0 .and. st(2).eq.180.0d0
     &                  .and. st(3).eq.0.0d0) then
               write (iprm,840)  ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt)
  840          format ('torsion5',2x,4i5,3x,f8.3,f4.1,i2,
     &                    f8.3,f6.1,i2,f8.3,f4.1,i2)
            else if (kt .le. 2) then
               write (iprm,850)  ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt)
  850          format ('torsion5',2x,4i5,6x,2(f11.3,f7.1,i3))
            else
               write (iprm,860)  ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt)
  860          format ('torsion5',2x,4i5,3x,6(f8.3,f6.1,i2))
            end if
         else if (keyword(1:9) .eq. 'TORSION4 ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do j = 1, 6
               vt(j) = 0.0d0
               st(j) = 0.0d0
               ft(j) = 0
            end do
            read (string,*,err=870,end=870)  ia,ib,ic,id,
     &                                       (vt(j),st(j),ft(j),j=1,6)
  870       continue
            if (ib .gt. ic) then
               itemp = ib
               ib = ic
               ic = itemp
               itemp = ia
               ia = id
               id = itemp
            else if (ib.eq.ic .and. ia.gt.id) then
               itemp = ia
               ia = id
               id = itemp
            end if
            kt = 0
            do j = 1, 6
               if (ft(j) .ne. 0) then
                  kt = j
               end if
            end do
            if (kt.eq.3 .and. st(1).eq.0.0d0 .and. st(2).eq.180.0d0
     &                  .and. st(3).eq.0.0d0) then
               write (iprm,880)  ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt)
  880          format ('torsion4',2x,4i5,3x,f8.3,f4.1,i2,
     &                    f8.3,f6.1,i2,f8.3,f4.1,i2)
            else if (kt .le. 2) then
               write (iprm,890)  ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt)
  890          format ('torsion4',2x,4i5,6x,2(f11.3,f7.1,i3))
            else
               write (iprm,900)  ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt)
  900          format ('torsion4',2x,4i5,3x,6(f8.3,f6.1,i2))
            end if
         else if (keyword(1:7) .eq. 'PITORS ') then
            ia = 0
            ib = 0
            pt = 0.0d0
            read (string,*,err=910,end=910)  ia,ib,pt
  910       continue
            if (ia .gt. ib) then
               itemp = ia
               ia = ib
               ib = itemp
            end if
            write (iprm,920)  ia,ib,pt
  920       format ('pitors',4x,2i5,5x,f11.2)
         else if (keyword(1:8) .eq. 'STRTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            bt1 = 0.0d0
            bt2 = 0.0d0
            bt3 = 0.0d0
            bt4 = 0.0d0
            bt5 = 0.0d0
            bt6 = 0.0d0
            bt7 = 0.0d0
            bt8 = 0.0d0
            bt9 = 0.0d0
            read (string,*,err=930,end=930)  ia,ib,ic,id,bt1,bt2,bt3,
     &                                       bt4,bt5,bt6,bt7,bt8,bt9
  930       continue
            write (iprm,940)  ia,ib,ic,id,bt1,bt2,bt3,
     &                        bt4,bt5,bt6,bt7,bt8,bt9
  940       format ('strtors',3x,4i5,1x,9f8.3)
         else if (keyword(1:8) .eq. 'ANGTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            at1 = 0.0d0
            at2 = 0.0d0
            at3 = 0.0d0
            at4 = 0.0d0
            at5 = 0.0d0
            at6 = 0.0d0
            read (string,*,err=950,end=950)  ia,ib,ic,id,at1,at2,
     &                                       at3,at4,at5,at6
  950       continue
            write (iprm,960)  ia,ib,ic,id,at1,at2,at3,at4,at5,at6
  960       format ('angtors',3x,4i5,1x,6f8.3)
         else if (keyword(1:8) .eq. 'TORTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            ie = 0
            nx = 0
            ny = 0
            read (string,*,err=970,end=970)  ia,ib,ic,id,ie,nx,ny
  970       continue
            write (iprm,980)  ia,ib,ic,id,ie,nx,ny
  980       format ('tortors',3x,5i5,5x,2i5)
            nxy = nx * ny
            do j = 1, nxy
               i = i + 1
               record = prmline(i)
               read (record,*,err=990,end=990)  tx,ty,tf
  990          continue
               write (iprm,1000)  tx,ty,tf
 1000          format (f8.1,1x,f8.1,1x,f11.5)
            end do
         else if (keyword(1:7) .eq. 'CHARGE ') then
            ia = 0
            cg = 0.0d0
            read (string,*,err=1010,end=1010)  ia,cg
 1010       continue
            write (iprm,1020)  ia,cg
 1020       format ('charge',4x,i5,10x,f11.4)
         else if (keyword(1:7) .eq. 'DIPOLE ') then
            ia = 0
            ib = 0
            dp = 0.0d0
            ps = 0.5d0
            read (string,*,err=1030,end=1030)  ia,ib,dp,ps
 1030       continue
            if (ia .gt. ib) then
               itemp = ia
               ia = ib
               ib = itemp
               dp = -dp
               ps = 1.0d0 - ps
            end if
            write (iprm,1040)  ia,ib,dp,ps
 1040       format ('dipole',4x,2i5,5x,f11.4,f11.3)
         else if (keyword(1:8) .eq. 'DIPOLE5 ') then
            ia = 0
            ib = 0
            dp = 0.0d0
            ps = 0.5d0
            read (string,*,err=1050,end=1050)  ia,ib,dp,ps
 1050       continue
            if (ia .gt. ib) then
               itemp = ia
               ia = ib
               ib = itemp
               dp = -dp
               ps = 1.0d0 - ps
            end if
            write (iprm,1060)  ia,ib,dp,ps
 1060       format ('dipole5',3x,2i5,5x,f11.4,f11.3)
         else if (keyword(1:8) .eq. 'DIPOLE4 ') then
            ia = 0
            ib = 0
            dp = 0.0d0
            ps = 0.5d0
            read (string,*,err=1070,end=1070)  ia,ib,dp,ps
 1070       continue
            if (ia .gt. ib) then
               itemp = ia
               ia = ib
               ib = itemp
               dp = -dp
               ps = 1.0d0 - ps
            end if
            write (iprm,1080)  ia,ib,dp,ps
 1080       format ('dipole4',3x,2i5,5x,f11.4,f11.3)
         else if (keyword(1:8) .eq. 'DIPOLE3 ') then
            ia = 0
            ib = 0
            dp = 0.0d0
            ps = 0.5d0
            read (string,*,err=1090,end=1090)  ia,ib,dp,ps
 1090       continue
            if (ia .gt. ib) then
               itemp = ia
               ia = ib
               ib = itemp
               dp = -dp
               ps = 1.0d0 - ps
            end if
            write (iprm,1100)  ia,ib,dp,ps
 1100       format ('dipole3',3x,2i5,5x,f11.4,f11.3)
         else if (keyword(1:10) .eq. 'MULTIPOLE ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            pl = 0.0d0
            read (string,*,err=1110,end=1110)  ia,ib,ic,id,pl
            goto 1120
 1110       continue
            id = 0
            read (string,*,err=1120,end=1120)  ia,ib,ic,pl
 1120       continue
            if (id .eq. 0) then
               write (iprm,1130)  ia,ib,ic,pl
 1130          format ('multipole',1x,3i5,11x,f11.5)
            else
               write (iprm,1140)  ia,ib,ic,id,pl
 1140          format ('multipole',1x,4i5,6x,f11.5)
            end if
            i = i + 1
            record = prmline(i)
            read (record,*,err=1150,end=1150)  pl1,pl2,pl3
 1150       continue
            write (iprm,1160)  pl1,pl2,pl3
 1160       format (36x,3f11.5)
            i = i + 1
            record = prmline(i)
            read (record,*,err=1170,end=1170)  pl1
 1170       continue
            write (iprm,1180)  pl1
 1180       format (36x,f11.5)
            i = i + 1
            record = prmline(i)
            read (record,*,err=1190,end=1190)  pl1,pl2
 1190       continue
            write (iprm,1200)  pl1,pl2
 1200       format (36x,2f11.5)
            i = i + 1
            record = prmline(i)
            read (record,*,err=1210,end=1210)  pl1,pl2,pl3
 1210       continue
            write (iprm,1220)  pl1,pl2,pl3
 1220       format (36x,3f11.5)
         else if (keyword(1:7) .eq. 'CHGPEN ') then
            ia = 0
            pel = 0.0d0
            pal = 0.0d0
            read (string,*,err=1230,end=1230)  ia,pel,pal
 1230       continue
            write (iprm,1240)  ia,pel,pal
 1240       format ('chgpen',9x,i5,5x,2f11.4)
         else if (keyword(1:9) .eq. 'POLARIZE ') then
            ia = 0
            pol = 0.0d0
            thl = -1.0d0
            thd = -1.0d0
            do j = 1, 20
               ig(j) = 0
            end do
            call getnumb (record,ia,next)
            call gettext (record,text,next)
            read (text,*,err=1250,end=1250)  pol
            call gettext (record,text,next)
            j = 1
            call getnumb (text,ig(1),j)
            if (ig(1) .eq. 0) then
               read (text,*,err=1250,end=1250)  thl
               call gettext (record,text,next)
               j = 1
               call getnumb (text,ig(1),j)
               string = record(next:240)
               if (ig(1) .eq. 0) then
                  read (text,*,err=1250,end=1250)  thd
                  read (string,*,err=1250,end=1250)  (ig(j),j=1,20)
               else
                  read (string,*,err=1250,end=1250)  (ig(j),j=2,20)
               end if
            else
               string = record(next:240)
               read (string,*,err=1250,end=1250)  (ig(j),j=2,20)
            end if
 1250       continue
            kg = 0
            do j = 1, 20
               if (ig(j) .ne. 0) then
                  kg = j
               end if
            end do
            call sort (kg,ig)
            if (thd .ge. 0.0d0) then
               write (iprm,1260)  ia,pol,thl,thd,(ig(j),j=1,kg)
 1260          format ('polarize',2x,i5,5x,3f11.4,2x,20i5)
            else if (thl .ge. 0.0d0) then
               write (iprm,1270)  ia,pol,thl,(ig(j),j=1,kg)
 1270          format ('polarize',2x,i5,10x,2f11.4,2x,20i5)
            else
               write (iprm,1280)  ia,pol,(ig(j),j=1,kg)
 1280          format ('polarize',2x,i5,10x,f11.4,2x,20i5)
            end if
         else if (keyword(1:8) .eq. 'POLPAIR ') then
            ia = 0
            ib = 0
            thl = 0.0d0
            thd = 0.0d0
            read (string,*,err=1290,end=1290)  ia,ib,thl,thd
 1290       continue
            write (iprm,1300)  ia,ib,thl,thd
 1300       format ('polpair',3x,2i5,5x,2f11.4)
         else if (keyword(1:7) .eq. 'CHGTRN ') then
            ia = 0
            ctrn = 0.0d0
            atrn = 0.0d0
            read (string,*,err=1310,end=1310)  ia,ctrn,atrn
 1310       continue
            write (iprm,1320)  ia,ctrn,atrn
 1320       format ('chgtrn',9x,i5,5x,2f11.4)
         else if (keyword(1:9) .eq. 'BNDCFLUX ') then
            ia = 0
            ib = 0
            cfb = 0.0d0
            read (string,*,err=1330,end=1330)  ia,ib,cfb
 1330       continue
            write (iprm,1340)  ia,ib,cfb
 1340       format ('bndcflux',2x,2i5,9x,f11.5)
         else if (keyword(1:9) .eq. 'ANGCFLUX ') then
            ia = 0
            ib = 0
            ic = 0
            cfa1 = 0.0d0
            cfa2 = 0.0d0
            cfb1 = 0.0d0
            cfb2 = 0.0d0
            read (string,*,err=1350,end=1350)  ia,ib,cfa1,cfa2,cfb1,cfb2
 1350       continue
            write (iprm,1360)  ia,ib,cfa1,cfa2,cfb1,cfb2
 1360       format ('angcflux',2x,2i5,9x,4f11.5)
         else if (keyword(1:7) .eq. 'SOLUTE ') then
            ia = 0
            pbrd = 0.0d0
            csrd = 0.0d0
            gkrd = 0.0d0
            snek = 0.0d0
            read (string,*,err=1370,end=1370)  ia,pbrd,csrd,gkrd,snek
 1370       continue
            write (iprm,1380)  ia,pbrd,csrd,gkrd,snek
 1380       format ('solute',4x,i5,5x,4f11.4)
         else if (keyword(1:7) .eq. 'PIATOM ') then
            ia = 0
            el = 0.0d0
            iz = 0.0d0
            rp = 0.0d0
            read (string,*,err=1390,end=1390)  ia,el,iz,rp
 1390       continue
            write (iprm,1400)  ia,el,iz,rp
 1400       format ('piatom',4x,i5,10x,f11.1,2f11.3)
         else if (keyword(1:7) .eq. 'PIBOND ') then
            ia = 0
            ib = 0
            ss = 0.0d0
            ts = 0.0d0
            read (string,*,err=1410,end=1410)  ia,ib,ss,ts
 1410       continue
            write (iprm,1420)  ia,ib,ss,ts
 1420       format ('pibond',4x,2i5,5x,f11.3,f11.4)
         else if (keyword(1:8) .eq. 'PIBOND5 ') then
            ia = 0
            ib = 0
            ss = 0.0d0
            ts = 0.0d0
            read (string,*,err=1430,end=1430)  ia,ib,ss,ts
 1430       continue
            write (iprm,1440)  ia,ib,ss,ts
 1440       format ('pibond5',3x,2i5,5x,f11.3,f11.4)
         else if (keyword(1:8) .eq. 'PIBOND4 ') then
            ia = 0
            ib = 0
            ss = 0.0d0
            ts = 0.0d0
            read (string,*,err=1450,end=1450)  ia,ib,ss,ts
 1450       continue
            write (iprm,1460)  ia,ib,ss,ts
 1460       format ('pibond4',3x,2i5,5x,f11.3,f11.4)
         else if (keyword(1:6) .eq. 'METAL ') then
            ia = 0
            call getnumb (record,ia,next)
            write (iprm,1470)  ia,record(next:length)
 1470       format ('metal',5x,i5,a)
         else if (keyword(1:8) .eq. 'BIOTYPE ') then
            ia = 0
            ib = 0
            sym = '   '
            note = '                        '
            read (string,*,err=1480,end=1480)  ia
            call getword (record,sym,next)
            call getstring (record,note,next)
            string = record(next:240)
            read (string,*,err=1480,end=1480)  ib
 1480       continue
            length = trimtext(note)
            string = '"'//note(1:length)//'"'//blank
            write (iprm,1490)  ia,sym,string(1:30),ib
 1490       format ('biotype',3x,i5,4x,a3,5x,a30,2x,i5)
         else if (length .eq. 0) then
            write (iprm,1500)
 1500       format ()
         else
            write (iprm,1510)  record(1:length)
 1510       format (a)
         end if
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine prmorder  --  reorder atom types and classes  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "prmorder" places a list of atom type or class numbers into
c     canonical order for potential energy parameter definitions
c
c
      subroutine prmorder (iprm,dotype,doclass)
      use iounit
      use params
      use sizes
      use vdwpot
      implicit none
      integer i,j,iprm
      integer it,ic,kt,kc
      integer ia,ib,id,ie
      integer ia0,ib0,ic0,id0
      integer offset,next
      integer length
      integer trimtext
      integer kg,ig(20)
      integer itype(0:maxtyp)
      integer iclass(0:maxclass)
      real*8 pol,thl,thd
      logical dotype,doclass
      logical keep,prtclass
      character*20 keyword
      character*20 text
      character*30 blank
      character*240 record
      character*240 string
c
c
c     zero out the storage for atom types and classes
c
      ia = 0
      ib = 0
      ic = 0
      id = 0
      ie = 0
      kt = 0
      kc = 0
      do i = 0, maxtyp
         itype(i) = 0
      end do
      do i = 0, maxclass
         iclass(i) = 0
      end do
      blank = '                              '
c
c     get the starting numbers for atom types and classes
c
      if (dotype) then
         write (iout,10)
   10    format (/,' Enter Starting Number for Atom Types [1] :  ',$)
         read (input,20)  offset
   20    format (i10)
         if (offset .gt. 0)  kt = offset - 1
      end if
      if (doclass) then
         write (iout,30)
   30    format (/,' Enter Starting Number for Atom Classes [1] :  ',$)
         read (input,40)  offset
   40    format (i10)
         if (offset .gt. 0)  kc = offset - 1
      end if
c
c     count, order and test equivalence of atom types and classes
c
      prtclass = .false.
      do i = 1, nprm
         record = prmline(i)
         next = 1
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:5) .eq. 'ATOM ') then
            it = 0
            ic = 0
            call getnumb (record,it,next)
            call getnumb (record,ic,next)
            if (ic .eq. 0)  ic = it
            if (it .ne. ic)  prtclass = .true.
            if (itype(it) .eq. 0) then
               kt = kt + 1
               if (dotype) then
                  itype(it) = kt
               else
                  itype(it) = it
               end if
            end if
            if (iclass(ic) .eq. 0) then
               kc = kc + 1
               if (doclass) then
                  iclass(ic) = kc
               else
                  iclass(ic) = ic
               end if
            end if
         end if
      end do
c
c     reorder, renumber and print the various parameters
c
      do i = 1, nprm
         record = prmline(i)
         length = trimtext (record)
         next = 1
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:5) .eq. 'ATOM ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            if (ib .eq. 0)  ib = ia
            ia = itype(ia)
            ib = iclass(ib)
            if (prtclass) then
               write (iprm,50)  ia,ib,record(next:length)
   50          format ('atom',6x,2i5,a)
            else
               write (iprm,60)  ia,record(next:length)
   60          format ('atom',6x,i5,a)
            end if
         else if (keyword(1:4) .eq. 'VDW ') then
            ia = 0
            call getnumb (record,ia,next)
            if (vdwindex .eq. 'TYPE') then
               ia = itype(ia)
            else
               ia = iclass(ia)
            end if
            if (ia .ne. 0) then
               write (iprm,70)  ia,record(next:length)
   70          format ('vdw',7x,i5,a)
            end if
         else if (keyword(1:6) .eq. 'VDW14 ') then
            ia = 0
            call getnumb (record,ia,next)
            if (vdwindex .eq. 'TYPE') then
               ia = itype(ia)
            else
               ia = iclass(ia)
            end if
            if (ia .ne. 0) then
               write (iprm,80)  ia,record(next:length)
   80          format ('vdw14',5x,i5,a)
            end if
         else if (keyword(1:8) .eq. 'VDWPAIR ' .or.
     &            keyword(1:6) .eq. 'VDWPR ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            if (vdwindex .eq. 'TYPE') then
               ia = itype(ia)
               ib = itype(ib)
            else
               ia = iclass(ia)
               ib = iclass(ib)
            end if
            if (min(ia,ib) .ne. 0) then
               call prmsort (2,ia,ib,0,0,0)
               write (iprm,90)  ia,ib,record(next:length)
   90          format ('vdwpair',3x,2i5,a)
            end if
         else if (keyword(1:6) .eq. 'HBOND ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            if (vdwindex .eq. 'TYPE') then
               ia = itype(ia)
               ib = itype(ib)
            else
               ia = iclass(ia)
               ib = iclass(ib)
            end if
            if (min(ia,ib) .ne. 0) then
               call prmsort (2,ia,ib,0,0,0)
               write (iprm,100)  ia,ib,record(next:length)
  100          format ('hbond',5x,2i5,a)
            end if
         else if (keyword(1:10) .eq. 'REPULSION ') then
            ia = 0
            call getnumb (record,ia,next)
            ia = iclass(ia)
            if (ia .ne. 0) then
               write (iprm,110)  ia,record(next:length)
  110          format ('repulsion',1x,i5,a)
            end if
         else if (keyword(1:11) .eq. 'DISPERSION ') then
            ia = 0
            call getnumb (record,ia,next)
            ia = iclass(ia)
            if (ia .ne. 0) then
               write (iprm,120)  ia,record(next:length)
  120          format ('dispersion',i5,a)
            end if
         else if (keyword(1:5) .eq. 'BOND ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = iclass(ia)
            ib = iclass(ib)
            if (min(ia,ib) .ne. 0) then
               call prmsort (2,ia,ib,0,0,0)
               write (iprm,130)  ia,ib,record(next:length)
  130          format ('bond',6x,2i5,a)
            end if
         else if (keyword(1:6) .eq. 'BOND5 ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = iclass(ia)
            ib = iclass(ib)
            if (min(ia,ib) .ne. 0) then
               call prmsort (2,ia,ib,0,0,0)
               write (iprm,140)  ia,ib,record(next:length)
  140          format ('bond5',5x,2i5,a)
            end if
         else if (keyword(1:6) .eq. 'BOND4 ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = iclass(ia)
            ib = iclass(ib)
            if (min(ia,ib) .ne. 0) then
               call prmsort (2,ia,ib,0,0,0)
               write (iprm,150)  ia,ib,record(next:length)
  150          format ('bond4',5x,2i5,a)
            end if
         else if (keyword(1:6) .eq. 'BOND3 ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = iclass(ia)
            ib = iclass(ib)
            if (min(ia,ib) .ne. 0) then
               call prmsort (2,ia,ib,0,0,0)
               write (iprm,160)  ia,ib,record(next:length)
  160          format ('bond3',5x,2i5,a)
            end if
         else if (keyword(1:9) .eq. 'ELECTNEG ') then
            ia = 0
            ib = 0
            ic = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            if (min(ia,ib,ic) .ne. 0) then
               write (iprm,170)  ia,ib,ic,record(next:length)
  170          format ('electneg',2x,3i5,a)
            end if
         else if (keyword(1:6) .eq. 'ANGLE ') then
            ia = 0
            ib = 0
            ic = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            if (min(ia,ib,ic) .ne. 0) then
               call prmsort (3,ia,ib,ic,0,0)
               write (iprm,180)  ia,ib,ic,record(next:length)
  180          format ('angle',5x,3i5,a)
            end if
         else if (keyword(1:7) .eq. 'ANGLE5 ') then
            ia = 0
            ib = 0
            ic = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            if (min(ia,ib,ic) .ne. 0) then
               call prmsort (3,ia,ib,ic,0,0)
               write (iprm,190)  ia,ib,ic,record(next:length)
  190          format ('angle5',4x,3i5,a)
            end if
         else if (keyword(1:7) .eq. 'ANGLE4 ') then
            ia = 0
            ib = 0
            ic = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            if (min(ia,ib,ic) .ne. 0) then
               call prmsort (3,ia,ib,ic,0,0)
               write (iprm,200)  ia,ib,ic,record(next:length)
  200          format ('angle4',4x,3i5,a)
            end if
         else if (keyword(1:7) .eq. 'ANGLE3 ') then
            ia = 0
            ib = 0
            ic = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            if (min(ia,ib,ic) .ne. 0) then
               call prmsort (3,ia,ib,ic,0,0)
               write (iprm,210)  ia,ib,ic,record(next:length)
  210          format ('angle3',4x,3i5,a)
            end if
         else if (keyword(1:7) .eq. 'ANGLEP ') then
            ia = 0
            ib = 0
            ic = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            if (min(ia,ib,ic) .ne. 0) then
               call prmsort (3,ia,ib,ic,0,0)
               write (iprm,220)  ia,ib,ic,record(next:length)
  220          format ('anglep',4x,3i5,a)
            end if
         else if (keyword(1:7) .eq. 'ANGLEF ') then
            ia = 0
            ib = 0
            ic = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            if (min(ia,ib,ic) .ne. 0) then
               call prmsort (3,ia,ib,ic,0,0)
               write (iprm,230)  ia,ib,ic,record(next:length)
  230          format ('anglef',4x,3i5,a)
            end if
         else if (keyword(1:7) .eq. 'STRBND ') then
            ia = 0
            ib = 0
            ic = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            if (min(ia,ib,ic) .ne. 0) then
               write (iprm,240)  ia,ib,ic,record(next:length)
  240          format ('strbnd',4x,3i5,a)
            end if
         else if (keyword(1:9) .eq. 'UREYBRAD ') then
            ia = 0
            ib = 0
            ic = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            if (min(ia,ib,ic) .ne. 0) then
               call prmsort (3,ia,ib,ic,0,0)
               write (iprm,250)  ia,ib,ic,record(next:length)
  250          format ('ureybrad',2x,3i5,a)
            end if
         else if (keyword(1:7) .eq. 'ANGANG ') then
            ia = 0
            call getnumb (record,ia,next)
            ia = iclass(ia)
            if (ia .ne. 0) then
               write (iprm,260)  ia,record(next:length)
  260          format ('angang',4x,i5,a)
            end if
         else if (keyword(1:7) .eq. 'OPBEND ') then
            ia0 = 0
            ib0 = 0
            ic0 = 0
            id0 = 0
            call getnumb (record,ia0,next)
            call getnumb (record,ib0,next)
            call getnumb (record,ic0,next)
            call getnumb (record,id0,next)
            ia = iclass(ia0)
            ib = iclass(ib0)
            ic = iclass(ic0)
            id = iclass(id0)
            keep = .true.
            if (ia0.ne.0 .and. ia.eq.0)  keep = .false.
            if (ib0.ne.0 .and. ib.eq.0)  keep = .false.
            if (ic0.ne.0 .and. ic.eq.0)  keep = .false.
            if (id0.ne.0 .and. id.eq.0)  keep = .false.
            if (keep) then
               call prmsort (2,ic,id,0,0,0)
               write (iprm,270)  ia,ib,ic,id,record(next:length)
  270          format ('opbend',4x,4i5,a)
            end if
         else if (keyword(1:7) .eq. 'OPDIST ') then
            ia0 = 0
            ib0 = 0
            ic0 = 0
            id0 = 0
            call getnumb (record,ia0,next)
            call getnumb (record,ib0,next)
            call getnumb (record,ic0,next)
            call getnumb (record,id0,next)
            ia = iclass(ia0)
            ib = iclass(ib0)
            ic = iclass(ic0)
            id = iclass(id0)
            keep = .true.
            if (ia0.ne.0 .and. ia.eq.0)  keep = .false.
            if (ib0.ne.0 .and. ib.eq.0)  keep = .false.
            if (ic0.ne.0 .and. ic.eq.0)  keep = .false.
            if (id0.ne.0 .and. id.eq.0)  keep = .false.
            if (keep) then
               call prmsort (2,ib,ic,0,0,0)
               call prmsort (2,ib,id,0,0,0)
               call prmsort (2,ic,id,0,0,0)
               write (iprm,280)  ia,ib,ic,id,record(next:length)
  280          format ('opdist',4x,4i5,a)
            end if
         else if (keyword(1:9) .eq. 'IMPROPER ') then
            ia0 = 0
            ib0 = 0
            ic0 = 0
            id0 = 0
            call getnumb (record,ia0,next)
            call getnumb (record,ib0,next)
            call getnumb (record,ic0,next)
            call getnumb (record,id0,next)
            ia = iclass(ia0)
            ib = iclass(ib0)
            ic = iclass(ic0)
            id = iclass(id0)
            keep = .true.
            if (ia0.ne.0 .and. ia.eq.0)  keep = .false.
            if (ib0.ne.0 .and. ib.eq.0)  keep = .false.
            if (ic0.ne.0 .and. ic.eq.0)  keep = .false.
            if (id0.ne.0 .and. id.eq.0)  keep = .false.
            if (keep) then
               write (iprm,290)  ia,ib,ic,id,record(next:length)
  290          format ('improper',2x,4i5,a)
            end if
         else if (keyword(1:8) .eq. 'IMPTORS ') then
            ia0 = 0
            ib0 = 0
            ic0 = 0
            id0 = 0
            call getnumb (record,ia0,next)
            call getnumb (record,ib0,next)
            call getnumb (record,ic0,next)
            call getnumb (record,id0,next)
            ia = iclass(ia0)
            ib = iclass(ib0)
            ic = iclass(ic0)
            id = iclass(id0)
            keep = .true.
            if (ia0.ne.0 .and. ia.eq.0)  keep = .false.
            if (ib0.ne.0 .and. ib.eq.0)  keep = .false.
            if (ic0.ne.0 .and. ic.eq.0)  keep = .false.
            if (id0.ne.0 .and. id.eq.0)  keep = .false.
            if (keep) then
               write (iprm,300)  ia,ib,ic,id,record(next:length)
  300          format ('imptors',3x,4i5,a)
            end if
         else if (keyword(1:8) .eq. 'TORSION ') then
            ia0 = 0
            ib0 = 0
            ic0 = 0
            id0 = 0
            call getnumb (record,ia0,next)
            call getnumb (record,ib0,next)
            call getnumb (record,ic0,next)
            call getnumb (record,id0,next)
            ia = iclass(ia0)
            ib = iclass(ib0)
            ic = iclass(ic0)
            id = iclass(id0)
            keep = .true.
            if (ia0.ne.0 .and. ia.eq.0)  keep = .false.
            if (ib0.ne.0 .and. ib.eq.0)  keep = .false.
            if (ic0.ne.0 .and. ic.eq.0)  keep = .false.
            if (id0.ne.0 .and. id.eq.0)  keep = .false.
            if (keep) then
               call prmsort (4,ia,ib,ic,id,0)
               write (iprm,310)  ia,ib,ic,id,record(next:length)
  310          format ('torsion',3x,4i5,a)
            end if
         else if (keyword(1:9) .eq. 'TORSION5 ') then
            ia0 = 0
            ib0 = 0
            ic0 = 0
            id0 = 0
            call getnumb (record,ia0,next)
            call getnumb (record,ib0,next)
            call getnumb (record,ic0,next)
            call getnumb (record,id0,next)
            ia = iclass(ia0)
            ib = iclass(ib0)
            ic = iclass(ic0)
            id = iclass(id0)
            keep = .true.
            if (ia0.ne.0 .and. ia.eq.0)  keep = .false.
            if (ib0.ne.0 .and. ib.eq.0)  keep = .false.
            if (ic0.ne.0 .and. ic.eq.0)  keep = .false.
            if (id0.ne.0 .and. id.eq.0)  keep = .false.
            if (keep) then
               call prmsort (4,ia,ib,ic,id,0)
               write (iprm,320)  ia,ib,ic,id,record(next:length)
  320          format ('torsion5',2x,4i5,a)
            end if
         else if (keyword(1:9) .eq. 'TORSION4 ') then
            ia0 = 0
            ib0 = 0
            ic0 = 0
            id0 = 0
            call getnumb (record,ia0,next)
            call getnumb (record,ib0,next)
            call getnumb (record,ic0,next)
            call getnumb (record,id0,next)
            ia = iclass(ia0)
            ib = iclass(ib0)
            ic = iclass(ic0)
            id = iclass(id0)
            keep = .true.
            if (ia0.ne.0 .and. ia.eq.0)  keep = .false.
            if (ib0.ne.0 .and. ib.eq.0)  keep = .false.
            if (ic0.ne.0 .and. ic.eq.0)  keep = .false.
            if (id0.ne.0 .and. id.eq.0)  keep = .false.
            if (keep) then
               call prmsort (4,ia,ib,ic,id,0)
               write (iprm,330)  ia,ib,ic,id,record(next:length)
  330          format ('torsion4',2x,4i5,a)
            end if
         else if (keyword(1:7) .eq. 'PITORS ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = iclass(ia)
            ib = iclass(ib)
            if (min(ia,ib) .ne. 0) then
               call prmsort (2,ia,ib,0,0,0)
               write (iprm,340)  ia,ib,record(next:length)
  340          format ('pitors',4x,2i5,a)
            end if
         else if (keyword(1:8) .eq. 'STRTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            call getnumb (record,id,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            id = iclass(id)
            write (iprm,350)  ia,ib,ic,id,record(next:length)
  350       format ('strtors',3x,4i5,a)
         else if (keyword(1:8) .eq. 'ANGTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            call getnumb (record,id,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            id = iclass(id)
            if (min(ia,ib,ic,id) .ne. 0) then
               write (iprm,360)  ia,ib,ic,id,record(next:length)
  360          format ('angtors',3x,4i5,a)
            end if
         else if (keyword(1:8) .eq. 'TORTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            ie = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            call getnumb (record,id,next)
            call getnumb (record,ie,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            id = iclass(id)
            ie = iclass(ie)
            if (min(ia,ib,ic,id,ie) .ne. 0) then
               write (iprm,370)  ia,ib,ic,id,ie,record(next:length)
  370          format ('tortors',3x,5i5,a)
            end if
         else if (keyword(1:7) .eq. 'CHARGE ') then
            ia = 0
            call getnumb (record,ia,next)
            ia = itype(ia)
            if (ia .ne. 0) then
               write (iprm,380)  ia,record(next:length)
  380          format ('charge',4x,i5,a)
            end if
         else if (keyword(1:7) .eq. 'DIPOLE ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = itype(ia)
            ib = itype(ib)
            if (min(ia,ib) .ne. 0) then
               write (iprm,390)  ia,ib,record(next:length)
  390          format ('dipole',4x,2i5,a)
            end if
         else if (keyword(1:8) .eq. 'DIPOLE5 ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = itype(ia)
            ib = itype(ib)
            if (min(ia,ib) .ne. 0) then
               write (iprm,400)  ia,ib,record(next:length)
  400          format ('dipole5',3x,2i5,a)
            end if
         else if (keyword(1:8) .eq. 'DIPOLE4 ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = itype(ia)
            ib = itype(ib)
            if (min(ia,ib) .ne. 0) then
               write (iprm,410)  ia,ib,record(next:length)
  410          format ('dipole4',3x,2i5,a)
            end if
         else if (keyword(1:8) .eq. 'DIPOLE3 ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = itype(ia)
            ib = itype(ib)
            if (min(ia,ib) .ne. 0) then
               write (iprm,420)  ia,ib,record(next:length)
  420          format ('dipole3',3x,2i5,a)
            end if
         else if (keyword(1:10) .eq. 'MULTIPOLE ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            call getnumb (record,id,next)
            ia = itype(ia)
            ib = isign(1,ib) * itype(abs(ib))
            ic = isign(1,ic) * itype(abs(ic))
            id = isign(1,id) * itype(abs(id))
            if (ia .ne. 0) then
               if (id .eq. 0) then
                  write (iprm,430)  ia,ib,ic,record(next:length)
  430             format ('multipole',1x,3i5,a)
               else
                  write (iprm,440)  ia,ib,ic,id,record(next:length)
  440             format ('multipole',1x,4i5,a)
               end if
            end if
         else if (keyword(1:7) .eq. 'CHGPEN ') then
            ia = 0
            call getnumb (record,ia,next)
            ia = iclass(ia)
            if (ia .ne. 0) then
               write (iprm,450)  ia,record(next:length)
  450          format ('chgpen',4x,i5,a)
            end if
         else if (keyword(1:9) .eq. 'POLARIZE ') then
            ia = 0
            pol = 0.0d0
            thl = -1.0d0
            thd = -1.0d0
            do j = 1, 20
               ig(j) = 0
            end do
            call getnumb (record,ia,next)
            call gettext (record,text,next)
            read (text,*,err=460,end=460)  pol
            call gettext (record,text,next)
            j = 1
            call getnumb (text,ig(1),j)
            if (ig(1) .eq. 0) then
               read (text,*,err=460,end=460)  thl
               call gettext (record,text,next)
               j = 1
               call getnumb (text,ig(1),j)
               string = record(next:240)
               if (ig(1) .eq. 0) then
                  read (text,*,err=460,end=460)  thd
                  read (string,*,err=460,end=460)  (ig(j),j=1,20)
               else
                  read (string,*,err=460,end=460)  (ig(j),j=2,20)
               end if
            else
               string = record(next:240)
               read (string,*,err=460,end=460)  (ig(j),j=2,20)
            end if
  460       continue
            ia = itype(ia)
            if (ia .ne. 0) then
               kg = 0
               do j = 1, 20
                  if (ig(j) .ne. 0) then
                     kg = j
                     ig(j) = itype(ig(j))
                  end if
               end do
               call sort (kg,ig)
               if (thd .ge. 0.0d0) then
                  write (iprm,470)  ia,pol,thl,thd,(ig(j),j=1,kg)
  470             format ('polarize',2x,i5,5x,3f11.4,2x,20i5)
               else if (thl .ge. 0.0d0) then
                  write (iprm,480)  ia,pol,thl,(ig(j),j=1,kg)
  480             format ('polarize',2x,i5,5x,2f11.4,2x,20i5)
               else
                  write (iprm,490)  ia,pol,(ig(j),j=1,kg)
  490             format ('polarize',2x,i5,5x,f11.4,2x,20i5)
               end if
            end if
         else if (keyword(1:8) .eq. 'POLPAIR ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = itype(ia)
            ib = itype(ib)
            if (min(ia,ib) .ne. 0) then
               call prmsort (2,ia,ib,0,0,0)
               write (iprm,500)  ia,ib,record(next:length)
  500          format ('polpair',3x,2i5,a)
            end if
         else if (keyword(1:7) .eq. 'CHGTRN ') then
            ia = 0
            call getnumb (record,ia,next)
            ia = iclass(ia)
            if (ia .ne. 0) then
               write (iprm,510)  ia,record(next:length)
  510          format ('chgtrn',4x,i5,a)
            end if
         else if (keyword(1:9) .eq. 'BNDCFLUX ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = iclass(ia)
            ib = iclass(ib)
            if (min(ia,ib) .ne. 0) then
               write (iprm,520)  ia,ib,record(next:length)
  520          format ('bndcflux',2x,2i5,a)
            end if
         else if (keyword(1:9) .eq. 'ANGCFLUX ') then
            ia = 0
            ib = 0
            ic = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            ia = iclass(ia)
            ib = iclass(ib)
            ic = iclass(ic)
            if (min(ia,ib,ic) .ne. 0) then
               write (iprm,530)  ia,ib,ic,record(next:length)
  530          format ('angcflux',2x,3i5,a)
            end if
         else if (keyword(1:7) .eq. 'PIATOM ') then
            ia = 0
            call getnumb (record,ia,next)
            ia = iclass(ia)
            if (ia .ne. 0) then
               write (iprm,540)  ia,record(next:length)
  540          format ('piatom',4x,i5,a)
            end if
         else if (keyword(1:7) .eq. 'PIBOND ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = iclass(ia)
            ib = iclass(ib)
            call prmsort (2,ia,ib,0,0,0)
            write (iprm,550)  ia,ib,record(next:length)
  550       format ('pibond',4x,2i5,a)
         else if (keyword(1:8) .eq. 'PIBOND5 ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = iclass(ia)
            ib = iclass(ib)
            call prmsort (2,ia,ib,0,0,0)
            write (iprm,560)  ia,ib,record(next:length)
  560       format ('pibond5',3x,2i5,a)
         else if (keyword(1:8) .eq. 'PIBOND4 ') then
            ia = 0
            ib = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            ia = iclass(ia)
            ib = iclass(ib)
            call prmsort (2,ia,ib,0,0,0)
            write (iprm,570)  ia,ib,record(next:length)
  570       format ('pibond4',3x,2i5,a)
         else if (keyword(1:6) .eq. 'METAL ') then
            ia = 0
            call getnumb (record,ia,next)
            ia = iclass(ia)
            if (ia .ne. 0) then
               write (iprm,580)  ia,record(next:length)
  580          format ('metal',5x,i5,a)
            end if
         else if (keyword(1:8) .eq. 'BIOTYPE ') then
            ia = 0
            ib = 0
            string = record(next:240)
            read (string,*,err=590,end=590)  ia
            call getword (record,string,next)
            call getstring (record,string,next)
            string = record(next:240)
            read (string,*,err=590,end=590)  ib
  590       continue
            if (ib .gt. 0)  ib = itype(ib)
            length = min(30,max(1,59-next))
            write (iprm,600)  record(8:next)//blank(1:length),ib
  600       format ('biotype',a,i5)
         else if (length .eq. 0) then
            write (iprm,610)
  610       format ()
         else
            write (iprm,620)  record(1:length)
  620       format (a)
         end if
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine prmsort  --  reorder atom types and classes  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "prmsort" places a list of atom type or class numbers into
c     canonical order for potential energy parameter definitions
c
c
      subroutine prmsort (index,ia,ib,ic,id,ie)
      implicit none
      integer ia,ib,ic,id,ie
      integer index,temp
c
c
c     put the atom type or class numbers into canonical order
c
      if (index .eq. 2) then
         if (ia .gt. ib) then
            temp = ia
            ia = ib
            ib = temp
         end if
      else if (index .eq. 3) then
         if (ia .gt. ic) then
            temp = ia
            ia = ic
            ic = temp
         end if
      else if (index .eq. 4) then
         if (ib.gt.ic .or. (ib.eq.ic.and.ia.gt.id)) then
            temp = ib
            ib = ic
            ic = temp
            temp = ia
            ia = id
            id = temp
         end if
      else if (index .eq. 5) then
         if (ib.gt.id .or. (ib.eq.id.and.ia.gt.ie)) then
            temp = ib
            ib = id
            id = temp
            temp = ia
            ia = ie
            ie = temp
         end if
      end if
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine polesort  --  sort multipoles by atom type  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "polesort" sorts a set of atomic multipole parameters based
c     on the atom types of centers involved
c
c
      subroutine polesort (iprm)
      use params
      implicit none
      integer i,j,n,iprm
      integer size,next
      integer ia,ib,ic,id
      integer, allocatable :: key(:)
      integer, allocatable :: line(:)
      real*8 v1,v2,v3
      character*4 pa,pb,pc,pd
      character*16, allocatable :: list(:)
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (key(nprm))
      allocate (line(nprm))
      allocate (list(nprm))
c
c     find and store atom types for the multipole parameters
c
      n = 0
      do i = 1, nprm
         record = prmline(i)
         next = 1
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:10) .eq. 'MULTIPOLE ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            call getnumb (record,ic,next)
            call getnumb (record,id,next)
            ia = abs(ia)
            ib = abs(ib)
            ic = abs(ic)
            id = abs(id)
            size = 4
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            n = n + 1
            line(n) = i
            list(n) = pa//pb//pc//pd
         end if
      end do
c
c     sort the parameters based on the atom type numbers
c
      call sort7 (n,list,key)
c
c     format and output the sorted multipole parameters
c
      do i = 1, n
         j = line(key(i))
         record = prmline(j)
         next = 1
         call gettext (record,keyword,next)
         ia = 0
         ib = 0
         ic = 0
         id = 0
         string = record(next:240)
         read (string,*,err=20,end=20)  ia,ib,ic,id,v1
         write (iprm,10)  ia,ib,ic,id,v1
   10    format ('multipole ',4i5,6x,f11.5)
         goto 40
   20    continue
         read (string,*,err=90,end=90)  ia,ib,ic,v1
         write (iprm,30)  ia,ib,ic,v1
   30    format ('multipole ',3i5,11x,f11.5)
   40    continue
         j = j + 1
         record = prmline(j)
         read (record,*,err=90,end=90)  v1,v2,v3
         write (iprm,50)  v1,v2,v3
   50    format (36x,3f11.5)
         j = j + 1
         record = prmline(j)
         read (record,*,err=90,end=90)  v1
         write (iprm,60)  v1
   60    format (36x,f11.5)
         j = j + 1
         record = prmline(j)
         read (record,*,err=90,end=90)  v1,v2
         write (iprm,70)  v1,v2
   70    format (36x,2f11.5)
         j = j + 1
         record = prmline(j)
         read (record,*,err=90,end=90)  v1,v2,v3
         write (iprm,80)  v1,v2,v3
   80    format (36x,3f11.5)
   90    continue
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (key)
      deallocate (line)
      deallocate (list)
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine biosort  --  renumber and format biotypes  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "biosort" renumbers and formats biotype parameters used to
c     convert biomolecular structure into force field atom types
c
c
      subroutine biosort (iprm)
      use params
      implicit none
      integer i,n,iprm
      integer next
      integer length
      integer trimtext
      integer ia,ib
      character*3 sym
      character*20 keyword
      character*30 blank
      character*240 record
      character*240 string
c
c
c     find, renumber and format the biotype parameters
c
      blank = '                              '
      n = 0
      do i = 1, nprm
         record = prmline(i)
         next = 1
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:8) .eq. 'BIOTYPE ') then
            n = n + 1
            call getnumb (record,ia,next)
            call getword (record,sym,next)
            call getstring (record,string,next)
            call getnumb (record,ib,next)
            if (ia .gt. n)  n = ia
            length = trimtext (string)
            string = '"'//string(1:length)//'"'//blank(1:30-length)
            write (iprm,10)  n,sym,string(1:32),ib
   10       format ('biotype',i8,4x,a3,5x,a32,i5)
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine prmkey  --  interpret force field keywords  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "prmkey" parses a text string to extract keywords related to
c     force field potential energy functional forms and constants
c
c
      subroutine prmkey (text)
      use angpot
      use bndpot
      use chgpot
      use ctrpot
      use dsppot
      use expol
      use extfld
      use fields
      use mplpot
      use polpot
      use potent
      use reppot
      use rxnpot
      use torpot
      use units
      use urypot
      use vdwpot
      implicit none
      integer i,next
      character*4 value
      character*20 keyword
      character*240 text
      character*240 record
      character*240 string
c
c
c     parse the line to extract any possible keyword
c
      record = text
      next = 1
      call upcase (record)
      call gettext (record,keyword,next)
      string = record(next:240)
c
c     select the individual force field potential terms
c
      if (keyword(1:9) .eq. 'BONDTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_bond = .true.
         if (value .eq. 'NONE')  use_bond = .false.
      else if (keyword(1:10) .eq. 'ANGLETERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_angle = .true.
         if (value .eq. 'NONE')  use_angle = .false.
      else if (keyword(1:11) .eq. 'STRBNDTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_strbnd = .true.
         if (value .eq. 'NONE')  use_strbnd = .false.
      else if (keyword(1:13) .eq. 'UREYBRADTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_urey = .true.
         if (value .eq. 'NONE')  use_urey = .false.
      else if (keyword(1:11) .eq. 'ANGANGTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_angang = .true.
         if (value .eq. 'NONE')  use_angang = .false.
      else if (keyword(1:11) .eq. 'OPBENDTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_opbend = .true.
         if (value .eq. 'NONE')  use_opbend = .false.
      else if (keyword(1:11) .eq. 'OPDISTTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_opdist = .true.
         if (value .eq. 'NONE')  use_opdist = .false.
      else if (keyword(1:11) .eq. 'IMPROPTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_improp = .true.
         if (value .eq. 'NONE')  use_improp = .false.
      else if (keyword(1:11) .eq. 'IMPTORTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_imptor = .true.
         if (value .eq. 'NONE')  use_imptor = .false.
      else if (keyword(1:12) .eq. 'TORSIONTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_tors = .true.
         if (value .eq. 'NONE')  use_tors = .false.
      else if (keyword(1:11) .eq. 'PITORSTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_pitors = .true.
         if (value .eq. 'NONE')  use_pitors = .false.
      else if (keyword(1:11) .eq. 'STRTORTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_strtor = .true.
         if (value .eq. 'NONE')  use_strtor = .false.
      else if (keyword(1:11) .eq. 'ANGTORTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_angtor = .true.
         if (value .eq. 'NONE')  use_angtor = .false.
      else if (keyword(1:11) .eq. 'TORTORTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_tortor = .true.
         if (value .eq. 'NONE')  use_tortor = .false.
      else if (keyword(1:8) .eq. 'VDWTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_vdw = .true.
         if (value .eq. 'NONE')  use_vdw = .false.
      else if (keyword(1:14) .eq. 'REPULSIONTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_repel = .true.
         if (value .eq. 'NONE')  use_repel = .false.
      else if (keyword(1:15) .eq. 'DISPERSIONTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_disp = .true.
         if (value .eq. 'NONE')  use_disp = .false.
      else if (keyword(1:11) .eq. 'CHARGETERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_charge = .true.
         if (value .eq. 'NONE')  use_charge = .false.
      else if (keyword(1:11) .eq. 'CHGDPLTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_chgdpl = .true.
         if (value .eq. 'NONE')  use_chgdpl = .false.
      else if (keyword(1:11) .eq. 'DIPOLETERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_dipole = .true.
         if (value .eq. 'NONE')  use_dipole = .false.
      else if (keyword(1:14) .eq. 'MULTIPOLETERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_mpole = .true.
         if (value .eq. 'NONE')  use_mpole = .false.
      else if (keyword(1:13) .eq. 'POLARIZETERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_polar = .true.
         if (value .eq. 'NONE')  use_polar = .false.
      else if (keyword(1:11) .eq. 'CHGTRNTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_chgtrn = .true.
         if (value .eq. 'NONE')  use_chgtrn = .false.
      else if (keyword(1:11) .eq. 'CHGFLXTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_chgflx = .true.
         if (value .eq. 'NONE')  use_chgflx = .false.
      else if (keyword(1:13) .eq. 'RXNFIELDTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_rxnfld = .true.
         if (value .eq. 'NONE')  use_rxnfld = .false.
      else if (keyword(1:12) .eq. 'SOLVATETERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_solv = .true.
         if (value .eq. 'NONE')  use_solv = .false.
      else if (keyword(1:12) .eq. 'METALTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_metal = .true.
         if (value .eq. 'NONE')  use_metal = .false.
      else if (keyword(1:13) .eq. 'RESTRAINTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_geom = .true.
         if (value .eq. 'NONE')  use_geom = .false.
      else if (keyword(1:10) .eq. 'EXTRATERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call potoff
         use_extra = .true.
         if (value .eq. 'NONE')  use_extra = .false.
      else if (keyword(1:12) .eq. 'VALENCETERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call nbondoff
         if (value .eq. 'NONE')  call valoff
      else if (keyword(1:12) .eq. 'NONBONDTERM ') then
         call getword (record,value,next)
         if (value .eq. 'ONLY')  call valoff
         if (value .eq. 'NONE')  call nbondoff
      end if
c
c     select the name of the force field parameter set
c
      if (keyword(1:11) .eq. 'FORCEFIELD ') then
         call getword (record,forcefield,next)
c
c     set control parameters for bond stretching potentials
c
      else if (keyword(1:9) .eq. 'BONDTYPE ') then
         call getword (record,bndtyp,next)
      else if (keyword(1:9) .eq. 'BONDUNIT ') then
         read (string,*,err=10,end=10)  bndunit
      else if (keyword(1:11) .eq. 'BOND-CUBIC ') then
         read (string,*,err=10,end=10)  cbnd
      else if (keyword(1:13) .eq. 'BOND-QUARTIC ') then
         read (string,*,err=10,end=10)  qbnd
c
c     set control parameters for bond angle bending potentials
c
      else if (keyword(1:10) .eq. 'ANGLEUNIT ') then
         read (string,*,err=10,end=10)  angunit
      else if (keyword(1:12) .eq. 'ANGLE-CUBIC ') then
         read (string,*,err=10,end=10)  cang
      else if (keyword(1:14) .eq. 'ANGLE-QUARTIC ') then
         read (string,*,err=10,end=10)  qang
      else if (keyword(1:13) .eq. 'ANGLE-PENTIC ') then
         read (string,*,err=10,end=10)  pang
      else if (keyword(1:13) .eq. 'ANGLE-SEXTIC ') then
         read (string,*,err=10,end=10)  sang
c
c     set control parameters for stretch-bend potentials
c
      else if (keyword(1:11) .eq. 'STRBNDUNIT ') then
         read (string,*,err=10,end=10)  stbnunit
c
c     set control parameters for Urey-Bradley potentials
c
      else if (keyword(1:9) .eq. 'UREYUNIT ') then
         read (string,*,err=10,end=10)  ureyunit
      else if (keyword(1:11) .eq. 'UREY-CUBIC ') then
         read (string,*,err=10,end=10)  cury
      else if (keyword(1:13) .eq. 'UREY-QUARTIC ') then
         read (string,*,err=10,end=10)  qury
c
c     set control parameters for out-of-plane bend potentials
c
      else if (keyword(1:11) .eq. 'OPBENDTYPE ') then
         call getword (record,opbtyp,next)
      else if (keyword(1:11) .eq. 'OPBENDUNIT ') then
         read (string,*,err=10,end=10)  opbunit
      else if (keyword(1:13) .eq. 'OPBEND-CUBIC ') then
         read (string,*,err=10,end=10)  copb
      else if (keyword(1:15) .eq. 'OPBEND-QUARTIC ') then
         read (string,*,err=10,end=10)  qopb
      else if (keyword(1:14) .eq. 'OPBEND-PENTIC ') then
         read (string,*,err=10,end=10)  popb
      else if (keyword(1:14) .eq. 'OPBEND-SEXTIC ') then
         read (string,*,err=10,end=10)  sopb
c
c     set control parameters for out-of-plane distance potentials
c
      else if (keyword(1:11) .eq. 'OPDISTUNIT ') then
         read (string,*,err=10,end=10)  opdunit
      else if (keyword(1:13) .eq. 'OPDIST-CUBIC ') then
         read (string,*,err=10,end=10)  copd
      else if (keyword(1:15) .eq. 'OPDIST-QUARTIC ') then
         read (string,*,err=10,end=10)  qopd
      else if (keyword(1:14) .eq. 'OPDIST-PENTIC ') then
         read (string,*,err=10,end=10)  popd
      else if (keyword(1:14) .eq. 'OPDIST-SEXTIC ') then
         read (string,*,err=10,end=10)  sopd
c
c     set control parameters for other local geometry potentials
c
      else if (keyword(1:11) .eq. 'ANGANGUNIT ') then
         read (string,*,err=10,end=10)  aaunit
      else if (keyword(1:11) .eq. 'IMPROPUNIT ') then
         read (string,*,err=10,end=10)  idihunit
      else if (keyword(1:11) .eq. 'IMPTORUNIT ') then
         read (string,*,err=10,end=10)  itorunit
      else if (keyword(1:12) .eq. 'TORSIONUNIT ') then
         read (string,*,err=10,end=10)  torsunit
      else if (keyword(1:11) .eq. 'PITORSUNIT ') then
         read (string,*,err=10,end=10)  ptorunit
      else if (keyword(1:11) .eq. 'STRTORUNIT ') then
         read (string,*,err=10,end=10)  storunit
      else if (keyword(1:11) .eq. 'ANGTORUNIT ') then
         read (string,*,err=10,end=10)  atorunit
      else if (keyword(1:11) .eq. 'TORTORUNIT ') then
         read (string,*,err=10,end=10)  ttorunit
c
c     set control parameters for van der Waals potentials
c
      else if (keyword(1:9) .eq. 'VDWINDEX ') then
         call getword (record,vdwindex,next)
      else if (keyword(1:8) .eq. 'VDWTYPE ') then
         call getword (record,vdwtyp,next)
      else if (keyword(1:11) .eq. 'RADIUSTYPE ') then
         call getword (record,radtyp,next)
      else if (keyword(1:11) .eq. 'RADIUSSIZE ') then
         call getword (record,radsiz,next)
      else if (keyword(1:11) .eq. 'RADIUSRULE ') then
         call getword (record,radrule,next)
      else if (keyword(1:12) .eq. 'EPSILONRULE ') then
         call getword (record,epsrule,next)
      else if (keyword(1:14) .eq. 'GAUSSTYPE ') then
         call getword (record,gausstyp,next)
      else if (keyword(1:10) .eq. 'A-EXPTERM ') then
         read (string,*,err=10,end=10)  abuck
      else if (keyword(1:10) .eq. 'B-EXPTERM ') then
         read (string,*,err=10,end=10)  bbuck
      else if (keyword(1:10) .eq. 'C-EXPTERM ') then
         read (string,*,err=10,end=10)  cbuck
      else if (keyword(1:14) .eq. 'GAMMA-HALGREN ') then
         read (string,*,err=10,end=10)  ghal
      else if (keyword(1:14) .eq. 'DELTA-HALGREN ') then
         read (string,*,err=10,end=10)  dhal
      else if (keyword(1:13) .eq. 'VDW-12-SCALE ') then
         read (string,*,err=10,end=10)  v2scale
         if (v2scale .gt. 1.0d0)  v2scale = 1.0d0 / v2scale
      else if (keyword(1:13) .eq. 'VDW-13-SCALE ') then
         read (string,*,err=10,end=10)  v3scale
         if (v3scale .gt. 1.0d0)  v3scale = 1.0d0 / v3scale
      else if (keyword(1:13) .eq. 'VDW-14-SCALE ') then
         read (string,*,err=10,end=10)  v4scale
         if (v4scale .gt. 1.0d0)  v4scale = 1.0d0 / v4scale
      else if (keyword(1:13) .eq. 'VDW-15-SCALE ') then
         read (string,*,err=10,end=10)  v5scale
         if (v5scale .gt. 1.0d0)  v5scale = 1.0d0 / v5scale
      else if (keyword(1:15) .eq. 'VDW-CORRECTION ') then
         use_vcorr = .true.
c
c     set control parameters for Pauli repulsion potential
c
      else if (keyword(1:13) .eq. 'REP-12-SCALE ') then
         read (string,*,err=10,end=10)  r2scale
         if (r2scale .gt. 1.0d0)  r2scale = 1.0d0 / r2scale
      else if (keyword(1:13) .eq. 'REP-13-SCALE ') then
         read (string,*,err=10,end=10)  r3scale
         if (r3scale .gt. 1.0d0)  r3scale = 1.0d0 / r3scale
      else if (keyword(1:13) .eq. 'REP-14-SCALE ') then
         read (string,*,err=10,end=10)  r4scale
         if (r4scale .gt. 1.0d0)  r4scale = 1.0d0 / r4scale
      else if (keyword(1:13) .eq. 'REP-15-SCALE ') then
         read (string,*,err=10,end=10)  r5scale
         if (r5scale .gt. 1.0d0)  r5scale = 1.0d0 / r5scale
c
c     set control parameters for dispersion potential
c
      else if (keyword(1:14) .eq. 'DISP-12-SCALE ') then
         read (string,*,err=10,end=10)  dsp2scale
         if (dsp2scale .gt. 1.0d0)  dsp2scale = 1.0d0 / dsp2scale
      else if (keyword(1:14) .eq. 'DISP-13-SCALE ') then
         read (string,*,err=10,end=10)  dsp3scale
         if (dsp3scale .gt. 1.0d0)  dsp3scale = 1.0d0 / dsp3scale
      else if (keyword(1:14) .eq. 'DISP-14-SCALE ') then
         read (string,*,err=10,end=10)  dsp4scale
         if (dsp4scale .gt. 1.0d0)  dsp4scale = 1.0d0 / dsp4scale
      else if (keyword(1:14) .eq. 'DISP-15-SCALE ') then
         read (string,*,err=10,end=10)  dsp5scale
         if (dsp5scale .gt. 1.0d0)  dsp5scale = 1.0d0 / dsp5scale
      else if (keyword(1:16) .eq. 'DISP-CORRECTION ') then
         use_dcorr = .true.
c
c     set control parameters for charge-charge potentials
c
      else if (keyword(1:9) .eq. 'ELECTRIC ') then
         read (string,*,err=10,end=10)  electric
      else if (keyword(1:11) .eq. 'DIELECTRIC ') then
         read (string,*,err=10,end=10)  dielec
      else if (keyword(1:11) .eq. 'CHG-BUFFER ') then
         read (string,*,err=10,end=10)  ebuffer
      else if (keyword(1:13) .eq. 'CHG-11-SCALE ') then
         read (string,*,err=10,end=10)  c1scale
         if (c1scale .gt. 1.0d0)  c1scale = 1.0d0 / c1scale
      else if (keyword(1:13) .eq. 'CHG-12-SCALE ') then
         read (string,*,err=10,end=10)  c2scale
         if (c2scale .gt. 1.0d0)  c2scale = 1.0d0 / c2scale
      else if (keyword(1:13) .eq. 'CHG-13-SCALE ') then
         read (string,*,err=10,end=10)  c3scale
         if (c3scale .gt. 1.0d0)  c3scale = 1.0d0 / c3scale
      else if (keyword(1:13) .eq. 'CHG-14-SCALE ') then
         read (string,*,err=10,end=10)  c4scale
         if (c4scale .gt. 1.0d0)  c4scale = 1.0d0 / c4scale
      else if (keyword(1:13) .eq. 'CHG-15-SCALE ') then
         read (string,*,err=10,end=10)  c5scale
         if (c5scale .gt. 1.0d0)  c5scale = 1.0d0 / c5scale
      else if (keyword(1:16) .eq. 'NEIGHBOR-GROUPS ') then
         neutnbr = .true.
      else if (keyword(1:15) .eq. 'NEUTRAL-GROUPS ') then
         neutcut = .true.
      else if (keyword(1:15) .eq. 'EXTERNAL-FIELD ') then
         read (string,*,err=10,end=10)  (exfld(i),i=1,3)
         use_exfld = .true.
         do i = 1, 3
            exfld(i) = exfld(i) / elefield
         end do
c
c     set control parameters for atomic multipole potentials
c
      else if (keyword(1:12) .eq. 'PENETRATION ') then
         call getword (record,pentyp,next)
      else if (keyword(1:15) .eq. 'MPOLE-12-SCALE ') then
         read (string,*,err=10,end=10)  m2scale
         if (m2scale .gt. 1.0d0)  m2scale = 1.0d0 / m2scale
      else if (keyword(1:15) .eq. 'MPOLE-13-SCALE ') then
         read (string,*,err=10,end=10)  m3scale
         if (m3scale .gt. 1.0d0)  m3scale = 1.0d0 / m3scale
      else if (keyword(1:15) .eq. 'MPOLE-14-SCALE ') then
         read (string,*,err=10,end=10)  m4scale
         if (m4scale .gt. 1.0d0)  m4scale = 1.0d0 / m4scale
      else if (keyword(1:15) .eq. 'MPOLE-15-SCALE ') then
         read (string,*,err=10,end=10)  m5scale
         if (m5scale .gt. 1.0d0)  m5scale = 1.0d0 / m5scale
c
c     set control parameters for polarization potentials
c
      else if (keyword(1:13) .eq. 'POLARIZATION ') then
         call getword (record,poltyp,next)
      else if (keyword(1:15) .eq. 'EXCHANGE-POLAR ') then
          call getword (record,scrtyp,next)
      else if (keyword(1:11) .eq. 'POLAR-ITER ') then
         read (string,*,err=10,end=10)  politer
      else if (keyword(1:10) .eq. 'POLAR-EPS ') then
         read (string,*,err=10,end=10)  poleps
      else if (keyword(1:13) .eq. 'USOLVE-ACCEL ') then
         read (string,*,err=10,end=10)  uaccel
      else if (keyword(1:11) .eq. 'D-EQUALS-P ') then
         dpequal = .true.
      else if (keyword(1:15) .eq. 'POLAR-12-SCALE ') then
         read (string,*,err=10,end=10)  p2scale
         if (p2scale .gt. 1.0d0)  p2scale = 1.0d0 / p2scale
      else if (keyword(1:15) .eq. 'POLAR-13-SCALE ') then
         read (string,*,err=10,end=10)  p3scale
         if (p3scale .gt. 1.0d0)  p3scale = 1.0d0 / p3scale
      else if (keyword(1:15) .eq. 'POLAR-14-SCALE ') then
         read (string,*,err=10,end=10)  p4scale
         if (p4scale .gt. 1.0d0)  p4scale = 1.0d0 / p4scale
      else if (keyword(1:15) .eq. 'POLAR-15-SCALE ') then
         read (string,*,err=10,end=10)  p5scale
         if (p5scale .gt. 1.0d0)  p5scale = 1.0d0 / p5scale
      else if (keyword(1:15) .eq. 'POLAR-12-INTRA ') then
         read (string,*,err=10,end=10)  p2iscale
         if (p2iscale .gt. 1.0d0)  p2iscale = 1.0d0 / p2iscale
      else if (keyword(1:15) .eq. 'POLAR-13-INTRA ') then
         read (string,*,err=10,end=10)  p3iscale
         if (p3iscale .gt. 1.0d0)  p3iscale = 1.0d0 / p3iscale
      else if (keyword(1:15) .eq. 'POLAR-14-INTRA ') then
         read (string,*,err=10,end=10)  p4iscale
         if (p4iscale .gt. 1.0d0)  p4iscale = 1.0d0 / p4iscale
      else if (keyword(1:15) .eq. 'POLAR-15-INTRA ') then
         read (string,*,err=10,end=10)  p5iscale
         if (p5iscale .gt. 1.0d0)  p5iscale = 1.0d0 / p5iscale
      else if (keyword(1:16) .eq. 'DIRECT-11-SCALE ') then
         read (string,*,err=10,end=10)  d1scale
         if (d1scale .gt. 1.0d0)  d1scale = 1.0d0 / d1scale
      else if (keyword(1:16) .eq. 'DIRECT-12-SCALE ') then
         read (string,*,err=10,end=10)  d2scale
         if (d2scale .gt. 1.0d0)  d2scale = 1.0d0 / d2scale
      else if (keyword(1:16) .eq. 'DIRECT-13-SCALE ') then
         read (string,*,err=10,end=10)  d3scale
         if (d3scale .gt. 1.0d0)  d3scale = 1.0d0 / d3scale
      else if (keyword(1:16) .eq. 'DIRECT-14-SCALE ') then
         read (string,*,err=10,end=10)  d4scale
         if (d4scale .gt. 1.0d0)  d4scale = 1.0d0 / d4scale
      else if (keyword(1:16) .eq. 'MUTUAL-11-SCALE ') then
         read (string,*,err=10,end=10)  u1scale
         if (u1scale .gt. 1.0d0)  u1scale = 1.0d0 / u1scale
      else if (keyword(1:16) .eq. 'MUTUAL-12-SCALE ') then
         read (string,*,err=10,end=10)  u2scale
         if (u2scale .gt. 1.0d0)  u2scale = 1.0d0 / u2scale
      else if (keyword(1:16) .eq. 'MUTUAL-13-SCALE ') then
         read (string,*,err=10,end=10)  u3scale
         if (u3scale .gt. 1.0d0)  u3scale = 1.0d0 / u3scale
      else if (keyword(1:16) .eq. 'MUTUAL-14-SCALE ') then
         read (string,*,err=10,end=10)  u4scale
         if (u4scale .gt. 1.0d0)  u4scale = 1.0d0 / u4scale
      else if (keyword(1:16) .eq. 'INDUCE-12-SCALE ') then
         read (string,*,err=10,end=10)  w2scale
         if (w2scale .gt. 1.0d0)  w2scale = 1.0d0 / w2scale
      else if (keyword(1:16) .eq. 'INDUCE-13-SCALE ') then
         read (string,*,err=10,end=10)  w3scale
         if (w3scale .gt. 1.0d0)  w3scale = 1.0d0 / w3scale
      else if (keyword(1:16) .eq. 'INDUCE-14-SCALE ') then
         read (string,*,err=10,end=10)  w4scale
         if (w4scale .gt. 1.0d0)  w4scale = 1.0d0 / w4scale
      else if (keyword(1:16) .eq. 'INDUCE-15-SCALE ') then
         read (string,*,err=10,end=10)  w5scale
         if (w5scale .gt. 1.0d0)  w5scale = 1.0d0 / w5scale
c
c     set control parameters for charge transfer potentials
c
      else if (keyword(1:15) .eq. 'CHARGETRANSFER ') then
         call getword (record,ctrntyp,next)
c
c     set control parameters for reaction field potentials
c
      else if (keyword(1:14) .eq. 'REACTIONFIELD ') then
         read (string,*,err=10,end=10)  rfsize,rfbulkd,rfterms
      end if
c
c     jump directly to the end if any error was detected
c
   10 continue
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine potoff  --  turn off all potential functions  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "potoff" clears the forcefield definition by turning off
c     the use of each of the potential energy functions
c
c
      subroutine potoff
      use potent
      implicit none
c
c
c     turn off the use of each of the potential energy functions
c
      use_bond = .false.
      use_angle = .false.
      use_strbnd = .false.
      use_urey = .false.
      use_angang = .false.
      use_opbend = .false.
      use_opdist = .false.
      use_improp = .false.
      use_imptor = .false.
      use_tors = .false.
      use_pitors = .false.
      use_strtor = .false.
      use_angtor = .false.
      use_tortor = .false.
      use_vdw = .false.
      use_repel = .false.
      use_disp = .false.
      use_charge = .false.
      use_chgdpl = .false.
      use_dipole = .false.
      use_mpole = .false.
      use_polar = .false.
      use_chgtrn = .false.
      use_rxnfld = .false.
      use_solv = .false.
      use_metal = .false.
      use_geom = .false.
      use_extra = .false.
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine valoff  --  turn off valence potential terms  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "valoff" turns off the use of each of the valence
c     potential energy functions
c
c
      subroutine valoff
      use potent
      implicit none
c
c
c     turn off the use of each of the valence energy functions
c
      use_bond = .false.
      use_angle = .false.
      use_strbnd = .false.
      use_urey = .false.
      use_angang = .false.
      use_opbend = .false.
      use_opdist = .false.
      use_improp = .false.
      use_imptor = .false.
      use_tors = .false.
      use_pitors = .false.
      use_strtor = .false.
      use_angtor = .false.
      use_tortor = .false.
      use_geom = .false.
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine nbondoff  --  turn off nonbond potential terms  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "nbondoff" turns off the use of each of the nonbonded
c     potential energy functions
c
c
      subroutine nbondoff
      use potent
      implicit none
c
c
c     turn off the use of each of the nonbonded energy functions
c
      use_vdw = .false.
      use_repel = .false.
      use_disp = .false.
      use_charge = .false.
      use_chgdpl = .false.
      use_dipole = .false.
      use_mpole = .false.
      use_polar = .false.
      use_chgtrn = .false.
      use_rxnfld = .false.
      use_solv = .false.
      use_metal = .false.
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine promo  --  version info and copywrite notice  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "promo" writes a banner message containing information
c     about the Tinker version, release date and copyright notice
c
c
      subroutine promo
      use iounit
      implicit none
c
c
c     print out the informational header message
c
      write (iout,10)
   10 format (/,5x,70('#'),
     &        /,3x,74('#'),
     &        /,2x,'###',70x,'###',
     &        /,1x,'###',12x,'Tinker  ---  Software Tools for',
     &           ' Molecular Design',12x,'###',
     &        /,1x,'##',74x,'##',
     &        /,1x,'##',23x,'Version 25.6   December 2025',23x,'##',
     &        /,1x,'##',74x,'##',
     &        /,1x,'##',15x,'Copyright (c)  Jay William Ponder',
     &           '  1990-2025',15x,'##',
     &        /,1x,'###',27x,'All Rights Reserved',26x,'###',
     &        /,2x,'###',70x,'###',
     &        /,3x,74('#'),
     &        /,5x,70('#'),/)
      flush (iout)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  program protein  --  build a polypeptide from sequence  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "protein" builds the internal and Cartesian coordinates
c     of a polypeptide from amino acid sequence and torsional
c     angle values for the peptide backbone and side chains
c
c
      program protein
      use atoms
      use files
      use iounit
      use sequen
      use titles
      implicit none
      integer i,izmt
      integer ixyz,iseq
      integer natom,mode
      integer freeunit,trimtext
      logical exist,clash
      character*240 seqfile
      character*240 intfile
      character*240 xyzfile
c
c
c     get the name to use for the output structure files
c
      call initial
      call nextarg (filename,exist)
      if (.not. exist) then
         write (iout,10)
   10    format (/,' Enter Name to be Used for Output Files :  ',$)
         read (input,20)  filename
   20    format (a240)
      end if
      call basefile (filename)
c
c     get the title line for the output files
c
      write (iout,30)
   30 format (/,' Enter Title :  ',$)
      read (input,40)  title
   40 format (a240)
      ltitle = trimtext (title)
c
c     read the keyfile and force field parameter file
c
      call getkey
      call field
c
c     get the sequence and build Z-matrix for the structure
c
      call getseq
      call prochain
c
c     find connectivities and generate Cartesian coordinates
c
      call connect
      call attach
      call molecule
      call makexyz
c
c     perform a packing calculation for multiple chains
c
      if (nchain .gt. 1) then
         call pauling
         call inertia (2)
      end if
c
c     remove dummy atoms and set undefined atoms to type zero
c
      natom = n
      do i = natom, 1, -1
         if (type(i) .eq. 0)  call delete (i)
         if (type(i) .lt. 0)  type(i) = 0
      end do
c
c     convert to internal and Cartesian coordinates
c
      mode = 0
      call makeint (mode)
      call makexyz
c
c     check for atom pairs with identical coordinates
c
      clash = .false.
      call chkxyz (clash)
c
c     write out a amino acid sequence file
c
      iseq = freeunit ()
      seqfile = filename(1:leng)//'.seq'
      call version (seqfile,'new')
      open (unit=iseq,file=seqfile,status='new')
      call prtseq (iseq)
      close (unit=iseq)
c
c     write out an internal coordinates file
c
      izmt = freeunit ()
      intfile = filename(1:leng)//'.int'
      call version (intfile,'new')
      open (unit=izmt,file=intfile,status='new')
      call prtint (izmt)
      close (unit=izmt)
c
c     write out a Cartesian coordinates file
c
      ixyz = freeunit ()
      xyzfile = filename(1:leng)//'.xyz'
      call version (xyzfile,'new')
      open (unit=ixyz,file=xyzfile,status='new')
      call prtxyz (ixyz)
      close (unit=ixyz)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine getseq  --  amino acid sequence and angles  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "getseq" asks the user for the amino acid sequence
c     and torsional angle values needed to define a peptide
c
c
      subroutine getseq
      use iounit
      use phipsi
      use resdue
      use sequen
      implicit none
      integer i,j,next
      integer length,trimtext
      logical done
      character*1 chir
      character*1 ucase(26)
      character*3 name
      character*240 record
      character*240 string
      data ucase  / 'A','B','C','D','E','F','G','H','I','J','K','L',
     &              'M','N','O','P','Q','R','S','T','U','V','W','X',
     &              'Y','Z' /
c
c
c     provide a header to explain the method of sequence input
c
      write (iout,10)
   10 format (/,' Enter One Residue Name per Line as the Standard',
     &           ' Three-Letter Code, and',
     &        /,' optionally, Phi-Psi-Omega Angles (3F), Chi Angles'
     &           ' (4F), Disulfide Partner',
     &        /,' if CYX Residue (I), and D/L Chirality (A1)',
     &        //,' If Only Residue Names are Entered, the Default',
     &           ' is to Build an Extended',
     &        /,' Conformation Using L-Amino Acids and Zwitterionic',
     &           ' Termini',
     &        //,' Standard Amino Acids:  GLY, ALA, VAL, LEU, ILE,',
     &           ' SER, THR, CYS, CYX, PRO,',
     &        /,' PHE, TYR, TRP, HIS, ASP, ASN, GLU, GLN, MET, LYS,',
     &           ' ARG, ORN, AIB',
     &        //,' Alternative Protonation States:  CYD, TYD, HID,',
     &           ' HIE, HIP, ASH, GLH, LYD',
     &        //,' N-Terminal Cap Residues:  H2N=Deprotonated,',
     &           ' FOR=Formyl, ACE=Acetyl,',
     &        /,27x,'PCA=Pyroglutamic Acid',
     &        /,' C-Terminal Cap Residues:  COH=Protonated, NH2=Amide,',
     &           ' NME=N-MethylAmide',
     &        //,' Use Residue Name=MOL to Start a New Chain, and',
     &           ' Use <Enter> to End Input')
c
c     initially, assume that only a single strand is present
c
      nchain = 1
      ichain(1,1) = 1
      chnnam(1) = ' '
c
c     get the amino acid sequence data and dihedral angle values
c
      i = 0
      done = .false.
      do while (.not. done)
         i = i + 1
         phi(i) = 0.0d0
         psi(i) = 0.0d0
         omg(i) = 0.0d0
         do j = 1, 4
            chi(j,i) = 0.0d0
         end do
         chiral(i) = 1
         disulf(i) = 0
         chir = ' '
         write (iout,20)  i
   20    format (/,' Enter Residue',i4,' :  ',$)
         read (input,30)  record
   30    format (a240)
         call upcase (record)
         next = 1
         call gettext (record,name,next)
         length = trimtext (name)
         string = record(next:240)
         read (string,*,err=40,end=40)  phi(i),psi(i),omg(i),
     &                                  (chi(j,i),j=1,4),disulf(i)
   40    continue
         call getword (record,chir,next)
c
c     handle special names used for certain amino acids
c
         if (name .eq. 'CYH')  name = 'CYS'
         if (name .eq. 'CSS')  name = 'CYX'
         if (name .eq. 'HIP')  name = 'HIS'
c
c     disulfide bridged residues are cystine instead of cysteine
c
         if (name(1:1).eq.'C' .and. disulf(i).ne.0) then
            length = 3
            name = 'CYX'
         end if
c
c     check the D/L chirality of the current residue
c
         if (chir .eq. 'D')  chiral(i) = -1
c
c     process and store the current amino acid residue type
c
         if (name .eq. 'MOL') then
            i = i - 1
            ichain(2,nchain) = i
            nchain = nchain + 1
            ichain(1,nchain) = i + 1
         else
            if (name .eq. '   ') then
               done = .true.
               nseq = i - 1
               ichain(2,nchain) = nseq
            else
               seq(i) = amino(maxamino)
               seqtyp(i) = 0
               if (length .eq. 1) then
                  do j = 1, maxamino
                     if (name(1:1) .eq. amino1(j)) then
                        seq(i) = amino(j)
                        seqtyp(i) = j
                     end if
                  end do
               else if (length .eq. 3) then
                  do j = 1, maxamino
                     if (name .eq. amino(j)) then
                        seq(i) = amino(j)
                        seqtyp(i) = j
                     end if
                  end do
               end if
               if (seqtyp(i) .eq. 0) then
                  i = i - 1
                  write (iout,50)  name
   50             format (/,' GETSEQ  --  Amino Acid Type ',a3,
     &                       ' is Not Supported')
               end if
            end if
         end if
      end do
c
c     set chain identifiers if multiple chains are present
c
      if (nchain .gt. 1) then
         do i = 1, nchain
            chnnam(i) = ucase(i)
         end do
      end if
c
c     set default values for the phi-psi-omega-chi angles;
c     use extended values if no phi-psi values were given
c
      do i = 1, nseq
         if (phi(i).eq.0.0d0 .and. psi(i).eq.0.0d0) then
            phi(i) = -135.0d0
            if (seq(i) .eq. 'PRO')  phi(i) = -60.0d0
            psi(i) = 135.0d0
         end if
         if (omg(i) .eq. 0.0d0) then
            omg(i) = 180.0d0
         end if
         if (chi(1,i) .eq. 0.0d0) then
            do j = 1, 4
               chi(j,i) = 180.0d0
               if (seq(i) .eq. 'PRO')  chi(j,i) = 0.0d0
               if (seq(i) .eq. 'PCA')  chi(j,i) = 0.0d0
            end do
            if (seq(i) .eq. 'LEU')  chi(2,i) = 60.0d0
            if (seq(i) .eq. 'PHE')  chi(2,i) = 90.0d0
            if (seq(i) .eq. 'TYR')  chi(2,i) = 90.0d0
            if (seq(i) .eq. 'TYD')  chi(2,i) = 90.0d0
            if (seq(i) .eq. 'TRP')  chi(2,i) = 90.0d0
            if (seq(i) .eq. 'HIS')  chi(2,i) = 90.0d0
            if (seq(i) .eq. 'HID')  chi(2,i) = 90.0d0
            if (seq(i) .eq. 'HIE')  chi(2,i) = 90.0d0
         end if
c
c     check for the presence of any disulfide bonds
c
         if (disulf(i) .ne. 0) then
            if (seq(i) .ne. 'CYX') then
               write (iout,60)  i
   60          format (' GETSEQ  --  Error in Disulfide Bond',
     &                    ' at Residue',i5)
            end if
            if (i.lt.disulf(i) .and. disulf(disulf(i)).ne.i) then
               write (iout,70)  i,disulf(i)
   70          format (' GETSEQ  --  Error in Disulfide Bond',
     &                    ' at Residue',i5,' or',i5)
            end if
         end if
      end do
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine prochain  --  build polypeptide backbone  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "prochain" builds up the internal coordinates for an amino
c     acid sequence from the phi, psi, omega and chi values
c
c
      subroutine prochain
      use atoms
      use iounit
      use phipsi
      use resdue
      use sequen
      implicit none
      integer i,k,m
      integer  next,nsave
      integer, allocatable :: ni(:)
      integer, allocatable :: cai(:)
      integer, allocatable :: ci(:)
      logical single,cyclic
      character*1 answer
      character*3 resname
      character*240 record
c
c
c     determine whether the peptide chain is cyclic
c
      cyclic = .false.
      write (iout,10)
   10 format (/,' Cyclize the Polypeptide Chain [N] :  ',$)
      read (input,20)  record
   20 format (a240)
      next = 1
      call gettext (record,answer,next)
      call upcase (answer)
      if (answer .eq. 'Y')  cyclic = .true.
c
c     perform dynamic allocation of some local arrays
c
      allocate (ni(nseq))
      allocate (cai(nseq))
      allocate (ci(nseq))
c
c     initialize the atom counter to the first atom
c
      n = 1
c
c     set the first residue number and get the type and name
c
      do m = 1, nchain
         single = .false.
         if (ichain(1,m) .eq. ichain(2,m))  single = .true.
         i = ichain(1,m)
         k = seqtyp(i)
         resname = amino(k)
c
c     build the first residue for a cyclic peptide
c
         if (cyclic) then
            if (m .eq. 1) then
               ni(i) = n
               call zatom (ntyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0)
               cai(i) = n
               call zatom (catyp(k),1.46d0,0.0d0,0.0d0,ni(i),0,0,0)
               ci(i) = n
               call zatom (ctyp(k),1.51d0,110.7d0,0.0d0,
     &                     cai(i),ni(i),0,0)
            else
               ni(i) = n
               call zatom (ntyp(k),30.0d0,150.0d0,180.0d0,n-1,n-2,n-3,0)
               call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
               cai(i) = n
               call zatom (catyp(k),1.46d0,150.0d0,180.0d0,
     &                     ni(i),n-2,n-3,0)
               ci(i) = n
               call zatom (ctyp(k),1.51d0,110.7d0,180.0d0,
     &                     cai(i),ni(i),n-3,0)
            end if
            call zatom (otyp(k),1.22d0,122.5d0,psi(i)-180.0d0,
     &                  ci(i),cai(i),ni(i),0)
            call zatom (hntyp(k),1.02d0,121.0d0,phi(i)-180.0d0,
     &                  ni(i),cai(i),ci(i),0)
            call zatom (hatyp(k),1.11d0,109.5d0,107.9d0,
     &                  cai(i),ni(i),ci(i),-chiral(i))
            call proside (resname,i,cai(i),ni(i),ci(i))
c
c     build the first residue as an N-terminal formyl group
c
         else if (resname .eq. 'FOR') then
            if (m .eq. 1) then
               ci(i) = n
               call zatom (cntyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0)
               ni(i) = n
               call zatom (ontyp(k),1.22d0,0.0d0,0.0d0,n-1,0,0,0)
               cai(i) = n
               call zatom (hantyp(k),1.12d0,120.0d0,0.0d0,n-2,n-1,0,0)
            else
               ci(i) = n
               call zatom (cntyp(k),30.0d0,150.0d0,180.0d0,
     &                     n-1,n-2,n-3,0)
               call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
               ni(i) = n
               call zatom (ontyp(k),1.22d0,150.0d0,180.0d0,
     &                     n-1,n-2,n-3,0)
               cai(i) = n
               call zatom (hantyp(k),1.12d0,120.0d0,0.0d0,n-2,n-1,n-3,0)
            end if
            psi(i) = 180.0d0
c
c     build the first residue as an N-terminal acetyl group
c
         else if (resname .eq. 'ACE') then
            if (m .eq. 1) then
               cai(i) = n
               call zatom (cantyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0)
               ci(i) = n
               call zatom (cntyp(k),1.51d0,0.0d0,0.0d0,n-1,0,0,0)
               call zatom (ontyp(k),1.22d0,122.5d0,0.0d0,n-1,n-2,0,0)
            else
               cai(i) = n
               call zatom (cantyp(k),30.0d0,150.0d0,180.0d0,
     &                     n-1,n-2,n-3,0)
               call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
               ci(i) = n
               call zatom (cntyp(k),1.51d0,150.0d0,180.0d0,
     &                     n-1,n-2,n-3,0)
               call zatom (ontyp(k),1.22d0,122.5d0,0.0d0,
     &                     n-1,n-2,n-3,0)
            end if
            ni(i) = n
            call zatom (hantyp(k),1.11d0,107.9d0,0.0d0,n-3,n-2,n-1,0)
            call zatom (hantyp(k),1.11d0,107.9d0,109.4d0,n-4,n-3,n-1,1)
            call zatom (hantyp(k),1.11d0,107.9d0,109.4d0,n-5,n-4,n-2,-1)
            psi(i) = 180.0d0
c
c     build the first residue as a proline
c
         else if (resname .eq. 'PRO') then
            if (m .eq. 1) then
               ni(i) = n
               call zatom (nntyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0)
               cai(i) = n
               call zatom (cantyp(k),1.50d0,0.0d0,0.0d0,ni(i),0,0,0)
               ci(i) = n
               if (single) then
                  call zatom (cctyp(k),1.51d0,111.6d0,0.0d0,
     &                        cai(i),ni(i),0,0)
               else
                  call zatom (cntyp(k),1.51d0,110.7d0,0.0d0,
     &                        cai(i),ni(i),0,0)
               end if
            else
               ni(i) = n
               call zatom (nntyp(k),30.0d0,150.0d0,180.0d0,
     &                     n-1,n-2,n-3,0)
               call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
               cai(i) = n
               call zatom (cantyp(k),1.50d0,150.0d0,180.0d0,
     &                     ni(i),n-2,n-3,0)
               ci(i) = n
               if (single) then
                  call zatom (cctyp(k),1.51d0,111.6d0,180.0d0,
     &                        cai(i),ni(i),n-3,0)
               else
                  call zatom (cntyp(k),1.51d0,110.7d0,180.0d0,
     &                        cai(i),ni(i),n-3,0)
               end if
            end if
            if (single) then
               call zatom (octyp(k),1.25d0,117.0d0,psi(1)-180.0d0,
     &                     ci(i),cai(i),ni(i),0)
            else
               call zatom (ontyp(k),1.22d0,122.5d0,psi(1)-180.0d0,
     &                     ci(i),cai(i),ni(i),0)
            end if
            call zatom (hnntyp(k),1.02d0,109.5d0,0.0d0,
     &                  ni(i),cai(i),ci(i),0)
            call zatom (hnntyp(k),1.02d0,109.5d0,-120.0d0,
     &                  ni(i),cai(i),ci(i),0)
            call zatom (hantyp(k),1.11d0,109.5d0,107.9d0,
     &                  cai(i),ni(i),ci(i),-chiral(i))
            call proside (resname,i,cai(i),ni(i),ci(i))
c
c     build the first residue as a pyroglutamic acid
c
         else if (resname .eq. 'PCA') then
            if (m .eq. 1) then
               ni(i) = n
               call zatom (nntyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0)
               cai(i) = n
               call zatom (cantyp(k),1.50d0,0.0d0,0.0d0,ni(i),0,0,0)
               ci(i) = n
               if (single) then
                  call zatom (cctyp(k),1.51d0,111.6d0,0.0d0,
     &                        cai(i),ni(i),0,0)
               else
                  call zatom (cntyp(k),1.51d0,110.7d0,0.0d0,
     &                        cai(i),ni(i),0,0)
               end if
            else
               ni(i) = n
               call zatom (nntyp(k),30.0d0,150.0d0,180.0d0,
     &                     n-1,n-2,n-3,0)
               call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
               cai(i) = n
               call zatom (cantyp(k),1.50d0,150.0d0,180.0d0,
     &                     ni(i),n-2,n-3,0)
               ci(i) = n
               if (single) then
                  call zatom (cctyp(k),1.51d0,111.6d0,180.0d0,
     &                        cai(i),ni(i),n-3,0)
               else
                  call zatom (cntyp(k),1.51d0,110.7d0,180.0d0,
     &                        cai(i),ni(i),n-3,0)
               end if
            end if
            if (single) then
               call zatom (octyp(k),1.25d0,117.0d0,psi(1)-180.0d0,
     &                     ci(i),cai(i),ni(i),0)
            else
               call zatom (ontyp(k),1.22d0,122.5d0,psi(1)-180.0d0,
     &                     ci(i),cai(i),ni(i),0)
            end if
            call zatom (hnntyp(k),1.02d0,109.5d0,-60.0d0,
     &                  ni(i),cai(i),ci(i),0)
            call zatom (hantyp(k),1.11d0,109.5d0,107.9d0,
     &                  cai(i),ni(i),ci(i),-chiral(i))
            call proside (resname,i,cai(i),ni(i),ci(i))
c
c     build the first residue for N-terminal deprotonated amino acids
c
         else if (resname .eq. 'H2N') then
            i = i + 1
            k = seqtyp(i)
            resname = amino(k)
            if (m .eq. 1) then
               ni(i) = n
               k = seqtyp(i-1)
               call zatom (nntyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0)
               k = seqtyp(i)
               cai(i) = n
               call zatom (cantyp(k),1.50d0,0.0d0,0.0d0,ni(i),0,0,0)
               ci(i) = n
               if (single) then
                  call zatom (cctyp(k),1.51d0,111.6d0,0.0d0,
     &                        cai(i),ni(i),0,0)
               else
                  call zatom (cntyp(k),1.51d0,110.7d0,0.0d0,
     &                        cai(i),ni(i),0,0)
               end if
            else
               ni(i) = n
               k = seqtyp(i-1)
               call zatom (nntyp(k),30.0d0,150.0d0,180.0d0,
     &                     n-1,n-2,n-3,0)
               k = seqtyp(i)
               call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
               cai(i) = n
               call zatom (cantyp(k),1.50d0,150.0d0,180.0d0,
     &                     ni(i),n-2,n-3,0)
               ci(i) = n
               if (single) then
                  call zatom (cctyp(k),1.51d0,111.6d0,180.0d0,
     &                        cai(i),ni(i),n-3,0)
               else
                  call zatom (cntyp(k),1.51d0,110.7d0,180.0d0,
     &                        cai(i),ni(i),n-3,0)
               end if
            end if
            if (single) then
               call zatom (octyp(k),1.25d0,117.0d0,psi(1)-180.0d0,
     &                     ci(i),cai(i),ni(i),0)
            else
               call zatom (ontyp(k),1.22d0,122.5d0,psi(1)-180.0d0,
     &                     ci(i),cai(i),ni(i),0)
            end if
            k = seqtyp(i-1)
            if (resname .eq. 'PRO') then
               call zatom (hnntyp(k),1.02d0,124.5d0,phi(i),
     &                     ni(i),cai(i),ci(i),0)
            else
               call zatom (hnntyp(k),1.02d0,109.5d0,phi(i),
     &                     ni(i),cai(i),ci(i),0)
               call zatom (hnntyp(k),1.02d0,109.5d0,108.0d0,
     &                     ni(i),cai(i),n-1,1)
            end if
            k = seqtyp(i)
            call zatom (hantyp(k),1.11d0,109.5d0,107.9d0,
     &                  cai(i),ni(i),ci(i),-chiral(i))
            call proside (resname,i,cai(i),ni(i),ci(i))
c
c     build the first residue for all other standard amino acids
c
         else
            if (m .eq. 1) then
               ni(i) = n
               call zatom (nntyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0)
               cai(i) = n
               call zatom (cantyp(k),1.50d0,0.0d0,0.0d0,ni(i),0,0,0)
               ci(i) = n
               if (single) then
                  call zatom (cctyp(k),1.51d0,111.6d0,0.0d0,
     &                        cai(i),ni(i),0,0)
               else
                  call zatom (cntyp(k),1.51d0,110.7d0,0.0d0,
     &                        cai(i),ni(i),0,0)
               end if
            else
               ni(i) = n
               call zatom (nntyp(k),30.0d0,150.0d0,180.0d0,
     &                     n-1,n-2,n-3,0)
               call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
               cai(i) = n
               call zatom (cantyp(k),1.50d0,150.0d0,180.0d0,
     &                     ni(i),n-2,n-3,0)
               ci(i) = n
               if (single) then
                  call zatom (cctyp(k),1.51d0,111.6d0,180.0d0,
     &                        cai(i),ni(i),n-3,0)
               else
                  call zatom (cntyp(k),1.51d0,110.7d0,180.0d0,
     &                        cai(i),ni(i),n-3,0)
               end if
            end if
            if (single) then
               call zatom (octyp(k),1.25d0,117.0d0,psi(1)-180.0d0,
     &                     ci(i),cai(i),ni(i),0)
            else
               call zatom (ontyp(k),1.22d0,122.5d0,psi(1)-180.0d0,
     &                     ci(i),cai(i),ni(i),0)
            end if
            call zatom (hnntyp(k),1.02d0,109.5d0,phi(i),
     &                  ni(i),cai(i),ci(i),0)
            call zatom (hnntyp(k),1.02d0,109.5d0,108.0d0,
     &                  ni(i),cai(i),n-1,1)
            call zatom (hnntyp(k),1.02d0,109.5d0,108.0d0,
     &                  ni(i),cai(i),n-2,-1)
            call zatom (hantyp(k),1.11d0,109.5d0,107.9d0,
     &                  cai(i),ni(i),ci(i),-chiral(i))
            call proside (resname,i,cai(i),ni(i),ci(i))
         end if
c
c     build atoms for residues in the middle of the chain
c
         do while (i .lt. ichain(2,m)-1)
            i = i + 1
            k = seqtyp(i)
            resname = amino(k)
            ni(i) = n
            call zatom (ntyp(k),1.34d0,112.7d0,psi(i-1),
     &                  ci(i-1),cai(i-1),ni(i-1),0)
            cai(i) = n
            call zatom (catyp(k),1.46d0,121.0d0,omg(i-1),
     &                  ni(i),ci(i-1),cai(i-1),0)
            ci(i) = n
            call zatom (ctyp(k),1.51d0,111.6d0,phi(i),
     &                  cai(i),ni(i),ci(i-1),0)
            call zatom (otyp(k),1.22d0,122.5d0,psi(i)-180.0d0,
     &                  ci(i),cai(i),ni(i),0)
            call zatom (hntyp(k),1.02d0,121.0d0,phi(i)-180.0d0,
     &                  ni(i),cai(i),ci(i),0)
            call zatom (hatyp(k),1.11d0,109.5d0,107.9d0,
     &                  cai(i),ni(i),ci(i),-chiral(i))
            call proside (resname,i,cai(i),ni(i),ci(i))
         end do
c
c     set the number and type of the last residue
c
         i = ichain(2,m)
         k = seqtyp(i)
         resname = amino(k)
c
c     build the last residue for a cyclic peptide
c
         if (cyclic) then
            ni(i) = n
            call zatom (ntyp(k),1.34d0,112.7d0,psi(i-1),
     &                  ci(i-1),cai(i-1),ni(i-1),0)
            cai(i) = n
            call zatom (catyp(k),1.46d0,121.0d0,omg(i-1),
     &                  ni(i),ci(i-1),cai(i-1),0)
            ci(i) = n
            call zatom (ctyp(k),1.51d0,111.6d0,phi(i),
     &                  cai(i),ni(i),ci(i-1),0)
            call zatom (-1,0.0d0,0.0d0,0.0d0,ni(1),ci(i),0,0)
            call zatom (otyp(k),1.22d0,122.5d0,psi(i)-180.0d0,
     &                  ci(i),cai(i),ni(i),0)
            call zatom (hntyp(k),1.02d0,121.0d0,phi(i)-180.0d0,
     &                  ni(i),cai(i),ci(i),0)
            call zatom (hatyp(k),1.11d0,109.5d0,107.9d0,
     &                  cai(i),ni(i),ci(i),-chiral(i))
            call proside (resname,i,cai(i),ni(i),ci(i))
c
c     build the last residue as a C-terminal amide
c
         else if (resname .eq. 'NH2') then
            call zatom (nctyp(k),1.34d0,112.7d0,psi(i-1),
     &                  ci(i-1),cai(i-1),ni(i-1),0)
            call zatom (hnctyp(k),1.02d0,119.0d0,0.0d0,
     &                  n-1,ci(i-1),cai(i-1),0)
            call zatom (hnctyp(k),1.02d0,119.0d0,180.0d0,
     &                  n-2,ci(i-1),cai(i-1),0)
c
c     build the last residue as a C-terminal N-methylamide
c
         else if (resname .eq. 'NME') then
            call zatom (nctyp(k),1.34d0,112.7d0,psi(i-1),
     &                  ci(i-1),cai(i-1),ni(i-1),0)
            call zatom (cactyp(k),1.46d0,121.0d0,180.0d0,
     &                  n-1,ci(i-1),cai(i-1),0)
            call zatom (hnctyp(k),1.02d0,118.0d0,121.0d0,
     &                  n-2,ci(i-1),n-1,1)
            call zatom (hactyp(k),1.11d0,109.5d0,180.0d0,
     &                  n-2,n-3,ci(i-1),0)
            call zatom (hactyp(k),1.11d0,109.5d0,109.5d0,
     &                  n-3,n-4,n-1,1)
            call zatom (hactyp(k),1.11d0,109.5d0,109.5d0,
     &                  n-4,n-5,n-2,-1)
c
c     build the last residue as a protonated C-terminal amino acid
c
         else if (resname .eq. 'COH') then
            nsave = n
            n = ci(i-1)
            call zatom (cctyp(k),1.51d0,111.6d0,phi(i),
     &                  cai(i-1),ni(i-1),ci(i-2),0)
            call zatom (octyp(k),1.22d0,122.5d0,psi(i)-180.0d0,
     &                  ci(i-1),cai(i-1),ni(i-1),0)
            n = nsave
            call zatom (nctyp(k),1.35d0,112.7d0,psi(i-1),
     &                  ci(i-1),cai(i-1),ni(i-1),0)
            call zatom (hnctyp(k),0.98d0,108.7d0,180.0d0,
     &                  n-1,ci(i-1),cai(i-1),0)
c
c     build the last residue for all other standard amino acids
c
         else
            if (.not. single) then
               ni(i) = n
               call zatom (nctyp(k),1.34d0,112.7d0,psi(i-1),
     &                     ci(i-1),cai(i-1),ni(i-1),0)
               cai(i) = n
               call zatom (cactyp(k),1.46d0,121.0d0,omg(i-1),
     &                     ni(i),ci(i-1),cai(i-1),0)
               ci(i) = n
               call zatom (cctyp(k),1.51d0,111.6d0,phi(i),
     &                     cai(i),ni(i),ci(i-1),0)
               call zatom (octyp(k),1.25d0,117.0d0,psi(i)-180.0d0,
     &                     ci(i),cai(i),ni(i),0)
               call zatom (hnctyp(k),1.02d0,121.0d0,phi(i)-180.0d0,
     &                     ni(i),cai(i),ci(i),0)
               call zatom (hactyp(k),1.11d0,109.5d0,107.9d0,
     &                     cai(i),ni(i),ci(i),-chiral(i))
               call proside (resname,i,cai(i),ni(i),ci(i))
            end if
            call zatom (octyp(k),1.25d0,117.0d0,psi(i),
     &                  ci(i),cai(i),ni(i),0)
         end if
      end do
c
c     finally, set the total number of atoms
c
      n = n - 1
c
c     perform deallocation of some local arrays
c
      deallocate (ni)
      deallocate (cai)
      deallocate (ci)
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine proside  --  build amino acid side chain  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "proside" builds the side chain for a single amino acid
c     residue in terms of internal coordinates
c
c     resname   3-letter name of current amino acid residue
c     i         number of the current amino acid residue
c     cai       atom number of alpha carbon in residue i
c     ni        atom number of amide nitrogen in residue i
c     ci        atom number of carbonyl carbon in residue i
c
c     note biotypes of CD and HD atoms for N-terminal proline
c     are set as absolute values, not relative to the CB atom
c
c
      subroutine proside (resname,i,cai,ni,ci)
      use atoms
      use phipsi
      use resdue
      use sequen
      implicit none
      integer i,k
      integer cai,ni,ci
      integer ntprocd
      integer ntprohd
      character*3 resname
c
c
c     set the CB atom as reference site
c
      k = cbtyp(seqtyp(i))
c
c     set biotypes for CD and HD of N-terminal PRO residue
c
      ntprocd = 469
      ntprohd = 470
c
c     glycine residue  (GLY)
c
      if (resname .eq. 'GLY') then
         k = hatyp(seqtyp(i))
         if (i .eq. 1)  k = hantyp(seqtyp(i))
         if (i .eq. nseq)  k = hactyp(seqtyp(i))
         call zatom (k,1.11d0,109.5d0,107.9d0,cai,ni,ci,chiral(i))
c
c     alanine residue  (ALA)
c
      else if (resname .eq. 'ALA') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+1,1.11d0,109.4d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-2,cai,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-3,cai,n-2,-1)
c
c     valine residue  (VAL)
c
      else if (resname .eq. 'VAL') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.54d0,109.5d0,109.5d0,n-2,cai,n-1,-1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-3,cai,n-2,1)
         call zatom (k+3,1.11d0,109.4d0,180.0d0,n-3,n-4,cai,0)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-4,n-5,n-1,1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-5,n-6,n-2,-1)
         call zatom (k+5,1.11d0,109.4d0,180.0d0,n-5,n-7,cai,0)
         call zatom (k+5,1.11d0,109.4d0,109.4d0,n-6,n-8,n-1,1)
         call zatom (k+5,1.11d0,109.4d0,109.4d0,n-7,n-9,n-2,-1)
c
c     leucine residue  (LEU)
c
      else if (resname .eq. 'LEU') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+6,1.54d0,109.5d0,109.4d0,n-2,n-3,n-1,-1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,-1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-5,n-6,n-4,1)
         call zatom (k+5,1.11d0,109.4d0,180.0d0,n-5,n-6,n-7,0)
         call zatom (k+5,1.11d0,109.4d0,109.4d0,n-6,n-7,n-1,1)
         call zatom (k+5,1.11d0,109.4d0,109.4d0,n-7,n-8,n-2,-1)
         call zatom (k+7,1.11d0,109.4d0,180.0d0,n-7,n-9,n-10,0)
         call zatom (k+7,1.11d0,109.4d0,109.4d0,n-8,n-10,n-1,1)
         call zatom (k+7,1.11d0,109.4d0,109.4d0,n-9,n-11,n-2,-1)
c
c     isoleucine residue  (ILE)
c
      else if (resname .eq. 'ILE') then
         call zatom (k,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.54d0,109.5d0,109.5d0,n-2,cai,n-1,1)
         call zatom (k+6,1.54d0,109.5d0,chi(2,i),n-2,n-3,cai,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,-1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-4,n-5,n-2,1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-5,n-6,n-3,-1)
         call zatom (k+5,1.11d0,110.0d0,180.0d0,n-5,n-7,n-6,0)
         call zatom (k+5,1.11d0,110.0d0,109.0d0,n-6,n-8,n-1,1)
         call zatom (k+5,1.11d0,110.0d0,109.0d0,n-7,n-9,n-2,-1)
         call zatom (k+7,1.11d0,110.0d0,180.0d0,n-7,n-9,n-10,0)
         call zatom (k+7,1.11d0,110.0d0,109.0d0,n-8,n-10,n-1,1)
         call zatom (k+7,1.11d0,110.0d0,109.0d0,n-9,n-11,n-2,-1)
c
c     serine residue  (SER)
c
      else if (resname .eq. 'SER') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.41d0,107.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+1,1.11d0,109.4d0,106.7d0,n-2,cai,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,106.7d0,n-3,cai,n-2,-1)
         call zatom (k+3,0.94d0,106.9d0,chi(2,i),n-3,n-4,cai,0)
c
c     threonine residue  (THR)
c
      else if (resname .eq. 'THR') then
         call zatom (k,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.41d0,107.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.54d0,109.5d0,107.7d0,n-2,cai,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,106.7d0,n-3,cai,n-2,-1)
         call zatom (k+3,0.94d0,106.9d0,chi(2,i),n-3,n-4,cai,0)
         call zatom (k+5,1.11d0,110.0d0,180.0d0,n-3,n-5,cai,0)
         call zatom (k+5,1.11d0,110.0d0,109.0d0,n-4,n-6,n-1,1)
         call zatom (k+5,1.11d0,110.0d0,109.0d0,n-5,n-7,n-2,-1)
c
c     cysteine residue  (CYS)
c
      else if (resname .eq. 'CYS') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.82d0,109.0d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+1,1.11d0,109.4d0,112.0d0,n-2,cai,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,112.0d0,n-3,cai,n-2,-1)
         call zatom (k+3,1.34d0,96.0d0,chi(2,i),n-3,n-4,cai,0)
c
c     cystine residue  (CYX)
c
      else if (resname .eq. 'CYX') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.82d0,109.0d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+1,1.11d0,109.4d0,112.0d0,n-2,cai,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,112.0d0,n-3,cai,n-2,-1)
         if (disulf(i) .gt. i) then
            disulf(i) = n - 3
         else if (disulf(i) .lt. i) then
            call zatom (-1,0.0d0,0.0d0,0.0d0,disulf(disulf(i)),n-3,0,0)
         end if
c
c     deprotonated cysteine residue  (CYD)
c
      else if (resname .eq. 'CYD') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.82d0,109.0d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+1,1.11d0,109.4d0,112.0d0,n-2,cai,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,112.0d0,n-3,cai,n-2,-1)
c
c     proline residue  (PRO)
c
      else if (resname .eq. 'PRO') then
         call zatom (k,1.54d0,107.0d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,107.0d0,chi(1,i),n-1,cai,ni,0)
         if (i .eq. 1) then
            call zatom (ntprocd,1.54d0,107.0d0,chi(2,i),n-1,n-2,cai,0)
         else
            call zatom (k+4,1.54d0,107.0d0,chi(2,i),n-1,n-2,cai,0)
         end if
         call zatom (-1,0.0d0,0.0d0,0.0d0,ni,n-1,0,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-3,cai,n-2,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,-1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-4,n-5,n-3,1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-5,n-6,n-4,-1)
         if (i .eq. 1) then
            call zatom (ntprohd,1.11d0,109.4d0,109.4d0,n-5,n-6,ni,1)
            call zatom (ntprohd,1.11d0,109.4d0,109.4d0,n-6,n-7,ni,-1)
         else
            call zatom (k+5,1.11d0,109.4d0,109.4d0,n-5,n-6,ni,1)
            call zatom (k+5,1.11d0,109.4d0,109.4d0,n-6,n-7,ni,-1)
         end if
c
c     phenylalanine residue  (PHE)
c
      else if (resname .eq. 'PHE') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+3,1.39d0,120.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+3,1.39d0,120.0d0,120.0d0,n-2,n-3,n-1,1)
         call zatom (k+5,1.39d0,120.0d0,180.0d0,n-2,n-3,n-4,0)
         call zatom (k+5,1.39d0,120.0d0,180.0d0,n-2,n-4,n-5,0)
         call zatom (k+7,1.39d0,120.0d0,0.0d0,n-2,n-4,n-5,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-8,cai,n-7,-1)
         call zatom (k+4,1.10d0,120.0d0,120.0d0,n-7,n-8,n-5,1)
         call zatom (k+4,1.10d0,120.0d0,120.0d0,n-7,n-9,n-5,1)
         call zatom (k+6,1.10d0,120.0d0,120.0d0,n-7,n-9,n-5,1)
         call zatom (k+6,1.10d0,120.0d0,120.0d0,n-7,n-9,n-6,1)
         call zatom (k+8,1.10d0,120.0d0,120.0d0,n-7,n-9,n-8,1)
c
c     tyrosine residue  (TYR)
c
      else if (resname .eq. 'TYR') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+3,1.39d0,120.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+3,1.39d0,120.0d0,120.0d0,n-2,n-3,n-1,1)
         call zatom (k+5,1.39d0,120.0d0,180.0d0,n-2,n-3,n-4,0)
         call zatom (k+5,1.39d0,120.0d0,180.0d0,n-2,n-4,n-5,0)
         call zatom (k+7,1.39d0,120.0d0,0.0d0,n-2,n-4,n-5,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
         call zatom (k+8,1.36d0,120.0d0,120.0d0,n-1,n-2,n-3,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-8,cai,n-7,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-9,cai,n-8,-1)
         call zatom (k+4,1.10d0,120.0d0,120.0d0,n-8,n-9,n-6,1)
         call zatom (k+4,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1)
         call zatom (k+6,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1)
         call zatom (k+6,1.10d0,120.0d0,120.0d0,n-8,n-10,n-7,1)
         call zatom (k+9,0.97d0,108.0d0,0.0d0,n-7,n-8,n-9,0)
c
c     deprotonated tyrosine residue  (TYD)
c
      else if (resname .eq. 'TYD') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+3,1.39d0,120.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+3,1.39d0,120.0d0,120.0d0,n-2,n-3,n-1,1)
         call zatom (k+5,1.39d0,120.0d0,180.0d0,n-2,n-3,n-4,0)
         call zatom (k+5,1.39d0,120.0d0,180.0d0,n-2,n-4,n-5,0)
         call zatom (k+7,1.39d0,120.0d0,0.0d0,n-2,n-4,n-5,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
         call zatom (k+8,1.36d0,120.0d0,120.0d0,n-1,n-2,n-3,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-8,cai,n-7,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-9,cai,n-8,-1)
         call zatom (k+4,1.10d0,120.0d0,120.0d0,n-8,n-9,n-6,1)
         call zatom (k+4,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1)
         call zatom (k+6,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1)
         call zatom (k+6,1.10d0,120.0d0,120.0d0,n-8,n-10,n-7,1)
c
c     tryptophan residue  (TRP)
c
      else if (resname .eq. 'TRP') then
         call zatom (k,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+3,1.35d0,126.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+5,1.35d0,126.0d0,108.0d0,n-2,n-3,n-1,1)
         call zatom (k+6,1.35d0,108.0d0,0.0d0,n-2,n-3,n-1,0)
         call zatom (k+8,1.35d0,108.0d0,0.0d0,n-1,n-3,n-4,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-3,n-1,0,0)
         call zatom (k+9,1.35d0,120.0d0,180.0d0,n-3,n-1,n-2,0)
         call zatom (k+11,1.35d0,120.0d0,0.0d0,n-2,n-4,n-1,0)
         call zatom (k+13,1.35d0,120.0d0,0.0d0,n-2,n-5,n-3,0)
         call zatom (k+15,1.35d0,120.0d0,0.0d0,n-2,n-4,n-6,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-10,cai,n-9,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-11,cai,n-10,-1)
         call zatom (k+4,1.10d0,126.0d0,126.0d0,n-10,n-11,n-8,1)
         call zatom (k+7,1.05d0,126.0d0,126.0d0,n-9,n-11,n-8,1)
         call zatom (k+10,1.10d0,120.0d0,120.0d0,n-8,n-11,n-6,1)
         call zatom (k+12,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1)
         call zatom (k+14,1.10d0,120.0d0,120.0d0,n-8,n-10,n-7,1)
         call zatom (k+16,1.10d0,120.0d0,120.0d0,n-8,n-10,n-9,1)
c
c     histidine (HD and HE) residue  (HIS)
c
      else if (resname .eq. 'HIS') then
         call zatom (k,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+3,1.35d0,126.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+5,1.35d0,126.0d0,108.0d0,n-2,n-3,n-1,1)
         call zatom (k+7,1.35d0,108.0d0,0.0d0,n-2,n-3,n-1,0)
         call zatom (k+9,1.35d0,108.0d0,0.0d0,n-2,n-4,n-3,0)
         call zatom (-1,0.0d0,0.0d0,.00d0,n-2,n-1,0,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,-1)
         call zatom (k+4,1.02d0,126.0d0,0.0d0,n-6,n-7,n-8,0)
         call zatom (k+6,1.10d0,126.0d0,126.0d0,n-6,n-8,n-4,1)
         call zatom (k+8,1.10d0,126.0d0,126.0d0,n-6,n-8,n-5,1)
         call zatom (k+10,1.02d0,126.0d0,126.0d0,n-6,n-8,n-7,1)
c
c     histidine (HD only) residue  (HID)
c
      else if (resname .eq. 'HID') then
         call zatom (k,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+3,1.35d0,126.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+5,1.35d0,126.0d0,108.0d0,n-2,n-3,n-1,1)
         call zatom (k+7,1.35d0,108.0d0,0.0d0,n-2,n-3,n-1,0)
         call zatom (k+9,1.35d0,108.0d0,0.0d0,n-2,n-4,n-3,0)
         call zatom (-1,0.0d0,0.0d0,.00d0,n-2,n-1,0,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,-1)
         call zatom (k+4,1.02d0,126.0d0,0.0d0,n-6,n-7,n-8,0)
         call zatom (k+6,1.10d0,126.0d0,126.0d0,n-6,n-8,n-4,1)
         call zatom (k+8,1.10d0,126.0d0,126.0d0,n-6,n-8,n-5,1)
c
c     histidine (HE only) residue  (HIE)
c
      else if (resname .eq. 'HIE') then
         call zatom (k,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+3,1.35d0,126.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+4,1.35d0,126.0d0,108.0d0,n-2,n-3,n-1,1)
         call zatom (k+6,1.35d0,108.0d0,0.0d0,n-2,n-3,n-1,0)
         call zatom (k+8,1.35d0,108.0d0,0.0d0,n-2,n-4,n-3,0)
         call zatom (-1,0.0d0,0.0d0,.00d0,n-2,n-1,0,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,-1)
         call zatom (k+5,1.10d0,126.0d0,126.0d0,n-5,n-7,n-3,1)
         call zatom (k+7,1.10d0,126.0d0,126.0d0,n-5,n-7,n-4,1)
         call zatom (k+9,1.02d0,126.0d0,126.0d0,n-5,n-7,n-6,1)
c
c     aspartate residue  (ASP)
c
      else if (resname .eq. 'ASP') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.51d0,107.8d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+3,1.25d0,117.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+3,1.25d0,117.0d0,126.0d0,n-2,n-3,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,107.9d0,n-4,cai,n-3,1)
         call zatom (k+1,1.11d0,109.4d0,107.9d0,n-5,cai,n-4,-1)
c
c     protonated aspartic acid residue  (ASH)
c
      else if (resname .eq. 'ASH') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.51d0,107.8d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+3,1.25d0,117.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+4,1.40d0,117.0d0,126.0d0,n-2,n-3,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,107.9d0,n-4,cai,n-3,1)
         call zatom (k+1,1.11d0,109.4d0,107.9d0,n-5,cai,n-4,-1)
         call zatom (k+5,0.98d0,108.7d0,0.0d0,n-3,n-5,n-4,0)
c
c     asparagine residue  (ASN)
c
      else if (resname .eq. 'ASN') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.51d0,107.8d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+3,1.22d0,122.5d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+4,1.34d0,112.7d0,124.0d0,n-2,n-3,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,107.9d0,n-4,cai,n-3,1)
         call zatom (k+1,1.11d0,109.4d0,107.9d0,n-5,cai,n-4,-1)
         call zatom (k+5,1.02d0,119.0d0,0.0d0,n-3,n-5,n-6,0)
         call zatom (k+5,1.02d0,119.0d0,120.0d0,n-4,n-6,n-1,1)
c
c     glutamate residue  (GLU)
c
      else if (resname .eq. 'GLU') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.51d0,107.8d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+5,1.25d0,117.0d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (k+5,1.25d0,117.0d0,126.0d0,n-2,n-3,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1)
         call zatom (k+3,1.11d0,109.4d0,107.9d0,n-6,n-7,n-5,1)
         call zatom (k+3,1.11d0,109.4d0,107.9d0,n-7,n-8,n-6,-1)
c
c     protonated glutamic acid residue  (GLH)
c
      else if (resname .eq. 'GLH') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.51d0,107.8d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+5,1.25d0,117.0d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (k+6,1.40d0,117.0d0,126.0d0,n-2,n-3,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1)
         call zatom (k+3,1.11d0,109.4d0,107.9d0,n-6,n-7,n-5,1)
         call zatom (k+3,1.11d0,109.4d0,107.9d0,n-7,n-8,n-6,-1)
         call zatom (k+7,0.98d0,108.7d0,0.0d0,n-5,n-7,n-6,0)
c
c     glutamine residue  (GLN)
c
      else if (resname .eq. 'GLN') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.51d0,107.8d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+5,1.22d0,122.5d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (k+6,1.34d0,112.7d0,124.0d0,n-2,n-3,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1)
         call zatom (k+3,1.11d0,109.4d0,107.9d0,n-6,n-7,n-5,1)
         call zatom (k+3,1.11d0,109.4d0,107.9d0,n-7,n-8,n-6,-1)
         call zatom (k+7,1.02d0,119.0d0,0.0d0,n-5,n-7,n-8,0)
         call zatom (k+7,1.02d0,119.0d0,120.0d0,n-6,n-8,n-1,1)
c
c     methionine residue  (MET)
c
      else if (resname .eq. 'MET') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.82d0,109.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+5,1.82d0,96.3d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,-1)
         call zatom (k+3,1.11d0,109.4d0,112.0d0,n-5,n-6,n-4,1)
         call zatom (k+3,1.11d0,109.4d0,112.0d0,n-6,n-7,n-5,-1)
         call zatom (k+6,1.11d0,112.0d0,180.0d0,n-5,n-6,n-7,0)
         call zatom (k+6,1.11d0,112.0d0,109.4d0,n-6,n-7,n-1,1)
         call zatom (k+6,1.11d0,112.0d0,109.4d0,n-7,n-8,n-2,-1)
c
c     lysine residue  (LYS)
c
      else if (resname .eq. 'LYS') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+6,1.54d0,109.5d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (k+8,1.50d0,109.5d0,chi(4,i),n-1,n-2,n-3,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,-1)
         call zatom (k+5,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,1)
         call zatom (k+5,1.11d0,109.4d0,109.4d0,n-8,n-9,n-7,-1)
         call zatom (k+7,1.11d0,109.4d0,108.8d0,n-8,n-9,n-7,1)
         call zatom (k+7,1.11d0,109.4d0,108.8d0,n-9,n-10,n-8,-1)
         call zatom (k+9,1.02d0,109.5d0,180.0d0,n-9,n-10,n-11,0)
         call zatom (k+9,1.02d0,109.5d0,109.5d0,n-10,n-11,n-1,1)
         call zatom (k+9,1.02d0,109.5d0,109.5d0,n-11,n-12,n-2,-1)
c
c     deprotonated lysine residue  (LYD)
c
      else if (resname .eq. 'LYD') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+6,1.54d0,109.5d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (k+8,1.50d0,109.5d0,chi(4,i),n-1,n-2,n-3,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,-1)
         call zatom (k+5,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,1)
         call zatom (k+5,1.11d0,109.4d0,109.4d0,n-8,n-9,n-7,-1)
         call zatom (k+7,1.11d0,109.4d0,108.8d0,n-8,n-9,n-7,1)
         call zatom (k+7,1.11d0,109.4d0,108.8d0,n-9,n-10,n-8,-1)
         call zatom (k+9,1.02d0,109.5d0,180.0d0,n-9,n-10,n-11,0)
         call zatom (k+9,1.02d0,109.5d0,109.5d0,n-10,n-11,n-1,1)
c
c     arginine residue  (ARG)
c
      else if (resname .eq. 'ARG') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+6,1.45d0,109.5d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (k+8,1.35d0,120.0d0,chi(4,i),n-1,n-2,n-3,0)
         call zatom (k+9,1.35d0,120.0d0,180.0d0,n-1,n-2,n-3,0)
         call zatom (k+9,1.35d0,120.0d0,120.0d0,n-2,n-3,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-8,cai,n-7,-1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-8,n-9,n-7,1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-9,n-10,n-8,-1)
         call zatom (k+5,1.11d0,109.4d0,109.4d0,n-9,n-10,n-8,1)
         call zatom (k+5,1.11d0,109.4d0,109.4d0,n-10,n-11,n-9,-1)
         call zatom (k+7,1.02d0,120.0d0,120.0d0,n-10,n-11,n-9,1)
         call zatom (k+10,1.02d0,120.0d0,180.0d0,n-9,n-10,n-11,0)
         call zatom (k+10,1.02d0,120.0d0,120.0d0,n-10,n-11,n-1,1)
         call zatom (k+10,1.02d0,120.0d0,180.0d0,n-10,n-12,n-13,0)
         call zatom (k+10,1.02d0,120.0d0,120.0d0,n-11,n-13,n-1,1)
c
c     ornithine residue  (ORN)
c
      else if (resname .eq. 'ORN') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (k+6,1.50d0,109.5d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,-1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-5,n-6,n-4,1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,-1)
         call zatom (k+5,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,1)
         call zatom (k+5,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,-1)
         call zatom (k+7,1.02d0,109.5d0,180.0d0,n-7,n-8,n-9,0)
         call zatom (k+7,1.02d0,109.5d0,109.5d0,n-8,n-9,n-1,1)
         call zatom (k+7,1.02d0,109.5d0,109.5d0,n-9,n-10,n-2,-1)
c
c     methylalanine residue  (AIB)
c
      else if (resname .eq. 'AIB') then
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,-chiral(i))
         call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (k+1,1.11d0,109.4d0,chi(1,i),n-2,cai,ni,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-3,cai,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-2,-1)
         call zatom (k+1,1.11d0,109.4d0,chi(1,i),n-4,cai,ni,0)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-1,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-2,-1)
c
c     pyroglutamic acid residue  (PCA)
c
      else if (resname .eq. 'PCA') then
         call zatom (k,1.54d0,107.0d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (k+2,1.54d0,107.0d0,chi(1,i),n-1,cai,ni,0)
         call zatom (k+4,1.54d0,107.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (-1,0.0d0,0.0d0,0.0d0,ni,n-1,0,0)
         call zatom (k+5,1.22d0,126.0d0,126.0d0,n-1,ni,n-2,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,1)
         call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,-1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-5,n-6,n-4,1)
         call zatom (k+3,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,-1)
c
c     unknown residue  (UNK)
c
      else if (resname .eq. 'UNK') then
         k = hatyp(seqtyp(i))
         if (i .eq. 1)  k = hantyp(seqtyp(i))
         if (i .eq. nseq)  k = hactyp(seqtyp(i))
         call zatom (k,1.11d0,109.5d0,107.9d0,cai,ni,ci,chiral(i))
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine pauling  --  pack multiple polypeptide chains  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "pauling" uses a rigid body optimization to approximately
c     pack multiple polypeptide chains
c
c
      subroutine pauling
      use atomid
      use atoms
      use couple
      use group
      use inform
      use katoms
      use molcul
      use output
      use potent
      use restrn
      use rigid
      use usage
      implicit none
      integer i,j,k,nvar
      real*8 minimum,grdmin
      real*8 pauling1
      real*8, allocatable :: xx(:)
      external pauling1,optsave
c
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(iuse))  allocate (iuse(n))
      if (.not. allocated(use))  allocate (use(0:n))
c
c     set all atoms to be active during energy evaluations
c
      nuse = n
      do i = 1, n
         use(i) = .true.
      end do
c
c     only geometric restraints will by used in optimization
c
      call potoff
      use_geom = .true.
c
c     set the default values for the restraint variables
c
      npfix = 0
      ndfix = 0
      ntfix = 0
      ngfix = 0
      nchir = 0
      use_basin = .true.
      depth = 3.0d0
      width = 1.5d0
      use_wall = .false.
c
c     enable use of groups based on number of molecules
c
      use_group = .true.
      ngrp = nmol
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(kgrp))  allocate (kgrp(n))
      if (.not. allocated(grplist))  allocate (grplist(n))
      if (.not. allocated(igrp))  allocate (igrp(2,0:ngrp))
      if (.not. allocated(grpmass))  allocate (grpmass(0:ngrp))
      if (.not. allocated(wgrp))  allocate (wgrp(0:ngrp,0:ngrp))
c
c     assign each chain to a separate molecule-based group
c
      do i = 1, ngrp
         igrp(1,i) = imol(1,i)
         igrp(2,i) = imol(2,i)
         do j = igrp(1,i), igrp(2,i)
            kgrp(j) = kmol(j)
            grplist(kgrp(j)) = i
         end do
      end do
      do i = 0, ngrp
         do j = 0, ngrp
            wgrp(j,i) = 1.0d0
         end do
         wgrp(i,i) = 1.0d0
      end do
c
c     assume unit mass for each atom and set group masses
c
      do i = 1, n
         mass(i) = 1.0d0
      end do
      do i = 1, ngrp
         grpmass(i) = dble(igrp(2,i)-igrp(1,i)+1)
      end do
c
c     perform dynamic allocation of some global arrays
c
      maxfix = max(n,ngrp*ngrp)
      if (allocated(ipfix))  deallocate(ipfix)
      if (allocated(kpfix))  deallocate(kpfix)
      if (allocated(xpfix))  deallocate(xpfix)
      if (allocated(ypfix))  deallocate(ypfix)
      if (allocated(zpfix))  deallocate(zpfix)
      if (allocated(pfix))  deallocate(pfix)
      if (allocated(igfix))  deallocate(igfix)
      if (allocated(gfix))  deallocate(gfix)
      allocate (ipfix(maxfix))
      allocate (kpfix(3,maxfix))
      allocate (xpfix(maxfix))
      allocate (ypfix(maxfix))
      allocate (zpfix(maxfix))
      allocate (pfix(2,maxfix))
      allocate (igfix(2,maxfix))
      allocate (gfix(3,maxfix))
c
c     set position restraints on alpha carbons of each chain
c
      do i = 1, n
         if (atmnum(type(i)) .eq. 6) then
            do j = 1, n12(i)
               if (atmnum(type(i12(j,i))) .eq. 7) then
                  do k = 1, n13(i)
                     if (atmnum(type(i13(k,i))) .eq. 8) then
                        npfix = npfix + 1
                        ipfix(npfix) = i
                        kpfix(1,npfix) = 1
                        kpfix(2,npfix) = 1
                        kpfix(3,npfix) = 0
                        xpfix(npfix) = 11.0d0 * dble(grplist(i)-1)
                        ypfix(npfix) = 0.0d0
                        zpfix(npfix) = 0.0d0
                        pfix(1,npfix) = 1.0d0
                        pfix(2,npfix) = 0.0d0
                        goto 10
                     end if
                  end do
               end if
            end do
         end if
   10    continue
      end do
c
c     set pairwise restraints between the centers of chains
c
      do i = 1, ngrp-1
         do j = i+1, ngrp
            ngfix = ngfix + 1
            igfix(1,ngfix) = i
            igfix(2,ngfix) = j
            gfix(1,ngfix) = 1.0d0
            gfix(2,ngfix) = 11.0d0 * dble(j-i)
            gfix(3,ngfix) = 11.0d0 * dble(j-i)
         end do
      end do
c
c     get rigid body reference coordinates for each chain
c
      call orient
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(6*ngrp))
c
c     convert rigid body coordinates to optimization parameters
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            xx(nvar) = rbc(j,i)
         end do
      end do
c
c     make the call to the optimization routine
c
      iprint = 0
      iwrite = 0
      grdmin = 0.1d0
      coordtype = 'NONE'
      call ocvm (nvar,xx,minimum,grdmin,pauling1,optsave)
c
c     convert optimization parameters to rigid body coordinates
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            rbc(j,i) = xx(nvar)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
c
c     convert from rigid body to Cartesian coordinates
c
      call rigidxyz
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function pauling1  --  energy and gradient for pauling  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "pauling1" is a service routine that computes the energy
c     and gradient for optimally conditioned variable metric
c     optimization of rigid bodies
c
c
      function pauling1 (xx,g)
      use group
      use math
      use rigid
      implicit none
      integer i,j,nvar
      real*8 pauling1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to rigid body coordinates
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            rbc(j,i) = xx(nvar)
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(6,ngrp))
c
c     compute and store the energy and gradient
c
      call rigidxyz
      call gradrgd (e,derivs)
      pauling1 = e
c
c     convert gradient components to optimization parameters
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            g(nvar) = derivs(j,i)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2022  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine prtarc  --  output of a coordinates archive  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "prtarc" writes a Cartesian coordinates archive as either
c     a formatted or binary file
c
c
      subroutine prtarc (iarc,first)
      use output
      implicit none
      integer iarc
      logical first
c
c
c     write archive file as either formatted or binary file
c
      if (archive) then
         call prtarcf (iarc)
      else if (binary) then
         call prtarcb (iarc,first)
      end if
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine prtarcf  --  output of Tinker archive file  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "prtarcf" writes out a set of Cartesian coordinates for
c     all active atoms in the Tinker XYZ archive format
c
c
      subroutine prtarcf (iarc)
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use files
      use inform
      use titles
      use usage
      implicit none
      integer i,j,k,iarc
      integer size,crdsiz
      real*8 crdmin,crdmax
      logical opened
      character*2 atmc
      character*2 crdc
      character*2 digc
      character*25 fstr
      character*240 arcfile
c
c
c     open output unit if not already done
c
      inquire (unit=iarc,opened=opened)
      if (.not. opened) then
         arcfile = filename(1:leng)//'.arc'
         call version (arcfile,'new')
         open (unit=iarc,file=arcfile,status='new')
      end if
c
c     check for large systems needing extended formatting
c
      atmc = 'i6'
      if (n .ge. 100000)  atmc = 'i7'
      if (n .ge. 1000000)  atmc = 'i8'
      crdmin = 0.0d0
      crdmax = 0.0d0
      do i = 1, n
         crdmin = min(crdmin,x(i),y(i),z(i))
         crdmax = max(crdmax,x(i),y(i),z(i))
      end do
      crdsiz = 6
      if (crdmin .le. -1000.0d0)  crdsiz = 7
      if (crdmax .ge. 10000.0d0)  crdsiz = 7
      if (crdmin .le. -10000.0d0)  crdsiz = 8
      if (crdmax .ge. 100000.0d0)  crdsiz = 8
      crdsiz = crdsiz + max(6,digits)
      size = 0
      call numeral (crdsiz,crdc,size)
      if (digits .le. 6) then
         digc = '6 '
      else if (digits .le. 8) then
         digc = '8'
      else
         digc = '10'
      end if
c
c     write out the number of atoms and the title
c
      if (ltitle .eq. 0) then
         fstr = '('//atmc//')'
         write (iarc,fstr(1:4))  nuse
      else
         fstr = '('//atmc//',2x,a)'
         write (iarc,fstr(1:9))  nuse,title(1:ltitle)
      end if
c
c     write out the periodic cell lengths and angles
c
      if (use_bounds) then
         fstr = '(1x,6f'//crdc//'.'//digc//')'
         write (iarc,fstr)  xbox,ybox,zbox,alpha,beta,gamma
      end if
c
c     write out the coordinate line for each atom
c
      fstr = '('//atmc//',2x,a3,3f'//crdc//
     &          '.'//digc//',i6,8'//atmc//')'
      do i = 1, n
         if (use(i)) then
            k = n12(i)
            if (k .eq. 0) then
               write (iarc,fstr)  iuse(i),name(i),x(i),y(i),z(i),
     &                            type(i)
            else
               write (iarc,fstr)  iuse(i),name(i),x(i),y(i),z(i),
     &                            type(i),(iuse(i12(j,i)),j=1,k)
            end if
         end if
      end do
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=iarc)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine prtarcb  --  output binary-format archive file  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "prtarcb" writes out a set of Cartesian coordinates for all
c     active atoms in the CHARMM DCD binary format
c
c     note the format used is based on the "dcdplugin.c" code from
c     the NAMD and VMD programs, and tutorial 4.1 from the software
c     package GENESIS: Generalized-Ensemble Simulation System
c
c     variables and parameters:
c
c     header     type of data (CORD=coordinates, VELD=velocities)
c     nframe     number of frames stored in the DCD file
c     nprev      number of previous integration steps
c     ncrdsav    frequency in steps for saving coordinate frames
c     nstep      number of integration steps in the total run
c     nvelsav    frequency of coordinate saves with velocity data
c     ndfree     number of degrees of freedom for the system
c     nfixat     number of fixed atoms for the system
c     usebox     flag for periodic boundaries (1=true, 0=false)
c     use4d      flag for 4D trajectory (1=true, 0=false)
c     usefq      flag for fluctuating charges (1=true, 0=false)
c     merged     result of merge without checks (1=true, 0=false)
c     vcharmm    version of CHARMM software for compatibility
c
c     in general a value of zero for any of the above indicates that
c     the particular feature is unused
c
c
      subroutine prtarcb (idcd,first)
      use atoms
      use bound
      use boxes
      use files
      use titles
      use usage
      implicit none
      integer i,k,idcd
      integer zero,one
      integer nframe,nprev
      integer ncrdsav,nstep
      integer nvelsav,ndfree
      integer nfixat,usebox
      integer use4d,usefq
      integer merged,vcharmm
      integer ntitle
      real*4 tdelta
      logical opened,first
      character*4 header
      character*240 dcdfile
c
c
c     open the output unit if not already done
c
      inquire (unit=idcd,opened=opened)
      if (.not. opened) then
         dcdfile = filename(1:leng)//'.dcd'
         call version (dcdfile,'new')
         open (unit=idcd,file=dcdfile,form='unformatted',status='new')
      end if
c
c     write header info along with title and number of atoms
c
      if (first) then
         first = .false.
         zero = 0
         one = 1
         header = 'CORD'
         nframe = zero
         nprev = zero
         ncrdsav = one
         nstep = zero
         nvelsav = zero
         ndfree = zero
         nfixat = zero
         tdelta = 0.0
         usebox = zero
         if (use_bounds)  usebox = one
         use4d = zero
         usefq = zero
         merged = zero
         vcharmm = 24
         ntitle = one
         write (idcd)  header,nframe,nprev,ncrdsav,nstep,
     &                 nvelsav,zero,zero,ndfree,nfixat,
     &                 tdelta,usebox,use4d,usefq,merged,
     &                 zero,zero,zero,zero,zero,vcharmm
         write (idcd)  ntitle,title(1:80)
         write (idcd)  nuse
      end if
c
c     append the lattice values based on header flag value
c
      if (use_bounds) then
         write (idcd)  xbox,gamma_cos,ybox,beta_cos,alpha_cos,zbox
      end if
c
c     remove unused atoms from the coordinates to be output
c
      if (nuse .ne. n) then
         k = 0
         do i = 1, n
            if (use(i)) then
               k = k + 1
               x(k) = x(i)
               y(k) = y(i)
               z(k) = z(i)
            end if
         end do
      end if
c
c     append the atomic coordinates along each axis in turn
c
      write (idcd)  (real(x(i)),i=1,nuse)
      write (idcd)  (real(y(i)),i=1,nuse)
      write (idcd)  (real(z(i)),i=1,nuse)
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=idcd)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2025  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine prtcif  --  output of PDB in PDBx/mmCIF format  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "prtcif" writes out a set of PDB coordinates in PDBx/mmCIF
c     format to an external file
c
c
      subroutine prtcif (icif)
      use ascii
      use bound
      use boxes
      use files
      use pdb
      use sequen
      use titles
      implicit none
      integer i,k
      integer icif
      integer start,stop
      integer resmax,resnumb
      integer, allocatable :: resid(:)
      real*8 crdmin,crdmax
      real*8 occupy,bfac
      logical opened
      logical header
      logical rename
      logical reformat
      character*1 letter
      character*1 chnname,entity
      character*1 insert,formal
      character*1, allocatable :: chain(:)
      character*2 atmc,resc,modc
      character*3 resname
      character*4 atmname
      character*6 crdc
      character*240 fstr
      character*240 ciffile
c
c
c     set flags for residue naming and extended formatting
c
      header = .true.
      if (imodel .gt. 1)  header = .false.
      rename = .false.
      reformat = .true.
c
c     open the output unit if not already done
c
      inquire (unit=icif,opened=opened)
      if (.not. opened) then
         ciffile = filename(1:leng)//'.cif'
         call version (ciffile,'new')
         open (unit=icif,file=ciffile,status='new')
      end if
c
c     write out the structure title as the initial section
c
      if (header) then
         fstr = '(''_struct.title '')'
         write (icif,fstr(1:18))
         if (ltitle .ne. 0) then
            letter = char(apostrophe)
            fstr = '(a1,a,a1)'
            write (icif,fstr(1:9))  letter,title(1:ltitle),letter
         end if
         fstr = '(''# '')'
         write (icif,fstr(1:6))
c
c     include any lattice parameters in the header info
c
         if (use_bounds) then
            fstr = '(''_cell.length_a'',8x,f9.3)'
            write (icif,fstr(1:26))  xbox
            fstr = '(''_cell.length_b'',8x,f9.3)'
            write (icif,fstr(1:26))  ybox
            fstr = '(''_cell.length_c'',8x,f9.3)'
            write (icif,fstr(1:26))  zbox
            fstr = '(''_cell.angle_alpha'',5x,f9.3)'
            write (icif,fstr(1:29))  alpha
            fstr = '(''_cell.angle_beta'',6x,f9.3)'
            write (icif,fstr(1:28))  beta
            fstr = '(''_cell.angle_gamma'',5x,f9.3)'
            write (icif,fstr(1:29))  gamma
            fstr = '(''# '')'
            write (icif,fstr(1:6))
         end if
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (resid(maxres))
      allocate (chain(maxres))
c
c     find chain name and chain position for each residue
c
      do i = 1, nchain
         start = ichain(1,i)
         stop = ichain(2,i)
         do k = start, stop
            resid(k) = k - start + 1
            chain(k) = chnnam(i)
         end do
      end do
c
c     change Tinker residue names to match PDB standards
c
      if (rename) then
         do i = 1, npdb
            if (pdbres(i) .eq. 'CYX')  pdbres(i) = 'CYS'
            if (pdbres(i) .eq. 'CYD')  pdbres(i) = 'CYS'
            if (pdbres(i) .eq. 'TYD')  pdbres(i) = 'TYR'
            if (pdbres(i) .eq. 'HID')  pdbres(i) = 'HIS'
            if (pdbres(i) .eq. 'HIE')  pdbres(i) = 'HIS'
            if (pdbres(i) .eq. 'HIP')  pdbres(i) = 'HIS'
            if (pdbres(i) .eq. 'ASH')  pdbres(i) = 'ASP'
            if (pdbres(i) .eq. 'GLH')  pdbres(i) = 'GLU'
            if (pdbres(i) .eq. 'LYD')  pdbres(i) = 'LYS'
         end do
      end if
c
c     set default format for atoms, residues and coordinates
c
      atmc = 'i3'
      resc = 'i3'
      crdc = '3f7.3 '
      modc = 'i2'
c
c     check for large values requiring extended formatting
c
      if (reformat) then
         resmax = 0
         crdmin = 0.0d0
         crdmax = 0.0d0
         do i = 1, npdb
            if (pdbrec(i) .eq. 'ATOM  ') then
               resmax = max(resmax,resid(resnum(i)))
            else
               resmax = max(resmax,resnum(i))
            end if
            crdmin = min(crdmin,xpdb(i),ypdb(i),zpdb(i))
            crdmax = max(crdmax,xpdb(i),ypdb(i),zpdb(i))
         end do
         if (npdb .ge. 1000)  atmc = 'i4'
         if (npdb .ge. 10000)  atmc = 'i5'
         if (npdb .ge. 100000)  atmc = 'i6'
         if (npdb .ge. 1000000)  atmc = 'i7'
         if (resmax .ge. 1000)  resc = 'i4'
         if (resmax .ge. 10000)  resc = 'i5'
         if (resmax .ge. 100000)  resc = 'i6'
         if (resmax .ge. 1000000)  resc = 'i7'
         if (crdmin .le. -10.0d0)  crdc = '3f8.3 '
         if (crdmin .le. 100.0d0)  crdc = '3f8.3 '
         if (crdmin .le. -100.0d0)  crdc = '3f9.3 '
         if (crdmax .ge. 1000.0d0)  crdc = '3f9.3 '
         if (crdmin .le. -1000.0d0)  crdc = '3f10.3'
         if (crdmax .ge. 10000.0d0)  crdc = '3f10.3'
         if (nmodel .ge. 100)  modc = 'i3'
         if (nmodel .ge. 1000)  modc = 'i4'
         if (nmodel .ge. 10000)  modc = 'i5'
         if (nmodel .ge. 100000)  modc = 'i6'
         if (nmodel .ge. 1000000)  modc = 'i7'
      end if
c
c     write the loop structure for the coordinates section
c
      if (header) then
         fstr = '(''loop_'')'
         write (icif,fstr(1:9))
         fstr = '(''_atom_site.group_PDB '')'
         write (icif,fstr(1:25))
         fstr = '(''_atom_site.id '')'
         write (icif,fstr(1:25))
         fstr = '(''_atom_site.type_symbol '')'
         write (icif,fstr(1:27))
         fstr = '(''_atom_site.label_atom_id '')'
         write (icif,fstr(1:29))
         fstr = '(''_atom_site.label_alt_id '')'
         write (icif,fstr(1:28))
         fstr = '(''_atom_site.label_comp_id '')'
         write (icif,fstr(1:29))
         fstr = '(''_atom_site.label_asym_id '')'
         write (icif,fstr(1:29))
         fstr = '(''_atom_site.label_entity_id '')'
         write (icif,fstr(1:31))
         fstr = '(''_atom_site.label_seq_id '')'
         write (icif,fstr(1:28))
         fstr = '(''_atom_site.pdbx_PDB_ins_code '')'
         write (icif,fstr(1:33))
         fstr = '(''_atom_site.Cartn_x '')'
         write (icif,fstr(1:23))
         fstr = '(''_atom_site.Cartn_y '')'
         write (icif,fstr(1:23))
         fstr = '(''_atom_site.Cartn_z '')'
         write (icif,fstr(1:23))
         fstr = '(''_atom_site.occupancy '')'
         write (icif,fstr(1:25))
         fstr = '(''_atom_site.B_iso_or_equiv '')'
         write (icif,fstr(1:30))
         fstr = '(''_atom_site.pdbx_formal_charge '')'
         write (icif,fstr(1:34))
         fstr = '(''_atom_site.auth_seq_id '')'
         write (icif,fstr(1:27))
         fstr = '(''_atom_site.auth_comp_id '')'
         write (icif,fstr(1:28))
         fstr = '(''_atom_site.auth_asym_id '')'
         write (icif,fstr(1:28))
         fstr = '(''_atom_site.auth_atom_id '')'
         write (icif,fstr(1:28))
         fstr = '(''_atom_site.pdbx_PDB_model_num '')'
         write (icif,fstr(1:34))
      end if
c
c     write information and coordinates for each atom
c
      fstr = '(a6,'//atmc//',1x,a3,1x,a4,1x,a1,1x,a3,1x,a1,1x,a1,'
     &          //resc//',1x,a1,1x,'//crdc//',2f5.2,1x,a1,'
     &          //resc//',1x,a3,1x,a1,1x,a4,1x,'//modc//')'
      altsym = '.'
      entity = '1'
      insert = '?'
      occupy = 1.0d0
      bfac = 0.0d0
      formal = '?'
      if (imodel .eq. 0) imodel = 1
      do i = 1, npdb
         atmname = pdbatm(i)
         if (atmname(1:1) .eq. ' ')  atmname = atmname(2:4)//' '
         resname = pdbres(i)
         if (resname(2:3) .eq. '  ')  resname = '  '//resname(1:1)
         if (resname(3:3) .eq. ' ')  resname = ' '//resname(1:2)
         if (pdbrec(i) .eq. 'ATOM  ') then
            resnumb = resid(resnum(i))
            chnname = chain(resnum(i))
         else
            resnumb = resnum(i)
            chnname = ' '
         end if
         write (icif,fstr)  pdbrec(i),i,pdbsym(i),atmname,altsym,
     &                      resname,chnname,entity,resnumb,insert,
     &                      xpdb(i),ypdb(i),zpdb(i),occupy,bfac,formal,
     &                      resnumb,resname,chnname,atmname,imodel
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (resid)
      deallocate (chain)
c
c     close the output unit if opened by this routine
c
c     if (.not. opened)  close (unit=icif)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine prtdyn  --  output of MD restart information  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "prtdyn" writes out the information needed to restart a
c     molecular dynamics trajectory to an external file
c
c
      subroutine prtdyn
      use atoms
      use boxes
      use files
      use group
      use mdstuf
      use moldyn
      use rgddyn
      use titles
      implicit none
      integer i,idyn
      integer freeunit
      logical exist
      character*2 atmc
      character*39 fstr
      character*240 dynfile
c
c
c     update an existing restart file or open a new one
c
      idyn = freeunit ()
      dynfile = filename(1:leng)//'.dyn'
      inquire (file=dynfile,exist=exist)
      if (exist) then
         open (unit=idyn,file=dynfile,status='old')
         rewind (unit=idyn)
      else
         open (unit=idyn,file=dynfile,status='new')
      end if
c
c     save the number of atoms and the title string
c
      fstr = '('' Number of Atoms and Title :'')'
      write (idyn,fstr(1:32))
      atmc = 'i6'
      if (n .ge. 100000)  atmc = 'i7'
      if (n .ge. 1000000)  atmc = 'i8'
      if (ltitle .eq. 0) then
         fstr = '('//atmc//')'
         write (idyn,fstr(1:4))  n
      else
         fstr = '('//atmc//',2x,a)'
         write (idyn,fstr(1:9))  n,title(1:ltitle)
      end if
c
c     save the periodic box edge lengths and angles
c
      fstr = '('' Periodic Box Dimensions :'')'
      write (idyn,fstr(1:30))
      fstr = '(3d26.16)'
      write (idyn,fstr(1:9))  xbox,ybox,zbox
      write (idyn,fstr(1:9))  alpha,beta,gamma
c
c     save rigid body positions, translational and angular velocities
c
      if (integrate .eq. 'RIGIDBODY') then
         fstr = '('' Current Atomic Positions :'')'
         write (idyn,fstr(1:31))
         fstr = '(3d26.16)'
         do i = 1, n
            write (idyn,fstr(1:9))  x(i),y(i),z(i)
         end do
         fstr = '('' Current Translational Velocities :'')'
         write (idyn,fstr(1:39))
         fstr = '(3d26.16)'
         do i = 1, ngrp
            write (idyn,fstr(1:9))  vcm(1,i),vcm(2,i),vcm(3,i)
         end do
         fstr = '('' Current Angular Velocities :'')'
         write (idyn,fstr(1:33))
         fstr = '(3d26.16)'
         do i = 1, ngrp
            write (idyn,fstr(1:9))  wcm(1,i),wcm(2,i),wcm(3,i)
         end do
         fstr = '('' Current Angular Momenta :'')'
         write (idyn,fstr(1:30))
         fstr = '(3d26.16)'
         do i = 1, ngrp
            write (idyn,fstr(1:9))  lm(1,i),lm(2,i),lm(3,i)
         end do
c
c     save the atomic positions, velocities and accelerations
c
      else
         fstr = '('' Current Atomic Positions :'')'
         write (idyn,fstr(1:31))
         fstr = '(3d26.16)'
         do i = 1, n
            write (idyn,fstr(1:9))  x(i),y(i),z(i)
         end do
         fstr = '('' Current Atomic Velocities :'')'
         write (idyn,fstr(1:32))
         fstr = '(3d26.16)'
         do i = 1, n
            write (idyn,fstr(1:9))  v(1,i),v(2,i),v(3,i)
         end do
         fstr = '('' Current Atomic Accelerations :'')'
         write (idyn,fstr(1:36))
         fstr = '(3d26.16)'
         do i = 1, n
            write (idyn,fstr(1:9))  a(1,i),a(2,i),a(3,i)
         end do
         fstr = '('' Alternate Atomic Accelerations :'')'
         write (idyn,fstr(1:38))
         fstr = '(3d26.16)'
         if (integrate .eq. 'VERLET') then
            do i = 1, n
               write (idyn,fstr(1:9))  a(1,i),a(2,i),a(3,i)
            end do
         else
            do i = 1, n
               write (idyn,fstr(1:9))  aalt(1,i),aalt(2,i),aalt(3,i)
            end do
         end if
      end if
c
c     close the dynamics trajectory restart file
c
      close (unit=idyn)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine prterr  --  output coordinates upon error  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "prterr" writes out a set of coordinates to a disk
c     file prior to aborting on a serious error
c
c
      subroutine prterr
      use files
      use output
      implicit none
      integer ierr,freeunit
      character*240 errorfile
c
c
c     write the current coordinates to a file after an error
c
      ierr = freeunit ()
      errorfile = filename(1:leng)//'.err'
      call version (errorfile,'new')
      open (unit=ierr,file=errorfile,status='new')
      if (coordtype .eq. 'CARTESIAN') then
         call prtxyz (ierr)
      else if (coordtype .eq. 'INTERNAL') then
         call prtint (ierr)
      else if (coordtype .eq. 'RIGIDBODY') then
         call prtxyz (ierr)
      end if
      close (unit=ierr)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2023  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine prtfrc  --  output of atom force components  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "prtfrc" writes out a set of atom force components to an
c     external file in Tinker XYZ format
c
c
      subroutine prtfrc (ifrc)
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use deriv
      use files
      use inform
      use titles
      implicit none
      integer i,j,k,ifrc
      integer size,crdsiz
      real*8 crdmin,crdmax
      logical opened
      character*2 atmc
      character*2 crdc
      character*2 digc
      character*25 fstr
      character*240 frcfile
c
c
c     open the output unit if not already done
c
      inquire (unit=ifrc,opened=opened)
      if (.not. opened) then
         frcfile = filename(1:leng)//'.frc'
         call version (frcfile,'new')
         open (unit=ifrc,file=frcfile,status='new')
      end if
c
c     check for large systems needing extended formatting
c
      atmc = 'i6'
      if (n .ge. 100000)  atmc = 'i7'
      if (n .ge. 1000000)  atmc = 'i8'
      crdmin = 0.0d0
      crdmax = 0.0d0
      do i = 1, n
         crdmin = min(crdmin,x(i),y(i),z(i))
         crdmax = max(crdmax,x(i),y(i),z(i))
      end do
      crdsiz = 6
      if (crdmin .le. -1000.0d0)  crdsiz = 7
      if (crdmax .ge. 10000.0d0)  crdsiz = 7
      if (crdmin .le. -10000.0d0)  crdsiz = 8
      if (crdmax .ge. 100000.0d0)  crdsiz = 8
      crdsiz = crdsiz + max(6,digits)
      size = 0
      call numeral (crdsiz,crdc,size)
      if (digits .le. 6) then
         digc = '6 '
      else if (digits .le. 8) then
         digc = '8'
      else
         digc = '10'
      end if
c
c     write out the number of atoms and the title
c
      if (ltitle .eq. 0) then
         fstr = '('//atmc//')'
         write (ifrc,fstr(1:4))  n
      else
         fstr = '('//atmc//',2x,a)'
         write (ifrc,fstr(1:9))  n,title(1:ltitle)
      end if
c
c     write out the periodic cell lengths and angles
c
      if (use_bounds) then
         fstr = '(1x,6f'//crdc//'.'//digc//')'
         write (ifrc,fstr)  xbox,ybox,zbox,alpha,beta,gamma
      end if
c
c     write out the atom force components for each atom
c
      fstr = '('//atmc//',2x,a3,3f'//crdc//
     &          '.'//digc//',i6,8'//atmc//')'
      do i = 1, n
         k = n12(i)
         if (k .eq. 0) then
            write (ifrc,fstr)  i,name(i),(-desum(j,i),j=1,3),type(i)
         else
            write (ifrc,fstr)  i,name(i),(-desum(j,i),j=1,3),type(i),
     &                         (i12(j,i),j=1,k)
         end if
      end do
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=ifrc)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine prtdcdf  --  output of DCD force components  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "prtdcdf" writes out a set of atomic force components to
c     a file in CHARMM DCD binary format compatible with the VMD
c     visualization software and other packages
c
c     note the format used is based on the "dcdplugin.c" code from
c     the NAMD and VMD programs, and tutorial 4.1 from the software
c     package GENESIS: Generalized-Ensemble Simulation System
c
c     variables and parameters:
c
c     header     type of data (CORD=coordinates, VELD=velocities)
c     nframe     number of frames stored in the DCD file
c     nprev      number of previous integration steps
c     ncrdsav    frequency in steps for saving coordinate frames
c     nstep      number of integration steps in the total run
c     nvelsav    frequency of coordinate saves with velocity data
c     ndfree     number of degrees of freedom for the system
c     nfixat     number of fixed atoms for the system
c     usebox     flag for periodic boundaries (1=true, 0=false)
c     use4d      flag for 4D trajectory (1=true, 0=false)
c     usefq      flag for fluctuating charges (1=true, 0=false)
c     merged     result of merge without checks (1=true, 0=false)
c     vcharmm    version of CHARMM software for compatibility
c
c     in general a value of zero for any of the above indicates that
c     the particular feature is unused
c
c
      subroutine prtdcdf (idcd,first)
      use atoms
      use bound
      use boxes
      use deriv
      use files
      use titles
      implicit none
      integer i,idcd
      integer zero,one
      integer nframe,nprev
      integer ncrdsav,nstep
      integer nvelsav,ndfree
      integer nfixat,usebox
      integer use4d,usefq
      integer merged,vcharmm
      integer ntitle
      real*4 tdelta
      logical opened,first
      character*4 header
      character*240 dcdfile
c
c
c     open the output unit if not already done
c
      inquire (unit=idcd,opened=opened)
      if (.not. opened) then
         dcdfile = filename(1:leng)//'.dcdf'
         call version (dcdfile,'new')
         open (unit=idcd,file=dcdfile,form='unformatted',status='new')
      end if
c
c     write header info along with title and number of atoms
c
      if (first) then
         first = .false.
         zero = 0
         one = 1
         header = 'CORD'
         nframe = zero
         nprev = zero
         ncrdsav = one
         nstep = zero
         nvelsav = zero
         ndfree = zero
         nfixat = zero
         tdelta = 0.0
         usebox = zero
         if (use_bounds)  usebox = one
         use4d = zero
         usefq = zero
         merged = zero
         vcharmm = 24
         ntitle = one
         write (idcd)  header,nframe,nprev,ncrdsav,nstep,
     &                 nvelsav,zero,zero,ndfree,nfixat,
     &                 tdelta,usebox,use4d,usefq,merged,
     &                 zero,zero,zero,zero,zero,vcharmm
         write (idcd)  ntitle,title(1:80)
         write (idcd)  n
      end if
c
c     append the lattice values based on header flag value;
c     using angle values is NAMD style, cosine values is CHARMM
c
      if (use_bounds) then
c        write (idcd)  xbox,gamma_cos,ybox,beta_cos,alpha_cos,zbox
         write (idcd)  xbox,gamma,ybox,beta,alpha,zbox
      end if
c
c     append the force components along each axis in turn
c
      write (idcd)  (real(-desum(1,i)),i=1,n)
      write (idcd)  (real(-desum(2,i)),i=1,n)
      write (idcd)  (real(-desum(3,i)),i=1,n)
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=idcd)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine prtint  --  output of internal coordinates  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "prtint" writes out a set of Z-matrix internal coordinates
c     to an external file in Tinker INT format
c
c
      subroutine prtint (izmt)
      use atomid
      use atoms
      use files
      use inform
      use titles
      use zclose
      use zcoord
      implicit none
      integer i,k,izmt
      logical opened
      character*2 atmc
      character*5 bndc,angc
      character*43 fstr
      character*240 zmtfile
c
c
c     open the output unit if not already done
c
      inquire (unit=izmt,opened=opened)
      if (.not. opened) then
         zmtfile = filename(1:leng)//'.int'
         call version (zmtfile,'new')
         open (unit=izmt,file=zmtfile,status='new')
      end if
c
c     check for large systems needing extended formatting
c
      atmc = 'i6'
      if (n .ge. 100000)  atmc = 'i7'
      if (n .ge. 1000000)  atmc = 'i8'
      if (digits .le. 6) then
         bndc = 'f10.5'
         angc = 'f10.4'
      else if (digits .le. 8) then
         bndc = 'f12.7'
         angc = 'f12.6'
      else
         bndc = 'f14.9'
         angc = 'f14.8'
      end if
c
c     write out the number of atoms and the title
c
      if (ltitle .eq. 0) then
         fstr = '('//atmc//')'
         write (izmt,fstr(1:4))  n
      else
         fstr = '('//atmc//',2x,a)'
         write (izmt,fstr(1:9))  n,title(1:ltitle)
      end if
c
c     output of first three atoms is handled separately
c
      fstr = '('//atmc//',2x,a3,i6,'//atmc//','//bndc//','//atmc//
     &          ','//angc//','//atmc//','//angc//','//'i6)'
      if (n .ge. 1)
     &   write (izmt,fstr)  1,name(1),type(1)
      if (n .ge. 2)
     &   write (izmt,fstr)  2,name(2),type(2),iz(1,2),zbond(2)
      if (n .ge. 3)
     &   write (izmt,fstr)  3,name(3),type(3),iz(1,3),zbond(3),
     &                      iz(2,3),zang(3)
c
c     convert torsional angles to lie in standard range
c
      do i = 4, n
         if (iz(4,i) .eq. 0) then
            do while (ztors(i) .lt. -180.0d0)
               ztors(i) = ztors(i) + 360.0d0
            end do
            do while (ztors(i) .gt. 180.0d0)
               ztors(i) = ztors(i) - 360.0d0
            end do
         end if
      end do
c
c     output the fourth through final atoms
c
      do i = 4, n
         write (izmt,fstr)  i,name(i),type(i),iz(1,i),zbond(i),
     &                      iz(2,i),zang(i),iz(3,i),ztors(i),iz(4,i)
      end do
c
c     addition and deletion of bonds as required
c
      if (nadd.ne.0 .or. ndel.ne.0) then
         fstr = '(2'//atmc//')'
         write (izmt,'()')
         do i = 1, nadd
            write (izmt,fstr(1:5))  (iadd(k,i),k=1,2)
         end do
         if (ndel .ne. 0)  write (izmt,'()')
         do i = 1, ndel
            write (izmt,fstr(1:5))  (idel(k,i),k=1,2)
         end do
      end if
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=izmt)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  program prtmol2  --  output Tripos MOL2 structure file  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "prtmol2" writes out a set of coordinates in Tripos MOL2
c     format to an external file
c
c
      subroutine prtmol2 (imol2)
      use atoms
      use bndstr
      use files
      use iounit
      use titles
      implicit none
      integer i,j,imol2
      integer substr
      integer trimtext
      real*8, allocatable :: atmchg(:)
      logical opened
      character*2, allocatable :: bndtyp(:)
      character*3 subnam
      character*5, allocatable :: atmtyp(:)
      character*8, allocatable :: atmnam(:)
      character*240 mol2file
c
c
c     open output unit if not already done
c
      inquire (unit=imol2,opened=opened)
      if (.not. opened) then
         mol2file = filename(1:leng)//'.mol2'
         call version (mol2file,'new')
         open (unit=imol2,file=mol2file,status='new')
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (atmnam(n))
      allocate (atmtyp(n))
      allocate (atmchg(n))
      allocate (bndtyp(nbond))
c
c     write the MOLECULE record type indicator
c
      write (imol2,10)
   10 format ('@<TRIPOS>MOLECULE')
      if (ltitle .eq. 0) then
         write (imol2,20)
   20    format ('****')
      else
         write (imol2,30)  title(1:ltitle)
   30    format (a)
      end if
      substr = 1
      write (imol2,40)  n,nbond,substr
   40 format (3i7)
      write (imol2,50)
   50 format ('SMALL')
      write (imol2,60)
   60 format ('USER_CHARGES')
c
c     determine MOL2 atom names/types and bond types
c
      call setmol2 (atmnam,atmtyp,atmchg,bndtyp)
c
c     write the ATOM record type indicator
c
      write (imol2,70)
   70 format (/,'@<TRIPOS>ATOM')
      do i = 1, n
         substr = 1
         subnam = '<1>'
         write (imol2,80)  i,atmnam(i),x(i),y(i),z(i),atmtyp(i),
     &                     substr,subnam,atmchg(i)
   80    format (i7,2x,a8,3f12.6,2x,a5,i4,2x,a3,f7.2)
      end do
c
c     write the BOND record type indicator
c
      write (imol2,90)
   90 format (/,'@<TRIPOS>BOND')
      do i = 1, nbond
         write (imol2,100)  i,(ibnd(j,i),j=1,2),
     &                      bndtyp(i)(1:trimtext(bndtyp(i)))
  100    format (3i7,2x,a)
      end do
c
c     write the SUBSTRUCTURE record type indicator
c
      write (imol2,110)
  110 format (/,'@<TRIPOS>SUBSTRUCTURE')
      write (imol2,120)  1,'****',1,'TEMP',0,'****','****',0,'ROOT'
  120 format (i7,2x,a4,i7,2x,a4,i7,2x,a4,2x,a4,i7,2x,a4)
c
c     perform deallocation of some local arrays
c
      deallocate (atmnam)
      deallocate (atmtyp)
      deallocate (bndtyp)
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=imol2)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  program setmol2  --  set MOL2 atom, charge & bond values  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "setmol2" assigns MOL2 atom names/types/charges and bond types
c     based upon atomic numbers and connectivity
c
c
      subroutine setmol2 (atmnam,atmtyp,atmchg,bndtyp)
      use angbnd
      use atmlst
      use atomid
      use atoms
      use bndstr
      use couple
      use ptable
      use ring
      use tors
      implicit none
      integer i,j,k,m
      integer ia,ib,ic,id
      integer ka,kb,kc
      integer leng,size
      integer atmnum
      integer it,nlist
      integer trimtext
      integer list(12)
      real*8 atmchg(*)
      logical aromat
      logical done,proceed
      logical terma,termd
      character*1 ta,tb,tc,td
      character*1 digit(0:9)
      character*2 bndtyp(*)
      character*3 element
      character*5 atmtyp(*)
      character*8 number
      character*8 atmnam(*)
      data digit  / '0','1','2','3','4','5','6','7','8','9' /
c
c
c     initialize atom_names, atom_types, charges and bond_types
c
      do i = 1, n
         atmnam(i) = '        '
         atmtyp(i) = '     '
         atmchg(i) = 0.0d0
         bndtyp(i) = '  '
      end do
c
c     determine the element types based upon atom names
c
      do i = 1, n
         it = n12(i)
         atomic(i) = 0
         call upcase (name(i))
         if (name(i)(1:1) .eq. 'H')  atomic(i) = 1
         if (name(i)(1:2).eq.'LI' .and. it.eq.0)  atomic(i) = 3
         if (name(i).eq.'F  ' .or. name(i).eq.'F- ')  atomic(i) = 9
         if (name(i)(1:2).eq.'NA' .and. it.eq.0)  atomic(i) = 11
         if (name(i)(1:2).eq.'MG' .and. it.eq.0)  atomic(i) = 12
         if (name(i)(1:2).eq.'AL' .and. it.eq.0)  atomic(i) = 13
         if (name(i)(1:2) .eq. 'SI')  atomic(i) = 14
         if (name(i).eq.'CL ' .or. name(i).eq.'CL-')  atomic(i) = 17
         if (name(i)(1:1).eq.'K' .and. it.eq.0)  atomic(i) = 19
         if (name(i)(1:2).eq.'CA' .and. it.eq.0)  atomic(i) = 20
         if (name(i)(1:2).eq.'CR' .and. it.eq.0)  atomic(i) = 24
         if (name(i)(1:2) .eq. 'MN')  atomic(i) = 25
         if (name(i)(1:2) .eq. 'FE')  atomic(i) = 26
         if (name(i)(1:2).eq.'CO' .and. ic.eq.0)  atomic(i) = 27
         if (name(i)(1:2) .eq. 'CU')  atomic(i) = 29
         if (name(i)(1:2) .eq. 'ZN')  atomic(i) = 30
         if (name(i)(1:2) .eq. 'SE')  atomic(i) = 34
         if (name(i).eq.'BR ' .or. name(i).eq.'BR-')  atomic(i) = 35
         if (name(i)(1:2) .eq. 'MO')  atomic(i) = 42
         if (name(i)(1:2) .eq. 'SN')  atomic(i) = 50
         if (name(i).eq.'I  ' .or. name(i).eq.'I- ')  atomic(i) = 53
         if (atomic(i) .eq. 0) then
            if (name(i)(1:1) .eq. 'C')  atomic(i) = 6
            if (name(i)(1:1) .eq. 'N')  atomic(i) = 7
            if (name(i)(1:1) .eq. 'O')  atomic(i) = 8
            if (name(i)(1:1) .eq. 'S')  atomic(i) = 16
         end if
      end do
c
c     construct the generic MOL2 atom_name for each atom
c
      do i = 1, n
         size = 1
         call numeral (i,number,size)
         if (atomic(i) .eq. 0) then
            atmnam(i) = 'X'//number(1:size)
         else
            element = elemnt(atomic(i))
            leng = trimtext (element)
            atmnam(i) = element(1:leng)//number(1:size)
         end if
      end do
c
c     assign the generic MOL2 atom_type for each atom
c
      do i = 1, n
         it = 0
         do k = 1, n12(i)
            if (atomic(i12(k,i)) .ne. 0)  it = it + 1
         end do
         atmnum = atomic(i)
         if (atmnum .eq. 0) then
            if (name(i) .eq. 'LP ')  atmtyp(i) = 'LP   '
            if (name(i) .eq. 'DU ')  atmtyp(i) = 'Du   '
         else if (atmnum .eq. 1) then
            atmtyp(i) = 'H    '
         else if (atmnum .eq. 3) then
            atmtyp(i) = 'Li   '
         else if (atmnum .eq. 6) then
            if (it .eq. 4)  atmtyp(i) = 'C.3  '
            if (it .eq. 3)  atmtyp(i) = 'C.2  '
            if (it .eq. 2)  atmtyp(i) = 'C.1  '
         else if (atmnum .eq. 7) then
            if (it .eq. 4)  atmtyp(i) = 'N.4  '
            if (it .eq. 3)  atmtyp(i) = 'N.3  '
            if (it .eq. 2)  atmtyp(i) = 'N.2  '
            if (it .eq. 1)  atmtyp(i) = 'N.1  '
         else if (atmnum .eq. 8) then
            if (it .ge. 2)  atmtyp(i) = 'O.3  '
            if (it .eq. 1)  atmtyp(i) = 'O.2  '
         else if (atmnum .eq. 9) then
            atmtyp(i) = 'F    '
         else if (atmnum .eq. 11) then
            atmtyp(i) = 'Na   '
         else if (atmnum .eq. 12) then
            atmtyp(i) = 'Mg   '
         else if (atmnum .eq. 13) then
            atmtyp(i) = 'Al   '
         else if (atmnum .eq. 14) then
            atmtyp(i) = 'Si   '
         else if (atmnum .eq. 15) then
            atmtyp(i) = 'P.3  '
         else if (atmnum .eq. 16) then
            if (it .ge. 2)  atmtyp(i) = 'S.3  '
            if (it .le. 1)  atmtyp(i) = 'S.2  '
         else if (atmnum .eq. 17) then
            atmtyp(i) = 'Cl   '
         else if (atmnum .eq. 19) then
            atmtyp(i) = 'K    '
         else if (atmnum .eq. 20) then
            atmtyp(i) = 'Ca   '
         else if (atmnum .eq. 24) then
            atmtyp(i) = 'Cr.oh'
         else if (atmnum .eq. 25) then
            atmtyp(i) = 'Mn   '
         else if (atmnum .eq. 26) then
            atmtyp(i) = 'Fe   '
         else if (atmnum .eq. 27) then
            atmtyp(i) = 'Co.oh'
         else if (atmnum .eq. 29) then
            atmtyp(i) = 'Cu   '
         else if (atmnum .eq. 30) then
            atmtyp(i) = 'Zn   '
         else if (atmnum .eq. 35) then
            atmtyp(i) = 'Br   '
         else if (atmnum .eq. 42) then
            atmtyp(i) = 'Mo   '
         else if (atmnum .eq. 50) then
            atmtyp(i) = 'Sn   '
         else if (atmnum .eq. 53) then
            atmtyp(i) = 'I    '
         end if
      end do
c
c     handle 5-membered rings for MOL2 atom_type assignment
c
      do i = 1, nring5
         aromat = .true.
         do j = 1, 5
            k = iring5(j,i)
            if (atomic(k).ne.6 .and. atomic(k).ne.7)  aromat = .false.
            if (atomic(k).eq.6 .and. n12(k).ne.3)  aromat = .false.
            if (atomic(k).eq.7 .and. n12(k).eq.4)  aromat = .false.
            if (atomic(k).eq.6 .and. n12(i).eq.3) then
               do m = 1, n12(k)
                  kc = i12(m,k)
                  if (atomic(kc).eq.8 .and. n12(kc).eq.1) then
                     aromat = .false.
                  end if
               end do
            end if
         end do
         if (aromat) then
            do j = 1, 5
               k = iring5(j,i)
c              atmtyp(k) = atmtyp(k)(1:1)//'.ar '
               if (atomic(k).eq.7 .and. n12(k).eq.3)
     &            atmtyp(k) = 'N.pl3'
            end do
         end if
      end do
c
c     handle 6-membered rings for MOL2 atom_type assignment
c
      do i = 1, nring6
         aromat = .true.
         do j = 1, 6
            k = iring6(j,i)
            if (atomic(k).ne.6 .and. atomic(k).ne.7)  aromat = .false.
            if (atomic(k).eq.6 .and. n12(k).ne.3)  aromat = .false.
            if (atomic(k).eq.7 .and. n12(k).eq.4)  aromat = .false.
            if (atomic(k).eq.6 .and. n12(i).eq.3) then
               do m = 1, n12(k)
                  kc = i12(m,k)
                  if (atomic(kc).eq.8 .and. n12(kc).eq.1) then
                     aromat = .false.
                  end if
               end do
            end if
         end do
         if (aromat) then
            do j = 1, 6
               k = iring6(j,i)
               atmtyp(k) = atmtyp(k)(1:1)//'.ar '
            end do
         end if
      end do
c
c     handle 7-membered rings for MOL2 atom_type assignment
c
      do i = 1, nring7
         aromat = .true.
         do j = 1, 7
            m = iring7(j,i)
            if (atomic(m).ne.6 .or. n12(m).ne.3)  aromat = .false.
         end do
         if (aromat) then
            do j = 1, 7
               list(j) = iring7(j,i)
            end do
            do k = 1, nring5
               do j = 1, 5
                  list(j+7) = iring5(j,k)
               end do
               nlist = 12
               call sort8 (nlist,list)
               if (nlist .eq. 10) then
                  aromat = .true.
                  do j = 1, 5
                     m = iring5(j,i)
                     if (atomic(m).ne.6 .or. n12(m).ne.3)
     &                  aromat = .false.
                  end do
                  if (aromat) then
                     do j = 1, 7
                        atmtyp(iring7(j,i)) = 'C.ar '
                     end do
                     do j = 1, 5
                        atmtyp(iring5(j,k)) = 'C.ar '
                     end do
                  end if
               end if
            end do
         end if
      end do
c
c     handle amide nitrogens for MOL2 atom_type assignment
c
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         if (atomic(ib).eq.6 .and. n12(ib).eq.3) then
            if (atomic(ia).eq.8 .and. n12(ia).eq.1 .and.
     &          atomic(ic).eq.7 .and. n12(ic).eq.3) then
               atmtyp(ic) = 'N.am '
            end if
            if (atomic(ic).eq.8 .and. n12(ic).eq.1 .and.
     &          atomic(ia).eq.7 .and. n12(ia).eq.3) then
               atmtyp(ia) = 'N.am '
            end if
         end if
      end do
c
c     handle guanidinium carbons for MOL2 atom_type assignment
c
      do i = 1, n
         if (atomic(i).eq.6 .and. n12(i).eq.3) then
            k = 0
            do m = 1, n12(i)
               kc = i12(m,i)
               if (atomic(kc).eq.7 .and. n12(kc).eq.3)  k = k + 1
            end do
            if (k .eq. 3)  atmtyp(i) = 'C.cat'
         end if
      end do
c
c     handle carboxylate oxygens for MOL2 atom_type assignment
c
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         if ((atomic(ia).eq.8.and.n12(ia).eq.1) .and.
     &       (atomic(ic).eq.8.and.n12(ic).eq.1)) then
            if (atomic(ib).eq.6.and.n12(ib).eq.3) then
               atmtyp(ia) = 'O.co2'
               atmtyp(ic) = 'O.co2'
            end if
         end if
      end do
c
c     handle phosphate oxygens for MOL2 atom_type assignment
c
      do i = 1, n
         if (atomic(i).eq.8 .and. n12(i).eq.1) then
            if (atomic(i12(1,i)) .eq. 15)  atmtyp(i) = 'O.co2'
         end if
      end do
c
c     handle sulfoxide sulfurs for MOL2 atom_type assignment
c
      do i = 1, n
         if (atomic(i).eq.16 .and. n12(i).eq.3) then
            k = 0
            do m = 1, n12(i)
               kc = i12(m,i)
               if (atomic(kc).eq.8 .and. n12(kc).eq.1)  k = k + 1
            end do
            if (k .eq. 1)  atmtyp(i) = 'S.o  '
         end if
      end do
c
c     handle sulfone sulfurs for MOL2 atom_type assignment
c
      do i = 1, n
         if (atomic(i).eq.16 .and. n12(i).eq.4) then
            k = 0
            do m = 1, n12(i)
               kc = i12(m,i)
               if (atomic(kc).eq.8 .and. n12(kc).eq.1)  k = k + 1
            end do
            if (k .ge. 2)  atmtyp(i) = 'S.o2 '
         end if
      end do
c
c     assign the generic MOL2 bond_type for each bond
c
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         bndtyp(i) = '1 '
         if (atmtyp(ia)(3:3).eq.'2' .and.
     &       atmtyp(ib)(3:3).eq.'2') then
            bndtyp(i) = '2 '
         end if
         if (atmtyp(ia)(3:3).eq.'2' .and.
     &       atmtyp(ib)(3:3).eq.'1') then
            bndtyp(i) = '2 '
         end if
         if (atmtyp(ia)(3:3).eq.'1' .and.
     &       atmtyp(ib)(3:3).eq.'2') then
            bndtyp(i) = '2 '
         end if
         if (atmtyp(ia)(3:3).eq.'1' .and.
     &       atmtyp(ib)(3:3).eq.'1') then
            bndtyp(i) = '3 '
         end if
      end do
c
c     handle aromaticity for MOL2 bond_type assignment
c
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         if (atmtyp(ia)(3:4).eq.'ar' .and.
     &       atmtyp(ib)(3:4).eq.'ar') then
            do k = 1, nring5
               m = 0
               do j = 1, 5
                  kc = iring5(j,k)
                  if (kc.eq.ia .or. kc.eq.ib)  m = m + 1
               end do
               if (m .eq. 2)  bndtyp(i) = 'ar'
            end do
            do k = 1, nring6
               m = 0
               do j = 1, 6
                  kc = iring6(j,k)
                  if (kc.eq.ia .or. kc.eq.ib)  m = m + 1
               end do
               if (m .eq. 2)  bndtyp(i) = 'ar'
            end do
            do k = 1, nring7
               m = 0
               do j = 1, 7
                  kc = iring7(j,k)
                  if (kc.eq.ia .or. kc.eq.ib)  m = m + 1
               end do
               if (m .eq. 2)  bndtyp(i) = 'ar'
            end do
         end if
      end do
c
c     handle conjugation for MOL2 bond_type assignment
c
      done = .false.
      do while (.not. done)
         done = .true.
         do i = 1, ntors
            ia = itors(1,i)
            ib = itors(2,i)
            ic = itors(3,i)
            id = itors(4,i)
            proceed = .false.
            do k = 1, n12(ib)
               j = bndlist(k,ib)
               ka = ibnd(1,j)
               kb = ibnd(2,j)
               if (ka.eq.ic .or. kb.eq.ic) then
                  if (bndtyp(j).eq.'2 ' .or.
     &                bndtyp(j).eq.'3 ') then
                     m = j
                     proceed = .true.
                  end if
               end if
            end do
            if (proceed) then
               ta = atmtyp(ia)(3:3)
               tb = atmtyp(ib)(3:3)
               tc = atmtyp(ic)(3:3)
               td = atmtyp(id)(3:3)
               if (atmtyp(ia) .eq. 'O.co2')  ta = '2'
               if (atmtyp(id) .eq. 'O.co2')  td = '2'
               if ((ta.eq.'2' .or. ta.eq.'1') .and.
     &             (tb.eq.'2' .or. tb.eq.'1') .and.
     &             (tc.eq.'2' .or. tc.eq.'1') .and.
     &             (td.eq.'2' .or. td.eq.'1')) then
                  terma = .true.
                  do k = 1, n12(ia)
                     j = bndlist(k,ia)
                     ka = ibnd(1,j)
                     kb = ibnd(2,j)
                     if (ka.ne.ib .and. kb.ne.ib) then
                        if (bndtyp(j).eq.'2 ' .or.
     &                      bndtyp(j).eq.'3 ') then
                           terma = .false.
                        end if
                     end if
                  end do
                  termd = .true.
                  do k = 1, n12(id)
                     j = bndlist(k,id)
                     ka = ibnd(1,j)
                     kb = ibnd(2,j)
                     if (ka.ne.ic .and. kb.ne.ic) then
                        if (bndtyp(j).eq.'2 ' .or.
     &                      bndtyp(j).eq.'3 ') then
                           termd = .false.
                        end if
                     end if
                  end do
                  if (terma .or. termd) then
                     bndtyp(m) = '1 '
                     done = .false.
                  end if
               end if
            end if
         end do
      end do
c
c     assign the generic MOL2 charge for each atom
c
      do i = 1, n
         it = 0
         do k = 1, n12(i)
            if (atomic(i12(k,i)) .ne. 0)  it = it + 1
         end do
         atmnum = atomic(i)
         if (atmnum.eq.3 .and. it.eq.0)  atmchg(i) = 1.0d0
         if (atmnum.eq.9 .and. it.eq.0)  atmchg(i) = -1.0d0
         if (atmnum.eq.11 .and. it.eq.0)  atmchg(i) = 1.0d0
         if (atmnum.eq.12 .and. it.eq.0)  atmchg(i) = 2.0d0
         if (atmnum.eq.13 .and. it.eq.0)  atmchg(i) = 3.0d0
         if (atmnum.eq.17 .and. it.eq.0)  atmchg(i) = -1.0d0
         if (atmnum.eq.19 .and. it.eq.0)  atmchg(i) = 1.0d0
         if (atmnum.eq.20 .and. it.eq.0)  atmchg(i) = 2.0d0
         if (atmnum.eq.24 .and. it.eq.0)  atmchg(i) = 3.0d0
         if (atmnum.eq.25 .and. it.eq.0)  atmchg(i) = 2.0d0
         if (atmnum.eq.26 .and. it.eq.0)  atmchg(i) = 3.0d0
         if (atmnum.eq.27 .and. it.eq.0)  atmchg(i) = 2.0d0
         if (atmnum.eq.29 .and. it.eq.0)  atmchg(i) = 2.0d0
         if (atmnum.eq.30 .and. it.eq.0)  atmchg(i) = 2.0d0
         if (atmnum.eq.35 .and. it.eq.0)  atmchg(i) = -1.0d0
         if (atmnum.eq.42 .and. it.eq.0)  atmchg(i) = 4.0d0
         if (atmnum.eq.53 .and. it.eq.0)  atmchg(i) = -1.0d0
c
c     handle ammonium nitrogens for MOL2 charge assignment
c
         if (atmtyp(i) .eq. 'N.4  ') then
            atmchg(i) = 1.0d0
         end if
c
c     handle pyridinium nitrogens for MOL2 charge assignment
c
         if (atmtyp(i).eq.'N.ar ' .and. it.eq.3) then
            atmchg(i) = 1.0d0
         end if
c
c     handle carboxylate oxygens for MOL2 charge assignment
c
         if (atmtyp(i) .eq. 'O.co2') then
            kc = i12(1,i)
            if (atomic(kc) .eq. 6) then
               atmchg(i) = -1.0d0
               atmchg(kc) = 1.0d0
            end if
         end if
c
c     handle phosphate groups for MOL2 charge assignment
c
         if (atmtyp(i) .eq. 'P.3  ') then
            atmchg(i) = 1.0d0
            do m = 1, n12(i)
               kc = i12(m,i)
               if (atmtyp(kc) .eq. 'O.co2') then
                  atmchg(kc) = -1.0d0
               end if
            end do
         end if
c
c     handle sulfonate groups for MOL2 charge assignment
c
         if (atmtyp(i) .eq. 'S.o2 ') then
            k = 0
            do m = 1, n12(i)
               kc = i12(m,i)
               if (atmtyp(kc) .eq. 'O.2  ')  k = k + 1
            end do
            if (k .ge. 3) then
               if (k .eq. 3)  atmchg(i) = 0.5d0
               do m = 1, n12(i)
                  kc = i12(m,i)
                  if (atmtyp(kc) .eq. 'O.2  ') then
                     atmchg(kc) = -0.5d0
                  end if
               end do
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine prtpdb  --  output of Protein Data Bank file  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "prtpdb" writes out a set of PDB coordinates in legacy PDB
c     format to an external file
c
c
      subroutine prtpdb (ipdb)
      use bound
      use boxes
      use files
      use pdb
      use sequen
      use titles
      implicit none
      integer i,k
      integer ipdb
      integer start,stop
      integer resmax,resnumb
      integer, allocatable :: resid(:)
      real*8 crdmin,crdmax
      logical opened
      logical header
      logical rename
      logical reformat
      character*1 chnname
      character*1, allocatable :: chain(:)
      character*2 atmc,resc
      character*3 resname
      character*6 crdc
      character*51 fstr
      character*240 pdbfile
c
c
c     set flags for residue naming and extended formatting
c
      header = .true.
      if (imodel .gt. 1)  header = .false.
      rename = .false.
      reformat = .true.
c
c     open the output unit if not already done
c
      inquire (unit=ipdb,opened=opened)
      if (.not. opened) then
         pdbfile = filename(1:leng)//'.pdb'
         call version (pdbfile,'new')
         open (unit=ipdb,file=pdbfile,status='new')
      end if
c
c     write out the header lines and the title
c
      if (header) then
         if (ltitle .eq. 0) then
            fstr = '(''HEADER'',/,''TITLE '',/,''COMPND'','
     &                //'/,''SOURCE'')'
            write (ipdb,fstr(1:45))
         else
            fstr = '(''HEADER'',/,''TITLE '',4x,a,'
     &                //'/,''COMPND'',/,''SOURCE'')'
            write (ipdb,fstr(1:50))  title(1:ltitle)
         end if
      end if
c
c     include any lattice parameters in the header
c
      if (use_bounds) then
         fstr = '(''CRYST1'',3f9.3,3f7.2)'
         write (ipdb,fstr(1:22)) xbox,ybox,zbox,alpha,beta,gamma
      end if
c
c     write record to initiate the current coordinate model
c
      if (imodel .ne. 0) then
         fstr = '(''MODEL '',i8)'
         write (ipdb,fstr(1:13))  imodel
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (resid(maxres))
      allocate (chain(maxres))
c
c     find the chain name and chain position for each residue
c
      do i = 1, nchain
         start = ichain(1,i)
         stop = ichain(2,i)
         do k = start, stop
            resid(k) = k - start + 1
            chain(k) = chnnam(i)
         end do
      end do
c
c     change Tinker residue names to match PDB standards
c
      if (rename) then
         do i = 1, npdb
            if (pdbres(i) .eq. 'CYX')  pdbres(i) = 'CYS'
            if (pdbres(i) .eq. 'CYD')  pdbres(i) = 'CYS'
            if (pdbres(i) .eq. 'TYD')  pdbres(i) = 'TYR'
            if (pdbres(i) .eq. 'HID')  pdbres(i) = 'HIS'
            if (pdbres(i) .eq. 'HIE')  pdbres(i) = 'HIS'
            if (pdbres(i) .eq. 'HIP')  pdbres(i) = 'HIS'
            if (pdbres(i) .eq. 'ASH')  pdbres(i) = 'ASP'
            if (pdbres(i) .eq. 'GLH')  pdbres(i) = 'GLU'
            if (pdbres(i) .eq. 'LYD')  pdbres(i) = 'LYS'
         end do
      end if
c
c     set formatting to match the PDB fixed format standard
c
      atmc = 'i5'
      resc = 'i4'
      crdc = '3f8.3 '
c
c     check for large values requiring extended formatting
c
      if (reformat) then
         resmax = 0
         crdmin = 0.0d0
         crdmax = 0.0d0
         do i = 1, npdb
            if (pdbrec(i) .eq. 'ATOM  ') then
               resmax = max(resmax,resid(resnum(i)))
            else
               resmax = max(resmax,resnum(i))
            end if
            crdmin = min(crdmin,xpdb(i),ypdb(i),zpdb(i))
            crdmax = max(crdmax,xpdb(i),ypdb(i),zpdb(i))
         end do
         if (npdb .ge. 100000)  atmc = 'i6'
         if (npdb .ge. 1000000)  atmc = 'i7'
         if (resmax .ge. 10000)  resc = 'i5'
         if (resmax .ge. 100000)  resc = 'i6'
         if (resmax .ge. 1000000)  resc = 'i7'
         if (crdmin .le. -100.0d0)  crdc = '3f9.3 '
         if (crdmax .ge. 1000.0d0)  crdc = '3f9.3 '
         if (crdmin .le. -1000.0d0)  crdc = '3f10.3'
         if (crdmax .ge. 10000.0d0)  crdc = '3f10.3'
      end if
c
c     write information and coordinates for each atom
c
      fstr = '(a6,'//atmc//',1x,a4,1x,a3,1x,a1,'//resc//
     &          ',4x,'//crdc//')'
      do i = 1, npdb
         resname = pdbres(i)
         if (resname(2:3) .eq. '  ')  resname = '  '//resname(1:1)
         if (resname(3:3) .eq. ' ')  resname = ' '//resname(1:2)
         if (pdbrec(i) .eq. 'ATOM  ') then
            resnumb = resid(resnum(i))
            chnname = chain(resnum(i))
         else
            resnumb = resnum(i)
            chnname = ' '
         end if
         write (ipdb,fstr)  pdbrec(i),i,pdbatm(i),resname,chnname,
     &                      resnumb,xpdb(i),ypdb(i),zpdb(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (resid)
      deallocate (chain)
c
c     check for large values requiring extended formatting
c
      if (reformat) then
         if (npdb .ge. 10000)  atmc = 'i6'
         if (npdb .ge. 100000)  atmc = 'i7'
         if (npdb .ge. 1000000)  atmc = 'i8'
      end if
c
c     write any connectivity records for the atoms
c
      fstr = '(''CONECT'',9'//atmc//')'
      do i = 1, npdb
         if (npdb12(i) .ne. 0) then
            write (ipdb,fstr(1:14))  i,(ipdb12(k,i),k=1,npdb12(i))
         end if
      end do
c
c     write record to close the current coordinate model
c
      if (imodel .ne. 0) then
         fstr = '(''ENDMDL'')'
         write (ipdb,fstr(1:10))
      end if
c
c     close the output unit if opened by this routine
c
c     if (.not. opened)  close (unit=ipdb)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine prtprm  --  output of force field parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "prtprm" writes out a formatted listing of the default
c     set of potential energy parameters for a force field
c
c
      subroutine prtprm (itxt)
      use angpot
      use bndpot
      use chgpot
      use fields
      use kanang
      use kangs
      use kantor
      use katoms
      use kbonds
      use kcflux
      use kchrge
      use kcpen
      use kctrn
      use kdipol
      use kdsp
      use kexpl
      use khbond
      use kiprop
      use kitors
      use kmulti
      use kopbnd
      use kopdst
      use korbs
      use kpitor
      use kpolpr
      use kpolr
      use krepl
      use ksolut
      use kstbnd
      use ksttor
      use ktorsn
      use ktrtor
      use kurybr
      use kvdws
      use kvdwpr
      use mplpot
      use polpot
      use sizes
      use urypot
      use vdwpot
      implicit none
      integer i,j,k,itxt
      integer number,npg
      integer k1,k2,k3
      integer k4,k5
      integer fold(6)
      real*8 ampli(6)
      real*8 phase(6)
      logical exist
      character*1 formfeed
      character*3 tname
      character*3 blank3
      character*8 blank8
      character*12 blank12
      character*16 blank16
      character*20 blank20
c
c
c     define blank character strings of various lengths
c
      blank3 = '   '
      blank8 = '        '
      blank12 = '            '
      blank16 = '                '
      blank20 = '                    '
c
c     set the string value of the formfeed character (Ctrl-L)
c
      formfeed = char(12)
c
c     force field atom type definitions
c
      exist = .false.
      do i = 1, maxtyp
         if (symbol(i) .ne. blank3)  exist = .true.
      end do
      if (exist) then
         write (itxt,10)  forcefield
   10    format (//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,20)
   20    format (//,15x,'Force Field Atom Definitions',
     &           //,54x,'Atomic',4x,'Atomic',
     &           /,5x,'Type',3x,'Class',3x,'Symbol',3x,'Description',
     &              14x,'Number',4x,'Weight',3x,'Valence',/)
         do i = 1, maxtyp
            if (symbol(i) .ne. blank3) then
               write (itxt,30)  i,atmcls(i),symbol(i),describe(i),
     &                          atmnum(i),weight(i),ligand(i)
   30          format (3x,i5,3x,i5,5x,a3,5x,a24,i5,f12.3,i7)
            end if
         end do
      end if
c
c     bond stretching parameters
c
      if (kb(1) .ne. blank8) then
         write (itxt,40)  formfeed,forcefield
   40    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,50)
   50    format (//,15x,'Bond Stretching Parameters',
     &           ///,22x,'Classes',15x,'KS',7x,'Length',/)
         do i = 1, maxnb
            if (kb(i) .eq. blank8)  goto 70
            k1 = number(kb(i)(1:4))
            k2 = number(kb(i)(5:8))
            write (itxt,60)  i,k1,k2,bcon(i),blen(i)
   60       format (8x,i7,5x,i4,'-',i4,6x,f12.3,f12.4)
         end do
   70    continue
      end if
c
c     bond stretching parameters for 5-membered rings
c
      if (kb5(1) .ne. blank8) then
         write (itxt,80)
   80    format (//,15x,'5-Membered Ring Stretch Parameters',
     &           ///,22x,'Classes',15x,'KS',7x,'Length',/)
         do i = 1, maxnb5
            if (kb5(i) .eq. blank8)  goto 100
            k1 = number(kb5(i)(1:4))
            k2 = number(kb5(i)(5:8))
            write (itxt,90)  i,k1,k2,bcon5(i),blen5(i)
   90       format (8x,i7,5x,i4,'-',i4,6x,f12.3,f12.4)
         end do
  100    continue
      end if
c
c     bond stretching parameters for 4-membered rings
c
      if (kb4(1) .ne. blank8) then
         write (itxt,110)
  110    format (//,15x,'4-Membered Ring Stretch Parameters',
     &           ///,22x,'Classes',15x,'KS',7x,'Length',/)
         do i = 1, maxnb4
            if (kb4(i) .eq. blank8)  goto 130
            k1 = number(kb4(i)(1:4))
            k2 = number(kb4(i)(5:8))
            write (itxt,120)  i,k1,k2,bcon4(i),blen4(i)
  120       format (8x,i7,5x,i4,'-',i4,6x,f12.3,f12.4)
         end do
  130    continue
      end if
c
c     bond stretching parameters for 3-membered rings
c
      if (kb3(1) .ne. blank8) then
         write (itxt,140)
  140    format (//,15x,'3-Membered Ring Stretch Parameters',
     &           ///,22x,'Classes',15x,'KS',7x,'Length',/)
         do i = 1, maxnb3
            if (kb3(i) .eq. blank8)  goto 160
            k1 = number(kb3(i)(1:4))
            k2 = number(kb3(i)(5:8))
            write (itxt,150)  i,k1,k2,bcon3(i),blen3(i)
  150       format (8x,i7,5x,i4,'-',i4,6x,f12.3,f12.4)
         end do
  160    continue
      end if
c
c     cubic and quartic bond stretching parameters
c
      if (cbnd.ne.0.0d0 .or. qbnd.ne.0.0d0) then
         write (itxt,170)  cbnd,qbnd
  170    format (//,15x,'Higher Order Stretching Constants',
     &           ///,20x,'Cubic',f17.3,/,20x,'Quartic',f15.3)
      end if
c
c     electronegativity bond length correction parameters
c
      if (kel(1) .ne. blank12) then
         write (itxt,180)
  180    format (//,15x,'Electronegativity Bond Length Parameters',
     &           ///,25x,'Classes',21x,'dLength',/)
         do i = 1, maxnel
            if (kel(i) .eq. blank12)  goto 200
            k1 = number(kel(i)(1:4))
            k2 = number(kel(i)(5:8))
            k3 = number(kel(i)(9:12))
            write (itxt,190)  i,k1,k2,k3,dlen(i)
  190       format (8x,i7,5x,i4,'-',i4,'-',i4,14x,f12.4)
         end do
  200    continue
      end if
c
c     bond angle bending parameters
c
      if (ka(1) .ne. blank12) then
         write (itxt,210)  formfeed,forcefield
  210    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,220)
  220    format (//,15x,'Angle Bending Parameters',
     &           ///,18x,'Classes',11x,'KB',6x,'Value 1',
     &              5x,'Value 2',5x,'Value 3',
     &           /,44x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/)
         do i = 1, maxna
            if (ka(i) .eq. blank12)  goto 250
            k1 = number(ka(i)(1:4))
            k2 = number(ka(i)(5:8))
            k3 = number(ka(i)(9:12))
            if (ang(2,i).eq.0.0d0 .and. ang(3,i).eq.0.0d0) then
               write (itxt,230)  i,k1,k2,k3,acon(i),ang(1,i)
  230          format (3x,i5,5x,i4,'-',i4,'-',i4,2f12.3)
            else
               write (itxt,240)  i,k1,k2,k3,acon(i),(ang(j,i),j=1,3)
  240          format (3x,i5,5x,i4,'-',i4,'-',i4,4f12.3)
            end if
         end do
  250    continue
      end if
c
c     angle bending parameters for 5-membered rings
c
      if (ka5(1) .ne. blank12) then
         write (itxt,260)
  260    format (//,17x,'5-Membered Ring Bend Parameters',
     &           ///,18x,'Classes',11x,'KB',6x,'Value 1',
     &              5x,'Value 2',5x,'Value 3',
     &           /,44x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/)
         do i = 1, maxna5
            if (ka5(i) .eq. blank12)  goto 290
            k1 = number(ka5(i)(1:4))
            k2 = number(ka5(i)(5:8))
            k3 = number(ka5(i)(9:12))
            if (ang5(2,i).eq.0.0d0 .and. ang5(3,i).eq.0.0d0) then
               write (itxt,270)  i,k1,k2,k3,acon5(i),ang5(1,i)
  270          format (3x,i5,5x,i4,'-',i4,'-',i4,2f12.3)
            else
               write (itxt,280)  i,k1,k2,k3,acon5(i),(ang5(j,i),j=1,3)
  280          format (3x,i5,5x,i4,'-',i4,'-',i4,4f12.3)
            end if
         end do
  290    continue
      end if
c
c     angle bending parameters for 4-membered rings
c
      if (ka4(1) .ne. blank12) then
         write (itxt,300)
  300    format (//,15x,'4-Membered Ring Bend Parameters',
     &           ///,18x,'Classes',11x,'KB',6x,'Value 1',
     &              5x,'Value 2',5x,'Value 3',
     &           /,44x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/)
         do i = 1, maxna4
            if (ka4(i) .eq. blank12)  goto 330
            k1 = number(ka4(i)(1:4))
            k2 = number(ka4(i)(5:8))
            k3 = number(ka4(i)(9:12))
            if (ang4(2,i).eq.0.0d0 .and. ang4(3,i).eq.0.0d0) then
               write (itxt,310)  i,k1,k2,k3,acon4(i),ang4(1,i)
  310          format (3x,i5,5x,i4,'-',i4,'-',i4,2f12.3)
            else
               write (itxt,320)  i,k1,k2,k3,acon4(i),(ang4(j,i),j=1,3)
  320          format (3x,i5,5x,i4,'-',i4,'-',i4,4f12.3)
            end if
         end do
  330    continue
      end if
c
c     angle bending parameters for 3-membered rings
c
      if (ka3(1) .ne. blank12) then
         write (itxt,340)
  340    format (//,15x,'3-Membered Ring Bend Parameters',
     &           ///,18x,'Classes',11x,'KB',6x,'Value 1',
     &              5x,'Value 2',5x,'Value 3',
     &           /,44x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/)
         do  i = 1, maxna3
            if (ka3(i) .eq. blank12)  goto 370
            k1 = number(ka3(i)(1:4))
            k2 = number(ka3(i)(5:8))
            k3 = number(ka3(i)(9:12))
            if (ang3(2,i).eq.0.0d0 .and. ang3(3,i).eq.0.0d0) then
               write (itxt,350)  i,k1,k2,k3,acon3(i),ang3(1,i)
  350          format (3x,i5,5x,i4,'-',i4,'-',i4,2f12.3)
            else
               write (itxt,360)  i,k1,k2,k3,acon3(i),(ang3(j,i),j=1,3)
  360          format (3x,i5,5x,i4,'-',i4,'-',i4,4f12.3)
            end if
         end do
  370    continue
      end if
c
c     in-plane projected angle bending parameters
c
      if (kap(1) .ne. blank12) then
         write (itxt,380)
  380    format (//,15x,'In-Plane Angle Bending Parameters',
     &           ///,18x,'Classes',11x,'KB',6x,'Value 1',5x,'Value 2',
     &           /,45x,'(X-R)',7x,'(X-H)'/)
         do  i = 1, maxnap
            if (kap(i) .eq. blank12)  goto 400
            k1 = number(kap(i)(1:4))
            k2 = number(kap(i)(5:8))
            k3 = number(kap(i)(9:12))
            write (itxt,390)  i,k1,k2,k3,aconp(i),(angp(j,i),j=1,2)
  390       format (3x,i5,5x,i4,'-',i4,'-',i4,3f12.3)
         end do
  400    continue
      end if
c
c     Fourier bond angle bending parameters
c
      if (kaf(1) .ne. blank12) then
         write (itxt,410)
  410    format (//,15x,'Fourier Angle Bending Parameters',
     &           ///,18x,'Classes',11x,'KB',8x,'Shift',6x,'Period',/)
         do  i = 1, maxnaf
            if (kaf(i) .eq. blank12)  goto 430
            k1 = number(kaf(i)(1:4))
            k2 = number(kaf(i)(5:8))
            k3 = number(kaf(i)(9:12))
            write (itxt,420)  i,k1,k2,k3,aconf(i),(angf(j,i),j=1,2)
  420       format (3x,i5,5x,i4,'-',i4,'-',i4,3f12.3)
         end do
  430    continue
      end if
c
c     cubic through sextic bond angle bending parameters
c
      if (cang.ne.0.0d0 .or. qang.ne.0.0d0 .or.
     &    pang.ne.0.0d0 .or. sang.ne.0.0d0) then
         write (itxt,440)  cang,qang,pang,sang
  440    format (//,15x,'Higher Order Bending Constants',
     &           ///,20x,'Cubic',d17.3,/,20x,'Quartic',d15.3,
     &           /,20x,'Pentic',d16.3,/,20x,'Sextic',d16.3)
      end if
c
c     stretch-bend parameters
c
      if (ksb(1) .ne. blank12) then
         write (itxt,450)  formfeed,forcefield
  450    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,460)
  460    format (//,15x,'Stretch-Bend Parameters',
     &           ///,18x,'Classes',18x,'KSB1',8x,'KSB2',/)
         do i = 1, maxnsb
            if (ksb(i) .eq. blank12)  goto 480
            k1 = number(ksb(i)(1:4))
            k2 = number(ksb(i)(5:8))
            k3 = number(ksb(i)(9:12))
            write (itxt,470)  i,k1,k2,k3,stbn(1,i),stbn(2,i)
  470       format (3x,i5,5x,i4,'-',i4,'-',i4,8x,2f12.3)
         end do
  480    continue
      end if
c
c     Urey-Bradley parameters
c
      if (ku(1) .ne. blank12) then
         write (itxt,490)  formfeed,forcefield
  490    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,500)
  500    format (//,15x,'Urey-Bradley Parameters',
     &           ///,18x,'Classes',19x,'KB',6x,'Distance',/)
         do i = 1, maxnu
            if (ku(i) .eq. blank12)  goto 520
            k1 = number(ku(i)(1:4))
            k2 = number(ku(i)(5:8))
            k3 = number(ku(i)(9:12))
            write (itxt,510)  i,k1,k2,k3,ucon(i),dst13(i)
  510       format (3x,i5,5x,i4,'-',i4,'-',i4,8x,f12.3,f12.4)
         end do
  520    continue
      end if
c
c     cubic and quartic Urey-Bradley parameters
c
      if (cury.ne.0.0d0 .or. qury.ne.0.0d0) then
         write (itxt,530)  cury,qury
  530    format (//,15x,'Higher Order Urey-Bradley Constants',
     &           ///,20x,'Cubic',f17.3,/,20x,'Quartic',f15.3)
      end if
c
c     angle-angle parameters
c
      exist = .false.
      do i = 1, maxclass
         do k = 1, 3
            if (anan(k,i) .ne. 0.0d0)  exist = .true.
         end do
      end do
      if (exist) then
         write (itxt,540)  formfeed,forcefield
  540    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,550)
  550    format (//,15x,'Angle-Angle Parameters',
     &           ///,20x,'Class',9x,'KAA 1',7x,'KAA 2',7x,'KAA 3',
     &           /,33x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/)
         k = 0
         do i = 1, maxclass
            if (anan(1,i).ne.0.0d0 .or. anan(2,i).ne.0.0d0
     &               .or. anan(3,i).ne.0.0d0) then
               k = k + 1
               write (itxt,560)  k,i,(anan(j,i),j=1,3)
  560          format (6x,i7,4x,i7,3x,3f12.3)
            end if
         end do
      end if
c
c     out-of-plane bending parameters
c
      if (kopb(1) .ne. blank16) then
         write (itxt,570)  formfeed,forcefield
  570    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,580)
  580    format (//,15x,'Out-of-Plane Bend Parameters',
     &           ///,26x,'Classes',11x,'KOPB',/)
         do i = 1, maxnopb
            if (kopb(i) .eq. blank16)  goto 600
            k1 = number(kopb(i)(1:4))
            k2 = number(kopb(i)(5:8))
            k3 = number(kopb(i)(9:12))
            k4 = number(kopb(i)(13:16))
            write (itxt,590)  i,k1,k2,k3,k4,opbn(i)
  590       format (6x,i7,5x,i4,'-',i4,'-',i4,'-',i4,f12.3)
         end do
  600    continue
      end if
c
c     out-of-plane distance parameters
c
      if (kopd(1) .ne. blank16) then
         write (itxt,610)  formfeed,forcefield
  610    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,620)
  620    format (//,15x,'Out-of-Plane Distance Parameters',
     &           ///,26x,'Classes',11x,'KOPD',/)
         do i = 1, maxnopd
            if (kopd(i) .eq. blank16)  goto 640
            k1 = number(kopd(i)(1:4))
            k2 = number(kopd(i)(5:8))
            k3 = number(kopd(i)(9:12))
            k4 = number(kopd(i)(13:16))
            write (itxt,630)  i,k1,k2,k3,k4,opds(i)
  630       format (6x,i7,5x,i4,'-',i4,'-',i4,'-',i4,f12.3)
         end do
  640    continue
      end if
c
c     improper dihedral parameters
c
      if (kdi(1) .ne. blank16) then
         write (itxt,650)  formfeed,forcefield
  650    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,660)
  660    format (//,15x,'Improper Dihedral Parameters',
     &           ///,20x,'Classes',12x,'KID',7x,'Target',/)
         do i = 1, maxndi
            if (kdi(i) .eq. blank16)  goto 680
            k1 = number(kdi(i)(1:4))
            k2 = number(kdi(i)(5:8))
            k3 = number(kdi(i)(9:12))
            k4 = number(kdi(i)(13:16))
            write (itxt,670)  i,k1,k2,k3,k4,dcon(i),tdi(i)
  670       format (2x,i5,5x,i4,'-',i4,'-',i4,'-',i4,f12.3,f12.4)
         end do
  680    continue
      end if
c
c     improper torsional parameters
c
      if (kti(1) .ne. blank16) then
         write (itxt,690)  formfeed,forcefield
  690    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,700)
  700    format (//,15x,'Improper Torsion Parameters',
     &           ///,17x,'Classes',15x,'KTI Values',/)
         do i = 1, maxnti
            if (kti(i) .eq. blank16)  goto 720
            k1 = number(kti(i)(1:4))
            k2 = number(kti(i)(5:8))
            k3 = number(kti(i)(9:12))
            k4 = number(kti(i)(13:16))
            j = 0
            if (ti1(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 1
               ampli(j) = ti1(1,i)
               phase(j) = ti1(2,i)
            end if
            if (ti2(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 2
               ampli(j) = ti2(1,i)
               phase(j) = ti2(2,i)
            end if
            if (ti3(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 3
               ampli(j) = ti3(1,i)
               phase(j) = ti3(2,i)
            end if
            write (itxt,710)  i,k1,k2,k3,k4,(ampli(k),
     &                        phase(k),fold(k),k=1,j)
  710       format (2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,2x,3(f8.3,f6.1,i2))
         end do
  720    continue
      end if
c
c     torsional angle parameters
c
      if (kt(1) .ne. blank16) then
         write (itxt,730)  formfeed,forcefield
  730    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,740)
  740    format (//,15x,'Torsional Parameters',
     &           ///,17x,'Classes',15x,'KT Values',/)
         do i = 1, maxnt
            if (kt(i) .eq. blank16)  goto 760
            k1 = number(kt(i)(1:4))
            k2 = number(kt(i)(5:8))
            k3 = number(kt(i)(9:12))
            k4 = number(kt(i)(13:16))
            j = 0
            if (t1(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 1
               ampli(j) = t1(1,i)
               phase(j) = t1(2,i)
            end if
            if (t2(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 2
               ampli(j) = t2(1,i)
               phase(j) = t2(2,i)
            end if
            if (t3(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 3
               ampli(j) = t3(1,i)
               phase(j) = t3(2,i)
            end if
            if (t4(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 4
               ampli(j) = t4(1,i)
               phase(j) = t4(2,i)
            end if
            if (t5(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 5
               ampli(j) = t5(1,i)
               phase(j) = t5(2,i)
            end if
            if (t6(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 6
               ampli(j) = t6(1,i)
               phase(j) = t6(2,i)
            end if
            write (itxt,750)  i,k1,k2,k3,k4,(ampli(k),
     &                        phase(k),fold(k),k=1,j)
  750       format (2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,2x,6(f8.3,f6.1,i2))
         end do
  760    continue
      end if
c
c     torsional angle parameters for 5-membered rings
c
      if (kt5(1) .ne. blank16) then
         write (itxt,770)
  770    format (//,15x,'5-Membered Ring Torsion Parameters',
     &           ///,17x,'Classes',15x,'KT Values',/)
         do i = 1, maxnt5
            if (kt5(i) .eq. blank16)  goto 790
            k1 = number(kt5(i)(1:4))
            k2 = number(kt5(i)(5:8))
            k3 = number(kt5(i)(9:12))
            k4 = number(kt5(i)(13:16))
            j = 0
            if (t15(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 1
               ampli(j) = t15(1,i)
               phase(j) = t15(2,i)
            end if
            if (t25(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 2
               ampli(j) = t25(1,i)
               phase(j) = t25(2,i)
            end if
            if (t35(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 3
               ampli(j) = t35(1,i)
               phase(j) = t35(2,i)
            end if
            if (t45(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 4
               ampli(j) = t45(1,i)
               phase(j) = t45(2,i)
            end if
            if (t55(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 5
               ampli(j) = t55(1,i)
               phase(j) = t55(2,i)
            end if
            if (t65(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 6
               ampli(j) = t65(1,i)
               phase(j) = t65(2,i)
            end if
            write (itxt,780)  i,k1,k2,k3,k4,(ampli(k),
     &                        phase(k),fold(k),k=1,j)
  780       format (2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,2x,6(f8.3,f6.1,i2))
         end do
  790    continue
      end if
c
c     torsional angle parameters for 4-membered rings
c
      if (kt4(1) .ne. blank16) then
         write (itxt,800)
  800    format (//,15x,'4-Membered Ring Torsion Parameters',
     &           ///,17x,'Classes',15x,'KT Values',/)
         do i = 1, maxnt4
            if (kt4(i) .eq. blank16)  goto 820
            k1 = number(kt4(i)(1:4))
            k2 = number(kt4(i)(5:8))
            k3 = number(kt4(i)(9:12))
            k4 = number(kt4(i)(13:16))
            j = 0
            if (t14(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 1
               ampli(j) = t14(1,i)
               phase(j) = t14(2,i)
            end if
            if (t24(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 2
               ampli(j) = t24(1,i)
               phase(j) = t24(2,i)
            end if
            if (t34(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 3
               ampli(j) = t34(1,i)
               phase(j) = t34(2,i)
            end if
            if (t44(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 4
               ampli(j) = t44(1,i)
               phase(j) = t44(2,i)
            end if
            if (t54(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 5
               ampli(j) = t54(1,i)
               phase(j) = t54(2,i)
            end if
            if (t64(1,i) .ne. 0.0d0) then
               j = j + 1
               fold(j) = 6
               ampli(j) = t64(1,i)
               phase(j) = t64(2,i)
            end if
            write (itxt,810)  i,k1,k2,k3,k4,(ampli(k),
     &                        phase(k),fold(k),k=1,j)
  810       format (2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,2x,6(f8.3,f6.1,i2))
         end do
  820    continue
      end if
c
c     pi-system torsion parameters
c
      if (kpt(1) .ne. blank8) then
         write (itxt,830)  formfeed,forcefield
  830    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,840)
  840    format (//,15x,'Pi-Orbital Torsion Parameters',
     &           ///,18x,'Classes',15x,'KPT',/)
         do i = 1, maxnpt
            if (kpt(i) .eq. blank8)  goto 860
            k1 = number(kpt(i)(1:4))
            k2 = number(kpt(i)(5:8))
            write (itxt,850)  i,k1,k2,ptcon(i)
  850       format (4x,i7,5x,i4,'-',i4,6x,f12.3)
         end do
  860    continue
      end if
c
c     stretch-torsion parameters
c
      if (kbt(1) .ne. blank16) then
         write (itxt,870)  formfeed,forcefield
  870    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,880)
  880    format (//,15x,'Stretch-Torsion Parameters',
     &           ///,17x,'Classes',12x,'Bond',8x,'KST1',
     &              8x,'KST2',8x,'KST3',/)
         do i = 1, maxnbt
            if (kbt(i) .eq. blank16)  goto 900
            k1 = number(kbt(i)(1:4))
            k2 = number(kbt(i)(5:8))
            k3 = number(kbt(i)(9:12))
            k4 = number(kbt(i)(13:16))
            write (itxt,890)  i,k1,k2,k3,k4,(btcon(j,i),j=1,9)
  890       format (2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,9x,'1st',3f12.3,
     &              /,37x,'2nd',3f12.3,/,37x,'3rd',3f12.3)
         end do
  900    continue
      end if
c
c     angle-torsion parameters
c
      if (kat(1) .ne. blank16) then
         write (itxt,910)  formfeed,forcefield
  910    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,920)
  920    format (//,15x,'Angle-Torsion Parameters',
     &           ///,17x,'Classes',12x,'Angle',7x,'KAT1',
     &              8x,'KAT2',8x,'KAT3',/)
         do i = 1, maxnat
            if (kat(i) .eq. blank16)  goto 940
            k1 = number(kat(i)(1:4))
            k2 = number(kat(i)(5:8))
            k3 = number(kat(i)(9:12))
            k4 = number(kat(i)(13:16))
            write (itxt,930)  i,k1,k2,k3,k4,(atcon(j,i),j=1,6)
  930       format (2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,9x,'1st',3f12.3
     &              /,37x,'2nd',3f12.3)
         end do
  940    continue
      end if
c
c     torsion-torsion parameters
c
      if (ktt(1) .ne. blank20) then
         write (itxt,950)  formfeed,forcefield
  950    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,960)
  960    format (//,15x,'Torsion-Torsion Parameters',
     &           ///,19x,'Classes',16x,'NX',7x,'NY',6x,'Tier')
         do i = 1, maxntt
            if (ktt(i) .eq. blank20)  goto 990
            k1 = number(ktt(i)(1:4))
            k2 = number(ktt(i)(5:8))
            k3 = number(ktt(i)(9:12))
            k4 = number(ktt(i)(13:16))
            k5 = number(ktt(i)(17:20))
            tname = ttier(i)
            if (tname .eq. blank3)  tname = '---'
            write (itxt,970)  i,k1,k2,k3,k4,k5,tnx(i),tny(i),tname
  970       format (/,2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,'-',i4,
     &                 2x,2i9,7x,a3/)
            k = tnx(i) * tny(i)
            write (itxt,980)  (tbf(j,i),j=1,k)
  980       format (3x,6f12.5)
         end do
  990    continue
      end if
c
c     van der Waals parameters
c
      exist = .false.
      do i = 1, maxtyp
         if (rad(i) .ne. 0.0d0)  exist = .true.
      end do
      if (exist) then
         write (itxt,1000)  formfeed,forcefield
 1000    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         if (vdwindex .eq. 'CLASS') then
            write (itxt,1010)
 1010       format (//,15x,'Van der Waals Parameters',
     &              ///,21x,'Class',6x,'Radius',6x,'Epsilon',
     &                    4x,'Reduction',/)
         else
            write (itxt,1020)
 1020       format (//,15x,'Van der Waals Parameters',
     &              ///,22x,'Type',6x,'Radius',6x,'Epsilon',
     &                    4x,'Reduction',/)
         end if
         k = 0
         do i = 1, maxtyp
            if (rad(i) .ne. 0.0d0) then
               k = k + 1
               write (itxt,1030)  k,i,rad(i),eps(i),reduct(i)
 1030          format (8x,i7,4x,i7,3f12.3)
            end if
         end do
c
c     van der Waals scaling parameters
c
         write (itxt,1040)  v2scale,v3scale,v4scale,v5scale
 1040    format (//,15x,'Van der Waals Scaling Factors',
     &           ///,20x,'1-2 Atoms',f17.3,/,20x,'1-3 Atoms',f17.3,
     &           /,20x,'1-4 Atoms',f17.3,/,20x,'1-5 Atoms',f17.3)
      end if
c
c     van der Waals 1-4 parameters for atom types
c
      exist = .false.
      do i = 1, maxtyp
         if (rad4(i) .ne. 0.0d0)  exist = .true.
      end do
      if (exist) then
         if (vdwindex .eq. 'CLASS') then
            write (itxt,1050)
 1050       format (//,15x,'Van der Waals Parameters for 1-4',
     &                 ' Interactions',
     &              ///,20x,'Class',7x,'Radius',6x,'Epsilon',/)
         else
            write (itxt,1060)
 1060       format (//,15x,'Van der Waals Parameters for 1-4',
     &                 ' Interactions',
     &              ///,20x,'Type',8x,'Radius',6x,'Epsilon',/)
         end if
         k = 0
         do i = 1, maxtyp
            if (rad4(i) .ne. 0.0d0) then
               k = k + 1
               write (itxt,1070)  k,i,rad4(i),eps4(i)
 1070          format (8x,i7,2x,i7,2x,2f12.3)
            end if
         end do
      end if
c
c     van der Waals parameters for specific atom pairs
c
      if (kvpr(1) .ne. blank8) then
         if (vdwindex .eq. 'CLASS') then
            write (itxt,1080)
 1080       format (//,15x,'Van der Waals Parameters for Atom Pairs',
     &              ///,22x,'Classes',7x,'Radii Sum',4x,'Epsilon',/)
         else
            write (itxt,1090)
 1090       format (//,15x,'Van der Waals Parameters for Atom Pairs',
     &              ///,23x,'Types',8x,'Radii Sum',4x,'Epsilon',/)
         end if
         do i = 1, maxnvp
            if (kvpr(i) .eq. blank8)  goto 1110
            k1 = number(kvpr(i)(1:4))
            k2 = number(kvpr(i)(5:8))
            write (itxt,1100)  i,k1,k2,radpr(i),epspr(i)
 1100       format (8x,i7,5x,i4,'-',i4,2x,2f12.3)
         end do
 1110    continue
      end if
c
c     hydrogen bonding parameters for specific atom pairs
c
      if (khb(1) .ne. blank8) then
         if (vdwindex .eq. 'CLASS') then
            write (itxt,1120)
 1120       format (//,15x,'Hydrogen Bonding Parameters for Atom Pairs',
     &              ///,22x,'Classes',7x,'Radii Sum',4x,'Epsilon',/)
         else
            write (itxt,1130)
 1130       format (//,15x,'Hydrogen Bonding Parameters for Atom Pairs',
     &              ///,23x,'Types',8x,'Radii Sum',4x,'Epsilon',/)
         end if
         do i = 1, maxnhb
            if (khb(i) .eq. blank8)  goto 1150
            k1 = number(khb(i)(1:4))
            k2 = number(khb(i)(5:8))
            write (itxt,1140)  i,k1,k2,radhb(i),epshb(i)
 1140       format (8x,i7,5x,i4,'-',i4,2x,2f12.3)
         end do
 1150    continue
      end if
c
c     Pauli repulsion parameters
c
      exist = .false.
      do i = 1, maxclass
         if (prsiz(i) .ne. 0.0d0)  exist = .true.
      end do
      if (exist) then
         write (itxt,1160)  formfeed,forcefield
 1160    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,1170)
 1170    format (//,15x,'Pauli Repulsion Parameters',
     &           ///,24x,'Class',14x,'Size',8x,'Damp',5x,'Valence'/)
         k = 0
         do i = 1, maxclass
            if (prsiz(i) .ne. 0.0d0) then
               k = k + 1
               write (itxt,1180)  k,i,prsiz(i),prdmp(i),prele(i)
 1180          format (10x,i7,3x,i7,8x,2f12.4,f12.3)
            end if
         end do
      end if
c
c     damped dispersion parameters
c
      exist = .false.
      do i = 1, maxclass
         if (dspsix(i) .ne. 0.0d0)  exist = .true.
      end do
      if (exist) then
         write (itxt,1190)  formfeed,forcefield
 1190    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,1200)
 1200    format (//,15x,'Damped Dispersion Parameters',
     &           ///,24x,'Class',15x,'C6',9x,'Damp',/)
         k = 0
         do i = 1, maxclass
            if (dspsix(i) .ne. 0.0d0) then
               k = k + 1
               write (itxt,1210)  k,i,dspsix(i),dspdmp(i)
 1210          format (10x,i7,3x,i7,8x,2f12.4)
            end if
         end do
      end if
c
c     atomic partial charge parameters
c
      exist = .false.
      do i = 1, maxtyp
         if (chg(i) .ne. 0.0d0)  exist = .true.
      end do
      if (exist) then
         write (itxt,1220)  formfeed,forcefield
 1220    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,1230)
 1230    format (//,15x,'Atomic Partial Charge Parameters',
     &           ///,24x,'Type',9x,'Partial Chg',/)
         k = 0
         do i = 1, maxtyp
            if (chg(i) .ne. 0.0d0) then
               k = k + 1
               write (itxt,1240)  k,i,chg(i)
 1240          format (10x,i7,3x,i7,6x,f12.3)
            end if
         end do
c
c     atomic partial charge scaling parameters
c
         write (itxt,1250)  c1scale,c2scale,c3scale,c4scale,c5scale
 1250    format (//,15x,'Atomic Partial Charge Scaling Factors',
     &           ///,20x,'1-1 Atoms',f17.3,/,20x,'1-2 Atoms',f17.3,
     &           /,20x,'1-3 Atoms',f17.3,/,20x,'1-4 Atoms',f17.3,
     &           /,20x,'1-5 Atoms',f17.3)
      end if
c
c     bond dipole moment parameters
c
      if (kd(1) .ne. blank8) then
         write (itxt,1260)  formfeed,forcefield
 1260    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,1270)
 1270    format (//,15x,'Bond Dipole Moment Parameters',
     &           ///,25x,'Types',10x,'Bond Dipole',4x,'Position',/)
         do i = 1, maxnd
            if (kd(i) .eq. blank8)  goto 1290
            k1 = number(kd(i)(1:4))
            k2 = number(kd(i)(5:8))
            write (itxt,1280)  i,k1,k2,dpl(i),pos(i)
 1280       format (10x,i7,5x,i4,'-',i4,6x,2f12.3)
         end do
 1290    continue
      end if
c
c     bond dipole moment parameters for 5-membered rings
c
      if (kd5(1) .ne. blank8) then
         write (itxt,1300)
 1300    format (//,15x,'5-Membered Ring Bond Dipole Parameters',
     &           ///,25x,'Types',10x,'Bond Dipole',4x,'Position',/)
         do i = 1, maxnd5
            if (kd5(i) .eq. blank8)  goto 1320
            k1 = number(kd5(i)(1:4))
            k2 = number(kd5(i)(5:8))
            write (itxt,1310)  i,k1,k2,dpl5(i),pos5(i)
 1310       format (10x,i7,5x,i4,'-',i4,6x,2f12.3)
         end do
 1320    continue
      end if
c
c     bond dipole moment parameters for 4-membered rings
c
      if (kd4(1) .ne. blank8) then
         write (itxt,1330)
 1330    format (//,15x,'4-Membered Ring Bond Dipole Parameters',
     &           ///,25x,'Types',10x,'Bond Dipole',4x,'Position',/)
         do i = 1, maxnd4
            if (kd4(i) .eq. blank8)  goto 1350
            k1 = number(kd4(i)(1:4))
            k2 = number(kd4(i)(5:8))
            write (itxt,1340)  i,k1,k2,dpl4(i),pos4(i)
 1340       format (10x,i7,5x,i4,'-',i4,6x,2f12.3)
         end do
 1350    continue
      end if
c
c     bond dipole moment parameters for 3-membered rings
c
      if (kd3(1) .ne. blank8) then
         write (itxt,1360)
 1360    format (//,15x,'3-Membered Ring Bond Dipole Parameters',
     &           ///,25x,'Types',10x,'Bond Dipole',4x,'Position',/)
         do i = 1, maxnd3
            if (kd3(i) .eq. blank8)  goto 1380
            k1 = number(kd3(i)(1:4))
            k2 = number(kd3(i)(5:8))
            write (itxt,1370)  i,k1,k2,dpl3(i),pos3(i)
 1370       format (10x,i7,5x,i4,'-',i4,6x,2f12.3)
         end do
 1380    continue
      end if
c
c     atomic multipole electrostatic parameters
c
      if (kmp(1) .ne. blank16) then
         write (itxt,1390)  formfeed,forcefield
 1390    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,1400)
 1400    format (//,17x,'Atomic Multipole Parameters',
     &           ///,11x,'Type',7x,'Axis Types',8x,'Frame',
     &              9x,'Multipoles (M-D-Q)',/)
         do i = 1, maxnmp
            if (kmp(i) .eq. blank16)  goto 1420
            k1 = number(kmp(i)(1:4))
            k2 = number(kmp(i)(5:8))
            k3 = number(kmp(i)(9:12))
            k4 = number(kmp(i)(13:16))
            write (itxt,1410)  i,k1,k2,k3,k4,mpaxis(i),multip(1,i),
     &                         multip(2,i),multip(3,i),multip(4,i),
     &                         multip(5,i),multip(8,i),multip(9,i),
     &                         multip(11,i),multip(12,i),multip(13,i)
 1410       format (2x,i5,3x,i4,3x,i4,2x,i4,2x,i4,5x,a8,2x,f10.5,
     &                 /,48x,3f10.5,/,48x,f10.5,
     &                 /,48x,2f10.5,/,48x,3f10.5)
         end do
 1420    continue
c
c     atomic multipole scaling parameters
c
         write (itxt,1430)  m2scale,m3scale,m4scale,m5scale
 1430    format (//,15x,'Atomic Multipole Scale Factors',
     &           ///,20x,'1-2 Atoms',f17.3,/,20x,'1-3 Atoms',f17.3,
     &           /,20x,'1-4 Atoms',f17.3,/,20x,'1-5 Atoms',f17.3)
      end if
c
c     charge penetration parameters
c
      exist = .false.
      do i = 1, maxclass
         if (cpele(i).ne.0.0d0 .or. cpalp(i).ne.0.0d0)  exist = .true
     &.
      end do
      if (exist) then
         write (itxt,1440)  formfeed,forcefield
 1440    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,1450)
 1450    format (//,15x,'Charge Penetration Parameters',
     &           ///,24x,'Class',10x,'Core Chg',8x,'Damp',/)
         k = 0
         do i = 1, maxclass
            if (cpele(i).ne.0.0d0 .or. cpalp(i).ne.0.0d0) then
               k = k + 1
               write (itxt,1460)  k,i,cpele(i),cpalp(i)
 1460          format (10x,i7,3x,i7,8x,2f12.4)
            end if
         end do
      end if
c
c     atomic dipole polarizability parameters
c
      exist = .false.
      use_thole = .false.
      use_tholed = .false.
      do i = 1, maxclass
         if (polr(i) .ne. 0.0d0)  exist = .true.
         if (athl(i) .ne. 0.0d0)  use_thole = .true.
         if (dthl(i) .ne. 0.0d0)  use_tholed = .true.
      end do
      if (exist) then
         write (itxt,1470)  formfeed,forcefield
 1470    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         if (use_tholed) then
            write (itxt,1480)
 1480       format (//,15x,'Dipole Polarizability Parameters',
     &              ///,22x,'Class',7x,'Alpha',5x,'Thole',
     &                 4x,'TholeD',6x,'Group Types',/)
         else if (use_thole) then
            write (itxt,1490)
 1490       format (//,15x,'Dipole Polarizability Parameters',
     &              ///,22x,'Class',7x,'Alpha',5x,'Thole',
     &                 6x,'Group Atom Types',/)
         else
            write (itxt,1500)
 1500       format (//,15x,'Dipole Polarizability Parameters',
     &              ///,22x,'Class',7x,'Alpha',6x,'Group Atom Types',/)
         end if
         k = 0
         do i = 1, maxclass
            if (polr(i) .ne. 0.0d0) then
               k = k + 1
               npg = 0
               do j = 1, maxval
                  if (pgrp(j,i) .ne. 0)  npg = npg + 1
               end do
               if (use_tholed) then
                  if (npg .eq. 0) then
                     write (itxt,1510)  k,i,polr(i),athl(i),dthl(i)
 1510                format (8x,i7,4x,i7,3x,3f10.3)
                  else
                     write (itxt,1520)  k,i,polr(i),athl(i),dthl(i),
     &                                  (pgrp(j,i),j=1,npg)
 1520                format (8x,i7,4x,i7,3x,3f10.3,4x,6i5)
                  end if
               else if (use_thole) then
                  if (npg .eq. 0) then
                     write (itxt,1530)  k,i,polr(i),athl(i)
 1530                format (8x,i7,4x,i7,3x,2f10.3)
                  else
                     write (itxt,1540)  k,i,polr(i),athl(i),
     &                                  (pgrp(j,i),j=1,npg)
 1540                format (8x,i7,4x,i7,3x,2f10.3,4x,6i5)
                  end if
               else
                  if (npg .eq. 0) then
                     write (itxt,1550)  k,i,polr(i)
 1550                format (8x,i7,4x,i7,3x,f10.3)
                  else
                     write (itxt,1560)  k,i,polr(i),(pgrp(j,i),j=1,npg)
 1560                format (8x,i7,4x,i7,3x,f10.3,4x,6i4)
                  end if
               end if
            end if
         end do
c
c     dipole polarizability scaling parameters
c
         write (itxt,1570)  d1scale,d2scale,d3scale,d4scale
 1570    format (//,15x,'Direct Induction Scale Factors',
     &           ///,20x,'1-1 Groups',f15.3,/,20x,'1-2 Groups',f15.3,
     &           /,20x,'1-3 Groups',f15.3,/,20x,'1-4 Groups',f15.3)
         write (itxt,1580)  u1scale,u2scale,u3scale,u4scale
 1580    format (//,15x,'Mutual Induction Scale Factors',
     &           ///,20x,'1-1 Groups',f15.3,/,20x,'1-2 Groups',f15.3,
     &           /,20x,'1-3 Groups',f15.3,/,20x,'1-4 Groups',f15.3)
         write (itxt,1590)  p2scale,p3scale,p4scale,p5scale
 1590    format (//,15x,'Inter-Group Polarizability Scale Factors',
     &           ///,20x,'1-2 Atoms',f16.3,/,20x,'1-3 Atoms',f16.3,
     &           /,20x,'1-4 Atoms',f16.3,/,20x,'1-5 Atoms',f16.3)
         write (itxt,1600)  p2iscale,p3iscale,p4iscale,p5iscale
 1600    format (//,15x,'Intra-Group Polarizability Scale Factors',
     &           ///,20x,'1-2 Atoms',f16.3,/,20x,'1-3 Atoms',f16.3,
     &           /,20x,'1-4 Atoms',f16.3,/,20x,'1-5 Atoms',f16.3)
         write (itxt,1610)  w2scale,w3scale,w4scale,w5scale
 1610    format (//,15x,'Induced Dipole Interaction Scale Factors',
     &           ///,20x,'1-2 Atoms',f16.3,/,20x,'1-3 Atoms',f16.3,
     &           /,20x,'1-4 Atoms',f16.3,/,20x,'1-5 Atoms',f16.3)
      end if
c
c     polarizability parameters for specific atom pairs
c
      if (kppr(1) .ne. blank8) then
         write (itxt,1620)
 1620    format (//,15x,'Polarizability Parameters for Atom Pairs',
     &           ///,23x,'Types',10x,'Thole',6x,'TholeD',/)
         do i = 1, maxnpp
            if (kppr(i) .eq. blank8)  goto 1640
            k1 = number(kppr(i)(1:4))
            k2 = number(kppr(i)(5:8))
            write (itxt,1630)  i,k1,k2,thlpr(i),thdpr(i)
 1630       format (8x,i7,5x,i4,'-',i4,2x,2f12.3)
         end do
 1640    continue
      end if
c
c     exchange polarization parameters
c
      exist = .false.
      do i = 1, maxclass
         if (pepdmp(i) .ne. 0.0d0)  exist = .true.
      end do
      if (exist) then
         write (itxt,1650)  formfeed,forcefield
 1650    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,1660)
 1660    format (//,15x,'Exchange Polarization Parameters',
     &           ///,22x,'Class',8x,'Spring',8x,'Size',8x,'Damp',
     &              8x,'Use'/)
         k = 0
         do i = 1, maxclass
            if (pepdmp(i) .ne. 0.0d0) then
               k = k + 1
               write (itxt,1670)  k,i,pepk(i),peppre(i),
     &                            pepdmp(i),pepl(k)
 1670          format (10x,i7,1x,i7,4x,2f12.4,f12.3,9x,l1)
            end if
         end do
      end if
c
c     charge transfer parameters
c
      exist = .false.
      do i = 1, maxclass
         if (ctchg(i).ne.0.0d0 .or. ctdmp(i).ne.0.0d0)  exist = .true
     &.
      end do
      if (exist) then
         write (itxt,1680)  formfeed,forcefield
 1680    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,1690)
 1690    format (//,15x,'Charge Transfer Parameters',
     &           ///,24x,'Class',12x,'Charge',7x,'Alpha',/)
         k = 0
         do i = 1, maxclass
            if (ctchg(i).ne.0.0d0 .or. ctdmp(i).ne.0.0d0) then
               k = k + 1
               write (itxt,1700)  k,i,ctchg(i),ctdmp(i)
 1700          format (10x,i7,3x,i7,8x,2f12.4)
            end if
         end do
      end if
c
c     bond charge flux parameters
c
      if (kcfb(1) .ne. blank8) then
         write (itxt,1710)  formfeed,forcefield
 1710    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,1720)
 1720    format (//,15x,'Bond Charge Flux Parameters',
     &           ///,22x,'Classes',14x,'KCFB',/)
         do i = 1, maxncfb
            if (kcfb(i) .eq. blank8)  goto 1740
            k1 = number(kcfb(i)(1:4))
            k2 = number(kcfb(i)(5:8))
            write (itxt,1730)  i,k1,k2,cflb(i)
 1730       format (8x,i7,5x,i4,'-',i4,6x,f12.4)
         end do
 1740    continue
      end if
c
c     angle charge flux parameters
c
      if (kcfa(1) .ne. blank12) then
         write (itxt,1750)  formfeed,forcefield
 1750    format (a1,//,15x,'Tinker Force Field Parameters for ',a20)
         write (itxt,1760)
 1760    format (//,15x,'Angle Charge Flux Parameters',
     &           ///,18x,'Classes',10x,'KCFA1',7x,'KCFA2',
     &              7x,'KCFB1',7x,'KCFB2',/)
         do i = 1, maxncfa
            if (kcfa(i) .eq. blank12)  goto 1780
            k1 = number(kcfa(i)(1:4))
            k2 = number(kcfa(i)(5:8))
            k3 = number(kcfa(i)(9:12))
            write (itxt,1770)  i,k1,k2,k3,cfla(1,i),cfla(2,i),
     &                        cflab(1,i),cflab(2,i)
 1770       format (1x,i7,5x,i4,'-',i4,'-',i4,1x,4f12.4)
         end do
 1780    continue
      end if
c
c     implicit solvation parameters
c
      exist = .false.
      do i = 1, maxtyp
         if (pbr(i).ne.0.0d0 .or. csr(i).ne.0.0d0 .or.
     &          gkr(i).ne.0.0d0 .or. snk(i).ne.0.0d0)  exist = .true.
      end do
      if (exist) then
         write (itxt,1790)  formfeed,forcefield
 1790    format (a1,//,15x,'Tinker Force Field Parameters for ',a2
     &0)
         write (itxt,1800)
 1800    format (//,15x,'Implicit Solvation Parameters',
     &           ///,22x,'Type',6x,'PB Size',5x,'CS Size',
     &              5x,'GK Size',6x,'S-Neck',/)
         k = 0
         do i = 1, maxtyp
            if (pbr(i).ne.0.0d0 .or. csr(i).ne.0.0d0 .or.
     &             gkr(i).ne.0.0d0 .or. snk(i).ne.0.0d0) then
               k = k + 1
               write (itxt,1810)  k,i,pbr(i),csr(i),gkr(i),snk(i)
 1810          format (8x,i7,4x,i7,1x,4f12.4)
            end if
         end do
      end if
c
c     conjugated pisystem atom parameters
c
      exist = .false.
      do i = 1, maxclass
         if (ionize(i) .ne. 0.0d0)  exist = .true.
      end do
      if (exist) then
         write (itxt,1820)  formfeed,forcefield
 1820    format (a1,//,15x,'Tinker Force Field Parameters for ',a2
     &0)
         write (itxt,1830)
 1830    format (//,15x,'Conjugated Pisystem Atom Parameters',
     &           ///,20x,'Class',3x,'Electron',
     &              3x,'Ionization',3x,'Repulsion',/)
         k = 0
         do i = 1, maxclass
            if (ionize(i) .ne. 0.0d0) then
               k = k + 1
               write (itxt,1840)  k,i,electron(i),ionize(i),repulse(i)
 1840          format (6x,i7,4x,i7,f10.1,2x,2f12.3)
            end if
         end do
      end if
c
c     conjugated pisystem bond parameters
c
      if (kpi(1) .ne. blank8) then
         write (itxt,1850)
 1850    format (//,15x,'Conjugated Pisystem Bond Parameters',
     &           ///,20x,'Classes',8x,'d Force',4x,'d Length',/)
         do i = 1, maxnpi
            if (kpi(i) .eq. blank8)  goto 1870
            k1 = number(kpi(i)(1:4))
            k2 = number(kpi(i)(5:8))
            write (itxt,1860)  i,k1,k2,sslope(i),tslope(i)
 1860       format (6x,i7,5x,i4,'-',i4,3x,2f12.3)
         end do
 1870    continue
      end if
c
c     conjugated pisystem bond parameters for 5-membered rings
c
      if (kpi5(1) .ne. blank8) then
         write (itxt,1880)
 1880    format (//,15x,'5-Membered Ring Pisystem Bond Parameters'
     &,           ///,20x,'Classes',8x,'d Force',4x,'d Length',/)
         do i = 1, maxnpi5
            if (kpi5(i) .eq. blank8)  goto 1900
            k1 = number(kpi5(i)(1:4))
            k2 = number(kpi5(i)(5:8))
            write (itxt,1890)  i,k1,k2,sslope5(i),tslope5(i)
 1890       format (6x,i7,5x,i4,'-',i4,3x,2f12.3)
         end do
 1900    continue
      end if
c
c     conjugated pisystem bond parameters for 4-membered rings
c
      if (kpi4(1) .ne. blank8) then
         write (itxt,1910)
 1910    format (//,15x,'4-Membered Ring Pisystem Bond Parameters'
     &,           ///,20x,'Classes',8x,'d Force',4x,'d Length',/)
         do i = 1, maxnpi4
            if (kpi4(i) .eq. blank8)  goto 1930
            k1 = number(kpi4(i)(1:4))
            k2 = number(kpi4(i)(5:8))
            write (itxt,1920)  i,k1,k2,sslope4(i),tslope4(i)
 1920       format (6x,i7,5x,i4,'-',i4,3x,2f12.3)
         end do
 1930    continue
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine prtseq  --  output of biopolymer sequence  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "prtseq" writes out a biopolymer sequence to an external
c     file with 15 residues per line and distinct chains separated
c     by blank lines
c
c
      subroutine prtseq (iseq)
      use files
      use sequen
      implicit none
      integer i,k,iseq
      integer smax,smin
      integer size,start,stop
      logical opened
      character*1 letter
      character*23 fstr
      character*240 seqfile
c
c
c     open the output unit if not already done
c
      inquire (unit=iseq,opened=opened)
      if (.not. opened) then
         seqfile = filename(1:leng)//'.seq'
         call version (seqfile,'new')
         open (unit=iseq,file=seqfile,status='new')
      end if
c
c     write out a three-letter code sequence file
c
      do i = 1, nchain
         letter = chnnam(i)
         start = ichain(1,i)
         stop = ichain(2,i)
         size = stop - start + 1
         smax = 0
         do while (smax .lt. size)
            smin = smax + 1
            smax = smax + 15
            smax = min(smax,size)
            if (i.ne.1 .and. smin.eq.1)  write (iseq,'()')
            fstr = '(3x,a1,i6,1x,15(1x,a3))'
            write (iseq,fstr)  letter,smin,(seq(k+start-1),k=smin,smax)
         end do
      end do
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=iseq)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2023  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine prtuind  --  output of atomic induced dipoles  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "prtuind" writes out a set of induced dipole components
c     to an external file in Tinker XYZ format
c
c
      subroutine prtuind (iind)
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use files
      use inform
      use polar
      use potent
      use solpot
      use titles
      use units
      implicit none
      integer i,j,k,iind
      integer size,crdsiz
      real*8 crdmin,crdmax
      logical opened
      character*2 atmc
      character*2 crdc
      character*2 digc
      character*25 fstr
      character*240 indfile
c
c
c     open the output unit if not already done
c
      inquire (unit=iind,opened=opened)
      if (.not. opened) then
         indfile = filename(1:leng)//'.uind'
         call version (indfile,'new')
         open (unit=iind,file=indfile,status='new')
      end if
c
c     check for large systems needing extended formatting
c
      atmc = 'i6'
      if (n .ge. 100000)  atmc = 'i7'
      if (n .ge. 1000000)  atmc = 'i8'
      crdmin = 0.0d0
      crdmax = 0.0d0
      do i = 1, n
         crdmin = min(crdmin,x(i),y(i),z(i))
         crdmax = max(crdmax,x(i),y(i),z(i))
      end do
      crdsiz = 6
      if (crdmin .le. -1000.0d0)  crdsiz = 7
      if (crdmax .ge. 10000.0d0)  crdsiz = 7
      if (crdmin .le. -10000.0d0)  crdsiz = 8
      if (crdmax .ge. 100000.0d0)  crdsiz = 8
      crdsiz = crdsiz + max(6,digits)
      size = 0
      call numeral (crdsiz,crdc,size)
      if (digits .le. 6) then
         digc = '6 '
      else if (digits .le. 8) then
         digc = '8'
      else
         digc = '10'
      end if
c
c     write out the number of atoms and the title
c
      if (ltitle .eq. 0) then
         fstr = '('//atmc//')'
         write (iind,fstr(1:4))  n
      else
         fstr = '('//atmc//',2x,a)'
         write (iind,fstr(1:9))  n,title(1:ltitle)
      end if
c
c     write out the periodic cell lengths and angles
c
      if (use_bounds) then
         fstr = '(1x,6f'//crdc//'.'//digc//')'
         write (iind,fstr)  xbox,ybox,zbox,alpha,beta,gamma
      end if
c
c     write out the induced dipole components for each atom
c
      fstr = '('//atmc//',2x,a3,3f'//crdc//
     &          '.'//digc//',i6,8'//atmc//')'
      if (use_solv .and.
     &       (solvtyp(1:2).eq.'GK'.or.solvtyp(1:2).eq.'PB')) then
         do i = 1, n
            k = n12(i)
            if (k .eq. 0) then
               write (iind,fstr)  i,name(i),(debye*uinds(j,i),j=1,3),
     &                            type(i)
            else
               write (iind,fstr)  i,name(i),(debye*uinds(j,i),j=1,3),
     &                            type(i),(i12(j,i),j=1,k)
            end if
         end do
      else
         do i = 1, n
            k = n12(i)
            if (k .eq. 0) then
               write (iind,fstr)  i,name(i),(debye*uind(j,i),j=1,3),
     &                            type(i)
            else
               write (iind,fstr)  i,name(i),(debye*uind(j,i),j=1,3),
     &                            type(i),(i12(j,i),j=1,k)
            end if
         end do
      end if
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=iind)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine prtdcdu  --  output of DCD induced dipoles  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "prtdcdu" writes out a set of induced dipole components to
c     a file in CHARMM DCD binary format compatible with the VMD
c     visualization software and other packages
c
c     note the format used is based on the "dcdplugin.c" code from
c     the NAMD and VMD programs, and tutorial 4.1 from the software
c     package GENESIS: Generalized-Ensemble Simulation System
c
c     variables and parameters:
c
c     header     type of data (CORD=coordinates, VELD=velocities)
c     nframe     number of frames stored in the DCD file
c     nprev      number of previous integration steps
c     ncrdsav    frequency in steps for saving coordinate frames
c     nstep      number of integration steps in the total run
c     nvelsav    frequency of coordinate saves with velocity data
c     ndfree     number of degrees of freedom for the system
c     nfixat     number of fixed atoms for the system
c     usebox     flag for periodic boundaries (1=true, 0=false)
c     use4d      flag for 4D trajectory (1=true, 0=false)
c     usefq      flag for fluctuating charges (1=true, 0=false)
c     merged     result of merge without checks (1=true, 0=false)
c     vcharmm    version of CHARMM software for compatibility
c
c     in general a value of zero for any of the above indicates that
c     the particular feature is unused
c
c
      subroutine prtdcdu (idcd,first)
      use atoms
      use bound
      use boxes
      use files
      use polar
      use potent
      use solpot
      use titles
      use units
      implicit none
      integer i,idcd
      integer zero,one
      integer nframe,nprev
      integer ncrdsav,nstep
      integer nvelsav,ndfree
      integer nfixat,usebox
      integer use4d,usefq
      integer merged,vcharmm
      integer ntitle
      real*4 tdelta
      logical opened,first
      character*4 header
      character*240 dcdfile
c
c
c     open the output unit if not already done
c
      inquire (unit=idcd,opened=opened)
      if (.not. opened) then
         dcdfile = filename(1:leng)//'.dcdu'
         call version (dcdfile,'new')
         open (unit=idcd,file=dcdfile,form='unformatted',status='new')
      end if
c
c     write header info along with title and number of atoms
c
      if (first) then
         first = .false.
         zero = 0
         one = 1
         header = 'CORD'
         nframe = zero
         nprev = zero
         ncrdsav = one
         nstep = zero
         nvelsav = zero
         ndfree = zero
         nfixat = zero
         tdelta = 0.0
         usebox = zero
         if (use_bounds)  usebox = one
         use4d = zero
         usefq = zero
         merged = zero
         vcharmm = 24
         ntitle = one
         write (idcd)  header,nframe,nprev,ncrdsav,nstep,
     &                 nvelsav,zero,zero,ndfree,nfixat,
     &                 tdelta,usebox,use4d,usefq,merged,
     &                 zero,zero,zero,zero,zero,vcharmm
         write (idcd)  ntitle,title(1:80)
         write (idcd)  n
      end if
c
c     append the lattice values based on header flag value;
c     using angle values is NAMD style, cosine values is CHARMM
c
      if (use_bounds) then
c        write (idcd)  xbox,gamma_cos,ybox,beta_cos,alpha_cos,zbox
         write (idcd)  xbox,gamma,ybox,beta,alpha,zbox
      end if
c
c     append the induced dipoles along each axis in turn
c
      if (use_solv .and.
     &       (solvtyp(1:2).eq.'GK'.or.solvtyp(1:2).eq.'PB')) then
         write (idcd)  (real(debye*uinds(1,i)),i=1,n)
         write (idcd)  (real(debye*uinds(2,i)),i=1,n)
         write (idcd)  (real(debye*uinds(3,i)),i=1,n)
      else
         write (idcd)  (real(debye*uind(1,i)),i=1,n)
         write (idcd)  (real(debye*uind(2,i)),i=1,n)
         write (idcd)  (real(debye*uind(3,i)),i=1,n)
      end if
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=idcd)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2023  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine prtvel  --  output of velocity components  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "prtvel" writes out a set of atomic velocity components
c     to an external file in Tinker XYZ format
c
c
      subroutine prtvel (ivel)
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use files
      use inform
      use moldyn
      use titles
      implicit none
      integer i,j,k,ivel
      integer size,crdsiz
      real*8 crdmin,crdmax
      logical opened
      character*2 atmc
      character*2 crdc
      character*2 digc
      character*25 fstr
      character*240 velfile
c
c
c     open the output unit if not already done
c
      inquire (unit=ivel,opened=opened)
      if (.not. opened) then
         velfile = filename(1:leng)//'.vel'
         call version (velfile,'new')
         open (unit=ivel,file=velfile,status='new')
      end if
c
c     check for large systems needing extended formatting
c
      atmc = 'i6'
      if (n .ge. 100000)  atmc = 'i7'
      if (n .ge. 1000000)  atmc = 'i8'
      crdmin = 0.0d0
      crdmax = 0.0d0
      do i = 1, n
         crdmin = min(crdmin,x(i),y(i),z(i))
         crdmax = max(crdmax,x(i),y(i),z(i))
      end do
      crdsiz = 6
      if (crdmin .le. -1000.0d0)  crdsiz = 7
      if (crdmax .ge. 10000.0d0)  crdsiz = 7
      if (crdmin .le. -10000.0d0)  crdsiz = 8
      if (crdmax .ge. 100000.0d0)  crdsiz = 8
      crdsiz = crdsiz + max(6,digits)
      size = 0
      call numeral (crdsiz,crdc,size)
      if (digits .le. 6) then
         digc = '6 '
      else if (digits .le. 8) then
         digc = '8'
      else
         digc = '10'
      end if
c
c     write out the number of atoms and the title
c
      if (ltitle .eq. 0) then
         fstr = '('//atmc//')'
         write (ivel,fstr(1:4))  n
      else
         fstr = '('//atmc//',2x,a)'
         write (ivel,fstr(1:9))  n,title(1:ltitle)
      end if
c
c     write out the periodic cell lengths and angles
c
      if (use_bounds) then
         fstr = '(1x,6f'//crdc//'.'//digc//')'
         write (ivel,fstr)  xbox,ybox,zbox,alpha,beta,gamma
      end if
c
c     write out the velocity components for each atom
c
      fstr = '('//atmc//',2x,a3,3f'//crdc//
     &          '.'//digc//',i6,8'//atmc//')'
      do i = 1, n
         k = n12(i)
         if (k .eq. 0) then
            write (ivel,fstr)  i,name(i),(v(j,i),j=1,3),type(i)
         else
            write (ivel,fstr)  i,name(i),(v(j,i),j=1,3),type(i),
     &                         (i12(j,i),j=1,k)
         end if
      end do
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=ivel)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine prtdcdv  --  output of DCD velocity components  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "prtdcdv" writes out a set of atomic velocity components to
c     a file in CHARMM DCD binary format compatible with the VMD
c     visualization software and other packages
c
c     note the format used is based on the "dcdplugin.c" code from
c     the NAMD and VMD programs, and tutorial 4.1 from the software
c     package GENESIS: Generalized-Ensemble Simulation System
c
c     variables and parameters:
c
c     header     type of data (CORD=coordinates, VELD=velocities)
c     nframe     number of frames stored in the DCD file
c     nprev      number of previous integration steps
c     ncrdsav    frequency in steps for saving coordinate frames
c     nstep      number of integration steps in the total run
c     nvelsav    frequency of coordinate saves with velocity data
c     ndfree     number of degrees of freedom for the system
c     nfixat     number of fixed atoms for the system
c     usebox     flag for periodic boundaries (1=true, 0=false)
c     use4d      flag for 4D trajectory (1=true, 0=false)
c     usefq      flag for fluctuating charges (1=true, 0=false)
c     merged     result of merge without checks (1=true, 0=false)
c     vcharmm    version of CHARMM software for compatibility
c
c     in general a value of zero for any of the above indicates that
c     the particular feature is unused
c
c
      subroutine prtdcdv (idcd,first)
      use atoms
      use bound
      use boxes
      use files
      use moldyn
      use titles
      implicit none
      integer i,idcd
      integer zero,one
      integer nframe,nprev
      integer ncrdsav,nstep
      integer nvelsav,ndfree
      integer nfixat,usebox
      integer use4d,usefq
      integer merged,vcharmm
      integer ntitle
      real*4 tdelta
      logical opened,first
      character*4 header
      character*240 dcdfile
c
c
c     open the output unit if not already done
c
      inquire (unit=idcd,opened=opened)
      if (.not. opened) then
         dcdfile = filename(1:leng)//'.dcdv'
         call version (dcdfile,'new')
         open (unit=idcd,file=dcdfile,form='unformatted',status='new')
      end if
c
c     write header info along with title and number of atoms
c
      if (first) then
         first = .false.
         zero = 0
         one = 1
         header = 'CORD'
         nframe = zero
         nprev = zero
         ncrdsav = one
         nstep = zero
         nvelsav = zero
         ndfree = zero
         nfixat = zero
         tdelta = 0.0
         usebox = zero
         if (use_bounds)  usebox = one
         use4d = zero
         usefq = zero
         merged = zero
         vcharmm = 24
         ntitle = one
         write (idcd)  header,nframe,nprev,ncrdsav,nstep,
     &                 nvelsav,zero,zero,ndfree,nfixat,
     &                 tdelta,usebox,use4d,usefq,merged,
     &                 zero,zero,zero,zero,zero,vcharmm
         write (idcd)  ntitle,title(1:80)
         write (idcd)  n
      end if
c
c     append the lattice values based on header flag value;
c     using angle values is NAMD style, cosine values is CHARMM
c
      if (use_bounds) then
c        write (idcd)  xbox,gamma_cos,ybox,beta_cos,alpha_cos,zbox
         write (idcd)  xbox,gamma,ybox,beta,alpha,zbox
      end if
c
c     append the velocity components along each axis in turn
c
      write (idcd)  (real(v(1,i)),i=1,n)
      write (idcd)  (real(v(2,i)),i=1,n)
      write (idcd)  (real(v(3,i)),i=1,n)
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=idcd)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine prtxyz  --  output of XYZ atomic coordinates  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "prtxyz" writes out a set of Cartesian atomic coordinates
c     to an external file in Tinker XYZ format
c
c
      subroutine prtxyz (ixyz)
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use files
      use inform
      use titles
      implicit none
      integer i,j,k,ixyz
      integer size,crdsiz
      real*8 crdmin,crdmax
      logical opened
      character*2 atmc
      character*2 crdc
      character*2 digc
      character*25 fstr
      character*240 xyzfile
c
c
c     open the output unit if not already done
c
      inquire (unit=ixyz,opened=opened)
      if (.not. opened) then
         xyzfile = filename(1:leng)//'.xyz'
         call version (xyzfile,'new')
         open (unit=ixyz,file=xyzfile,status='new')
      end if
c
c     check for large systems needing extended formatting
c
      atmc = 'i6'
      if (n .ge. 100000)  atmc = 'i7'
      if (n .ge. 1000000)  atmc = 'i8'
      crdmin = 0.0d0
      crdmax = 0.0d0
      do i = 1, n
         crdmin = min(crdmin,x(i),y(i),z(i))
         crdmax = max(crdmax,x(i),y(i),z(i))
      end do
      crdsiz = 6
      if (crdmin .le. -1000.0d0)  crdsiz = 7
      if (crdmax .ge. 10000.0d0)  crdsiz = 7
      if (crdmin .le. -10000.0d0)  crdsiz = 8
      if (crdmax .ge. 100000.0d0)  crdsiz = 8
      crdsiz = crdsiz + max(6,digits)
      size = 0
      call numeral (crdsiz,crdc,size)
      if (digits .le. 6) then
         digc = '6 '
      else if (digits .le. 8) then
         digc = '8'
      else
         digc = '10'
      end if
c
c     write out the number of atoms and the title
c
      if (ltitle .eq. 0) then
         fstr = '('//atmc//')'
         write (ixyz,fstr(1:4))  n
      else
         fstr = '('//atmc//',2x,a)'
         write (ixyz,fstr(1:9))  n,title(1:ltitle)
      end if
c
c     write out the periodic cell lengths and angles
c
      if (use_bounds) then
         fstr = '(1x,6f'//crdc//'.'//digc//')'
         write (ixyz,fstr)  xbox,ybox,zbox,alpha,beta,gamma
      end if
c
c     write out the atomic coordinates for each atom
c
      fstr = '('//atmc//',2x,a3,3f'//crdc//
     &          '.'//digc//',i6,8'//atmc//')'
      do i = 1, n
         k = n12(i)
         if (k .eq. 0) then
            write (ixyz,fstr)  i,name(i),x(i),y(i),z(i),type(i)
         else
            write (ixyz,fstr)  i,name(i),x(i),y(i),z(i),type(i),
     &                         (i12(j,i),j=1,k)
         end if
      end do
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=ixyz)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine prtdcd  --  output of DCD atomic coordinates  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "prtdcd" writes out a set of Cartesian atomic coordinates to
c     a file in CHARMM DCD binary format compatible with the VMD
c     visualization software and other packages
c
c     note the format used is based on the "dcdplugin.c" code from
c     the NAMD and VMD programs, and tutorial 4.1 from the software
c     package GENESIS: Generalized-Ensemble Simulation System
c
c     variables and parameters:
c
c     header     type of data (CORD=coordinates, VELD=velocities)
c     nframe     number of frames stored in the DCD file
c     nprev      number of previous integration steps
c     ncrdsav    frequency in steps for saving coordinate frames
c     nstep      number of integration steps in the total run
c     nvelsav    frequency of coordinate saves with velocity data
c     ndfree     number of degrees of freedom for the system
c     nfixat     number of fixed atoms for the system
c     usebox     flag for periodic boundaries (1=true, 0=false)
c     use4d      flag for 4D trajectory (1=true, 0=false)
c     usefq      flag for fluctuating charges (1=true, 0=false)
c     merged     result of merge without checks (1=true, 0=false)
c     vcharmm    version of CHARMM software for compatibility
c
c     in general a value of zero for any of the above indicates that
c     the particular feature is unused
c
c
      subroutine prtdcd (idcd,first)
      use atoms
      use bound
      use boxes
      use files
      use titles
      implicit none
      integer i,idcd
      integer zero,one
      integer nframe,nprev
      integer ncrdsav,nstep
      integer nvelsav,ndfree
      integer nfixat,usebox
      integer use4d,usefq
      integer merged,vcharmm
      integer ntitle
      real*4 tdelta
      logical opened,first
      character*4 header
      character*240 dcdfile
c
c
c     open the output unit if not already done
c
      inquire (unit=idcd,opened=opened)
      if (.not. opened) then
         dcdfile = filename(1:leng)//'.dcd'
         call version (dcdfile,'new')
         open (unit=idcd,file=dcdfile,form='unformatted',status='new')
      end if
c
c     write header info along with title and number of atoms
c
      if (first) then
         first = .false.
         zero = 0
         one = 1
         header = 'CORD'
         nframe = zero
         nprev = zero
         ncrdsav = one
         nstep = zero
         nvelsav = zero
         ndfree = zero
         nfixat = zero
         tdelta = 0.0
         usebox = zero
         if (use_bounds)  usebox = one
         use4d = zero
         usefq = zero
         merged = zero
         vcharmm = 24
         ntitle = one
         write (idcd)  header,nframe,nprev,ncrdsav,nstep,
     &                 nvelsav,zero,zero,ndfree,nfixat,
     &                 tdelta,usebox,use4d,usefq,merged,
     &                 zero,zero,zero,zero,zero,vcharmm
         write (idcd)  ntitle,title(1:80)
         write (idcd)  n
      end if
c
c     append the lattice values based on header flag value;
c     using angle values is NAMD style, cosine values is CHARMM
c
      if (use_bounds) then
c        write (idcd)  xbox,gamma_cos,ybox,beta_cos,alpha_cos,zbox
         write (idcd)  xbox,gamma,ybox,beta,alpha,zbox
      end if
c
c     append the atomic coordinates along each axis in turn
c
      write (idcd)  (real(x(i)),i=1,n)
      write (idcd)  (real(y(i)),i=1,n)
      write (idcd)  (real(z(i)),i=1,n)
c
c     close the output unit if opened by this routine
c
      if (.not. opened)  close (unit=idcd)
      return
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 1997 by Rohit Pappu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  program pss  --  Cartesian potential smoothing & search  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "pss" implements the potential smoothing plus search method
c     for global optimization in Cartesian coordinate space with
c     local searches performed in Cartesian or torsional space
c
c     literature reference:
c
c     J. Kostrowicki and H. A. Scheraga, "Application of the Diffusion
c     Equation Method for Global Optimization to Oligopeptides", Journal
c     of Physical Chemistry, 96, 7442-7449 (1992)
c
c     S. Nakamura, H. Hirose, M. Ikeguchi and J. Doi, "Conformational
c     Energy Minimization Using a Two-Stage Method", Journal of Physical
c     Chemistry, 99, 8374-8378 (1995)
c
c
      program pss
      use atoms
      use inform
      use iounit
      use omega
      use refer
      use tree
      use warp
      implicit none
      integer i,next,range
      integer start,stop
      real*8 minimum,grdmin
      real*8 srchmax,rms
      real*8 ratio,sigmoid
      logical exist,check
      logical use_forward
      logical use_cart
      logical use_tors
      character*1 answer
      character*1 formtyp
      character*240 record
      character*240 string
c
c
c     set up the structure, mechanics calculation and smoothing
c
      call initial
      call getxyz
      use_smooth = .true.
      use_dem = .true.
      call mechanic
      iwrite = 0
c
c     get the number of points along the deformation schedule
c
      nlevel = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  nlevel
   10 continue
      if (nlevel .lt. 0) then
         write (iout,20)
   20    format (/,' Enter the Number of Steps for Smoothing Schedule',
     &              ' [100] :  ',$)
         read (input,30)  nlevel
   30    format (i10)
         if (nlevel .le. 0)  nlevel = 100
      end if
c
c     decide whether to use forward smoothing of initial structure
c
      use_forward = .true.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,40)
   40    format (/,' Perform Forward Smoothing from Input Structure',
     &              ' [Y] :  ',$)
         read (input,50)  record
   50    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'N')  use_forward = .false.
c
c     get the functional form for the deformation schedule
c
      formtyp = 'C'
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,60)
   60    format (/,' Use Quadratic, Cubic or Sigmoidal Schedule',
     &              ' (Q [C] or S) :  ',$)
         read (input,70)  record
   70    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'Q')  formtyp = answer
      if (answer .eq. 'S')  formtyp = answer
c
c     decide which type of local search procedure to use
c
      use_cart = .false.
      use_tors = .false.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,80)
   80    format (/,' Local Search Type - Cartesian, Torsional or None',
     &              ' (C T or [N]) :  ',$)
         read (input,90)  record
   90    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'C')  use_cart = .true.
      if (answer .eq. 'T')  use_tors = .true.
c
c     get the rotatable bonds for torsional local search
c
      if (use_tors) then
         call makeint (0)
         call initrot
         call active
      end if
c
c     get the number of eigenvectors to use for local search
c
      if (use_cart .or. use_tors) then
         start = -1
         stop = -1
         call nextarg (string,exist)
         if (exist)  read (string,*,err=100,end=100)  start
         call nextarg (string,exist)
         if (exist)  read (string,*,err=100,end=100)  stop
  100    continue
         if (stop .le. 0) then
            write (iout,110)
  110       format (/,' Enter the Range of Local Search Directions',
     &                 ' (1=Highest Freq) :  ',$)
            read (input,120)  record
  120       format (a240)
            read (record,*)  start,stop
            range = abs(stop-start)
            start = min(start,stop)
            stop = start + range
         end if
         if (use_cart)  stop = min(stop,3*n-6)
         if (use_tors)  stop = min(stop,nomega)
      end if
c
c     get the maximal smoothing level for use of local search
c
      if (use_cart .or. use_tors) then
         srchmax = -1.0d0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=130,end=130)  srchmax
  130    continue
         if (srchmax .lt. 0.0d0) then
            write (iout,140)
  140       format (/,' Enter the Largest Smoothing Level for',
     &                 ' Local Search [5.0] :  ',$)
            read (input,150)  srchmax
  150       format (f20.0)
            if (srchmax .lt. 0.0d0)  srchmax = 5.0d0
         end if
      end if
c
c     decide whether to use forward smoothing of initial structure
c
      check = .false.
      if ((use_cart .or. use_tors) .and. .not.use_forward) then
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,160)
  160       format (/,' Restrict Local Search to Children of Input',
     &                 ' Structure [N] :  ',$)
            read (input,170)  record
  170       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  check = .true.
      end if
c
c     get the termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=180,end=180)  grdmin
  180 continue
      if (grdmin .le. 0.0d0) then
         write (iout,190)
  190    format (/,' Enter RMS Gradient per Atom Criterion',
     &              ' [0.0001] :  ',$)
         read (input,200)  grdmin
  200    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.0001d0
c
c     compute the smoothing levels for the desired protocol
c
      do i = 0, nlevel
         ratio = 1.0d0 - dble(nlevel-i)/dble(nlevel)
         if (formtyp .eq. 'Q') then
            ilevel(i) = deform * ratio**2
         else if (formtyp .eq. 'C') then
            ilevel(i) = deform * ratio**3
         else if (formtyp .eq. 'S') then
            ilevel(i) = deform * sigmoid (12.0d0,ratio)
         end if
      end do
c
c     perform forward PSS by looping over smoothed surfaces
c
      if (use_forward) then
         do i = 0, nlevel-1
            deform = ilevel(i)
            call makeref (1)
            iprint = 1
            call localxyz (minimum,grdmin)
            call impose (n,xref,yref,zref,n,x,y,z,rms)
            call psswrite (i)
            write (iout,210)  minimum,deform
  210       format (/,' Final Function Value and Deformation :',2f15.4)
         end do
      end if
c
c     perform PSS reversal by looping over smoothed surfaces
c
      do i = nlevel, 0, -1
         deform = ilevel(i)
         call makeref (1)
         iprint = 1
         call localxyz (minimum,grdmin)
         call impose (n,xref,yref,zref,n,x,y,z,rms)
         if (i .eq. nlevel)  etree = minimum
         if (deform .le. srchmax) then
            if (use_cart) then
               call modecart (start,stop,minimum,grdmin,check)
            else if (use_tors) then
               call modetors (start,stop,minimum,grdmin,check)
            end if
         end if
         if (use_forward) then
            call psswrite (2*nlevel-i)
         else
            call psswrite (nlevel-i)
         end if
         write (iout,220)  minimum,deform
  220    format (/,' Final Function Value and Deformation :',2f15.4)
      end do
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  function pss1  --  energy and gradient values for PSS  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "pss1" is a service routine that computes the energy
c     and gradient during PSS global optimization in Cartesian
c     coordinate space
c
c
      function pss1 (xx,g)
      use atoms
      implicit none
      integer i,nvar
      real*8 pss1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the energy and gradient
c
      call gradient (e,derivs)
      pss1 = e
c
c     convert gradient components to optimization parameters
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         g(nvar) = derivs(1,i)
         nvar = nvar + 1
         g(nvar) = derivs(2,i)
         nvar = nvar + 1
         g(nvar) = derivs(3,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine pss2  --  Hessian matrix values for PSS  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "pss2" is a service routine that computes the sparse
c     matrix Hessian elements during PSS global optimization
c     in Cartesian coordinate space
c
c
      subroutine pss2 (mode,xx,h,hinit,hstop,hindex,hdiag)
      use atoms
      implicit none
      integer i,nvar
      integer hinit(*)
      integer hstop(*)
      integer hindex(*)
      real*8 xx(*)
      real*8 hdiag(*)
      real*8 h(*)
      character*4 mode
c
c
c     convert optimization parameters to atomic coordinates
c
      if (mode .eq. 'NONE')  return
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     compute and store the Hessian elements
c
      call hessian (h,hinit,hstop,hindex,hdiag)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine modecart  --  Cartesian local search for PSS  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine modecart (start,stop,minimum,grdmin,check)
      use atoms
      use iounit
      use omega
      use refer
      implicit none
      integer i,j,k,nfreq
      integer start,stop
      integer niter,nsearch
      real*8 minimum,grdmin
      real*8 minref,minbest
      real*8 eps,rms,size
      real*8, allocatable :: xbest(:)
      real*8, allocatable :: ybest(:)
      real*8, allocatable :: zbest(:)
      real*8, allocatable :: eigen(:)
      real*8, allocatable :: step(:,:)
      real*8, allocatable :: vects(:,:)
      logical done,check
c
c
c     store the current coordinates as the reference set
c
      call makeref (1)
c
c     set parameters related to the local search procedure
c
      done = .false.
      eps = 0.0001d0
      minref = minimum
      minbest = minimum
      niter = 0
c
c     perform dynamic allocation of some local arrays
c
      nfreq = 3 * n
      allocate (xbest(n))
      allocate (ybest(n))
      allocate (zbest(n))
      allocate (eigen(nfreq))
      allocate (step(3,nfreq))
      allocate (vects(nfreq,nfreq))
c
c     find local minimum along each of the steepest directions
c
      do while (.not. done)
         niter = niter + 1
         write (iout,10)  niter,minref
   10    format (/,' Cartesian Mode Search :',5x,'Iteration',i4,
     &              6x,'Energy',f12.4,/)
         call eigenxyz (eigen,vects)
c
c     search both directions along each eigenvector in turn
c
         nsearch = 0
         do i = start, stop
            do k = 1, n
               j = 3*(k-1)
               size = 1.0d0 / sqrt(abs(eigen(3*n-i+1)))
               step(1,k) = size * vects(j+1,3*n-i+1)
               step(2,k) = size * vects(j+2,3*n-i+1)
               step(3,k) = size * vects(j+3,3*n-i+1)
            end do
            nsearch = nsearch + 1
            call getref (1)
            call climbxyz (nsearch,minimum,step,grdmin,check)
            if (minimum .lt. minbest) then
               minbest = minimum
               do k = 1, n
                  xbest(k) = x(k)
                  ybest(k) = y(k)
                  zbest(k) = z(k)
               end do
            end if
            do k = 1, n
               step(1,k) = -step(1,k)
               step(2,k) = -step(2,k)
               step(3,k) = -step(3,k)
            end do
            nsearch = nsearch + 1
            call getref (1)
            call climbxyz (nsearch,minimum,step,grdmin,check)
            if (minimum .lt. minbest) then
               minbest = minimum
               do k = 1, n
                  xbest(k) = x(k)
                  ybest(k) = y(k)
                  zbest(k) = z(k)
               end do
            end if
         end do
c
c     check for convergence of the local search procedure
c
         if (minbest .lt. minref-eps) then
            done = .false.
            minref = minbest
            call impose (n,xref,yref,zref,n,xbest,ybest,zbest,rms)
            do k = 1, n
               x(k) = xbest(k)
               y(k) = ybest(k)
               z(k) = zbest(k)
            end do
            call makeref (1)
         else
            done = .true.
            minimum = minref
            call getref (1)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xbest)
      deallocate (ybest)
      deallocate (zbest)
      deallocate (eigen)
      deallocate (step)
      deallocate (vects)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine modetors  --  torsional local search for PSS  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine modetors (start,stop,minimum,grdmin,check)
      use atoms
      use iounit
      use omega
      use refer
      implicit none
      integer i,k
      integer start,stop
      integer niter,nsearch
      real*8 minimum,grdmin
      real*8 minref,minbest
      real*8 eps,rms
      real*8, allocatable :: xbest(:)
      real*8, allocatable :: ybest(:)
      real*8, allocatable :: zbest(:)
      real*8, allocatable :: step(:)
      real*8, allocatable :: eigen(:)
      real*8, allocatable :: vects(:,:)
      logical done,check
c
c
c     store the current coordinates as the reference set
c
      call makeref (1)
c
c     set parameters related to the local search procedure
c
      done = .false.
      eps = 0.0001d0
      minref = minimum
      minbest = minimum
      niter = 0
c
c     perform dynamic allocation of some local arrays
c
      allocate (xbest(n))
      allocate (ybest(n))
      allocate (zbest(n))
      allocate (step(nomega))
      allocate (eigen(nomega))
      allocate (vects(nomega,nomega))
c
c     find local minimum along each of the steepest directions
c
      do while (.not. done)
         niter = niter + 1
         write (iout,10)  niter,minref
   10    format (/,' Torsional Mode Search :',5x,'Iteration',i4,
     &              6x,'Energy',f12.4,/)
         call makeint (0)
         call eigentor (eigen,vects)
c
c     search both directions along each eigenvector in turn
c
         nsearch = 0
         do i = start, stop
            do k = 1, nomega
               step(k) = vects(k,nomega-i+1)
            end do
            nsearch = nsearch + 1
            call climbtor (nsearch,minimum,step,grdmin,check)
            if (minimum .lt. minbest) then
               minbest = minimum
               do k = 1, n
                  xbest(k) = x(k)
                  ybest(k) = y(k)
                  zbest(k) = z(k)
               end do
            end if
            do k = 1, nomega
               step(k) = -step(k)
            end do
            nsearch = nsearch + 1
            call climbtor (nsearch,minimum,step,grdmin,check)
            if (minimum .lt. minbest) then
               minbest = minimum
               do k = 1, n
                  xbest(k) = x(k)
                  ybest(k) = y(k)
                  zbest(k) = z(k)
               end do
            end if
         end do
c
c     check for convergence of the local search procedure
c
         if (minbest .lt. minref-eps) then
            done = .false.
            minref = minbest
            call impose (n,xref,yref,zref,n,xbest,ybest,zbest,rms)
            do k = 1, n
               x(k) = xbest(k)
               y(k) = ybest(k)
               z(k) = zbest(k)
            end do
            call makeref (1)
         else
            done = .true.
            minimum = minref
            call getref (1)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xbest)
      deallocate (ybest)
      deallocate (zbest)
      deallocate (step)
      deallocate (eigen)
      deallocate (vects)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eigenxyz  --  Cartesian Hessian eigenvectors  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine eigenxyz (eigen,vects)
      use atoms
      use hescut
      implicit none
      integer i,j,k,nfreq,ihess
      integer, allocatable :: hindex(:)
      integer, allocatable :: hinit(:,:)
      integer, allocatable :: hstop(:,:)
      real*8 eigen(*)
      real*8, allocatable :: matrix(:)
      real*8, allocatable :: h(:)
      real*8 vects(3*n,*)
      real*8, allocatable :: hdiag(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      nfreq = 3 * n
      allocate (hindex((nfreq*(nfreq-1))/2))
      allocate (hinit(3,n))
      allocate (hstop(3,n))
      allocate (matrix((nfreq*(nfreq+1))/2))
      allocate (h((nfreq*(nfreq-1))/2))
      allocate (hdiag(3,n))
c
c     compute the Hessian matrix in Cartesian space
c
      hesscut = 0.0d0
      call hessian (h,hinit,hstop,hindex,hdiag)
c
c     place Hessian elements into triangular form
c
      ihess = 0
      do i = 1, n
         do j = 1, 3
            ihess = ihess + 1
            matrix(ihess) = hdiag(j,i)
            do k = hinit(j,i), hstop(j,i)
               ihess = ihess + 1
               matrix(ihess) = h(k)
            end do
         end do
      end do
c
c     diagonalize the Hessian to obtain eigenvalues
c
      call diagq (nfreq,nfreq,matrix,eigen,vects)
c
c     perform deallocation of some local arrays
c
      deallocate (hindex)
      deallocate (hinit)
      deallocate (hstop)
      deallocate (matrix)
      deallocate (h)
      deallocate (hdiag)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eigentor  --  torsional Hessian eigenvectors  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine eigentor (eigen,vects)
      use atoms
      use omega
      implicit none
      integer i,j,ihess
      real*8 eigen(*)
      real*8, allocatable :: matrix(:)
      real*8 vects(nomega,*)
      real*8, allocatable :: hrot(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (matrix(nomega*(nomega+1)/2))
      allocate (hrot(nomega,nomega))
c
c     compute the Hessian in torsional space
c
      call hessrot ('FULL',hrot)
c
c     place Hessian elements into triangular form
c
      ihess = 0
      do i = 1, nomega
         do j = i, nomega
            ihess = ihess + 1
            matrix(ihess) = hrot(i,j)
         end do
      end do
c
c     diagonalize the Hessian to obtain eigenvalues
c
      call diagq (nomega,nomega,matrix,eigen,vects)
c
c     perform deallocation of some local arrays
c
      deallocate (matrix)
      deallocate (hrot)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine climbxyz  --  Cartesian local search direction  ##
c     ##                                                             ##
c     #################################################################
c
c
      subroutine climbxyz (nsearch,minimum,step,grdmin,check)
      use atoms
      use inform
      use iounit
      use refer
      implicit none
      integer maxstep
      parameter (maxstep=500)
      integer i,kstep
      integer nstep,nsearch
      real*8 minimum,grdmin
      real*8 parent
      real*8 energy,big
      real*8 step(3,*)
      real*8 estep(0:maxstep)
      logical done,check,keep
c
c
c     convert current reference coordinates to a Z-matrix
c
      call getref (1)
c
c     set the maximum number of steps and the step size
c
      done = .false.
      keep = .true.
      iprint = 0
      big = 1000000.0d0
      minimum = big
      kstep = 0
      nstep = 65
c
c     scan the search direction for a minimization candidate
c
      do while (.not. done)
         if (kstep .ne. 0) then
            do i = 1, n
               x(i) = x(i) + step(1,i)
               y(i) = y(i) + step(2,i)
               z(i) = z(i) + step(3,i)
            end do
         end if
         estep(kstep) = energy ()
         if (kstep .ge. 2) then
            if (estep(kstep) .lt. estep(kstep-2) .and.
     &          estep(kstep-1) .lt. estep(kstep-2)) then
               done = .true.
               do i = 1, n
                  x(i) = x(i) - step(1,i)
                  y(i) = y(i) - step(2,i)
                  z(i) = z(i) - step(3,i)
               end do
               call localxyz (minimum,grdmin)
               parent = minimum
               if (check)  call chktree (parent,grdmin,keep)
               if (minimum .ge. -big) then
                  if (check) then
                     write (iout,10)  nsearch,kstep-1,minimum,parent
   10                format (4x,'Search Direction',i4,10x,'Step',
     &                          i6,10x,2f12.4)
                  else
                     write (iout,20)  nsearch,kstep-1,minimum
   20                format (4x,'Search Direction',i4,10x,'Step',
     &                          i6,10x,f12.4)
                  end if
               else
                  minimum = big
                  write (iout,30)  nsearch
   30             format (4x,'Search Direction',i4,36x,'------')
               end if
               if (.not. keep)  minimum = big
            end if
         end if
         if (kstep.ge.nstep .and. .not.done) then
            done = .true.
            write (iout,40)  nsearch
   40       format (4x,'Search Direction',i4,36x,'------')
         end if
         kstep = kstep + 1
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine climbtor  --  torsional local search direction  ##
c     ##                                                             ##
c     #################################################################
c
c
      subroutine climbtor (nsearch,minimum,step,grdmin,check)
      use inform
      use iounit
      use math
      use omega
      use zcoord
      implicit none
      integer maxstep
      parameter (maxstep=500)
      integer i,kstep
      integer nstep,nsearch
      real*8 minimum,grdmin
      real*8 parent
      real*8 energy,big,size
      real*8 step(*)
      real*8 estep(0:maxstep)
      logical done,check,keep
c
c
c     convert current reference coordinates to a Z-matrix
c
      call getref (1)
      call makeint (0)
c
c     set the maximum number of steps and the step size
c
      done = .false.
      keep = .true.
      iprint = 0
      big = 1000000.0d0
      minimum = big
      kstep = 0
      nstep = 65
      size = 0.1d0 * radian
      do i = 1, nomega
         step(i) = size * step(i)
      end do
c
c     scan the search direction for a minimization candidate
c
      do while (.not. done)
         if (kstep .ne. 0) then
            do i = 1, nomega
               ztors(zline(i)) = ztors(zline(i)) + step(i)
            end do
         end if
         call makexyz
         estep(kstep) = energy ()
         if (kstep .ge. 2) then
            if (estep(kstep) .lt. estep(kstep-2) .and.
     &          estep(kstep-1) .lt. estep(kstep-2)) then
               done = .true.
               do i = 1, nomega
                  ztors(zline(i)) = ztors(zline(i)) - step(i)
               end do
               call makexyz
               call localxyz (minimum,grdmin)
               parent = minimum
               if (check)  call chktree (parent,grdmin,keep)
               if (minimum .ge. -big) then
                  if (check) then
                     write (iout,10)  nsearch,kstep-1,minimum,parent
   10                format (4x,'Search Direction',i4,10x,'Step',
     &                          i6,10x,2f12.4)
                  else
                     write (iout,20)  nsearch,kstep-1,minimum
   20                format (4x,'Search Direction',i4,10x,'Step',
     &                          i6,10x,f12.4)
                  end if
               else
                  minimum = big
                  write (iout,30)  nsearch
   30             format (4x,'Search Direction',i4,36x,'------')
               end if
               if (.not. keep)  minimum = big
            end if
         end if
         if (kstep.ge.nstep .and. .not.done) then
            done = .true.
            write (iout,40)  nsearch
   40       format (4x,'Search Direction',i4,36x,'------')
         end if
         kstep = kstep + 1
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine localxyz  --  PSS local search optimization  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "localxyz" is used during the potential smoothing and search
c     procedure to perform a local optimization at the current
c     smoothing level
c
c
      subroutine localxyz (minimum,grdmin)
      use atoms
      use inform
      implicit none
      integer i,nvar
      real*8 minimum
      real*8 grdmin
      real*8 pss1
      real*8, allocatable :: xx(:)
      logical oldverb
      character*6 mode
      character*6 method
      external pss1,pss2
      external optsave
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(3*n))
c
c     translate the coordinates of each atom
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         xx(nvar) = x(i)
         nvar = nvar + 1
         xx(nvar) = y(i)
         nvar = nvar + 1
         xx(nvar) = z(i)
      end do
c
c     make the call to the optimization routine
c
      oldverb = verbose
      verbose = .false.
      mode = 'AUTO'
      method = 'AUTO'
      call tncg (mode,method,nvar,xx,minimum,grdmin,
     &                  pss1,pss2,optsave)
      verbose = oldverb
c
c     untranslate the final coordinates for each atom
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine chktree  --  check for legitimacy of branch  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "chktree" tests a minimum energy structure to see if it
c     belongs to the correct progenitor in the existing map
c
c
      subroutine chktree (parent,grdmin,keep)
      use atoms
      use tree
      use warp
      implicit none
      integer i
      real*8 parent,grdmin
      real*8 deform0,eps
      real*8, allocatable :: x0(:)
      real*8, allocatable :: y0(:)
      real*8, allocatable :: z0(:)
      logical keep
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (x0(n))
      allocate (y0(n))
      allocate (z0(n))
c
c     store the current smoothing level and coordinates
c
      deform0 = deform
      do i = 1, n
         x0(i) = x(i)
         y0(i) = y(i)
         z0(i) = z(i)
      end do
c
c     forward smoothing optimizations back to highest level
c
      do i = 1, nlevel
         if (deform .lt. ilevel(i)) then
            deform = ilevel(i)
            call localxyz (parent,grdmin)
         end if
      end do
c
c     compare energy to reference value for this tree branch
c
      eps = 1.0d-4
      keep = .false.
      if (abs(parent-etree) .lt. eps)  keep = .true.
c
c     restore the original smoothing level and coordinates
c
      deform = deform0
      do i = 1, n
         x(i) = x0(i)
         y(i) = y0(i)
         z(i) = z0(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (x0)
      deallocate (y0)
      deallocate (z0)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine psswrite  --  output structures on PSS path  ##
c     ##                                                          ##
c     ##############################################################
c
c
      subroutine psswrite (i)
      use files
      implicit none
      integer i,ixyz
      integer lext,freeunit
      character*7 ext
      character*240 xyzfile
c
c
c     write the coordinates of the current minimum to a file
c
      lext = 3
      call numeral (i,ext,lext)
      ixyz = freeunit ()
      xyzfile = filename(1:leng)//'.'//ext(1:lext)
      call version (xyzfile,'new')
      open (unit=ixyz,file=xyzfile,status='new')
      call prtxyz (ixyz)
      close (unit=ixyz)
      return
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 1997 by Rohit Pappu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  program pssrigid  --  smoothing & search over rigid bodies  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "pssrigid" implements the potential smoothing plus search method
c     for global optimization for a set of rigid bodies
c
c     literature reference:
c
c     J. Kostrowicki and H. A. Scheraga, "Application of the Diffusion
c     Equation Method for Global Optimization to Oligopeptides", Journal
c     of Physical Chemistry, 96, 7442-7449 (1992)
c
c     S. Nakamura, H. Hirose, M. Ikeguchi and J. Doi, "Conformational
c     Energy Minimization Using a Two-Stage Method", Journal of Physical
c     Chemistry, 99, 8374-8378 (1995)
c
c
      program pssrigid
      use atoms
      use files
      use group
      use inform
      use iounit
      use math
      use molcul
      use refer
      use rigid
      use warp
      implicit none
      integer i,j,k,ixyz
      integer nvar,lext
      integer npoint,neigen
      integer next,freeunit
      real*8 minimum,grdmin
      real*8 srchmax,rms
      real*8 pssrgd1,deform0
      real*8 ratio,sigmoid
      real*8, allocatable :: xx(:)
      logical exist
      logical use_local
      character*1 answer
      character*7 ext
      character*240 xyzfile
      character*240 record
      character*240 string
      external pssrgd1
      external optsave
c
c
c     set up the structure, mechanics calculation and smoothing
c
      call initial
      call getxyz
      use_smooth = .true.
      use_dem = .true.
      call mechanic
c
c     get rigid body coordinates and save the Cartesian coordinates
c
      use_rigid = .true.
      call orient
      call makeref (1)
c
c     set maximum deformation value and disable coordinate saves
c
      deform0 = deform
      iwrite = 0
c
c     get the number of points along the deformation schedule
c
      npoint = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  npoint
   10 continue
      if (npoint .lt. 0) then
         write (iout,20)
   20    format (/,' Enter the Number of Steps for the PSS Schedule',
     &              ' [100] :  ',$)
         read (input,30)  npoint
   30    format (i10)
         if (npoint .le. 0)  npoint = 100
      end if
c
c     decide whether to use the local search procedure
c
      use_local = .false.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,40)
   40    format (/,' Use Local Search to Explore Each Smoothing Level',
     &              ' [N] :  ',$)
         read (input,50)  record
   50    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'Y')  use_local = .true.
c
c     get the number of eigenvectors to use for the local search
c
      if (use_local) then
         neigen = -1
         call nextarg (string,exist)
         if (exist)  read (string,*,err=60,end=60)  neigen
   60    continue
         if (neigen .le. 0) then
            nvar = 6 * (ngrp-1)
            write (iout,70)  nvar
   70       format (/,' Enter the Number of Directions for Local',
     &                 ' Search [',i2,'] :  ',$)
            read (input,80)  neigen
   80       format (i10)
            if (neigen .gt. nvar)  neigen = nvar
         end if
      end if
c
c     get the maximal smoothing level for use of local search
c
      if (use_local) then
         srchmax = -1.0d0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=90,end=90)  srchmax
   90    continue
         if (srchmax .lt. 0.0d0) then
            write (iout,100)
  100       format (/,' Enter the Largest Smoothing Value for Local',
     &                 ' Search [5.0] :  ',$)
            read (input,110)  srchmax
  110       format (f20.0)
            if (srchmax .lt. 0.0d0)  srchmax = 5.0d0
         end if
      end if
c
c     get the termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=120,end=120)  grdmin
  120 continue
      if (grdmin .le. 0.0d0) then
         write (iout,130)
  130    format (/,' Enter RMS Gradient per Rigid Body Criterion',
     &              ' [0.0001] :  ',$)
         read (input,140)  grdmin
  140    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.0001d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(6*ngrp))
c
c     perform PSS iteration by looping over smoothed surfaces
c
      do k = 0, 2*npoint
         ratio = 1.0d0 - dble(abs(npoint-k))/dble(npoint)
         if (nmol .eq. 1) then
            deform = deform0 * ratio**3
         else
            deform = deform0 * sigmoid (12.0d0,ratio)
         end if
c
c     convert rigid body coordinates to optimization parameters
c
         nvar = 0
         do i = 1, ngrp
            do j = 1, 6
               nvar = nvar + 1
               xx(nvar) = rbc(j,i)
            end do
         end do
c
c     make the call to the variable metric optimization routine
c
         iprint = 1
         call ocvm (nvar,xx,minimum,grdmin,pssrgd1,optsave)
c
c     convert optimization parameters to rigid body coordinates
c
         nvar = 0
         do i = 1, ngrp
            do j = 1, 6
               nvar = nvar + 1
               rbc(j,i) = xx(nvar)
            end do
         end do
c
c     use normal mode local search to explore adjacent minima
c
         if (use_local) then
            if (deform.le.srchmax .and. k.ge.npoint)
     &         call modergd (neigen,minimum,grdmin)
         end if
c
c     write out final energy function value and smoothing level
c
         write (iout,150)  minimum,deform
  150    format (/,' Final Function Value and Deformation :',2f15.4)
c
c     get Cartesian coordinates and superimpose on reference
c
         call rigidxyz
         if (igrp(1,1).eq.1 .and. igrp(2,ngrp).eq.n)
     &      call impose (n,xref,yref,zref,n,x,y,z,rms)
c
c     write the coordinates of the current minimum to a file
c
         lext = 3
         call numeral (k,ext,lext)
         ixyz = freeunit ()
         xyzfile = filename(1:leng)//'.'//ext(1:lext)
         call version (xyzfile,'new')
         open (unit=ixyz,file=xyzfile,status='new')
         call prtxyz (ixyz)
         close (unit=ixyz)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function pssrgd1  --  energy and gradient values for PSS  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "pssrgd1" is a service routine that computes the energy and
c     gradient during PSS global optimization over rigid bodies
c
c
      function pssrgd1 (xx,g)
      use group
      use math
      use rigid
      implicit none
      integer i,j,nvar
      real*8 pssrgd1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to rigid body coordinates
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            rbc(j,i) = xx(nvar)
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(6,ngrp))
c
c     compute and store the energy and gradient
c
      call rigidxyz
      call gradrgd (e,derivs)
      pssrgd1 = e
c
c     convert gradient components to optimization parameters
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            g(nvar) = derivs(j,i)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine modergd  --  local search for rigid body PSS  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine modergd (neigen,minimum,grdmin)
      use group
      use iounit
      use rigid
      use sizes
      implicit none
      integer maxrgd
      parameter (maxrgd=6*maxgrp)
      integer i,j,k
      integer neigen,ndoi
      integer nvar,nsearch
      real*8 minimum,grdmin
      real*8 eps,minref,minbest
      real*8, allocatable :: step(:)
      real*8, allocatable :: eigen(:)
      real*8, allocatable :: rorig(:,:)
      real*8, allocatable :: rbest(:,:)
      real*8, allocatable :: vects(:,:)
      logical done
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (step(ngrp))
      allocate (eigen(ngrp))
      allocate (rorig(6,ngrp))
      allocate (rbest(6,ngrp))
      allocate (vects(6*ngrp,6*ngrp))
c
c     set parameters related to the local search procedure
c
      done = .false.
      eps = 0.0001d0
      minref = minimum
      minbest = minimum
      ndoi = 0
      nvar = 6 * ngrp
      do i = 1, ngrp
         do j = 1, 6
            rorig(j,i) = rbc(j,i)
         end do
      end do
c
c     find local minimum along each of the steepest directions
c
      do while (.not. done)
         ndoi = ndoi + 1
         write (iout,10)  ndoi,minref
   10    format (/,' Normal Mode Search :',8x,'Iteration',i4,
     &              6x,'Energy',f12.4,/)
         call rigidxyz
         call eigenrgd (eigen,vects)
c
c     search both directions along each eigenvector in turn
c
         nsearch = 0
         do i = 1, neigen
            do k = 1, nvar
               step(k) = vects(k,nvar-i+1)
            end do
            do k = 1, ngrp
               do j = 1, 6
                  rbc(j,k) = rorig(j,k)
               end do
            end do
            nsearch = nsearch + 1
            call climbrgd (nsearch,minimum,step,grdmin)
            if (minimum .lt. minbest) then
               minbest = minimum
               do k = 1, ngrp
                  do j = 1, 6
                     rbest(j,k) = rbc(j,k)
                  end do
               end do
            end if
            do k = 1, nvar
               step(k) = -vects(k,nvar-i+1)
            end do
            do k = 1, ngrp
               do j = 1, 6
                  rbc(j,k) = rorig(j,k)
               end do
            end do
            nsearch = nsearch + 1
            call climbrgd (nsearch,minimum,step,grdmin)
            if (minimum .lt. minbest) then
               minbest = minimum
               do k = 1, ngrp
                  do j = 1, 6
                     rbest(j,k) = rbc(j,k)
                  end do
               end do
            end if
         end do
c
c     check for convergence of the local search procedure
c
         if (minbest .lt. minref-eps) then
            done = .false.
            minref = minbest
            do k = 1, ngrp
               do j = 1, 6
                  rorig(j,k) = rbest(j,k)
               end do
            end do
         else
            done = .true.
            minimum = minref
            do k = 1, ngrp
               do j = 1, 6
                  rbc(j,k) = rorig(j,k)
               end do
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (step)
      deallocate (eigen)
      deallocate (rorig)
      deallocate (rbest)
      deallocate (vects)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eigenrgd  --  rigid body Hessian eigenvectors  ##
c     ##                                                            ##
c     ################################################################
c
c
      subroutine eigenrgd (eigen,vects)
      use atoms
      use group
      implicit none
      integer maxrgd
      parameter (maxrgd=6*maxgrp)
      integer i,j
      integer ihess,nvar
      real*8 vnorm
      real*8 eigen(*)
      real*8, allocatable :: matrix(:)
      real*8 vects(6*ngrp,*)
      real*8, allocatable :: hrigid(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (matrix(6*ngrp*(6*ngrp+1)/2))
      allocate (hrigid(6*ngrp,6*ngrp))
c
c     compute the Hessian for rigid body motion
c
      call hessrgd (hrigid)
c
c     place Hessian elements into triangular form
c
      nvar = 6 * ngrp
      ihess = 0
      do i = 1, nvar
         do j = i, nvar
            ihess = ihess + 1
            matrix(ihess) = hrigid(i,j)
         end do
      end do
c
c     diagonalize the Hessian to obtain eigenvalues
c
      call diagq (nvar,nvar,matrix,eigen,vects)
c
c     normalize the rigid body Hessian eigenvectors
c
      do i = 1, nvar
         vnorm = 0.0d0
         do j = 1, nvar
            vnorm = vnorm + vects(j,i)**2
         end do
         vnorm = sqrt(vnorm)
         do j = 1, nvar
            vects(j,i) = vects(j,i) / vnorm
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (matrix)
      deallocate (hrigid)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine climbrgd  --  minimum from a PSS local search  ##
c     ##                                                            ##
c     ################################################################
c
c
      subroutine climbrgd (nsearch,minimum,step,grdmin)
      use group
      use iounit
      use math
      use rigid
      implicit none
      integer maxstep
      parameter (maxstep=500)
      integer i,j,nsearch
      integer nvar,kstep,nstep
      real*8 minimum,grdmin
      real*8 big,energy,size
      real*8 estep(0:maxstep)
      real*8 step(*)
      logical done
c
c
c     set the maximum number of steps and the step size
c
      done = .false.
      big = 100000.0d0
      minimum = big
      kstep = 0
      nstep = 65
c     size = 0.1d0
      size = 1.0d0
      nvar = 6 * ngrp
      do i = 1, nvar
         step(i) = size * step(i)
      end do
c
c     scan the search direction for a minimization candidate
c
      do while (.not. done)
         if (kstep .ne. 0) then
            nvar = 0
            do i = 1, ngrp
               do j = 1, 6
                  nvar = nvar + 1
                  rbc(j,i) = rbc(j,i) + step(nvar)
               end do
            end do
         end if
         call rigidxyz
         estep(kstep) = energy ()
         if (kstep.ge.2 .and. estep(kstep).le.10000.0d0) then
            if (estep(kstep) .lt. estep(kstep-2) .and.
     &          estep(kstep-1) .lt. estep(kstep-2)) then
               done = .true.
               nvar = 0
               do i = 1, ngrp
                  do j = 1, 6
                     nvar = nvar + 1
                     rbc(j,i) = rbc(j,i) - step(nvar)
                  end do
               end do
               call rigidxyz
               call localrgd (minimum,grdmin)
               if (minimum .ge. -big) then
                  write (iout,10)  nsearch,kstep-1,minimum
   10             format (4x,'Search Direction',i4,10x,'Step',
     &                       i6,10x,f12.4)
               else
                  minimum = big
                  write (iout,20)  nsearch
   20             format (4x,'Search Direction',i4,36x,'------')
               end if
            end if
         end if
         if (kstep.ge.nstep .and. .not.done) then
            done = .true.
            write (iout,30)  nsearch
   30       format (4x,'Search Direction',i4,36x,'------')
         end if
         kstep = kstep + 1
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine localrgd  --  PSS local search optimization  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "localrgd" is used during the PSS local search procedure
c     to perform a rigid body energy minimization
c
c
      subroutine localrgd (minimum,grdmin)
      use inform
      use group
      use minima
      use rigid
      implicit none
      integer i,j,nvar
      integer oldprt
      real*8 minimum
      real*8 grdmin
      real*8 pssrgd1
      real*8, allocatable :: xx(:)
      logical oldverb
      external pssrgd1
      external optsave
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(6*ngrp))
c
c     convert rigid body coordinates to optimization parameters
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            xx(nvar) = rbc(j,i)
         end do
      end do
c
c     make the call to the optimization routine
c
      oldverb = verbose
      oldprt = iprint
      verbose = .false.
      iprint = 0
      call ocvm (nvar,xx,minimum,grdmin,pssrgd1,optsave)
      verbose = oldverb
      iprint = oldprt
c
c     convert optimization parameters to rigid body coordinates
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            rbc(j,i) = xx(nvar)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      return
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 1997 by Rohit Pappu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  program pssrot  --  torsional potential smoothing & search  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "pssrot" implements the potential smoothing plus search method
c     for global optimization in torsional space
c
c     literature reference:
c
c     J. Kostrowicki and H. A. Scheraga, "Application of the Diffusion
c     Equation Method for Global Optimization to Oligopeptides", Journal
c     of Physical Chemistry, 96, 7442-7449 (1992)
c
c     S. Nakamura, H. Hirose, M. Ikeguchi and J. Doi, "Conformational
c     Energy Minimization Using a Two-Stage Method", Journal of Physical
c     Chemistry, 99, 8374-8378 (1995)
c
c
      program pssrot
      use atoms
      use files
      use inform
      use iounit
      use math
      use omega
      use refer
      use warp
      use zcoord
      implicit none
      integer i,k
      integer ixyz,next
      integer npoint,neigen
      integer lext,freeunit
      real*8 minimum,grdmin
      real*8 pssrot1,rms
      real*8 srchmax
      real*8 deform0,ratio
      real*8, allocatable :: xx(:)
      logical exist
      logical use_local
      character*1 answer
      character*7 ext
      character*240 xyzfile
      character*240 record
      character*240 string
      external pssrot1
      external optsave
c
c
c     set up the structure, mechanics calculation and smoothing
c
      call initial
      call getint
      use_smooth = .true.
      use_dem = .true.
      call mechanic
      call initrot
c
c     convert to Cartesian coordinates and save the initial set
c
      call makexyz
      call makeref (1)
c
c     set maximum deformation value and disable coordinate saves
c
      deform0 = deform
      iwrite = 0
c
c     get the number of points along the deformation schedule
c
      npoint = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  npoint
   10 continue
      if (npoint .lt. 0) then
         write (iout,20)
   20    format (/,' Enter the Number of Steps for the PSS Schedule',
     &              ' [100] :  ',$)
         read (input,30)  npoint
   30    format (i10)
         if (npoint .le. 0)  npoint = 100
      end if
c
c     decide whether to use the local search procedure
c
      use_local = .false.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,40)
   40    format (/,' Use Local Search to Explore the Smoothing Levels',
     &              ' [N] :  ',$)
         read (input,50)  record
   50    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'Y')  use_local = .true.
c
c     get the number of eigenvectors to use for the local search
c
      if (use_local) then
         neigen = -1
         call nextarg (string,exist)
         if (exist)  read (string,*,err=60,end=60)  neigen
   60    continue
         if (neigen .le. 0) then
            write (iout,70)
   70       format (/,' Enter the Number of Directions for Local',
     &                 ' Search [5] :  ',$)
            read (input,80)  neigen
   80       format (i10)
            if (neigen .le. 0)  neigen = 5
         end if
      end if
c
c     get the maximal smoothing level for use of local search
c
      if (use_local) then
         srchmax = -1.0d0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=90,end=90)  srchmax
   90    continue
         if (srchmax .lt. 0.0d0) then
            write (iout,100)
  100       format (/,' Enter the Largest Smoothing Value for Local',
     &                 ' Search [5.0] :  ',$)
            read (input,110)  srchmax
  110       format (f20.0)
            if (srchmax .lt. 0.0d0)  srchmax = 5.0d0
         end if
      end if
c
c     get the termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=120,end=120)  grdmin
  120 continue
      if (grdmin .le. 0.0d0) then
         write (iout,130)
  130    format (/,' Enter RMS Gradient per Atom Criterion',
     &              ' [0.0001] :  ',$)
         read (input,140)  grdmin
  140    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.0001d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nomega))
c
c     perform PSS iteration by looping over smoothed surfaces
c
      do k = 0, 2*npoint
         ratio = 1.0d0 - dble(abs(npoint-k))/dble(npoint)
         deform = deform0 * ratio**3
c
c     translate the initial coordinates
c
         do i = 1, nomega
            xx(i) = dihed(i)
         end do
c
c     make the call to the variable metric optimization routine
c
         iprint = 1
         call ocvm (nomega,xx,minimum,grdmin,pssrot1,optsave)
c
c     untranslate the final coordinates for each atom
c
         do i = 1, nomega
            dihed(i) = xx(i)
            ztors(zline(i)) = dihed(i) * radian
         end do
c
c     use normal mode local search to explore adjacent minima
c
         if (use_local) then
            if (k.ge.npoint .and. deform.le.srchmax)
     &         call moderot (neigen,minimum,grdmin)
         end if
c
c     write out final energy function value and smoothing level
c
         write (iout,150)  minimum,deform
  150    format (/,' Final Function Value and Deformation :',2f15.4)
c
c     get Cartesian coordinates and superimpose on reference
c
         call makexyz
         call impose (n,xref,yref,zref,n,x,y,z,rms)
c
c     write the coordinates of the current minimum to a file
c
         lext = 3
         call numeral (k,ext,lext)
         ixyz = freeunit ()
         xyzfile = filename(1:leng)//'.'//ext(1:lext)
         call version (xyzfile,'new')
         open (unit=ixyz,file=xyzfile,status='new')
         call prtxyz (ixyz)
         close (unit=ixyz)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function pssrot1  --  energy and gradient values for PSS  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "pssrot1" is a service routine that computes the energy and
c     gradient during PSS global optimization in torsional space
c
c
      function pssrot1 (xx,g)
      use math
      use omega
      use zcoord
      implicit none
      integer i
      real*8 pssrot1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:)
c
c
c     translate optimization variables into dihedrals
c
      do i = 1, nomega
         dihed(i) = xx(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(nomega))
c
c     compute and store the energy and gradient
c
      call makexyz
      call gradrot (e,derivs)
      pssrot1 = e
c
c     store torsional gradient as optimization gradient
c
      do i = 1, nomega
         g(i) = derivs(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine moderot  --  torsional local search for PSS  ##
c     ##                                                          ##
c     ##############################################################
c
c
      subroutine moderot (neigen,minimum,grdmin)
      use iounit
      use math
      use omega
      use zcoord
      implicit none
      integer i,k,neigen
      integer ndoi,nsearch
      real*8 minimum,grdmin
      real*8 eps,minref,minbest
      real*8, allocatable :: step(:)
      real*8, allocatable :: eigen(:)
      real*8, allocatable :: zorig(:)
      real*8, allocatable :: zbest(:)
      real*8, allocatable :: vects(:,:)
      logical done
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (step(nomega))
      allocate (eigen(nomega))
      allocate (zorig(nomega))
      allocate (zbest(nomega))
      allocate (vects(nomega,nomega))
c
c     set parameters related to the local search procedure
c
      done = .false.
      eps = 0.0001d0
      minref = minimum
      minbest = minimum
      ndoi = 0
      do k = 1, nomega
         zorig(k) = ztors(zline(k))
      end do
c
c     find local minimum along each of the steepest directions
c
      do while (.not. done)
         ndoi = ndoi + 1
         write (iout,10)  ndoi,minref
   10    format (/,' Torsional Mode Search :',5x,'Iteration',i4,
     &              6x,'Energy',f12.4,/)
         call makexyz
         call eigenrot (eigen,vects)
c
c     search both directions along each eigenvector in turn
c
         nsearch = 0
         do i = 1, neigen
            do k = 1, nomega
               step(k) = vects(k,nomega-i+1)
               ztors(zline(k)) = zorig(k)
            end do
            nsearch = nsearch + 1
            call climbrot (nsearch,minimum,step,grdmin)
            if (minimum .lt. minbest) then
               minbest = minimum
               do k = 1, nomega
                  zbest(k) = ztors(zline(k))
               end do
            end if
            do k = 1, nomega
               step(k) = -vects(k,nomega-i+1)
               ztors(zline(k)) = zorig(k)
            end do
            nsearch = nsearch + 1
            call climbrot (nsearch,minimum,step,grdmin)
            if (minimum .lt. minbest) then
               minbest = minimum
               do k = 1, nomega
                  zbest(k) = ztors(zline(k))
               end do
            end if
         end do
c
c     check for convergence of the local search procedure
c
         if (minbest .lt. minref-eps) then
            done = .false.
            minref = minbest
            do k = 1, nomega
               zorig(k) = zbest(k)
            end do
         else
            done = .true.
            minimum = minref
            do k = 1, nomega
               dihed(k) = zorig(k) / radian
               ztors(zline(k)) = zorig(k)
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (step)
      deallocate (eigen)
      deallocate (zorig)
      deallocate (zbest)
      deallocate (vects)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eigenrot  --  torsional Hessian eigenvectors  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine eigenrot (eigen,vects)
      use atoms
      use omega
      implicit none
      integer i,j,ihess
      real*8 eigen(*)
      real*8, allocatable :: matrix(:)
      real*8 vects(nomega,*)
      real*8, allocatable :: hrot(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (matrix(nomega*(nomega+1)/2))
      allocate (hrot(nomega,nomega))
c
c     compute the Hessian in torsional space
c
      call hessrot ('FULL',hrot)
c
c     place Hessian elements into triangular form
c
      ihess = 0
      do i = 1, nomega
         do j = i, nomega
            ihess = ihess + 1
            matrix(ihess) = hrot(i,j)
         end do
      end do
c
c     diagonalize the Hessian to obtain eigenvalues
c
      call diagq (nomega,nomega,matrix,eigen,vects)
c
c     perform deallocation of some local arrays
c
      deallocate (matrix)
      deallocate (hrot)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine climbrot  --  minimum from a PSS local search  ##
c     ##                                                            ##
c     ################################################################
c
c
      subroutine climbrot (nsearch,minimum,step,grdmin)
      use iounit
      use math
      use omega
      use zcoord
      implicit none
      integer maxstep
      parameter (maxstep=500)
      integer i,nsearch
      integer kstep,nstep
      real*8 minimum,grdmin
      real*8 energy
      real*8 big,small,size
      real*8 estep(0:maxstep)
      real*8 step(*)
      logical done
c
c
c     set the maximum number of steps and the step size
c
      done = .false.
      big = 1.0d10
      small = -1.0d5
      minimum = big
      kstep = 0
      nstep = 65
      size = 0.1d0 * radian
      do i = 1, nomega
         step(i) = size * step(i)
      end do
c
c     scan the search direction for a minimization candidate
c
      do while (.not. done)
         if (kstep .ne. 0) then
            do i = 1, nomega
               ztors(zline(i)) = ztors(zline(i)) + step(i)
            end do
         end if
         call makexyz
         estep(kstep) = energy ()
         if (kstep .ge. 2) then
            if (estep(kstep) .lt. estep(kstep-2) .and.
     &          estep(kstep-1) .lt. estep(kstep-2)) then
               done = .true.
               do i = 1, nomega
                  ztors(zline(i)) = ztors(zline(i)) - step(i)
               end do
               call makexyz
               call localrot (minimum,grdmin)
               if (minimum .ge. small) then
                  write (iout,10)  nsearch,kstep-1,minimum
   10             format (4x,'Search Direction',i4,10x,'Step',
     &                       i6,10x,f12.4)
               else
                  minimum = big
                  write (iout,20)  nsearch
   20             format (4x,'Search Direction',i4,36x,'------')
               end if
            end if
         end if
         if (kstep.ge.nstep .and. .not.done) then
            done = .true.
            write (iout,30)  nsearch
   30       format (4x,'Search Direction',i4,36x,'------')
         end if
         kstep = kstep + 1
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine localrot  --  PSS local search optimization  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "localrot" is used during the PSS local search procedure
c     to perform a torsional space energy minimization
c
c
      subroutine localrot (minimum,grdmin)
      use inform
      use minima
      use math
      use omega
      use zcoord
      implicit none
      integer i,oldprt
      real*8 minimum
      real*8 grdmin
      real*8 pssrot1
      real*8, allocatable :: xx(:)
      logical oldverb
      external pssrot1
      external optsave
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nomega))
c
c     translate the coordinates of each atom
c
      do i = 1, nomega
         dihed(i) = ztors(zline(i)) / radian
         xx(i) = dihed(i)
      end do
c
c     make the call to the optimization routine
c
      oldverb = verbose
      oldprt = iprint
      verbose = .false.
      iprint = 0
      call ocvm (nomega,xx,minimum,grdmin,pssrot1,optsave)
      verbose = oldverb
      iprint = oldprt
c
c     untranslate the final coordinates for each atom
c
      do i = 1, nomega
         dihed(i) = xx(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2012  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module ptable  --  symbols and info for chemical elements  ##
c     ##                                                             ##
c     #################################################################
c
c
c     maxele   maximum number of elements from periodic table
c
c     atmass   standard atomic weight for each chemical element
c     vdwrad   van der Waals radius for each chemical element
c     covrad   covalent radius for each chemical element
c     elemnt   atomic symbol for each chemical element
c
c
      module ptable
      implicit none
      integer maxele
      parameter (maxele=118)
      real*8 atmass(maxele)
      real*8 vdwrad(maxele)
      real*8 covrad(maxele)
      character*3 elemnt(maxele)
      save
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2009 by Chuanjie Wu and Jay William Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##   module qmstuf  --  quantum data from Gaussian calculation  ##
c     ##                                                              ##
c     ##################################################################
c
c   
c     ngatom   number of atoms in the QM data file
c     egau     quantum mechanical (QM) total energy (kcal/mole)
c     gx       x-coordinate of each atom in the QM data file
c     gy       y-coordinate of each atom in the QM data file
c     gz       z-coordinate of each atom in the QM data file
c     gfreq    calculated vibrational frequencies from QM data
c     gforce   force components on each atom from QM data
c     gh       Hessian matrix elements from QM data
c
c
      module qmstuf
      implicit none
      integer ngatom
      real*8 egau
      real*8, allocatable :: gx(:)
      real*8, allocatable :: gy(:)
      real*8, allocatable :: gz(:)
      real*8, allocatable :: gfreq(:)
      real*8, allocatable :: gforce(:,:)
      real*8, allocatable :: gh(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine qrfact  --  rectangular matrix QR factorization  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "qrfact" computes the QR factorization of an m by n matrix via
c     a Householder transformations with optional column pivoting;
c     it finds an orthogonal matrix q, permutation matrix p, and upper
c     trapezoidal matrix r with diagonal elements of nonincreasing
c     magnitude, such that a*p = q*r; the Householder transformation
c     for column k, k = 1,2,...,min(m,n), is of the form:
c
c               i - (1/u(k))*u*u(transpose)
c
c     where u has zeros in the first k-1 positions
c
c     arguments and variables:
c
c     n        number of columns in the "a" matrix
c     m        number of rows in the "a" matrix
c     a        on input contains the m by n matrix for which the QR
c                factorization is to be computed; on output the
c                strict upper trapezoidal part contains the strict
c                upper trapezoidal part of r, the lower trapezoidal
c                part contains a factored form of q
c     pivot    logical flag governing use of pivoting
c     ipvt     integer output array which defines the permutation
c                matrix p such that a*p = q*r; column j of p is
c                column ipvt(j) of the identity matrix
c     rdiag    output vector of length n with diagonal elements of r
c
c
      subroutine qrfact (n,m,a,pivot,ipvt,rdiag)
      implicit none
      integer i,j,k
      integer m,n,minmn
      integer jmax,itemp
      integer ipvt(*)
      real*8 aknorm,temp
      real*8 rdiag(*)
      real*8, allocatable :: work(:)
      real*8 a(m,*)
      logical pivot
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (work(n))
c
c     initialize variables, and find the initial column norms
c
      do j = 1, n
         temp = 0.0d0
         do i = 1, m
            temp = temp + a(i,j)**2
         end do
         rdiag(j) = sqrt(temp)
         work(j) = rdiag(j)
         if (pivot)  ipvt(j) = j
      end do
c
c     bring the column of largest norm into the pivot position
c
      minmn = min(m,n)
      do k = 1, minmn
         if (pivot) then
            jmax = k
            do j = k, n
               if (rdiag(j) .gt. rdiag(jmax))  jmax = j
            end do
            if (jmax .ne. k) then
               do i = 1, m
                  temp = a(i,k)
                  a(i,k) = a(i,jmax)
                  a(i,jmax) = temp
               end do
               rdiag(jmax) = rdiag(k)
               work(jmax) = work(k)
               itemp = ipvt(k)
               ipvt(k) = ipvt(jmax)
               ipvt(jmax) = itemp
            end if
         end if
c
c     compute the Householder transformation to reduce the
c     k-th column of "a" to a multiple of the k-th unit vector
c
         aknorm = 0.0d0
         do i = k, m
            aknorm = aknorm + a(i,k)**2
         end do
         aknorm = sqrt(aknorm)
         if (aknorm .ne. 0.0d0) then
            if (a(k,k) .lt. 0.0d0)  aknorm = -aknorm
            do i = k, m
               a(i,k) = a(i,k) / aknorm
            end do
            a(k,k) = a(k,k) + 1.0d0
c
c     apply transform to remaining columns and update column norms
c
            if (n .ge. k+1) then
               do j = k+1, n
                  temp = 0.0d0
                  do i = k, m
                     temp = temp + a(i,k)*a(i,j)
                  end do
                  temp = temp / a(k,k)
                  do i = k, m
                     a(i,j) = a(i,j) - temp*a(i,k)
                  end do
                  if (pivot .and. rdiag(j).ne.0.0d0) then
                     temp = a(k,j) / rdiag(j)
                     if (abs(temp) .lt. 1.0d0) then
                        rdiag(j) = rdiag(j) * sqrt(1.0d0-temp**2)
                     else
                        temp = 0.0d0
                        do i = k+1, m
                           temp = temp + a(i,j)**2
                        end do
                        rdiag(j) = sqrt(temp)
                        work(j) = rdiag(j)
                     end if
                  end if
               end do
            end if
         end if
         rdiag(k) = -aknorm
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (work)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine qrsolve  --  triangular least squares solution  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "qrsolve" solves a*x = b and d*x = 0 in the least squares sense;
c     used with routine "qrfact" to solve least squares problems
c
c     arguments and variables:
c
c     n        number of rows and columns in the matrix r
c     np       leading physical dimension of r in the calling program
c     r        on input, an n by n array with the upper triangular
c                matrix r; on output the full triangle is unaltered,
c                and the strict lower triangle contains the transpose
c                of the strict upper triangular matrix s
c     ipvt     vector of length n which defines the permutation
c                matrix p such that a*p = q*r; column j of p is
c                column ipvt(j) of the identity matrix
c     diag     vector of length n containing the diagonal elements
c                of the matrix d
c     qtb      vector of length n containing the first n elements
c                of the vector q(transpose)*b
c     x        vector of length n containing the least squares
c                solution of the systems a*x = b and d*x = 0
c     sdiag    vector of length n containing the diagonal elements
c                of the upper triangular matrix s
c     xpvt     vector of length n containing permuted (pivoted)
c                solution of the systems
c
c
      subroutine qrsolve (n,np,r,ipvt,diag,qtb,x,sdiag,xpvt)
      implicit none
      integer i,j,k,jj
      integer n,np,nsing
      integer ipvt(*)
      real*8 sine,cosine
      real*8 tangent
      real*8 cotangent
      real*8 qtbpj,temp
      real*8 diag(*)
      real*8 qtb(*)
      real*8 x(*)
      real*8 sdiag(*)
      real*8 xpvt(*)
      real*8 r(np,*)
c
c
c     copy r and (q transpose)*b to preserve input and initialize s;
c     in particular, save the diagonal elements of r in x
c
      do j = 1, n-1
         do k = j+1, n
            r(k,j) = r(j,k)
         end do
      end do
      do j = 1, n
         x(j) = r(j,j)
         xpvt(j) = qtb(j)
      end do
c
c     eliminate the diagonal matrix d using a Givens rotation;
c     first, prepare the row of d to be eliminated, locating
c     the diagonal element from the QR factorization
c
      do j = 1, n
         jj = ipvt(j)
         if (diag(jj) .ne. 0.0d0) then
            do k = j, n
               sdiag(k) = 0.0d0
            end do
            sdiag(j) = diag(jj)
c
c     transform to eliminate the row of d modify only one element
c     of (q transpose)*b beyond the first n, which is initially zero
c
            qtbpj = 0.0d0
            do k = j, n
c
c     determine a Givens rotation which eliminates the
c     appropriate element in the current row of d
c
               if (sdiag(k) .ne. 0.0d0) then
                  if (abs(r(k,k)) .lt. abs(sdiag(k))) then
                     cotangent = r(k,k) / sdiag(k)
                     sine = 0.5d0 / sqrt(0.25d0+0.25d0*cotangent**2)
                     cosine = sine * cotangent
                  else
                     tangent = sdiag(k) / r(k,k)
                     cosine = 0.5d0 / sqrt(0.25d0+0.25d0*tangent**2)
                     sine = cosine * tangent
                  end if
c
c     compute the modified diagonal element of r
c     and the modified element of ((q transpose)*b,0)
c
                  r(k,k) = cosine*r(k,k) + sine*sdiag(k)
                  temp = cosine*xpvt(k) + sine*qtbpj
                  qtbpj = -sine*xpvt(k) + cosine*qtbpj
                  xpvt(k) = temp
c
c     accumulate the tranformation in the row of s
c
                  if (n .ge. k+1) then
                     do i = k+1, n
                        temp = cosine*r(i,k) + sine*sdiag(i)
                        sdiag(i) = -sine*r(i,k) + cosine*sdiag(i)
                        r(i,k) = temp
                     end do
                  end if
               end if
            end do
         end if
c
c     store the diagonal element of s and restore
c     the corresponding diagonal elements of r
c
         sdiag(j) = r(j,j)
         r(j,j) = x(j)
      end do
c
c     solve the triangular system for xpvt; if the system
c     is singular, then obtain a least squares solution
c
      nsing = n
      do j = 1, n
         if (sdiag(j).eq.0.0d0 .and. nsing.eq.n)  nsing = j - 1
         if (nsing .lt. n)  xpvt(j) = 0.0d0
      end do
      if (nsing .ge. 1) then
         do k = 1, nsing
            j = nsing - k + 1
            temp = 0.0d0
            if (nsing .ge. j+1) then
               do i = j+1, nsing
                  temp = temp + r(i,j)*xpvt(i)
               end do
            end if
            xpvt(j) = (xpvt(j)-temp) / sdiag(j)
         end do
      end if
c
c     permute the components of xpvt back to components of x
c
      do j = 1, n
         k = ipvt(j)
         x(k) = xpvt(j)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine quatfit  --  optimal rotation for superposition  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "quatfit" uses a quaternion-based method to find the optimal
c     rotation to achieve the best fit superposition of two sets of
c     coordinates, assuming the centroids are already superimposed
c
c     literature reference:
c
c     S. K. Kearsley, "On the Orthogonal Transformation Used for
c     Structural Comparisons", Acta Crystallographica Section A,
c     45, 208-210 (1989)
c
c     adapted from an original program written by D. J. Heisterberg,
c     Ohio Supercomputer Center, Columbus, OH
c
c
      subroutine quatfit (n1,x1,y1,z1,n2,x2,y2,z2)
      use align
      implicit none
      integer i,i1,i2,n1,n2
      real*8 weigh,xrot,yrot,zrot
      real*8 xxyx,xxyy,xxyz
      real*8 xyyx,xyyy,xyyz
      real*8 xzyx,xzyy,xzyz
      real*8 q(4),d(4)
      real*8 x1(*),x2(*)
      real*8 y1(*),y2(*)
      real*8 z1(*),z2(*)
      real*8 rot(3,3)
      real*8 c(4,4),v(4,4)
c
c
c     build the upper triangle of the quadratic form matrix
c
      xxyx = 0.0d0
      xxyy = 0.0d0
      xxyz = 0.0d0
      xyyx = 0.0d0
      xyyy = 0.0d0
      xyyz = 0.0d0
      xzyx = 0.0d0
      xzyy = 0.0d0
      xzyz = 0.0d0
      do i = 1, nfit
         i1 = ifit(1,i)
         i2 = ifit(2,i)
         weigh = wfit(i)
         xxyx = xxyx + weigh*x1(i1)*x2(i2)
         xxyy = xxyy + weigh*y1(i1)*x2(i2)
         xxyz = xxyz + weigh*z1(i1)*x2(i2)
         xyyx = xyyx + weigh*x1(i1)*y2(i2)
         xyyy = xyyy + weigh*y1(i1)*y2(i2)
         xyyz = xyyz + weigh*z1(i1)*y2(i2)
         xzyx = xzyx + weigh*x1(i1)*z2(i2)
         xzyy = xzyy + weigh*y1(i1)*z2(i2)
         xzyz = xzyz + weigh*z1(i1)*z2(i2)
      end do
      c(1,1) = xxyx + xyyy + xzyz
      c(1,2) = xzyy - xyyz
      c(2,2) = xxyx - xyyy - xzyz
      c(1,3) = xxyz - xzyx
      c(2,3) = xxyy + xyyx
      c(3,3) = xyyy - xzyz - xxyx
      c(1,4) = xyyx - xxyy
      c(2,4) = xzyx + xxyz
      c(3,4) = xyyz + xzyy
      c(4,4) = xzyz - xxyx - xyyy
c
c     diagonalize the quadratic form matrix
c
      call jacobi (4,c,d,v)
c
c     extract the desired quaternion components
c
      q(1) = v(1,4)
      q(2) = v(2,4)
      q(3) = v(3,4)
      q(4) = v(4,4)
c
c     assemble rotation matrix that superimposes the molecules
c
      rot(1,1) = q(1)**2 + q(2)**2 - q(3)**2 - q(4)**2
      rot(2,1) = 2.0d0 * (q(2) * q(3) - q(1) * q(4))
      rot(3,1) = 2.0d0 * (q(2) * q(4) + q(1) * q(3))
      rot(1,2) = 2.0d0 * (q(3) * q(2) + q(1) * q(4))
      rot(2,2) = q(1)**2 - q(2)**2 + q(3)**2 - q(4)**2
      rot(3,2) = 2.0d0 * (q(3) * q(4) - q(1) * q(2))
      rot(1,3) = 2.0d0 * (q(4) * q(2) - q(1) * q(3))
      rot(2,3) = 2.0d0 * (q(4) * q(3) + q(1) * q(2))
      rot(3,3) = q(1)**2 - q(2)**2 - q(3)**2 + q(4)**2
c
c     rotate second molecule to best fit with first molecule
c
      do i = 1, n2
         xrot = x2(i)*rot(1,1) + y2(i)*rot(1,2) + z2(i)*rot(1,3)
         yrot = x2(i)*rot(2,1) + y2(i)*rot(2,2) + z2(i)*rot(2,3)
         zrot = x2(i)*rot(3,1) + y2(i)*rot(3,2) + z2(i)*rot(3,3)
         x2(i) = xrot
         y2(i) = yrot
         z2(i) = zrot
      end do
      return
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 1995 by Yong Kong and Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program radial  --  compute radial distribution function  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "radial" finds the radial distribution function for a specified
c     pair of atom types via analysis of a set of coordinate frames
c
c
      program radial
      use argue
      use atomid
      use atoms
      use bound
      use boxes
      use files
      use inform
      use iounit
      use limits
      use math
      use molcul
      use potent
      implicit none
      integer i,j,k
      integer nframe,iframe
      integer iarc,next
      integer molj,molk
      integer numj,numk
      integer typej,typek
      integer start,stop
      integer step,skip
      integer nbin,bin
      integer, allocatable :: hist(:)
      real*8 xj,yj,zj
      real*8 dx,dy,dz
      real*8 rjk,rmax,width
      real*8 rlower,rupper
      real*8 factor,pairs
      real*8 volume,expect
      real*8 dist,dmax,gmax
      real*8, allocatable :: gr(:)
      real*8, allocatable :: gs(:)
      logical exist,query
      logical first,intramol
      character*1 answer
      character*3 namej,namek
      character*6 labelj,labelk
      character*240 record
      character*240 string
c
c
c     perform the standard initialization functions
c
      call initial
c
c     open the trajectory archive and read the initial frame
c
      call getarc (iarc)
c
c     get the unitcell parameters and number of molecules
c
      call unitcell
      call molecule
c
c     set cutoffs small to enforce use of minimum images
c
      use_vdw = .true.
      use_charge = .false.
      use_dipole = .false.
      use_mpole = .false.
      use_ewald = .false.
      vdwcut = 0.01d0
      call lattice
c
c     get numbers of the coordinate frames to be processed
c
      start = 1
      stop = 100000
      step = 1
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  start
         query = .false.
      end if
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  stop
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  step
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' Numbers of First & Last Frame and Step',
     &              ' Increment :  ',$)
         read (input,30)  record
   30    format (a240)
         read (record,*,err=40,end=40)  start,stop,step
   40    continue
      end if
c
c     get the names of the atoms to be used in rdf computation
c
      call nextarg (labelj,exist)
      call nextarg (labelk,exist)
      if (.not. exist) then
         write (iout,50)
   50    format (/,' Enter 1st & 2nd Atom Names or Type Numbers :  ',$)
         read (input,60)  record
   60    format (a240)
         next = 1
         call gettext (record,labelj,next)
         call gettext (record,labelk,next)
      end if
c
c     convert the labels to either atom names or type numbers
c
      namej = '   '
      typej = -1
      read (labelj,*,err=70,end=70)  typej
   70 continue
      if (typej .le. 0) then
         next = 1
         call gettext (labelj,namej,next)
      end if
      namek = '   '
      typek = -1
      read (labelk,*,err=80,end=80)  typek
   80 continue
      if (typek .le. 0) then
         next = 1
         call gettext (labelk,namek,next)
      end if
c
c     get maximum distance from input or minimum image convention
c
      if (.not. use_bounds) then
         rmax = -1.0d0
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=90,end=90)  rmax
            query = .false.
         end if
   90    continue
         if (query) then
            write (iout,100)
  100       format (/,' Enter Maximum Distance to Accumulate',
     &                 ' [10.0 Ang] :  ',$)
            read (input,110)  rmax
  110       format (f20.0)
         end if
         if (rmax .le. 0.0d0)  rmax = 10.0d0
      else if (octahedron) then
         rmax = (sqrt(3.0d0)/4.0d0) * xbox
         rmax = 0.95d0 * rmax
      else
         rmax = min(xbox2*beta_sin*gamma_sin,ybox2*gamma_sin,
     &                         zbox2*beta_sin)
         rmax = 0.95d0 * rmax
      end if
c
c     get the desired width of the radial distance bins
c
      width = -1.0d0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=120,end=120)  width
         query = .false.
      end if
  120 continue
      if (query) then
         write (iout,130)
  130    format (/,' Enter Width of Distance Bins [0.01 Ang] :  ',$)
         read (input,140)  width
  140    format (f20.0)
      end if
      if (width .le. 0.0d0)  width = 0.01d0
c
c     decide whether to restrict to intermolecular atom pairs
c
      intramol = .false.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,150)
  150    format (/,' Include Intramolecular Pairs in Distribution',
     &              ' [N] :  ',$)
         read (input,160)  record
  160    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'Y')  intramol = .true.
c
c     count the number of coordinate frames in the archive file
c
      abort = .false.
      rewind (unit=iarc)
      first = .true.
      nframe = 0
      do while (.not. abort)
         call readcart (iarc,first)
         nframe = nframe + 1
      end do
      nframe = nframe - 1
      stop = min(nframe,stop)
      nframe = (stop-start)/step + 1
      write (iout,170)  nframe
  170 format (/,' Number of Coordinate Frames :',i14)
c
c     set the number of distance bins to be accumulated
c
      nbin = int(rmax/width)
      write (iout,180)  nbin
  180 format (' Number of Distance Bins :',i18)
c
c     perform dynamic allocation of some local arrays
c
      allocate (hist(nbin))
      allocate (gr(nbin))
      allocate (gs(nbin))
c
c     zero out the distance bins and distribution functions
c
      do i = 1, nbin
         hist(i) = 0
         gr(i) = 0.0d0
         gs(i) = 0.0d0
      end do
c
c     get the archived coordinates for each frame in turn
c
      write (iout,190)
  190 format (/,' Reading the Coordinates Archive File :',/)
      rewind (unit=iarc)
      first = .true.
      nframe = 0
      iframe = start
      skip = start
      do while (iframe.ge.start .and. iframe.le.stop)
         do j = 1, skip-1
            call readcart (iarc,first)
         end do
         iframe = iframe + step
         skip = step
         call readcart (iarc,first)
         if (.not. abort) then
            nframe = nframe + 1
            if (mod(nframe,100) .eq. 0) then
               write (iout,200)  nframe
  200          format (4x,'Processing Coordinate Frame',i13)
            end if
            do j = 1, n
               if (name(j).eq.namej .or. type(j).eq.typej) then
                  xj = x(j)
                  yj = y(j)
                  zj = z(j)
                  molj = molcule(j)
                  do k = 1, n
                     if (name(k).eq.namek .or. type(k).eq.typek) then
                        if (j .ne. k) then
                           molk = molcule(k)
                           if (intramol .or. molj.ne.molk) then
                              dx = x(k) - xj
                              dy = y(k) - yj
                              dz = z(k) - zj
                              call image (dx,dy,dz)
                              rjk = sqrt(dx*dx + dy*dy + dz*dz)
                              bin = int(rjk/width) + 1
                              if (bin .le. nbin)
     &                           hist(bin) = hist(bin) + 1
                           end if
                        end if
                     end if
                  end do
               end if
            end do
         end if
      end do
c
c     ensure a valid frame is loaded and report total frames
c
      if (abort) then
         rewind (unit=iarc)
         first = .true.
         call readcart (iarc,first)
      end if
      close (unit=iarc)
      if (mod(nframe,100) .ne. 0) then
         write (iout,210)  nframe
  210    format (4x,'Processing Coordinate Frame',i13)
      end if
c
c     count the number of occurrences of each atom type
c
      numj = 0
      numk = 0
      do i = 1, n
         if (name(i).eq.namej .or. type(i).eq.typej)  numj = numj + 1
         if (name(i).eq.namek .or. type(i).eq.typek)  numk = numk + 1
      end do
c
c     normalize the distance bins to give radial distribution
c
      if (numj.ne.0 .and. numk.ne.0) then
         factor = (4.0d0/3.0d0) * pi * dble(nframe)
         if (use_bounds) then
            pairs = dble(numj) * dble(numk)
            volume = (gamma_sin*gamma_term) * xbox * ybox * zbox
            if (octahedron)  volume = 0.5d0 * volume
            if (dodecadron)  volume = volume / root2
            factor = factor * pairs / volume
         end if
         do i = 1, nbin
            rupper = dble(i) * width
            rlower = rupper - width
            expect = factor * (rupper**3 - rlower**3)
            gr(i) = dble(hist(i)) / expect
         end do
      end if
c
c     find the 5th degree polynomial smoothed distribution function
c
      if (nbin .ge. 5) then
         gs(1) = (69.0d0*gr(1) + 4.0d0*gr(2) - 6.0d0*gr(3)
     &             + 4.0d0*gr(4) - gr(5)) / 70.0d0
         gs(2) = (2.0d0*gr(1) + 27.0d0*gr(2) + 12.0d0*gr(3)
     &             - 8.0d0*gr(4) + 2.0d0*gr(5)) / 35.0d0
         do i = 3, nbin-2
            gs(i) = (-3.0d0*gr(i-2) + 12.0d0*gr(i-1) + 17.0d0*gr(i)
     &                + 12.0d0*gr(i+1) - 3.0d0*gr(i+2)) / 35.0d0
         end do
         gs(nbin-1) = (2.0d0*gr(nbin-4) - 8.0d0*gr(nbin-3)
     &                  + 12.0d0*gr(nbin-2) + 27.0d0*gr(nbin-1)
     &                       + 2.0d0*gr(nbin)) / 35.0d0
         gs(nbin) = (-gr(nbin-4) + 4.0d0*gr(nbin-3) - 6.0d0*gr(nbin-2)
     &                + 4.0d0*gr(nbin-1) + 69.0d0*gr(nbin)) / 70.0d0
         do i = 1, nbin
            gs(i) = max(0.0d0,gs(i))
         end do
      end if
c
c     output the final radial distribution function results
c
      write (iout,220)  labelj,labelk
  220 format (/,' Pairwise Radial Distribution Function :'
     &        //,7x,'First Name or Type :  ',a6,
     &           5x,'Second Name or Type :  ',a6)
      write (iout,230)
  230 format (/,5x,'Bin',9x,'Counts',7x,'Distance',7x,'Raw g(r)',
     &           4x,'Smooth g(r)',/)
      gmax = 0.0d0
      do i = 1, nbin
         dist = (dble(i)-0.5d0) * width
         write (iout,240)  i,hist(i),dist,gr(i),gs(i)
  240    format (i8,i15,3x,f12.4,3x,f12.4,3x,f12.4)
         if (gs(i) .gt. gmax) then
            dmax = dist
            gmax = gs(i)
         end if
      end do
      write (iout,250)  gmax,dmax
  250 format (/,' Maximum g(r) Value :',f12.4,' at Distance',f10.4)
c
c     perform deallocation of some local arrays
c
c     deallocate (hist)
c     deallocate (gr)
c     deallocate (gs)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  function random  --  portable random number generator  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "random" generates a random number on [0,1] via a long
c     period generator due to L'Ecuyer with Bays-Durham shuffle
c
c     literature references:
c
c     P. L'Ecuyer, Communications of the ACM, 31, 742-774 (1988)
c
c     W. H. Press, S. A. Teukolsky, W. T. Vetterling and B. P.
c     Flannery, Numerical Recipes (Fortran), 2nd Ed., Cambridge
c     University Press, 1992, Section 7.1
c
c
      function random ()
      use inform
      use iounit
      use keys
      implicit none
      integer im1,ia1,iq1,ir1
      integer im2,ia2,iq2,ir2
      integer big,nshuffle
      integer imm1,ndiv
      real*8 factor
      parameter (im1=2147483563)
      parameter (ia1=40014)
      parameter (iq1=53668)
      parameter (ir1=12211)
      parameter (im2=2147483399)
      parameter (ia2=40692)
      parameter (iq2=52774)
      parameter (ir2=3791)
      parameter (big=141803398)
      parameter (nshuffle=32)
      parameter (imm1=im1-1)
      parameter (ndiv=1+imm1/nshuffle)
      parameter (factor=1.0d0/im1)
      integer i,k,iy,next
      integer seed,seed2
      integer year,month,day
      integer hour,minute,second
      integer ishuffle(nshuffle)
      real*8 random
      logical first
      character*20 keyword
      character*240 record
      character*240 string
      save first
      save seed,seed2
      save iy,ishuffle
      data first  / .true. /
c
c
c     random number seed is first set to a big number,
c     then incremented by the seconds elapsed this decade
c
      if (first) then
         first = .false.
         seed = big
         call calendar (year,month,day,hour,minute,second)
         year = mod(year,10)
         seed = seed + 32140800*year + 2678400*(month-1)
         seed = seed + 86400*(day-1) + 3600*hour
         seed = seed + 60*minute + second
c
c     search the keywords for a random number seed
c
         do i = 1, nkey
            next = 1
            record = keyline(i)
            call gettext (record,keyword,next)
            call upcase (keyword)
            if (keyword(1:11) .eq. 'RANDOMSEED ') then
               string = record(next:240)
               read (string,*,err=10)  seed
               seed = max(1,seed)
            end if
   10       continue
         end do
c
c     print the value used for the random number seed
c
         if (verbose) then
            write (iout,20)  seed
   20       format (/,' Random Number Generator Initialized',
     &                 ' with SEED :',3x,i12)
         end if
c
c     warm up and then load the shuffling table
c
         seed2 = seed
         do i = nshuffle+8, 1, -1
            k = seed / iq1
            seed = ia1 * (seed-k*iq1) - k*ir1
            if (seed .lt. 0)  seed = seed + im1
            if (i .le. nshuffle)  ishuffle(i) = seed
         end do
         iy = ishuffle(1)
      end if
c
c     get a new random number value each call
c
      k = seed / iq1
      seed = ia1*(seed-k*iq1) - k*ir1
      if (seed .lt. 0)  seed = seed + im1
      k = seed2 / iq2
      seed2 = ia2*(seed2-k*iq2) - k*ir2
      if (seed2 .lt. 0)  seed2 = seed2 + im2
      i = 1 + iy/ndiv
      iy = ishuffle(i) - seed2
      ishuffle(i) = seed
      if (iy .lt. 1)  iy = iy + imm1
      random = factor * iy
c
c     print the value of the current random number
c
c     if (debug) then
c        write (iout,30)  random
c  30    format (' RANDOM  --  Random Number Value is',f12.8)
c     end if
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  function normal  --  random number from normal curve  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "normal" generates a random number from a normal Gaussian
c     distribution with a mean of zero and a variance of one
c
c
      function normal ()
      use inform
      use iounit
      implicit none
      real*8 v1,v2,rsq
      real*8 factor,store
      real*8 normal,random
      logical compute
      external random
      save compute,store
      data compute  / .true. /
c
c
c     get a pair of random values from the distribution
c
      if (compute) then
   10    continue
         v1 = 2.0d0*random() - 1.0d0
         v2 = 2.0d0*random() - 1.0d0
         rsq = v1**2 + v2**2
         if (rsq .ge. 1.0d0)  goto 10
         factor = sqrt(-2.0d0*log(rsq)/rsq)
         store = v1 * factor
         normal = v2 * factor
         compute = .false.
c
c     use the second random value computed at the last call
c
      else
         normal = store
         compute = .true.
      end if
c
c     print the value of the current random number
c
c     if (debug) then
c        write (iout,20)  normal
c  20    format (' NORMAL  --  Normal Random Number is',f12.8)
c     end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine ranvec  --  unit vector in random direction  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "ranvec" generates a unit vector in 3-dimensional
c     space with uniformly distributed random orientation
c
c     literature references:
c
c     G. Marsaglia, Ann. Math. Stat., 43, 645 (1972)
c
c     R. C. Rapaport, The Art of Molecular Dynamics Simulation,
c     2nd Edition, Cambridge University Press, 2004, Section 18.4
c
c
      subroutine ranvec (vector)
      use inform
      use iounit
      implicit none
      real*8 x,y,s
      real*8 random
      real*8 vector(3)
      external random
c
c
c     get a pair of appropriate components in the plane
c
      s = 2.0d0
      do while (s .ge. 1.0d0)
         x = 2.0d0*random() - 1.0d0
         y = 2.0d0*random() - 1.0d0
         s = x**2 + y**2
      end do
c
c     construct the 3-dimensional random unit vector
c
      vector(3) = 1.0d0 - 2.0d0*s
      s = 2.0d0 * sqrt(1.0d0 - s)
      vector(2) = s * y
      vector(1) = s * x
c
c     print the components of the random unit vector
c
c     if (debug) then
c        write (iout,10)  vector(1),vector(2),vector(3)
c  10    format (' RANVEC  --  Unit Random Vector is',3f10.4)
c     end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine sphere  --  uniform set of points on sphere  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "sphere" finds a specified number of uniformly distributed
c     points on a sphere of unit radius centered at the origin
c
c     literature reference:
c
c     E. B. Saff and A. B. J. Kuijlaars, "Distributing Many
c     Points on a Sphere", The Mathematical Intelligencer,
c     19, 5-11 (1997)
c
c
      subroutine sphere (ndot,dot)
      use math
      implicit none
      integer i,ndot
      real*8 theta,phi
      real*8 h,phiold
      real*8 tot,tot1
      real*8 dot(3,*)
c
c
c     find spherical coordinates then convert to Cartesian
c
      tot = dble(ndot)
      tot1 = dble(ndot-1)
      do i = 1, ndot
         h = -1.0d0 + 2.0d0*dble(i-1)/tot1
         h = min(1.0d0,h)
         theta = acos(h)
         if (i.eq.1 .or. i.eq.ndot) then
            phi = 0.0d0
         else
            phi = mod(phiold+3.6d0/sqrt(tot*(1.0d0-h*h)),2.0d0*pi)
         end if
         dot(1,i) = sin(theta) * cos(phi)
         dot(2,i) = sin(theta) * sin(phi)
         dot(3,i) = cos(theta)
         phiold = phi
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine wiggle  --  random perturbation of coordinates  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "wiggle" applies a small random perturbation of coordinates
c     to avoid numerical instability in geometric calculations for
c     linear, planar and other symmetric structures
c
c
      subroutine wiggle (nxyz,xyz,eps)
      implicit none
      integer i,nxyz
      real*8 eps
      real*8 vector(3)
      real*8 xyz(3,*)
c
c
c     apply a small perturbation to the position of each atom
c
      do i = 1, nxyz
         call ranvec (vector)
         xyz(1,i) = xyz(1,i) + eps*vector(1)
         xyz(2,i) = xyz(2,i) + eps*vector(2)
         xyz(3,i) = xyz(3,i) + eps*vector(3)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine rattle  --  RATTLE distance constraint method  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "rattle" implements the first portion of the RATTLE algorithm
c     by correcting atomic positions and half-step velocities to
c     maintain interatomic distance and absolute spatial constraints
c
c     literature reference:
c
c     H. C. Andersen, "RATTLE: A Velocity Version of the SHAKE
c     Algorithm for Molecular Dynamics Calculations", Journal of
c     Computational Physics, 52, 24-34 (1983)
c
c
      subroutine rattle (dt,xold,yold,zold)
      use atomid
      use atoms
      use freeze
      use group
      use inform
      use iounit
      use moldyn
      use usage
      implicit none
      integer i,j,k
      integer ia,ib,mode
      integer niter,maxiter
      integer start,stop
      real*8 dt,eps,sor
      real*8 xr,yr,zr
      real*8 xo,yo,zo
      real*8 xv,yv,zv
      real*8 dot,rma,rmb
      real*8 weigh,dist2
      real*8 delta,term
      real*8 xterm,yterm,zterm
      real*8 xold(*)
      real*8 yold(*)
      real*8 zold(*)
      logical done
      logical, allocatable :: moved(:)
      logical, allocatable :: update(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (moved(n))
      allocate (update(n))
c
c     initialize the lists of atoms previously corrected
c
      do i = 1, n
         if (use(i)) then
            moved(i) = .true.
         else
            moved(i) = .false.
         end if
         update(i) = .false.
      end do
c
c     set the iteration counter, termination and tolerance
c
      maxiter = 500
      sor = 1.25d0
      eps = rateps
c
c     iterate the distances and velocities to convergence
c
      niter = 0
      done = .false.
      do while (.not.done .and. niter.lt.maxiter)
         niter = niter + 1
         done = .true.
         do i = 1, nrat
            ia = irat(1,i)
            ib = irat(2,i)
            if (moved(ia) .or. moved(ib)) then
               xr = x(ib) - x(ia)
               yr = y(ib) - y(ia)
               zr = z(ib) - z(ia)
               if (frzimage(i))  call image (xr,yr,zr)
               dist2 = xr*xr + yr*yr + zr*zr
               delta = krat(i)**2 - dist2
               if (abs(delta) .gt. eps) then
                  done = .false.
                  update(ia) = .true.
                  update(ib) = .true.
                  xo = xold(ib) - xold(ia)
                  yo = yold(ib) - yold(ia)
                  zo = zold(ib) - zold(ia)
                  if (frzimage(i))  call image (xo,yo,zo)
                  dot = xr*xo + yr*yo + zr*zo
                  rma = 1.0d0 / mass(ia)
                  rmb = 1.0d0 / mass(ib)
                  term = 0.5d0 * sor * delta / ((rma+rmb) * dot)
                  xterm = xo * term
                  yterm = yo * term
                  zterm = zo * term
                  x(ia) = x(ia) - xterm*rma
                  y(ia) = y(ia) - yterm*rma
                  z(ia) = z(ia) - zterm*rma
                  x(ib) = x(ib) + xterm*rmb
                  y(ib) = y(ib) + yterm*rmb
                  z(ib) = z(ib) + zterm*rmb
                  rma = rma / dt
                  rmb = rmb / dt
                  v(1,ia) = v(1,ia) - xterm*rma
                  v(2,ia) = v(2,ia) - yterm*rma
                  v(3,ia) = v(3,ia) - zterm*rma
                  v(1,ib) = v(1,ib) + xterm*rmb
                  v(2,ib) = v(2,ib) + yterm*rmb
                  v(3,ib) = v(3,ib) + zterm*rmb
               end if
            end if
         end do
         do i = 1, n
            moved(i) = update(i)
            update(i) = .false.
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (moved)
      deallocate (update)
c
c     write information on the number of iterations needed
c
      if (niter .eq. maxiter) then
         write (iout,10)
   10    format (/,' RATTLE  --  Warning, Distance Constraints',
     &              ' not Satisfied')
         call prterr
         call fatal
      else if (debug) then
         write (iout,20)  niter
   20    format (' RATTLE   --  Distance Constraints met at',i6,
     &              ' Iterations')
      end if
c
c     any rigid planar water molecules are handled separately
c
      call settle (dt,xold,yold,zold)
c
c     apply group position and velocity constraints via exact reset
c
      do i = 1, nratx
         ia = iratx(i)
         mode = kratx(i)
         xr = 0.0d0
         yr = 0.0d0
         zr = 0.0d0
         xv = 0.0d0
         yv = 0.0d0
         zv = 0.0d0
         start = igrp(1,ia)
         stop = igrp(2,ia)
         do j = start, stop
            k = kgrp(j)
            weigh = mass(k) / grpmass(ia)
            if (mode .gt. 2) then
               xr = xr + x(k)*weigh
               xv = xv + v(1,k)*weigh
            end if
            if (mode .gt. 1) then
               yr = yr + y(k)*weigh
               yv = yv + v(2,k)*weigh
            end if
            zr = zr + z(k)*weigh
            zv = zv + v(3,k)*weigh
         end do
         do j = start, stop
            k = kgrp(j)
            x(k) = x(k) - xr
            y(k) = y(k) - yr
            z(k) = z(k) - zr
            v(1,k) = v(1,k) - xv
            v(2,k) = v(2,k) - yv
            v(3,k) = v(3,k) - zv
         end do
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine rattle2  --  RATTLE atom velocity corrections  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "rattle2" implements the second portion of the RATTLE algorithm
c     by correcting the full-step velocities in order to maintain
c     interatomic distance constraints
c
c
      subroutine rattle2 (dt)
      use atomid
      use atoms
      use freeze
      use group
      use inform
      use iounit
      use moldyn
      use units
      use usage
      use virial
      implicit none
      integer i,j,k
      integer ia,ib,mode
      integer niter,maxiter
      integer start,stop
      real*8 dt,eps,sor
      real*8 xr,yr,zr
      real*8 xv,yv,zv
      real*8 dot,rma,rmb
      real*8 weigh,vterm,term
      real*8 xterm,yterm,zterm
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      logical done
      logical, allocatable :: moved(:)
      logical, allocatable :: update(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (moved(n))
      allocate (update(n))
c
c     initialize the lists of atoms previously corrected
c
      do i = 1, n
         if (use(i)) then
            moved(i) = .true.
         else
            moved(i) = .false.
         end if
         update(i) = .false.
      end do
c
c     set the iteration counter, termination and tolerance
c
      maxiter = 500
      sor = 1.25d0
      eps = rateps / dt
      vterm = 2.0d0 / (dt*ekcal)
c
c     apply the RATTLE algorithm to correct the velocities
c
      niter = 0
      done = .false.
      do while (.not.done .and. niter.lt.maxiter)
         niter = niter + 1
         done = .true.
         do i = 1, nrat
            ia = irat(1,i)
            ib = irat(2,i)
            if (moved(ia) .or. moved(ib)) then
               xr = x(ib) - x(ia)
               yr = y(ib) - y(ia)
               zr = z(ib) - z(ia)
               if (frzimage(i))  call image (xr,yr,zr)
               xv = v(1,ib) - v(1,ia)
               yv = v(2,ib) - v(2,ia)
               zv = v(3,ib) - v(3,ia)
               dot = xr*xv + yr*yv + zr*zv
               rma = 1.0d0 / mass(ia)
               rmb = 1.0d0 / mass(ib)
               term = -dot / ((rma+rmb) * krat(i)**2)
               if (abs(term) .gt. eps) then
                  done = .false.
                  update(ia) = .true.
                  update(ib) = .true.
                  term = sor * term
                  xterm = xr * term
                  yterm = yr * term
                  zterm = zr * term
                  v(1,ia) = v(1,ia) - xterm*rma
                  v(2,ia) = v(2,ia) - yterm*rma
                  v(3,ia) = v(3,ia) - zterm*rma
                  v(1,ib) = v(1,ib) + xterm*rmb
                  v(2,ib) = v(2,ib) + yterm*rmb
                  v(3,ib) = v(3,ib) + zterm*rmb
c
c     increment the internal virial tensor components
c
                  xterm = xterm * vterm
                  yterm = yterm * vterm
                  zterm = zterm * vterm
                  vxx = xr * xterm
                  vyx = yr * xterm
                  vzx = zr * xterm
                  vyy = yr * yterm
                  vzy = zr * yterm
                  vzz = zr * zterm
                  vir(1,1) = vir(1,1) - vxx
                  vir(2,1) = vir(2,1) - vyx
                  vir(3,1) = vir(3,1) - vzx
                  vir(1,2) = vir(1,2) - vyx
                  vir(2,2) = vir(2,2) - vyy
                  vir(3,2) = vir(3,2) - vzy
                  vir(1,3) = vir(1,3) - vzx
                  vir(2,3) = vir(2,3) - vzy
                  vir(3,3) = vir(3,3) - vzz
               end if
            end if
         end do
         do i = 1, n
            moved(i) = update(i)
            update(i) = .false.
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (moved)
      deallocate (update)
c
c     write information on the number of iterations needed
c
      if (niter .eq. maxiter) then
         write (iout,10)
   10    format (/,' RATTLE2  --  Warning, Velocity Constraints',
     &              ' not Satisfied')
         call prterr
         call fatal
      else if (debug) then
         write (iout,20)  niter
   20    format (' RATTLE2  --  Velocity Constraints met at',i6,
     &              ' Iterations')
      end if
c
c     any rigid planar water molecules are handled separately
c
      call settle2 (dt)
c
c     apply any atom group velocity constraints via exact reset
c
      do i = 1, nratx
         ia = iratx(i)
         mode = kratx(i)
         xv = 0.0d0
         yv = 0.0d0
         zv = 0.0d0
         start = igrp(1,ia)
         stop = igrp(2,ia)
         do j = start, stop
            k = kgrp(j)
            weigh = mass(k) / grpmass(ia)
            if (mode .gt. 2) then
               xv = xv + v(1,k)*weigh
            end if
            if (mode .gt. 1) then
               yv = yv + v(2,k)*weigh
            end if
            zv = zv + v(3,k)*weigh
         end do
         do j = start, stop
            k = kgrp(j)
            v(1,k) = v(1,k) - xv
            v(2,k) = v(2,k) - yv
            v(3,k) = v(3,k) - zv
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2022  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine readcart  --  input of Cartesian coordinates  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "readcart" gets a set of Cartesian coordinates from either
c     a formatted or binary file
c
c
      subroutine readcart (ixyz,first)
      use output
      implicit none
      integer ixyz
      logical first
c
c
c     get next coordinates set from formatted or binary file
c
      if (archive) then
         call readxyz (ixyz)
      else if (binary) then
         call readdcd (ixyz,first)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2025  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine readcif  --  input of PDBx/mmCIF format file  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "readcif" gets a set of coordinates in RCSB PDBx/mmCIF
c     format from an external file
c
c
      subroutine readcif (icif)
      use boxes
      use files
      use inform
      use iounit
      use pdb
      use resdue
      use sequen
      use titles
      implicit none
      integer i,j,k,icif
      integer start,stop
      integer index,serial
      integer next,nxtlast
      integer residue,reslast
      integer model
      integer trimtext
      real*8 xx,yy,zz
      real*8 xbx,ybx,zbx
      real*8 aan,ban,gan
      real*8 occupy,bfac
      logical exist,opened
      logical first
      character*1 letter
      character*1 chain,chnlast
      character*1 altloc,formal
      character*1 insert,inslast
      character*1, allocatable :: chnatm(:)
      character*3 resname,atmsymb
      character*3 namelast
      character*4 atmname
      character*6 remark
      character*20 float
      character*240 ciffile
      character*240 record
      character*240 string
      save first
      data first  / .true. /
c
c
c     open the input file if it has not already been done
c
      inquire (unit=icif,opened=opened)
      if (.not. opened) then
         ciffile = filename(1:leng)//'.cif'
         call version (ciffile,'old')
         inquire (file=ciffile,exist=exist)
         if (exist) then
            open (unit=icif,file=ciffile,status='old')
            rewind (unit=icif)
         else
            write (iout,10)
   10       format (/,' READCIF  --  Unable to Find the PDBx/mmCIF',
     &                 ' Format File')
            call fatal
         end if
      end if
c
c     get alternate sites, chains and insertions to be used
c
      if (first)  call scancif (icif)
c
c     initialize title, atom and residue counters and name
c
      title = ' '
      ltitle = 0
      npdb = 0
      nres = 0
      reslast = maxres
      namelast = '   '
      chnlast = ' '
c
c     perform dynamic allocation of some local arrays
c
      allocate (chnatm(maxatm))
c
c     perform dynamic allocation of some global arrays
c
      if (first) then
         first = .false.
         if (.not. allocated(resnum))  allocate (resnum(maxatm))
         if (.not. allocated(resatm))  allocate (resatm(2,maxatm))
         if (.not. allocated(pdbmod))  allocate (pdbmod(maxatm))
         if (.not. allocated(xpdb))  allocate (xpdb(maxatm))
         if (.not. allocated(ypdb))  allocate (ypdb(maxatm))
         if (.not. allocated(zpdb))  allocate (zpdb(maxatm))
         if (.not. allocated(pdbres))  allocate (pdbres(maxatm))
         if (.not. allocated(pdbsym))  allocate (pdbsym(maxatm))
         if (.not. allocated(pdbatm))  allocate (pdbatm(maxatm))
         if (.not. allocated(pdbrec))  allocate (pdbrec(maxatm))
      end if
c
c     process info and individual atoms from PDBx/mmCIF file
c
      do while (.true.)
         read (icif,20,err=110,end=110)  record
   20    format (a240)
         call upcase (record)
         remark = record(1:6)
         if (record(1:13) .eq. '_STRUCT.TITLE') then
            next = 14
            call getstring (record,title,next)
            ltitle = trimtext (title)
            if (ltitle .eq. 0) then
               read (icif,30,err=40,end=40)  record
   30          format (a240)
               call upcase (record)
               next = 1
               call getstring (record,title,next)
               ltitle = trimtext (title)
            end if
   40       continue
         else if (record(1:21) .eq. '_DATABASE_2.PDBX_DOI') then
            if (ltitle .eq. 0) then
               next = 21
               ltitle = trimtext (record)
               title = record(21:ltitle)
               ltitle = ltitle - 20
               if (ltitle .eq. 0) then
                  read (icif,50,err=60,end=60)  record
   50             format (a240)
                  call upcase (record)
                  ltitle = trimtext (record)
                  title = record(1:ltitle)
               end if
   60          continue
            end if
         else if (record(1:14) .eq. '_CELL.LENGTH_A') then
            next = 15
            call getfloat (record,xbx,next)
         else if (record(1:14) .eq. '_CELL.LENGTH_B') then
            next = 15
            call getfloat (record,ybx,next)
         else if (record(1:14) .eq. '_CELL.LENGTH_C') then
            next = 15
            call getfloat (record,zbx,next)
         else if (record(1:17) .eq. '_CELL.ANGLE_ALPHA') then
            next = 18
            call getfloat (record,aan,next)
         else if (record(1:16) .eq. '_CELL.ANGLE_BETA') then
            next = 17
            call getfloat (record,ban,next)
         else if (record(1:17) .eq. '_CELL.ANGLE_GAMMA') then
            next = 18
            call getfloat (record,gan,next)
         else if (record(1:5) .eq. 'ATOM ') then
            remark = 'ATOM  '
            next = 6
            call getnumb (record,serial,next)
            call gettext (record,atmsymb,next)
            call gettext (record,atmname,next)
            call gettext (record,altloc,next)
            call gettext (record,resname,next)
            call gettext (record,chain,next)
            call gettext (record,letter,next)
            call getnumb (record,residue,next)
            call gettext (record,insert,next)
            call getfloat (record,xx,next)
            call getfloat (record,yy,next)
            call getfloat (record,zz,next)
            call getfloat (record,occupy,next)
            call getfloat (record,bfac,next)
            call gettext (record,formal,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call getnumb (record,model,next)
            if (altloc .eq. '.')  altloc = ' '
            if (insert .eq. '?')  insert = ' '
            if (formal .eq. '?')  formal = ' '
            if (index(chnsym,chain) .eq. 0)  goto 80
            if (altloc.ne.' ' .and. altloc.ne.altsym)  goto 80
            if (insert.ne.' ' .and. index(instyp,insert).eq.0)  goto 80
            if (model .ne. imodel)  goto 80
            call fixcif (resname,atmname)
            if (resname .eq. 'HOH') then
               remark = 'HETATM'
            else if (resname .eq. ' LI') then
               remark = 'HETATM'
            else if (resname .eq. '  F') then
               remark = 'HETATM'
            else if (resname .eq. ' NA') then
               remark = 'HETATM'
            else if (resname .eq. ' MG') then
               remark = 'HETATM'
            else if (resname .eq. ' CL') then
               remark = 'HETATM'
            else if (resname .eq. '  K') then
               remark = 'HETATM'
            else if (resname .eq. ' CA') then
               remark = 'HETATM'
            else if (resname .eq. ' FE') then
               remark = 'HETATM'
            else if (resname .eq. ' ZN') then
               remark = 'HETATM'
            else if (resname .eq. ' BR') then
               remark = 'HETATM'
            else if (resname .eq. '  I') then
               remark = 'HETATM'
            else if (residue.ne.reslast .or. resname.ne.namelast .or.
     &               chain.ne.chnlast .or. insert.ne.inslast) then
               nres = nres + 1
               reslast = residue
               namelast = resname
               chnlast = chain
               inslast = insert
               if (nres .gt. maxres) then
                  write (iout,70)  maxres
   70             format (/,' READPDB  --  The Maximum of',i6,
     &                       ' Residues has been Exceeded')
                  call fatal
               end if
               nseq = nres
               seq(nseq) = resname
            end if
            npdb = npdb + 1
            xpdb(npdb) = xx
            ypdb(npdb) = yy
            zpdb(npdb) = zz
            pdbrec(npdb) = remark
            pdbsym(npdb) = atmsymb
            pdbatm(npdb) = atmname
            pdbres(npdb) = resname
            pdbmod(npdb) = model
            resnum(npdb) = nres
            if (resname .eq. 'HOH')  resnum(npdb) = 0
            chnatm(npdb) = chain
   80       continue
         else if (remark .eq. 'HETATM') then
            next = 7
            call getnumb (record,serial,next)
            call gettext (record,atmsymb,next)
            call gettext (record,atmname,next)
            call gettext (record,altloc,next)
            call gettext (record,resname,next)
            call gettext (record,chain,next)
            call gettext (record,letter,next)
            call getnumb (record,residue,next)
            call gettext (record,insert,next)
            call getfloat (record,xx,next)
            call getfloat (record,yy,next)
            call getfloat (record,zz,next)
            call getfloat (record,occupy,next)
            call getfloat (record,bfac,next)
            call gettext (record,formal,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call getnumb (record,model,next)
            if (altloc .eq. '.')  altloc = ' '
            if (insert .eq. '?')  insert = ' '
            if (formal .eq. '?')  formal = ' '
            if (index(chnsym,chain) .eq. 0)  goto 90
            if (altloc.ne.' ' .and. altloc.ne.altsym)  goto 90
            if (insert.ne.' ' .and. index(instyp,insert).eq.0)  goto 90
            if (model .gt. 1)  goto 90
            call fixcif (resname,atmname)
            npdb = npdb + 1
            xpdb(npdb) = xx
            ypdb(npdb) = yy
            zpdb(npdb) = zz
            pdbrec(npdb) = remark
            pdbatm(npdb) = atmname
            pdbsym(npdb) = atmsymb
            pdbres(npdb) = resname
            pdbmod(npdb) = model
            resnum(npdb) = 0
            chnatm(npdb) = chain
   90       continue
         end if
         if (npdb .gt. maxatm) then
            write (iout,100)  maxatm
  100       format (/,' READCIF  --  The Maximum of',i6,
     &                 ' Atoms has been Exceeded')
            call fatal
         end if
      end do
  110 continue
c
c     set up crystal lattice if values were read from file
c
      if (xbx .gt. 1.0d0) then
         xbox = xbx
         ybox = ybx
         zbox = zbx
         alpha = aan
         beta = ban
         gamma = gan
         call unitcell
      end if
c
c     set the total sequence length and chain terminus sites
c
      if (npdb .ne. 0) then
         nchain = 0
         chnlast = '#'
         do i = 1, npdb
            if (pdbrec(i) .eq. 'ATOM  ') then
               letter = chnatm(i)
               if (letter .ne. chnlast) then
                  nchain = nchain + 1
                  ichain(1,nchain) = resnum(i)
                  chnnam(nchain) = letter
                  chnlast = letter
               else
                  ichain(2,nchain) = resnum(i)
               end if
            end if
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (chnatm)
c
c     find the type of species present in each chain
c
      do i = 1, nchain
         start = ichain(1,i)
         stop = ichain(2,i)
         chntyp(i) = 'GENERIC'
         do j = start, stop
            do k = 1, maxamino
               if (seq(j) .eq. amino(k)) then
                  chntyp(i) = 'PEPTIDE'
                  goto 120
               end if
            end do
            chntyp(i) = 'GENERIC'
            goto 130
  120       continue
         end do
  130    continue
         if (chntyp(i) .eq. 'GENERIC') then
            do j = start, stop
               do k = 1, maxnuc
                  if (seq(j) .eq. nuclz(k)) then
                     chntyp(i) = 'NUCLEIC'
                     goto 140
                  end if
               end do
               chntyp(i) = 'GENERIC'
               goto 150
  140          continue
            end do
  150       continue
         end if
      end do
c
c     get the three-letter sequence and code for each residue
c
      do i = 1, nchain
         start = ichain(1,i)
         stop = ichain(2,i)
         do j = start, stop
            do k = 1, maxamino
               if (seq(j) .eq. amino(k)) then
                  seqtyp(j) = k
                  goto 160
               end if
            end do
            do k = 1, maxnuc
               if (seq(j) .eq. nuclz(k)) then
                  seqtyp(j) = k
                  goto 160
               end if
            end do
            seq(j) = 'UNK'
            seqtyp(j) = 0
            if (chntyp(i) .eq. 'PEPTIDE')  seqtyp(j) = maxamino
            if (chntyp(i) .eq. 'NUCLEIC')  seqtyp(j) = maxnuc
  160       continue
         end do
      end do
c
c     set a pointer to the first and last atom of each residue
c
      nres = 0
      k = 0
      do i = 1, npdb
         if (pdbrec(i) .eq. 'ATOM  ') then
            if (resnum(i) .ne. k) then
               k = resnum(i)
               nres = nres + 1
               resatm(1,nres) = i
               if (nres .gt. 1)  resatm(2,nres-1) = i - 1
            end if
         end if
      end do
      if (nres .ge. 1)  resatm(2,nres) = npdb
c
c     close the input file and quit if no coordinates found
c
      if (.not. opened)  close (unit=icif)
      if (npdb .eq. 0)  abort = .true.
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine scancif  --  PDBx chains, alternates & inserts  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "scancif" reads the first model in a RCSB PDBx/mmCIF file
c     and finds chains, alternate sites, insertions and models
c
c
      subroutine scancif (icif)
      use iounit
      use pdb
      use sequen
      implicit none
      integer i,k,icif
      integer next,length
      integer nalt,nins
      integer model,modtemp
      logical exist,done
      character*1 letter
      character*1 chain,chnlast
      character*1 altloc,altlast
      character*1 insert,inslast
      character*6 remark
      character*20 blank,text
      character*20 chntemp
      character*20 alttyp
      character*20 instemp
      character*240 record
      character*240 string
c
c
c     initialize chain, alternate site and insertion lists
c
      nchain = 0
      nalt = 0
      nins = 0
      chnlast = '#'
      altlast = '#'
      inslast = '#'
      blank = '                    '
      chnsym = '####################'
      altsym = ' '
      alttyp = blank
      instyp = blank
      nmodel = 0
      imodel = 0
c
c     scan for multiple chains, alternate locations and inserts
c
      done = .false.
      do while (.not. done)
         read (icif,10,err=20,end=20)  record
   10    format (a240)
         remark = record(1:6)
         call upcase (remark)
         if (remark(1:5).eq.'ATOM ' .or. remark.eq.'HETATM') then
            next = 6
            if (remark .eq. 'HETATM')  next = 7
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,altloc,next)
            call gettext (record,letter,next)
            call gettext (record,chain,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,insert,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call gettext (record,letter,next)
            call getnumb (record,model,next)
            if (altloc .eq. '.')  altloc = ' '
            if (insert .eq. '?')  insert = ' '
            nmodel = max(model,nmodel)
            if (chain .ne. chnlast) then
               if (index(chnsym,chain) .eq. 0) then
                  nchain = nchain + 1
                  chnsym(nchain:nchain) = chain
                  chnlast = chain
               end if
            end if
            if (altloc .ne. altlast) then
               if (index(alttyp,altloc) .eq. 0) then
                  nalt = nalt + 1
                  alttyp(nalt:nalt) = altloc
                  altlast = altloc
               end if
            end if
            if (insert .ne. inslast) then
               if (index(instyp,insert) .eq. 0) then
                  nins = nins + 1
                  instyp(nins:nins) = insert
                  inslast = insert
               end if
            end if
         end if
      end do
   20 continue
      rewind (unit=icif)
c
c     find out which of the multiple chains will be used
c
      if (nchain .gt. 1) then
         call nextarg (chntemp,exist)
         if (.not. exist) then
            chntemp = blank
            if (chnsym(1:1) .eq. ' ') then
               string = 'BLANK=@'
               length = 7
            else
               string(1:1) = chnsym(1:1)
               length = 1
            end if
            do i = 2, nchain
               if (chnsym(i:i) .eq. ' ') then
                  string = string(1:length)//' BLANK=@'
                  length = length + 8
               else
                  string = string(1:length)//' '//chnsym(i:i)
                  length = length + 2
               end if
            end do
            string = string(1:length)//' [ALL]'
            length = length + 6
            write (iout,30)  string(1:length)
   30       format (/,' Enter the Chain Names to Include',
     &                 ' (',a,') :  ',$)
            read (input,40)  chntemp
   40       format (a20)
         end if
         call upcase (chntemp)
         next = 1
         call gettext (chntemp,text,next)
         if (text.eq.blank .or. text(1:3).eq.'ALL') then
            chnsym = chnsym(1:nchain)
         else
            do i = 1, nchain
               chain = chnsym(i:i)
               if (chain .eq. ' ')  chain = '@'
               k = index(chntemp,chain)
               if (k .eq. 0)  chnsym(i:i) = '#'
            end do
            chntemp = chnsym
            k = 0
            do i = 1, nchain
               chain = chntemp(i:i)
               if (chain .eq. '@')  chain = ' '
               if (chain .ne. '#') then
                  k = k + 1
                  chnsym(k:k) = chain
               end if
            end do
            nchain = k
         end if
      end if
      do i = nchain+1, 20
         chnsym(i:i) = '#'
      end do
c
c     find out which of alternate locations will be used
c
      if (nalt .gt. 0) then
         call nextarg (altsym,exist)
         if (.not. exist) then
            string(1:3) = '['//alttyp(1:1)//']'
            length = 3
            do i = 2, nalt
               string = string(1:length)//' '//alttyp(i:i)
               length = length + 2
            end do
            write (iout,50)  string(1:length)
   50       format (/,' Enter a Set of Alternate Atom Locations',
     &                 ' from (',a,') :  ',$)
            read (input,60)  record
   60       format (a240)
            next = 1
            call gettext (record,altsym,next)
         end if
         if (altsym .eq. ' ')  altsym = alttyp(1:1)
         call upcase (altsym)
      end if
c
c     find out which of the insert records will be used
c
      if (nins .gt. 0) then
         call nextarg (instemp,exist)
         if (.not. exist) then
            instemp = blank
            string(1:1) = instyp(1:1)
            length = 1
            do i = 2, nins
               string = string(1:length)//' '//instyp(i:i)
               length = length + 2
            end do
            string = string(1:length)//' [ALL] NONE'
            length = length + 11
            write (iout,70)  string(1:length)
   70       format (/,' Enter the Insert Records to Include',
     &                 ' (',a,') :  ',$)
            read (input,80)  instemp
   80       format (a20)
         end if
         call upcase (instemp)
         next = 1
         call gettext (instemp,text,next)
         if (text.eq.blank .or. text.eq.'ALL ') then
            instyp = instyp(1:nins)
         else if (text .eq. 'NONE ') then
            instyp = blank
         else
            instyp = instemp
         end if
      end if
c
c     find out which of the multiple models will be used
c
      if (nmodel .gt. 1) then
         call nextarg (string,exist)
         read (string,*,err=90,end=90)  modtemp
   90    continue
         if (.not. exist) then
            modtemp = 0
            write (iout,100)
  100       format (/,' Enter the Structural Model to Extract',
     &                 ' [0=All] :  ',$)
            read (input,110)  modtemp
  110       format (i10)
         end if
         if (modtemp .ne. 0)  nmodel = 1
         if (modtemp .eq. 0)  modtemp = 1
         imodel = modtemp
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine fixcif  --  shift CIF atom names to PDB names  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "fixcif" corrects CIF atom name entries by shifting them to
c     align with the standard PDB values
c
c
      subroutine fixcif (resname,atmname)
      implicit none
      character*1 first,last
      character*3 resname
      character*4 atmname
c
c
c     shift left-justified CIF names to standard PDB names
c
      first = atmname(1:1)
      if (first.ge.'A' .and.  first.le.'Z') then
         last = atmname(4:4)
         if (last .eq. ' ')  atmname = ' '//atmname(1:3)
      end if
c
c     convert unusual PDB names to their standard forms
c
      call fixpdb (resname,atmname)
      return
      end
c
c
c     ###########################################################
c     ##  COPYRIGHT (C) 2022 by Zhi Wang & Jay William Ponder  ##
c     ##                  All Rights Reserved                  ##
c     ###########################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine readdcd  --  input of DCD coordinate archive  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "readdcd" reads in a set of Cartesian coordinates from an
c     external file in CHARMM DCD binary format
c
c
      subroutine readdcd (idcd,first)
      use atoms
      use bound
      use boxes
      use files
      use inform
      use iounit
      use math
      use titles
      implicit none
      integer i,idcd
      integer blank
      integer nframe,nprev
      integer ncrdsav,nstep
      integer nvelsav,ndfree
      integer nfixat,usebox
      integer use4d,usefq
      integer merged,vcharmm
      integer ntitle
      real*4 tdelta
      real*4, allocatable :: xs(:)
      real*4, allocatable :: ys(:)
      real*4, allocatable :: zs(:)
      logical exist,opened
      logical first
      character*4 header
      character*80 info(10)
      character*240 dcdfile
c
c
c     open the input unit if it has not already been done
c
      inquire (unit=idcd,opened=opened)
      if (.not. opened) then
         dcdfile = filename(1:leng)//'.dcd'
         call version (dcdfile,'old')
         inquire (file=dcdfile,exist=exist)
         if (exist) then
            open (unit=idcd,file=dcdfile,form='unformatted',
     &               status='old')
            rewind (unit=idcd)
         else
            write (iout,10)
   10       format (/,' READDCD  --  Unable to Find the DCD',
     &                 ' Binary Archive File')
            call fatal
         end if
      end if
c
c     read header info along with title and number of atoms
c
      abort = .true.
      if (first) then
         first = .false.
         read (idcd,err=20,end=20)  header,nframe,nprev,ncrdsav,
     &                              nstep,nvelsav,blank,blank,ndfree,
     &                              nfixat,tdelta,usebox,use4d,usefq,
     &                              merged,blank,blank,blank,blank,
     &                              blank,vcharmm
         read (idcd,err=20,end=20)  ntitle,(info(i),i=1,ntitle)
         read (idcd,err=20,end=20)  n
         if (usebox .eq. 1)  use_bounds = .true.
         title(1:80) = info(1)
      end if
c
c     quit if the binary DCD file was not parsed correctly
c
      abort = .false.
   20 continue
      if (abort) then
         write (iout,30)
   30    format (/,' READDCD  --  Error Reading Header from',
     &              ' Binary DCD File')
         call fatal
      end if
c
c     read the lattice values based on header flag value;
c     using angle values is NAMD style, cosine values is CHARMM
c
      abort = .true.
      if (use_bounds) then
         call unitcell
         read (idcd,err=40,end=60)  xbox,gamma,ybox,beta,alpha,zbox
         if (abs(alpha) .le. 1.0d0)  alpha = radian * acos(alpha)
         if (abs(beta) .le. 1.0d0)  beta = radian * acos(beta)
         if (abs(gamma) .le. 1.0d0)  gamma = radian * acos(gamma)
         call lattice
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (xs(n))
      allocate (ys(n))
      allocate (zs(n))
c
c     read the atomic coordinates along each axis in turn
c
      abort = .true.
      read (idcd,err=40,end=60)  (xs(i),i=1,n)
      read (idcd,err=40,end=40)  (ys(i),i=1,n)
      read (idcd,err=40,end=40)  (zs(i),i=1,n)
c
c     quit if the binary DCD file was not parsed correctly
c
      abort = .false.
   40 continue
      if (abort) then
         write (iout,50)
   50    format (/,' READDCD  --  Error Reading Coordinates from',
     &              ' Binary DCD File')
         call fatal
      end if
c
c     copy the atomic coordinates into the current structure
c
      do i = 1, n
         x(i) = dble(xs(i))
         y(i) = dble(ys(i))
         z(i) = dble(zs(i))
      end do
c
c     perform deallocation of some local arrays
c
   60 continue
      if (allocated(xs))  deallocate (xs)
      if (allocated(ys))  deallocate (ys)
      if (allocated(zs))  deallocate (zs)
c
c     close the input unit if opened by this routine
c
      if (.not. opened)  close (unit=idcd)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine readdyn  --  input of MD restart information  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "readdyn" get the positions, velocities and accelerations
c     for a molecular dynamics restart from an external file
c
c
      subroutine readdyn (idyn)
      use atoms
      use boxes
      use files
      use group
      use iounit
      use mdstuf
      use moldyn
      use rgddyn
      implicit none
      integer i,j,idyn,ndyn
      logical exist,opened,quit
      character*240 dynfile
      character*240 record
c
c
c     open the input file if it has not already been done
c
      inquire (unit=idyn,opened=opened)
      if (.not. opened) then
         dynfile = filename(1:leng)//'.dyn'
         call version (dynfile,'old')
         inquire (file=dynfile,exist=exist)
         if (exist) then
            open (unit=idyn,file=dynfile,status='old')
            rewind (unit=idyn)
         else
            write (iout,10)
   10       format (/,' READDYN  --  Unable to Find the Dynamics',
     &                 ' Restart File')
            call fatal
         end if
      end if
c
c     initialize error handling during reading of the file
c
      i = 0
      quit = .true.
c
c     get the number of atoms and check for consistency
c
      read (idyn,20)
   20 format ()
      read (idyn,30)  record
   30 format (a240)
      read (record,*,err=240,end=240)  ndyn
      if (ndyn .ne. n) then
         write (iout,40)
   40    format (/,' READDYN  --  Restart File has Incorrect',
     &              ' Number of Atoms')
         call fatal
      end if
c
c     get the periodic box edge lengths and angles
c
      read (idyn,50)
   50 format ()
      read (idyn,60)  record
   60 format (a240)
      read (record,*,err=240,end=240)  xbox,ybox,zbox
      read (idyn,70)  record
   70 format (a240)
      read (record,*,err=240,end=240)  alpha,beta,gamma
c
c     set the box volume and additional periodic box values
c
      call lattice
c
c     get rigid body positions, translational and angular velocities
c
      if (integrate .eq. 'RIGIDBODY') then
         read (idyn,80)
   80    format ()
         do i = 1, n
            read (idyn,90)  record
   90       format (a240)
            read (record,*,err=240,end=240)  x(i),y(i),z(i)
         end do
         read (idyn,100)
  100    format ()
         do i = 1, ngrp
            read (idyn,110)  record
  110       format (a240)
            read (record,*,err=240,end=240)  vcm(1,i),vcm(2,i),vcm(3,i)
         end do
         read (idyn,120)
  120    format ()
         do i = 1, ngrp
            read (idyn,130)  record
  130       format (a240)
            read (record,*,err=240,end=240)  wcm(1,i),wcm(2,i),wcm(3,i)
         end do
         read (idyn,140)
  140    format ()
         do i = 1, ngrp
            read (idyn,150)  record
  150       format (a240)
            read (record,*,err=240,end=240)  lm(1,i),lm(2,i),lm(3,i)
         end do
c
c     get the atomic positions, velocities and accelerations
c
      else
         read (idyn,160)
  160    format ()
         do i = 1, n
            read (idyn,170)  record
  170       format (a240)
            read (record,*,err=240,end=240)  x(i),y(i),z(i)
         end do
         read (idyn,180)
  180    format ()
         do i = 1, n
            read (idyn,190)  record
  190       format (a240)
            read (record,*,err=240,end=240)  v(1,i),v(2,i),v(3,i)
         end do
         read (idyn,200)
  200    format ()
         do i = 1, n
            read (idyn,210)  record
  210       format (a240)
            read (record,*,err=240,end=240)  a(1,i),a(2,i),a(3,i)
         end do
         read (idyn,220)
  220    format ()
         do i = 1, n
            read (idyn,230)  record
  230       format (a240)
            read (record,*,err=240,end=240)  aalt(1,i),aalt(2,i),
     &                                       aalt(3,i)
         end do
         do i = 1, n
            do j = 1, 3
               aslow(j,i) = a(j,i)
               afast(j,i) = aalt(j,i)
            end do
         end do
      end if
      quit = .false.
  240 continue
      if (.not. opened)  close (unit=idyn)
c
c
c

c
c     report any error in reading the dynamics restart file
c
      if (quit) then
         write (iout,250)  i
  250    format (/,' READDYN  --  Error in Dynamics Restart',
     &              ' File at Atom',i6)
         call fatal
      end if
      return
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 2008 by Chuanjie Wu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine readgau  --  read data from G09 output file  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "readgau" reads an ab initio optimized structure, forces,
c     Hessian and frequencies from a Gaussian 09 output file
c
c
      subroutine readgau
      use ascii
      use iounit
      use qmstuf
      use units
      implicit none
      integer i,j
      integer igau,code
      integer ngfreq,nghess
      integer itmp,jtmp,ktmp
      integer length,next
      integer freeunit
      integer trimtext
      logical hasinputxyz
      logical hasmp2
      logical exist
      real*8 xtmp,ytmp,ztmp
      real*8 frcunit,hessunit
      character*4 arcstart
      character*6 gname
      character*240 gaufile
      character*240 record
      character*240 string
      character*240 word
c
c
c     initialize some values prior to opening the log file
c
      exist = .false.
      hasinputxyz = .false.
      ngatom = 0
      ngfreq = 0
      arcstart = '1'//char(backslash)//'1'//char(backslash)
c
c     specify and open the Gaussian 09 output log file
c
      call nextarg (gaufile,exist)
      if (exist) then
         inquire (file=gaufile,exist=exist)
         igau = freeunit()
         call basefile (gaufile)
         call suffix (gaufile,'log','old')
         inquire (file=gaufile,exist=exist)
         if (.not. exist) then
            call basefile (gaufile)
            call suffix (gaufile,'out','old')
            inquire (file=gaufile,exist=exist)
         end if
      end if
      do while (.not. exist)
         write (iout,10)
   10    format (/,' Enter the Gaussian Output File Name :  ',$)
         read (input,20)  gaufile
   20    format (a240)
         igau = freeunit ()
         call basefile (gaufile)
         call suffix (gaufile,'log','old')
         inquire (file=gaufile,exist=exist)
         if (.not. exist) then
            call basefile (gaufile)
            call suffix (gaufile,'out','old')
            inquire (file=gaufile,exist=exist)
         end if
      end do
c
c     scan the Gaussian output file to get the number of atoms
c
      open (unit=igau,file=gaufile,status='old')
      rewind (unit=igau)
c     do while (.true. .and. .not.eof(igau))
      do while (.true.)
         read (igau,30,err=70,end=70)  record
   30    format (a240)
         next = 1
         string = record
         call trimhead (string)
         length = trimtext (string)
         call upcase (string)
         if (string(1:20) .eq. 'STANDARD ORIENTATION') then
            do i = 1, 4
               read (igau,40,err=70,end=70)  record
   40          format (a240)
            end do
            i = 1
            do while (.true.)
               read (igau,50,err=70,end=70)  record
   50          format (a240)
               read (record,*,err=60,end=60)  itmp,jtmp,ktmp,
     &                                        xtmp,ytmp,ztmp
               if (jtmp .le. 0)  goto 60
               i = i + 1
            end do
   60       continue
            ngatom = i - 1
         end if
      end do
   70 continue
c
c     perform dynamic allocation of some global arrays
c
      nghess = (3*ngatom*(3*ngatom+1)) / 2
      if (.not. allocated(gx))  allocate (gx(ngatom))
      if (.not. allocated(gy))  allocate (gy(ngatom))
      if (.not. allocated(gz))  allocate (gz(ngatom))
      if (.not. allocated(gfreq))  allocate (gfreq(3*ngatom))
      if (.not. allocated(gforce))  allocate (gforce(3,ngatom))
      if (.not. allocated(gh))  allocate (gh(nghess))
c
c     read structure, forces and frequencies from Gaussian output
c
      rewind (unit=igau)
c     do while (.true. .and. .not.eof(igau))
      do while (.true.)
         read (igau,80,err=220,end=220)  record
   80    format (a240)
         next = 1
         string = record
         call trimhead (string)
         length = trimtext (string)
         call upcase (string)
         if (string(1:20) .eq. 'STANDARD ORIENTATION') then
            do i = 1, 4
               read (igau,90,err=220,end=220)  record
   90          format (a240)
            end do
            i = 1
            do while (i .le. ngatom)
               read (igau,100,err=220,end=220)  record
  100          format (a240)
               read (record,*,err=110,end=110)  itmp,jtmp,ktmp,
     &                                          gx(i),gy(i),gz(i)
               if (jtmp .le. 0)  goto 110
               i = i + 1
            end do
  110       continue
            ngatom = i - 1
         else if (string(37:58) .eq. 'FORCES (HARTREES/BOHR)') then
            read (igau,120,err=220,end=220)  record
  120       format (a240)
            read (igau,130,err=220,end=220)  record
  130       format (a240)
            frcunit = hartree / bohr
            do i = 1, ngatom
               gforce(1,i) = 0.0d0
               gforce(2,i) = 0.0d0
               gforce(3,i) = 0.0d0
               read (igau,140,err=220,end=220)  record
  140          format (a240)
               read (record,*,err=150,end=150)  itmp,jtmp,gforce(1,i),
     &                                          gforce(2,i),gforce(3,i)
               do j = 1, 3
                  gforce(j,i) = frcunit * gforce(j,i)
               end do
  150          continue
            end do
         else if (string(1:14) .eq. 'FREQUENCIES --') then
            gfreq(ngfreq+1) = 0.0d0
            gfreq(ngfreq+2) = 0.0d0
            gfreq(ngfreq+3) = 0.0d0
            read (string(15:240),*,err=160,end=160)  gfreq(ngfreq+1),
     &                                               gfreq(ngfreq+2),
     &                                               gfreq(ngfreq+3)
  160       continue
            ngfreq = ngfreq + 3
c
c     read the Hessian from archive section at bottom of output
c
         else if (string(1:4) .eq. arcstart) then
            itmp = 0
c           do while (.true. .and. .not.eof(igau))
            do while (.true.)
               if (next .gt. 73) then
                  read (igau,170,err=220,end=220)  record
  170             format (a240)
                  next = 1
               end if
               call readgarc (igau,record,word,length,next)
               if (word(1:1) .eq. char(backslash))  itmp = itmp + 1
               if (itmp.eq.16 .and. hasinputxyz) then
                  do i = 1, ngatom
                     do j = 1, 5
                        if (next .gt. 73) then
                           read (igau,180,err=220,end=220)  record
  180                      format (a240)
                           next = 1
                        end if
                        call readgarc (igau,record,word,length,next)
                        if (j .eq. 1)  read(word(1:length),*)  gname
                        if (j .eq. 2)  read(word(1:length),*)  gx(i)
                        if (j .eq. 3)  read(word(1:length),*)  gy(i)
                        if (j .eq. 4)  read(word(1:length),*)  gz(i)
                     end do
                  end do
               end if
               if (itmp.gt.16 .and. word(1:2).eq.'HF') then
                  do i = 1, 2
                     if (next .gt. 73) then
                        read (igau,190,err=220,end=220)  record
  190                   format (a240)
                        next = 1
                     end if
                     call readgarc (igau,record,word,length,next)
                  end do
                  read (word(1:length),*)  egau
                  egau = hartree * egau
               else if (itmp.gt.16 .and. word(1:3).eq.'MP2') then
                  hasmp2 = .true.
                  do i = 1, 2
                     if (next .gt. 73) then
                        read (igau,200,err=220,end=220)  record
  200                   format (a240)
                        next = 1
                     end if
                     call readgarc (igau,record,word,length,next)
                  end do
                  read (word(1:length),*)  egau
                  egau = hartree * egau
               else if (word(1:5) .eq. 'NImag') then
                  do i = 1, 4
                     call readgarc (igau,record,word,length,next)
                  end do
                  hessunit = hartree / bohr**2
                  do i = 1, nghess
                     call readgarc (igau,record,word,length,next)
                     read (word(1:length),*)  gh(i)
                     gh(i) = hessunit * gh(i)
                  end do
                  goto 220
               end if
               code = ichar(word(1:1))
               if (code .eq. atsign)  goto 210
            end do
         end if
  210    continue
      end do
  220 continue
      close (unit=igau)
c
c     zero out the frequencies if none were in Gaussian output
c
      if (ngfreq .eq. 0) then
         do i = 1, 3*ngatom
            gfreq(i) = 0.0d0
         end do
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine readgarc  --  read Gaussian archive section  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "readgarc" reads data from Gaussian archive section; each
c     entry is terminated with a backslash symbol
c
c
      subroutine readgarc (igau,string,word,length,next)
      use ascii
      implicit none
      integer i,igau,code
      integer next,length
      character*1 letter
      character*240 word
      character*240 string
c
c
c     initialize some values prior to parsing the test string
c
      length = 1
      letter = ' '
      do i = 1, 240
         word(i:i) = ' '
      end do
c
c     attempt to read a text word entry from the input string
c
      letter = string (next:next)
      code = ichar(letter)
      if (code.eq.backslash .or. code.eq.equal
     &       .or. code.eq.space) then
         word(1:1) = letter
         next = next + 1
         length = 1
         return
      end if
   10 continue
      do i = next, 75
         if (code.eq.backslash .or. code.eq.equal
     &          .or. code.eq.space)  return
         if (next .gt. 70) then
            read (igau,20,err=30,end=30)  string
   20       format (a240)
            next = 1
            goto 10
         end if
         if (code .eq. comma) then
            next = next + 1
            return
         end if
         if (code.eq.backslash .or. code.eq.equal
     &          .or. code.eq.space)  return
         word(length:length) = letter
         next = next + 1
         letter = string(next:next)
         code = ichar(letter)
         length = length + 1
      end do
      if (code .eq. atsign) then
         word(1:1) = letter
         length = 1
      end if
   30 continue
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2008  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine readgdma  --  input of GDMA multipole analysis  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "readgdma" takes the Distributed Multipole Analysis (DMA) output
c     in spherical harmonics from the GDMA program and converts to
c     Cartesian multipoles in the global coordinate frame
c
c     this version is compatible with the formatted output from
c     GDMA package developed by Anthony Stone; it also reads GDMA
c     output from Psi4
c
c
      subroutine readgdma (idma)
      use atomid
      use atoms
      use dma
      use files
      use iounit
      use mpole
      use units
      implicit none
      integer i,j,k
      integer idma,next
      integer freeunit
      real*8 term
      logical exist,done
      logical opened
      logical use_bohr
      character*3 atmnam
      character*240 record
      character*240 dmafile
c
c
c     open the input file if it has not already been done
c
      inquire (unit=idma,opened=opened)
      if (.not. opened) then
         dmafile = filename(1:leng)//'.dma'
         call version (dmafile,'old')
         inquire (file=dmafile,exist=exist)
         if (exist) then
            open (unit=idma,file=dmafile,status='old')
            rewind (unit=idma)
         else
            call nextarg (dmafile,exist)
            if (exist) then
               call basefile (dmafile)
               call suffix (dmafile,'dma','old')
               inquire (file=dmafile,exist=exist)
            end if
            do while (.not. exist)
               write (iout,10)
   10          format (/,' Enter GDMA Output File Name :  ',$)
               read (input,20)  dmafile
   20          format (a240)
               call basefile (dmafile)
               call suffix (dmafile,'dma','old')
               inquire (file=dmafile,exist=exist)
            end do
         end if
      end if
c
c     first open and then read the GDMA output file
c
      idma = freeunit ()
      open (unit=idma,file=dmafile,status='old')
c
c     count the number of atoms in the GDMA output file
c
      i = 0
      rewind (unit=idma)
      do while (.true.)
         read (idma,30,err=40,end=40)  record
   30    format (a240)
         if (record(12:14) .eq. 'x =') then
            i = i + 1
         else if (record(1:16) .eq. 'Total multipoles') then
            goto 40
         end if
      end do
   40 continue
      n = i
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(mp))  allocate (mp(n))
      if (.not. allocated(dpx))  allocate (dpx(n))
      if (.not. allocated(dpy))  allocate (dpy(n))
      if (.not. allocated(dpz))  allocate (dpz(n))
      if (.not. allocated(q20))  allocate (q20(n))
      if (.not. allocated(q21c))  allocate (q21c(n))
      if (.not. allocated(q21s))  allocate (q21s(n))
      if (.not. allocated(q22c))  allocate (q22c(n))
      if (.not. allocated(q22s))  allocate (q22s(n))
c
c     zero out the atomic coordinates and DMA values
c
      do i = 1, n
         x(i) = 0.0d0
         y(i) = 0.0d0
         z(i) = 0.0d0
         mp(i) = 0.0d0
         dpx(i) = 0.0d0
         dpy(i) = 0.0d0
         dpz(i) = 0.0d0
         q20(i) = 0.0d0
         q21c(i) = 0.0d0
         q21s(i) = 0.0d0
         q22c(i) = 0.0d0
         q22s(i) = 0.0d0
      end do
c
c     get coordinates and multipoles from GDMA output file
c
      i = 0
      rewind (unit=idma)
      do while (.true.)
         read (idma,50,err=70,end=70)  record
   50    format (a240)
         if (i .ne. 0)  call match1 (i,record)
         if (record(12:14) .eq. 'x =') then
            i = i + 1
            next = 1
            call gettext (record,name(i),next)
            read (record(15:24),*)  x(i)
            read (record(30:39),*)  y(i)
            read (record(45:54),*)  z(i)
            read (idma,60,err=70,end=70)
   60       format ()
         else if (record(1:16) .eq. 'Total multipoles') then
            goto 70
         end if
      end do
   70 continue
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(rpole))  allocate (rpole(maxpole,n))
c
c     convert quadrupole from spherical harmonic to Cartesian
c
      term = sqrt(0.75d0)
      do i = 1, n
         rpole(1,i) = mp(i)
         rpole(2,i) = dpx(i)
         rpole(3,i) = dpy(i)
         rpole(4,i) = dpz(i)
         rpole(5,i) = -0.5d0*q20(i) + term*q22c(i)
         rpole(6,i) = term*q22s(i)
         rpole(7,i) = term*q21c(i)
         rpole(8,i) = rpole(6,i)
         rpole(9,i) = -0.5d0*q20(i) - term*q22c(i)
         rpole(10,i) = term*q21s(i)
         rpole(11,i) = rpole(7,i)
         rpole(12,i) = rpole(10,i)
         rpole(13,i) = q20(i)
      end do
c
c     check for GDMA coordinate values in atomic units
c
      use_bohr = .false.
      rewind (unit=idma)
      do while (.true.)
         read (idma,80,err=90,end=90)  record
   80    format (a240)
         if (record(1:27) .eq. 'Positions and radii in bohr') then
            use_bohr = .true.
            goto 90
         end if
      end do
   90 continue
c
c     convert coordinates from Bohrs to Angstroms if needed
c
      if (use_bohr) then
         do i = 1, n
            x(i) = x(i) * bohr
            y(i) = y(i) * bohr
            z(i) = z(i) * bohr
         end do
      end if
c
c     find atomic numbers in verbose GDMA output if available
c
      done = .false.
      rewind (unit=idma)
      do while (.true.)
         read (idma,100,err=120,end=120)  record
  100    format (a240)
         if (record(1:16) .eq. 'Nuclear charges:') then
            k = min(n,20)
            read (record(17:240),*,err=120,end=120)  (atomic(i),i=1,k)
            do while (k .ne. n)
               j = k + 1
               k = min(n,k+20)
               read (idma,110,err=120,end=120)  record
  110          format (a240)
               read (record,*,err=120,end=120)  (atomic(i),i=j,k)
            end do
            done = .true.
         end if
      end do
  120 continue
c
c     attempt to get atomic numbers from GDMA atom names
c
      if (.not. done) then
         do i = 1, n
            atomic(i) = 0
            atmnam = name(i)
            call upcase (atmnam)
            if (atmnam(1:2) .eq. 'SI') then
               atomic(i) = 14
            else if (atmnam(1:2) .eq. 'CL') then
               atomic(i) = 17
            else if (atmnam(1:2) .eq. 'BR') then
               atomic(i) = 35
            else if (atmnam(1:1) .eq. 'H') then
               atomic(i) = 1
            else if (atmnam(1:1) .eq. 'B') then
               atomic(i) = 5
            else if (atmnam(1:1) .eq. 'C') then
               atomic(i) = 6
            else if (atmnam(1:1) .eq. 'N') then
               atomic(i) = 7
            else if (atmnam(1:1) .eq. 'O') then
               atomic(i) = 8
            else if (atmnam(1:1) .eq. 'F') then
               atomic(i) = 9
            else if (atmnam(1:1) .eq. 'P') then
               atomic(i) = 15
            else if (atmnam(1:1) .eq. 'S') then
               atomic(i) = 16
            else if (atmnam(1:1) .eq. 'I') then
               atomic(i) = 53
            else
               read (atmnam,*,err=130,end=130)  atomic(i)
  130          continue
            end if
         end do
      end if
c
c     print the global frame Cartesian atomic multipoles
c
      write (iout,140)
  140 format (/,' Global Frame Cartesian Multipole Moments :')
      do i = 1, n
         write (iout,150)  i,name(i),atomic(i)
  150    format (/,' Atom:',i8,9x,'Name:',3x,a3,7x,'Atomic Number:',i8)
         write (iout,160)  x(i),y(i),z(i)
  160    format (/,' Coordinates:',5x,3f15.6)
         write (iout,170)  rpole(1,i)
  170    format (/,' Charge:',10x,f15.5)
         write (iout,180)  rpole(2,i),rpole(3,i),rpole(4,i)
  180    format (' Dipole:',10x,3f15.5)
         write (iout,190)  rpole(5,i)
  190    format (' Quadrupole:',6x,f15.5)
         write (iout,200)  rpole(8,i),rpole(9,i)
  200    format (18x,2f15.5)
         write (iout,210)  rpole(11,i),rpole(12,i),rpole(13,i)
  210    format (18x,3f15.5)
      end do
c
c     convert the dipole and quadrupole moments to Angstroms,
c     quadrupole divided by 3 for use as traceless values
c
      do i = 1, n
         do k = 2, 4
            rpole(k,i) = rpole(k,i) * bohr
         end do
         do k = 5, 13
            rpole(k,i) = rpole(k,i) * bohr**2 / 3.0d0
         end do
      end do
c
c     close the GDMA multipole analysis output file
c
      if (.not. opened)  close (unit=idma)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine match1  --  match first value from GDMA output  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "match1" finds and stores the first multipole component found
c     on a line of output from Stone's GDMA program
c
c
      subroutine match1 (i,record)
      use dma
      implicit none
      integer i
      character*240 record
c
c
c     store first multipole components on a line of GDMA output
c
      if (record(6:8) .eq. 'Q0 ') then
         read (record(13:23),*)  mp(i)
         call match2 (i,record)
      else if (record(20:23) .eq. 'Q00 ') then
         read (record(26:36),*)  mp(i)
      else if (record(20:23) .eq. 'Q10 ') then
         read (record(26:36),*)  dpz(i)
         call match2 (i,record)
      else if (record(20:23) .eq. 'Q11c') then
         read (record(26:36),*)  dpx(i)
         call match2 (i,record)
      else if (record(20:23) .eq. 'Q11s') then
         read (record(26:36),*)  dpy(i)
         call match2 (i,record)
      else if (record(20:23) .eq. 'Q20 ') then
         read (record(26:36),*)  q20(i)
         call match2 (i,record)
      else if (record(20:23) .eq. 'Q21c') then
         read (record(26:36),*)  q21c(i)
         call match2 (i,record)
      else if (record(20:23) .eq. 'Q21s') then
         read (record(26:36),*)  q21s(i)
         call match2 (i,record)
      else if (record(20:23) .eq. 'Q22c') then
         read (record(26:36),*)  q22c(i)
         call match2 (i,record)
      else if (record(20:23) .eq. 'Q22s') then
         read (record(26:36),*)  q22s(i)
         call match2 (i,record)
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine match2  --  match second value from GDMA output  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "match2" finds and stores the second multipole component found
c     on a line of output from Stone's GDMA program
c
c
      subroutine match2 (i,record)
      use dma
      implicit none
      integer i
      character*240 record
c
c
c     store second multipole component on a line of GDMA output
c
      if (record(29:31) .eq. 'Q1 ') then
         read (record(36:46),*)  dpz(i)
         call match3 (i,record)
      else if (record(39:42) .eq. 'Q11c') then
         read (record(45:55),*)  dpx(i)
         call match3 (i,record)
      else if (record(39:42) .eq. 'Q11s') then
         read (record(45:55),*)  dpy(i)
         call match3 (i,record)
      else if (record(39:42) .eq. 'Q21c') then
         read (record(45:55),*)  q21c(i)
         call match3 (i,record)
      else if (record(39:42) .eq. 'Q21s') then
         read (record(45:55),*)  q21s(i)
         call match3 (i,record)
      else if (record(39:42) .eq. 'Q22c') then
         read (record(45:55),*)  q22c(i)
         call match3 (i,record)
      else if (record(39:42) .eq. 'Q22s') then
         read (record(45:55),*)  q22s(i)
         call match3 (i,record)
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine match3  --  match third value from GDMA output  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "match3" finds and stores the third multipole component found
c     on a line of output from Stone's GDMA program
c
c
      subroutine match3 (i,record)
      use dma
      implicit none
      integer i
      character*240 record
c
c
c     store third multipole component on a line of GDMA output
c
      if (record(52:54) .eq. 'Q2 ') then
         read (record(59:69),*)  q20(i)
      else if (record(58:61) .eq. 'Q11s') then
         read (record(64:74),*)  dpy(i)
      else if (record(58:61) .eq. 'Q21s') then
         read (record(64:74),*)  q21s(i)
      else if (record(58:61) .eq. 'Q22c') then
         read (record(64:74),*)  q22c(i)
      else if (record(58:61) .eq. 'Q22s') then
         read (record(64:74),*)  q22s(i)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine readint  --  input of internal coordinates  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "readint" gets a set of Z-matrix internal coordinates
c     from an external file
c
c
      subroutine readint (izmt)
      use atomid
      use atoms
      use files
      use inform
      use iounit
      use titles
      use zclose
      use zcoord
      implicit none
      integer i,j,izmt
      integer next,size
      integer first,last
      integer nexttext
      integer trimtext
      logical exist,opened
      logical quit
      character*240 intfile
      character*240 record
      character*240 string
c
c
c     initialize the total number of atoms in the system
c
      n = 0
c
c     open the input file if it has not already been done
c
      inquire (unit=izmt,opened=opened)
      if (.not. opened) then
         intfile = filename(1:leng)//'.int'
         open (unit=izmt,file=intfile,status='old')
         rewind (unit=izmt)
         call version (intfile,'old')
         inquire (file=intfile,exist=exist)
         if (exist) then
            open (unit=izmt,file=intfile,status='old')
            rewind (unit=izmt)
         else
            write (iout,10)
   10       format (/,' READINT  --  Unable to Find the Internal',
     &                 ' Coordinates File')
            call fatal
         end if
      end if
c
c     read first line and return if already at end of file
c
      quit = .false.
      abort = .true.
      size = 0
      do while (size .eq. 0)
         read (izmt,20,err=70,end=70)  record
   20    format (a240)
         size = trimtext (record)
      end do
      abort = .false.
      quit = .true.
c
c     parse the title line to get the number of atoms
c
      i = 0
      next = 1
      call gettext (record,string,next)
      read (string,*,err=70,end=70)  n
c
c     extract the title and determine its length
c
      string = record(next:240)
      first = nexttext (string)
      last = trimtext (string)
      if (last .eq. 0) then
         title = ' '
         ltitle = 0
      else
         title = string(first:last)
         ltitle = trimtext (title)
      end if
c
c     check for too many total atoms in the file
c
      if (n .le. 0) then
         write (iout,30)
   30    format (/,' READINT  --  The Coordinate File Does Not',
     &              ' Contain Any Atoms')
         call fatal
      else if (n .gt. maxatm) then
         write (iout,40)  maxatm
   40    format (' READINT  --  The Maximum of',i9,' Atoms',
     &              ' has been Exceeded')
         call fatal
      end if
c
c     initialize coordinates and connectivities for each atom
c
      do i = 1, n
         tag(i) = 0
         name(i) = '   '
         zbond(i) = 0.0d0
         zang(i) = 0.0d0
         ztors(i) = 0.0d0
         type(i) = 0
         do j = 1, 4
            iz(j,i) = 0
         end do
      end do
c
c     read the coordinates and connectivities for each atom
c
      do i = 1, n
         next = 1
         size = 0
         do while (size .eq. 0)
            read (izmt,50,err=70,end=70)  record
   50       format (a240)
            size = trimtext (record)
         end do
         read (record,*,err=70,end=70)  tag(i)
         call getword (record,name(i),next)
         string = record(next:240)
         read (string,*,err=60,end=60)  type(i),iz(1,i),zbond(i),
     &                                  iz(2,i),zang(i),iz(3,i),
     &                                  ztors(i),iz(4,i)
   60    continue
      end do
      quit = .false.
   70 continue
      if (.not. opened)  close (unit=izmt)
c
c     an error occurred in reading the Z-matrix coordinates
c
      if (quit) then
         write (iout,80)  i
   80    format (' READZ  --  Error in Z-Matrix File at Atom',i9)
         call fatal
      end if
c
c     read in any additional bonds to be added or deleted
c
      nadd = 0
      ndel = 0
      read (izmt,90,err=130,end=130)
   90 format ()
      do i = 1, maxatm
         read (izmt,100,err=130,end=130)  record
  100    format (a240)
         read (record,*,err=110,end=110)  (iadd(j,i),j=1,2)
         nadd = i
      end do
  110 continue
      do i = 1, maxatm
         read (izmt,120,err=130,end=130)  record
  120    format (a240)
         read (record,*,err=130,end=130)  (idel(j,i),j=1,2)
         ndel = i
      end do
  130 continue
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2024  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine readmbis  --  input of MBIS multipole analysis  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "readmbis" takes the Minimal Basis Iterative Stockholder (MBIS)
c     output as Cartesian multipoles from the Multiwfn program and
c     converts to Tinker format
c
c     this version assumes Multiwfn was invoked using Frank Jensen's
c     MBIS method to compute atomic multipoles
c
c
      subroutine readmbis (ichg,imbis)
      use atomid
      use atoms
      use files
      use iounit
      use mpole
      use units
      implicit none
      integer i,j,k,next
      integer ichg,imbis
      integer freeunit
      logical exist
      logical openchg
      logical openmbis
      character*3 atmnam
      character*240 record
      character*240 string
      character*240 chgfile
      character*240 mbisfile
c
c
c     open the charge and coordinates file if not already done
c
      inquire (unit=ichg,opened=openchg)
      if (.not. openchg) then
         chgfile = filename(1:leng)//'.chg'
         call version (chgfile,'old')
         inquire (file=chgfile,exist=exist)
         if (exist) then
            open (unit=ichg,file=chgfile,status='old')
            rewind (unit=ichg)
         else
            call nextarg (chgfile,exist)
            if (exist) then
               call basefile (chgfile)
               call suffix (chgfile,'chg','old')
               inquire (file=chgfile,exist=exist)
            end if
            do while (.not. exist)
               write (iout,10)
   10          format (/,' Enter CHG Output File Name :  ',$)
               read (input,20)  chgfile
   20          format (a240)
               call basefile (chgfile)
               call suffix (chgfile,'chg','old')
               inquire (file=chgfile,exist=exist)
            end do
         end if
      end if
c
c     open the MBIS atomic multipole file if not already done
c
      inquire (unit=imbis,opened=openmbis)
      if (.not. openmbis) then
         mbisfile = filename(1:leng)//'.mbis'
         call version (mbisfile,'old')
         inquire (file=mbisfile,exist=exist)
         if (exist) then
            open (unit=imbis,file=mbisfile,status='old')
            rewind (unit=imbis)
         else
            call nextarg (mbisfile,exist)
            if (exist) then
               call basefile (mbisfile)
               call suffix (mbisfile,'mbis_mpl','old')
               inquire (file=mbisfile,exist=exist)
            end if
            do while (.not. exist)
               write (iout,30)
   30          format (/,' Enter MBIS Output File Name :  ',$)
               read (input,40)  mbisfile
   40          format (a240)
               call basefile (mbisfile)
               call suffix (mbisfile,'mbis_mpl','old')
               inquire (file=mbisfile,exist=exist)
            end do
         end if
      end if
c
c     first open and then read the charge output file
c
      ichg = freeunit ()
      open (unit=ichg,file=chgfile,status='old')
      rewind (unit=ichg)
c
c     get the number of atoms and the atomic coordinates
c
      i = 0
      do while (.true.)
         read (ichg,50,err=60,end=60)  record
   50    format (a240)
         i = i + 1
         next = 1
         call gettext (record,name(i),next)
         string = record(next:240)
         read (string,*,err=60,end=60)  x(i),y(i),z(i)
      end do
   60 continue
      n = i
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(rpole))  allocate (rpole(maxpole,n))
c
c     now open and then read the MBIS output file
c
      imbis = freeunit ()
      open (unit=imbis,file=mbisfile,status='old')
      rewind (unit=imbis)
c
c     get the atomic multipole values from MBIS output file
c
      do while (.true.)
         read (imbis,70,err=110,end=110)  record
   70    format (a240)
         if (record(3:16) .eq. 'Atomic charges') then
            do i = 1, n
               read (imbis,80,err=110,end=110)  record
   80          format (a240)
               next = 1
               call gettext (record,name(i),next)
               string = record(next:240)
               read (string,*,err=110,end=110)  rpole(1,i)
            end do
         end if
         if (record(3:16) .eq. 'Atomic dipoles') then
            do i = 1, n
               read (imbis,90,err=110,end=110)  record
   90          format (a240)
               next = 1
               call gettext (record,name(i),next)
               string = record(next:240)
               read (string,*,err=110,end=110)  (rpole(j,i),j=2,4)
            end do
         end if
         if (record(3:31) .eq. 'Atomic quadrupoles, Traceless') then
            do i = 1, n
               read (imbis,100,err=110,end=110)  record
  100          format (a240)
               next = 1
               call gettext (record,name(i),next)
               string = record(next:240)
               read (string,*,err=110,end=110)  rpole(5,i),rpole(6,i),
     &                                          rpole(7,i),rpole(9,i),
     &                                          rpole(10,i),rpole(13,i)
               rpole(8,i) = rpole(6,i)
               rpole(11,i) = rpole(7,i)
               rpole(12,i) = rpole(10,i)
            end do
         end if
      end do
  110 continue
c
c     attempt to get atomic numbers from Multiwfn atom names
c
      do i = 1, n
         atomic(i) = 0
         atmnam = name(i)
         call upcase (atmnam)
         if (atmnam(1:2) .eq. 'SI') then
            atomic(i) = 14
         else if (atmnam(1:2) .eq. 'CL') then
            atomic(i) = 17
         else if (atmnam(1:2) .eq. 'BR') then
            atomic(i) = 35
         else if (atmnam(1:1) .eq. 'H') then
            atomic(i) = 1
         else if (atmnam(1:1) .eq. 'B') then
            atomic(i) = 5
         else if (atmnam(1:1) .eq. 'C') then
            atomic(i) = 6
         else if (atmnam(1:1) .eq. 'N') then
            atomic(i) = 7
         else if (atmnam(1:1) .eq. 'O') then
            atomic(i) = 8
         else if (atmnam(1:1) .eq. 'F') then
            atomic(i) = 9
         else if (atmnam(1:1) .eq. 'P') then
            atomic(i) = 15
         else if (atmnam(1:1) .eq. 'S') then
            atomic(i) = 16
         else if (atmnam(1:1) .eq. 'I') then
            atomic(i) = 53
         else
            read (atmnam,*,err=120,end=120)  atomic(i)
  120       continue
         end if
      end do
c
c     print the global frame Cartesian atomic multipoles
c
      write (iout,130)
  130 format (/,' Global Frame Cartesian Multipole Moments :')
      do i = 1, n
         write (iout,140)  i,name(i),atomic(i)
  140    format (/,' Atom:',i8,9x,'Name:',3x,a3,7x,'Atomic Number:',i8)
         write (iout,150)  x(i),y(i),z(i)
  150    format (/,' Coordinates:',5x,3f15.6)
         write (iout,160)  rpole(1,i)
  160    format (/,' Charge:',10x,f15.5)
         write (iout,170)  rpole(2,i),rpole(3,i),rpole(4,i)
  170    format (' Dipole:',10x,3f15.5)
         write (iout,180)  rpole(5,i)
  180    format (' Quadrupole:',6x,f15.5)
         write (iout,190)  rpole(8,i),rpole(9,i)
  190    format (18x,2f15.5)
         write (iout,200)  rpole(11,i),rpole(12,i),rpole(13,i)
  200    format (18x,3f15.5)
      end do
c
c     convert the dipole and quadrupole moments to Angstroms,
c     quadrupole divided by 3 for use as traceless values
c
      do i = 1, n
         do k = 2, 4
            rpole(k,i) = rpole(k,i) * bohr
         end do
         do k = 5, 13
            rpole(k,i) = rpole(k,i) * bohr**2 / 3.0d0
         end do
      end do
c
c     close the MBIS multipole analysis output file
c
      if (.not. openchg)  close (unit=imbis)
      if (.not. openmbis)  close (unit=imbis)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2012  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine readmol  --  read in a MDL MOL format file  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "readmol" gets a set of MDL MOL coordinates from an
c     external file
c
c
      subroutine readmol (imdl)
      use atomid
      use atoms
      use couple
      use files
      use iounit
      use ptable
      use titles
      implicit none
      integer i,j,ia,ib,imdl
      integer nbond
      integer trimtext
      logical exist,opened
      character*240 mdlfile
c
c
c     open the input file if it has not already been done
c
      inquire (unit=imdl,opened=opened)
      if (.not. opened) then
         mdlfile = filename(1:leng)//'.mol'
         call version (mdlfile,'old')
         inquire (file=mdlfile,exist=exist)
         if (exist) then
            open (unit=imdl,file=mdlfile,status='old')
            rewind (unit=imdl)
         else
            write (iout,10)
   10       format (/,' READMOL  --  Unable to Find the Specified',
     &                 ' MDL MOL File')
            call fatal
         end if
      end if
c
c     zero out the total number of atoms and of bonds
c
      n = 0
      nbond = 0
c
c     get title line and get the number of atoms and bonds
c
      read (imdl,20)  title
   20 format (a240)
      ltitle = trimtext (title)
      read (imdl,30)
   30 format (/)
      read (imdl,40)  n,nbond
   40 format (2i3)
c
c     check for too few or too many total atoms in the file
c
      if (n .le. 0) then
         write (iout,50)
   50    format (/,' READMOL  --  The Coordinate File Does Not',
     &              ' Contain Any Atoms')
         call fatal
      else if (n .gt. maxatm) then
         write (iout,60)  maxatm
   60    format (/,' READMOL  --  The Maximum of',i9,' Atoms',
     &              ' has been Exceeded')
         call fatal
      end if
c
c     read the atomic coordinates and atomic symbol
c
      do i = 1, n
         read (imdl,70)  x(i),y(i),z(i),name(i)
   70    format (3f10.4,1x,a3)
         n12(i) = 0
      end do
c
c     read the bond list to get attached atom lists
c
      do i = 1, nbond
         read (imdl,80)  ia,ib
   80    format (2i3)
         n12(ia) = n12(ia) + 1
         i12(n12(ia),ia) = ib
         n12(ib) = n12(ib) + 1
         i12(n12(ib),ib) = ia
      end do
c
c     assign atom types from atomic number and connectivity
c
      do i = 1, n
         type(i) = 0
         do j = 1, maxele
            if (name(i) .eq. elemnt(j)) then
               type(i) = 10*j + n12(i)
               goto 90
            end if
         end do
   90    continue
      end do
c
c     for each atom, sort its list of attached atoms
c
      do i = 1, n
         call sort (n12(i),i12(1,i))
      end do
      if (.not. opened)  close (unit=imdl)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine readmol2  --  input of a Tripos MOL2 file  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "readmol2" gets a set of Tripos MOL2 coordinates from an
c     external file
c
c
      subroutine readmol2 (imol2)
      use atomid
      use atoms
      use couple
      use files
      use iounit
      use ptable
      use titles
      implicit none
      integer i,j,k,m
      integer ia,ib,imol2
      integer nbond,number
      integer next,trimtext
      logical exist,opened
      character*8 atmnam
      character*240 mol2file
      character*240 record
      character*240 string
c
c
c     open the input file if it has not already been done
c
      inquire (unit=imol2,opened=opened)
      if (.not. opened) then
         mol2file = filename(1:leng)//'.mol2'
         call version (mol2file,'old')
         inquire (file=mol2file,exist=exist)
         if (exist) then
            open (unit=imol2,file=mol2file,status='old')
            rewind (unit=imol2)
         else
            write (iout,10)
   10       format (/,' READMOL2  --  Unable to Find the TRIPOS',
     &                 ' MOL2 File')
            call fatal
         end if
      end if
c
c     zero out the total number of atoms and of bonds
c
      n = 0
      nbond = 0
c
c     get title line and get the number of atoms and bonds
c
      do while (.true.)
         read (imol2,20,err=50,end=50)  record
   20    format (a240)
         next = 1
         call gettext (record,string,next)
         call upcase (string)
         if (string .eq. '@<TRIPOS>MOLECULE') then
            read (imol2,30)  title
   30       format (a240)
            ltitle = trimtext (title)
            read (imol2,40)  record
   40       format (a240)
            read (record,*)  n,nbond
            goto 50
         end if
      end do
   50 continue
c
c     check for too few or too many total atoms in the file
c
      if (n .le. 0) then
         write (iout,60)
   60    format (/,' READMOL2  --  The Coordinate File Does Not',
     &              ' Contain Any Atoms')
         call fatal
      else if (n .gt. maxatm) then
         write (iout,70)  maxatm
   70    format (/,' READMOL2  --  The Maximum of',i9,' Atoms',
     &              ' has been Exceeded')
         call fatal
      end if
c
c     read the atom names and coordinates
c
      do while (.true.)
         read (imol2,80,err=100,end=100)  record
   80    format (a240)
         next = 1
         call gettext (record,string,next)
         call upcase (string)
         if (string .eq. '@<TRIPOS>ATOM') then
            do j = 1, n
               read (imol2,90)  record
   90          format (a240)
               read (record,*)  number
               next = 1
               call getword (record,atmnam,next)
               string = record(next:240)
               read (string,*)  x(j),y(j),z(j)
               call getword (record,atmnam,next)
               name(j) = atmnam(1:3)
               do k = 1, 3
                  if (atmnam(k:k) .eq. '.') then
                     do m = k, 3
                        name(j)(m:m) = ' '
                     end do
                  end if
               end do
            end do
            goto 100
         end if
      end do
  100 continue
c
c     read the bond list to get attached atom lists
c
      do while (.true.)
         read (imol2,110,err=130,end=130)  record
  110    format (a240)
         next = 1
         call gettext (record,string,next)
         call upcase (string)
         if (string .eq. '@<TRIPOS>BOND') then
            do j = 1, nbond
               read (imol2,120)  record
  120          format (a240)
               read (record,*)  number,ia,ib
               n12(ia) = n12(ia) + 1
               i12(n12(ia),ia) = ib
               n12(ib) = n12(ib) + 1
               i12(n12(ib),ib) = ia
            end do
            goto 130
         end if
      end do
  130 continue
c
c     assign atom types from atomic number and connectivity
c
      do i = 1, n
         type(i) = 0
         do j = 1, maxele
            if (name(i) .eq. elemnt(j)) then
               type(i) = 10*j + n12(i)
               goto 140
            end if
         end do
  140    continue
      end do
c
c     for each atom, sort its list of attached atoms
c
      do i = 1, n
         call sort (n12(i),i12(1,i))
      end do
      if (.not. opened)  close (unit=imol2)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine readpdb  --  input of Protein Data Bank file  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "readpdb" gets a set of coordinates in RCSB legacy PDB
c     format from an external file
c
c
      subroutine readpdb (ipdb)
      use boxes
      use files
      use inform
      use iounit
      use pdb
      use resdue
      use sequen
      use titles
      implicit none
      integer i,j,k,ipdb
      integer start,stop
      integer index,serial
      integer next,nxtlast
      integer residue,reslast
      integer model
      integer trimtext
      real*8 xx,yy,zz
      real*8 xbx,ybx,zbx
      real*8 aan,ban,gan
      logical exist,opened
      logical first
      character*1 chain,chnlast
      character*1 altloc
      character*1 insert,inslast
      character*1 letter
      character*1, allocatable :: chnatm(:)
      character*3 resname,atmsymb
      character*3 namelast
      character*4 atmname
      character*6 remark
      character*240 pdbfile
      character*240 record
      character*240 string
      save first
      data first  / .true. /
c
c
c     open the input file if it has not already been done
c
      inquire (unit=ipdb,opened=opened)
      if (.not. opened) then
         pdbfile = filename(1:leng)//'.pdb'
         call version (pdbfile,'old')
         inquire (file=pdbfile,exist=exist)
         if (exist) then
            open (unit=ipdb,file=pdbfile,status='old')
            rewind (unit=ipdb)
         else
            write (iout,10)
   10       format (/,' READPDB  --  Unable to Find the Protein',
     &                 ' Data Bank File')
            call fatal
         end if
      end if
c
c     get alternate sites, chains and insertions to be used
c
      if (first)  call scanpdb (ipdb)
c
c     initialize title, atom and residue counters and name
c
      title = ' '
      ltitle = 0
      npdb = 0
      nres = 0
      reslast = maxres
      namelast = '   '
      chnlast = ' '
      model = 0
c
c     perform dynamic allocation of some local arrays
c
      allocate (chnatm(maxatm))
c
c     perform dynamic allocation of some global arrays
c
      if (first) then
         first = .false.
         if (.not. allocated(resnum))  allocate (resnum(maxatm))
         if (.not. allocated(resatm))  allocate (resatm(2,maxatm))
         if (.not. allocated(pdbmod))  allocate (pdbmod(maxatm))
         if (.not. allocated(xpdb))  allocate (xpdb(maxatm))
         if (.not. allocated(ypdb))  allocate (ypdb(maxatm))
         if (.not. allocated(zpdb))  allocate (zpdb(maxatm))
         if (.not. allocated(pdbres))  allocate (pdbres(maxatm))
         if (.not. allocated(pdbsym))  allocate (pdbsym(maxatm))
         if (.not. allocated(pdbatm))  allocate (pdbatm(maxatm))
         if (.not. allocated(pdbrec))  allocate (pdbrec(maxatm))
      end if
c
c     process info and individual atoms from the PDB file
c
      do while (.true.)
         read (ipdb,20,err=230,end=230)  record
   20    format (a240)
         remark = record(1:6)
         call upcase (remark)
         if (remark .eq. 'TITLE ') then
            title = record(11:70)
            ltitle = trimtext (title)
         else if (remark .eq. 'HEADER') then
            if (ltitle .eq. 0) then
               title = record(11:70)
               ltitle = trimtext (title)
            end if
         else if (remark .eq. 'CRYST1') then
            next = 7
            string = record(next:240)
            read (string,*)  xbx,ybx,zbx,aan,ban,gan
            if (xbx .gt. 1.0d0) then
               xbox = xbx
               ybox = ybx
               zbox = zbx
               alpha = aan
               beta = ban
               gamma = gan
               call unitcell
            end if
         else if (remark .eq. 'ATOM  ') then
            next = 7
            call getnumb (record,serial,next)
            string = record(next+1:next+4)
            read (string,30)  atmname
   30       format (a4)
            call upcase (atmname)
            string = record(next+5:next+5)
            read (string,40)  altloc
   40       format (a1)
            string = record(next+6:next+8)
            read (string,50)  resname
   50       format (a3)
            call upcase (resname)
            string = record(next+10:next+10)
            read (string,60)  chain
   60       format (a1)
            next = next + 11
            nxtlast = next
            call getnumb (record,residue,next)
            if (next .eq. nxtlast) then
               string = record(next:next+3)
               read (string,70)  residue
   70          format (i4)
               next = next + 4
            end if
            string = record(next:next)
            read (string,80)  insert
   80       format (a1)
            string = record(next+1:240)
            read (string,*,err=90,end=90)  xx,yy,zz
            goto 100
   90       continue
            string = record(31:38)
            read (string,*)  xx
            string = record(39:46)
            read (string,*)  yy
            string = record(47:54)
            read (string,*)  zz
  100       continue
            next = 77
            call getword (record,atmsymb,next)
            if (index(chnsym,chain) .eq. 0)  goto 120
            if (altloc.ne.' ' .and. altloc.ne.altsym)  goto 120
            if (insert.ne.' ' .and. index(instyp,insert).eq.0)  goto 120
            if (model.ne.imodel .and. imodel.ne.0)  goto 120
            call fixpdb (resname,atmname)
            if (resname .eq. 'HOH') then
               remark = 'HETATM'
            else if (resname .eq. ' LI') then
               remark = 'HETATM'
            else if (resname .eq. '  F') then
               remark = 'HETATM'
            else if (resname .eq. ' NA') then
               remark = 'HETATM'
            else if (resname .eq. ' MG') then
               remark = 'HETATM'
            else if (resname .eq. ' CL') then
               remark = 'HETATM'
            else if (resname .eq. '  K') then
               remark = 'HETATM'
            else if (resname .eq. ' CA') then
               remark = 'HETATM'
            else if (resname .eq. ' FE') then
               remark = 'HETATM'
            else if (resname .eq. ' ZN') then
               remark = 'HETATM'
            else if (resname .eq. ' BR') then
               remark = 'HETATM'
            else if (resname .eq. '  I') then
               remark = 'HETATM'
            else if (residue.ne.reslast .or. resname.ne.namelast .or.
     &               chain.ne.chnlast .or. insert.ne.inslast) then
               nres = nres + 1
               reslast = residue
               namelast = resname
               chnlast = chain
               inslast = insert
               if (nres .gt. maxres) then
                  write (iout,110)  maxres
  110             format (/,' READPDB  --  The Maximum of',i6,
     &                       ' Residues has been Exceeded')
                  call fatal
               end if
               nseq = nres
               seq(nseq) = resname
            end if
            npdb = npdb + 1
            xpdb(npdb) = xx
            ypdb(npdb) = yy
            zpdb(npdb) = zz
            pdbrec(npdb) = remark
            pdbatm(npdb) = atmname
            pdbsym(npdb) = atmsymb
            pdbres(npdb) = resname
            pdbmod(npdb) = model
            resnum(npdb) = nres
            if (resname .eq. 'HOH')  resnum(npdb) = 0
            chnatm(npdb) = chain
  120       continue
         else if (remark .eq. 'HETATM') then
            next = 7
            call getnumb (record,serial,next)
            string = record(next+1:next+4)
            read (string,130)  atmname
  130       format (a4)
            call upcase (atmname)
            string = record(next+5:next+5)
            read (string,140)  altloc
  140       format (a1)
            string = record(next+6:next+8)
            read (string,150)  resname
  150       format (a3)
            call upcase (resname)
            string = record(next+10:next+10)
            read (string,160)  chain
  160       format (a1)
            next = next + 11
            call getnumb (record,residue,next)
            if (next .eq. nxtlast) then
               string = record(next:next+3)
               read (string,170)  residue
  170          format (i4)
               next = next + 4
            end if
            string = record(next:next)
            read (string,180)  insert
  180       format (a1)
            string = record(next+1:240)
            read (string,*,err=190,end=190)  xx,yy,zz
            goto 200
  190       continue
            string = record(31:38)
            read (string,*)  xx
            string = record(39:46)
            read (string,*)  yy
            string = record(47:54)
            read (string,*)  zz
  200       continue
            next = 77
            call getword (record,atmsymb,next)
            if (index(chnsym,chain) .eq. 0)  goto 210
            if (altloc.ne.' ' .and. altloc.ne.altsym)  goto 210
            if (insert.ne.' ' .and. index(instyp,insert).eq.0)  goto 210
            if (model.ne.imodel .and. imodel.ne.0)  goto 210
            call fixpdb (resname,atmname)
            npdb = npdb + 1
            xpdb(npdb) = xx
            ypdb(npdb) = yy
            zpdb(npdb) = zz
            pdbrec(npdb) = remark
            pdbatm(npdb) = atmname
            pdbsym(npdb) = atmsymb
            pdbres(npdb) = resname
            pdbmod(npdb) = model
            resnum(npdb) = 0
            chnatm(npdb) = chain
  210       continue
         else if (remark .eq. 'MODEL ') then
            next = 7
            string = record(next:240)
            read (string,*)  model
         else if (remark .eq. 'END   ') then
            goto 230
         end if
         if (npdb .gt. maxatm) then
            write (iout,220)  maxatm
  220       format (/,' READPDB  --  The Maximum of',i6,
     &                 ' Atoms has been Exceeded')
            call fatal
         end if
      end do
  230 continue
c
c     set the total sequence length and chain terminus sites
c
      if (npdb .ne. 0) then
         nchain = 0
         chnlast = '#'
         do i = 1, npdb
            if (pdbrec(i) .eq. 'ATOM  ') then
               letter = chnatm(i)
               if (letter .ne. chnlast) then
                  nchain = nchain + 1
                  ichain(1,nchain) = resnum(i)
                  chnnam(nchain) = letter
                  chnlast = letter
               else
                  ichain(2,nchain) = resnum(i)
               end if
            end if
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (chnatm)
c
c     find the type of species present in each chain
c
      do i = 1, nchain
         start = ichain(1,i)
         stop = ichain(2,i)
         chntyp(i) = 'GENERIC'
         do j = start, stop
            do k = 1, maxamino
               if (seq(j) .eq. amino(k)) then
                  chntyp(i) = 'PEPTIDE'
                  goto 240
               end if
            end do
            chntyp(i) = 'GENERIC'
            goto 250
  240       continue
         end do
  250    continue
         if (chntyp(i) .eq. 'GENERIC') then
            do j = start, stop
               do k = 1, maxnuc
                  if (seq(j) .eq. nuclz(k)) then
                     chntyp(i) = 'NUCLEIC'
                     goto 260
                  end if
               end do
               chntyp(i) = 'GENERIC'
               goto 270
  260          continue
            end do
  270       continue
         end if
      end do
c
c     get the three-letter sequence and code for each residue
c
      do i = 1, nchain
         start = ichain(1,i)
         stop = ichain(2,i)
         do j = start, stop
            do k = 1, maxamino
               if (seq(j) .eq. amino(k)) then
                  seqtyp(j) = k
                  goto 280
               end if
            end do
            do k = 1, maxnuc
               if (seq(j) .eq. nuclz(k)) then
                  seqtyp(j) = k
                  goto 280
               end if
            end do
            seq(j) = 'UNK'
            seqtyp(j) = 0
            if (chntyp(i) .eq. 'PEPTIDE')  seqtyp(j) = maxamino
            if (chntyp(i) .eq. 'NUCLEIC')  seqtyp(j) = maxnuc
  280       continue
         end do
      end do
c
c     set a pointer to the first and last atom of each residue
c
      nres = 0
      k = 0
      do i = 1, npdb
         if (pdbrec(i) .eq. 'ATOM  ') then
            if (resnum(i) .ne. k) then
               k = resnum(i)
               nres = nres + 1
               resatm(1,nres) = i
               if (nres .gt. 1)  resatm(2,nres-1) = i - 1
            end if
         end if
      end do
      if (nres .ge. 1)  resatm(2,nres) = npdb
c
c     close the input file and quit if no coordinates found
c
      if (.not. opened)  close (unit=ipdb)
      if (npdb .eq. 0)  abort = .true.
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine scanpdb  --  PDB chains, alternates & inserts  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "scanpdb" reads the first model in a legacy PDB file and
c     finds chains, alternate sites, insertions and models
c
c
      subroutine scanpdb (ipdb)
      use iounit
      use pdb
      use sequen
      implicit none
      integer i,k,ipdb
      integer next,nxtlast
      integer length,dummy
      integer nalt,nins
      integer model,modtemp
      logical exist,done
      character*1 chain,chnlast
      character*1 altloc,altlast
      character*1 insert,inslast
      character*6 remark
      character*20 blank,text
      character*20 chntemp
      character*20 alttyp
      character*20 instemp
      character*240 record
      character*240 string
c
c
c     initialize chain, alternate site and insertion lists
c
      nchain = 0
      nalt = 0
      nins = 0
      chnlast = '#'
      altlast = '#'
      inslast = '#'
      blank = '                    '
      chnsym = '####################'
      altsym = ' '
      alttyp = blank
      instyp = blank
      nmodel = 0
      imodel = 0
c
c     scan for multiple chains, alternate locations and inserts
c
      done = .false.
      do while (.not. done)
         read (ipdb,10,err=60,end=60)  record
   10    format (a240)
         remark = record(1:6)
         call upcase (remark)
         if (remark.eq.'ATOM  ' .or. remark.eq.'HETATM') then
            next = 7
            call getnumb (record,dummy,next)
            string = record(next+5:next+5)
            read (string,20)  altloc
   20       format (a1)
            string = record(next+10:next+10)
            read (string,30)  chain
   30       format (a1)
            next = next + 11
            nxtlast = next
            call getnumb (record,dummy,next)
            if (next .eq. nxtlast) then
               string = record(next:next+3)
               read (string,40)  dummy
   40          format (i4)
               next = next + 4
            end if
            string = record(next:next)
            read (string,50)  insert
   50       format (a1)
            if (chain .ne. chnlast) then
               if (index(chnsym,chain) .eq. 0) then
                  nchain = nchain + 1
                  chnsym(nchain:nchain) = chain
                  chnlast = chain
               end if
            end if
            if (altloc .ne. altlast) then
               if (index(alttyp,altloc) .eq. 0) then
                  nalt = nalt + 1
                  alttyp(nalt:nalt) = altloc
                  altlast = altloc
               end if
            end if
            if (insert .ne. inslast) then
               if (index(instyp,insert) .eq. 0) then
                  nins = nins + 1
                  instyp(nins:nins) = insert
                  inslast = insert
               end if
            end if
         else if (remark .eq. 'MODEL ') then
            next = 7
            string = record(next:240)
            read (string,*)  model
            nmodel = max(model,nmodel)
         else if (remark .eq. 'END   ') then
            done = .true.
         end if
      end do
   60 continue
      rewind (unit=ipdb)
c
c     find out which of the multiple chains will be used
c
      if (nchain .gt. 1) then
         call nextarg (chntemp,exist)
         if (.not. exist) then
            chntemp = blank
            if (chnsym(1:1) .eq. ' ') then
               string = 'BLANK=@'
               length = 7
            else
               string(1:1) = chnsym(1:1)
               length = 1
            end if
            do i = 2, nchain
               if (chnsym(i:i) .eq. ' ') then
                  string = string(1:length)//' BLANK=@'
                  length = length + 8
               else
                  string = string(1:length)//' '//chnsym(i:i)
                  length = length + 2
               end if
            end do
            string = string(1:length)//' [ALL]'
            length = length + 6
            write (iout,70)  string(1:length)
   70       format (/,' Enter the Chain Names to Include',
     &                 ' (',a,') :  ',$)
            read (input,80)  chntemp
   80       format (a20)
         end if
         call upcase (chntemp)
         next = 1
         call gettext (chntemp,text,next)
         if (text.eq.blank .or. text(1:3).eq.'ALL') then
            chnsym = chnsym(1:nchain)
         else
            do i = 1, nchain
               chain = chnsym(i:i)
               if (chain .eq. ' ')  chain = '@'
               k = index(chntemp,chain)
               if (k .eq. 0)  chnsym(i:i) = '#'
            end do
            chntemp = chnsym
            k = 0
            do i = 1, nchain
               chain = chntemp(i:i)
               if (chain .eq. '@')  chain = ' '
               if (chain .ne. '#') then
                  k = k + 1
                  chnsym(k:k) = chain
               end if
            end do
            nchain = k
         end if
      end if
      do i = nchain+1, 20
         chnsym(i:i) = '#'
      end do
c
c     find out which of alternate locations will be used
c
      if (nalt .gt. 0) then
         call nextarg (altsym,exist)
         if (.not. exist) then
            string(1:3) = '['//alttyp(1:1)//']'
            length = 3
            do i = 2, nalt
               string = string(1:length)//' '//alttyp(i:i)
               length = length + 2
            end do
            write (iout,90)  string(1:length)
   90       format (/,' Enter a Set of Alternate Atom Locations',
     &                 ' from (',a,') :  ',$)
            read (input,100)  record
  100       format (a240)
            next = 1
            call gettext (record,altsym,next)
         end if
         if (altsym .eq. ' ')  altsym = alttyp(1:1)
         call upcase (altsym)
      end if
c
c     find out which of the insert records will be used
c
      if (nins .gt. 0) then
         call nextarg (instemp,exist)
         if (.not. exist) then
            instemp = blank
            string(1:1) = instyp(1:1)
            length = 1
            do i = 2, nins
               string = string(1:length)//' '//instyp(i:i)
               length = length + 2
            end do
            string = string(1:length)//' [ALL] NONE'
            length = length + 11
            write (iout,110)  string(1:length)
  110       format (/,' Enter the Insert Records to Include',
     &                 ' (',a,') :  ',$)
            read (input,120)  instemp
  120       format (a20)
         end if
         call upcase (instemp)
         next = 1
         call gettext (instemp,text,next)
         if (text.eq.blank .or. text.eq.'ALL ') then
            instyp = instyp(1:nins)
         else if (text .eq. 'NONE ') then
            instyp = blank
         else
            instyp = instemp
         end if
      end if
c
c     find out which of the multiple models will be used
c
      if (nmodel .gt. 1) then
         call nextarg (string,exist)
         read (string,*,err=130,end=130)  modtemp
  130    continue
         if (.not. exist) then
            modtemp = 0
            write (iout,140)
  140       format (/,' Enter the Structural Model to Extract',
     &                 ' [0=All] :  ',$)
            read (input,150)  modtemp
  150       format (i10)
         end if
         if (modtemp .ne. 0)  nmodel = 1
         if (modtemp .eq. 0)  modtemp = 1
         imodel = modtemp
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine fixpdb  --  standard PDB atom and residue names  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "fixpdb" corrects issues with PDB entries by converting residue
c     and atom names to the standard forms used by Tinker
c
c
      subroutine fixpdb (resname,atmname)
      use resdue
      implicit none
      integer i
      character*3 resname
      character*4 atmname
      character*7 restype
c
c
c     convert traditional 3-letter base names to PDB names
c
      if (resname .eq. 'ADE')  resname = '  A'
      if (resname .eq. 'GUA')  resname = '  G'
      if (resname .eq. 'CYT')  resname = '  C'
      if (resname .eq. 'URA')  resname = '  U'
      if (resname .eq. 'DAD')  resname = ' DA'
      if (resname .eq. 'DGU')  resname = ' DG'
      if (resname .eq. 'DCY')  resname = ' DC'
      if (resname .eq. 'THY')  resname = ' DT'
c
c     convert shifted standard base names to PDB names
c
      if (resname .eq. 'A  ')  resname = '  A'
      if (resname .eq. 'G  ')  resname = '  G'
      if (resname .eq. 'C  ')  resname = '  C'
      if (resname .eq. 'U  ')  resname = '  U'
      if (resname .eq. ' A ')  resname = '  A'
      if (resname .eq. ' G ')  resname = '  G'
      if (resname .eq. ' C ')  resname = '  C'
      if (resname .eq. ' U ')  resname = '  U'
      if (resname .eq. 'DA ')  resname = ' DA'
      if (resname .eq. 'DG ')  resname = ' DG'
      if (resname .eq. 'DC ')  resname = ' DC'
      if (resname .eq. 'DT ')  resname = ' DT'
c
c     convert terminal 3-letter base names to PDB names
c
      if (resname .eq. 'DA5')  resname = ' DA'
      if (resname .eq. 'DG5')  resname = ' DG'
      if (resname .eq. 'DC5')  resname = ' DC'
      if (resname .eq. 'DT5')  resname = ' DT'
      if (resname .eq. 'DA3')  resname = ' DA'
      if (resname .eq. 'DG3')  resname = ' DG'
      if (resname .eq. 'DC3')  resname = ' DC'
      if (resname .eq. 'DT3')  resname = ' DT'
c
c     convert unusual names for protonated histidine residues
c
      if (resname .eq. 'HSD')  resname = 'HID'
      if (resname .eq. 'HSE')  resname = 'HIE'
      if (resname .eq. 'HSP')  resname = 'HIS'
      if (resname .eq. 'HSH')  resname = 'HIS'
      if (resname .eq. 'HIP')  resname = 'HIS'
      if (resname .eq. 'HIH')  resname = 'HIS'
c
c     convert unusual names for other amino acid residues
c
      if (resname .eq. 'CYN')  resname = 'CYS'
      if (resname .eq. 'CYM')  resname = 'CYD'
      if (resname .eq. 'LYP')  resname = 'LYS'
      if (resname .eq. 'LYN')  resname = 'LYD'
      if (resname .eq. 'LSN')  resname = 'LYD'
c
c     convert unusual names for terminal capping residues
c
      if (resname .eq. 'ACP')  resname = 'ACE'
      if (resname .eq. 'NMA')  resname = 'NME'
      if (resname .eq. 'CT3')  resname = 'NME'
      if (resname .eq. 'NHE')  resname = 'NH2'
      if (resname .eq. 'CT2')  resname = 'NH2'
c
c     convert nonstandard names for water molecules
c
      if (resname .eq. 'H2O')  resname = 'HOH'
      if (resname .eq. 'WAT')  resname = 'HOH'
      if (resname .eq. 'TIP')  resname = 'HOH'
      if (resname .eq. 'DOD')  resname = 'HOH'
c
c     convert shifted and unusual names for atoms and ions
c
      if (resname .eq. 'HE ')  resname = ' HE'
      if (resname .eq. 'LI ')  resname = ' LI'
      if (resname .eq. 'LI+')  resname = ' LI'
      if (resname .eq. 'F  ')  resname = '  F'
      if (resname .eq. 'F- ')  resname = '  F'
      if (resname .eq. 'NE ')  resname = ' NE'
      if (resname .eq. 'NA ')  resname = ' NA'
      if (resname .eq. 'NA+')  resname = ' NA'
      if (resname .eq. 'SOD')  resname = ' NA'
      if (resname .eq. 'MG ')  resname = ' MG'
      if (resname .eq. 'MG+')  resname = ' MG'
      if (resname .eq. 'MAG')  resname = ' MG'
      if (resname .eq. 'CL ')  resname = ' CL'
      if (resname .eq. 'CL-')  resname = ' CL'
      if (resname .eq. 'CLA')  resname = ' CL'
      if (resname .eq. 'AR ')  resname = ' AR'
      if (resname .eq. 'K  ')  resname = '  K'
      if (resname .eq. 'K+ ')  resname = '  K'
      if (resname .eq. 'POT')  resname = '  K'
      if (resname .eq. 'CA ')  resname = ' CA'
      if (resname .eq. 'CA+')  resname = ' CA'
      if (resname .eq. 'CAL')  resname = ' CA'
      if (resname .eq. 'FE ')  resname = ' FE'
      if (resname .eq. 'FE+')  resname = ' FE'
      if (resname .eq. 'ZN ')  resname = ' ZN'
      if (resname .eq. 'ZN+')  resname = ' ZN'
      if (resname .eq. 'BR ')  resname = ' BR'
      if (resname .eq. 'BR-')  resname = ' BR'
      if (resname .eq. 'KR ')  resname = ' KR'
      if (resname .eq. 'RB ')  resname = ' RB'
      if (resname .eq. 'RB+')  resname = ' RB'
      if (resname .eq. 'RUB')  resname = ' RB'
      if (resname .eq. 'SR ')  resname = ' SR'
      if (resname .eq. 'SR+')  resname = ' SR'
      if (resname .eq. 'I  ')  resname = '  I'
      if (resname .eq. 'I- ')  resname = '  I'
      if (resname .eq. 'XE ')  resname = ' XE'
      if (resname .eq. 'CS ')  resname = ' CS'
      if (resname .eq. 'CS+')  resname = ' CS'
      if (resname .eq. 'CES')  resname = ' CS'
      if (resname .eq. 'BA ')  resname = ' BA'
      if (resname .eq. 'BA+')  resname = ' BA'
      if (resname .eq. 'BAR')  resname = ' BA'
c
c     decide whether residue is protein or nucleic acid
c
      restype = 'UNKNOWN'
      do i = 1, maxamino
         if (resname .eq. amino(i))  restype = 'PROTEIN'
      end do
      do i = 1, maxnuc
         if (resname .eq. nuclz(i))  restype = 'NUCLEIC'
      end do
c
c     convert unusual names common to many protein residues
c
      if (restype .eq. 'PROTEIN') then
         if (atmname .eq. ' HN ')  atmname = ' H  '
         if (atmname .eq. ' D  ')  atmname = ' H  '
      end if
c
c     convert unusual names in protein terminal residues
c
      if (restype .eq. 'PROTEIN') then
         if (atmname .eq. '1H  ')  atmname = ' H1 '
         if (atmname .eq. ' HN1')  atmname = ' H1 '
         if (atmname .eq. ' HT1')  atmname = ' H1 '
         if (atmname .eq. '2H  ')  atmname = ' H2 '
         if (atmname .eq. ' HN2')  atmname = ' H2 '
         if (atmname .eq. ' HT2')  atmname = ' H2 '
         if (atmname .eq. '3H  ')  atmname = ' H3 '
         if (atmname .eq. ' HN3')  atmname = ' H3 '
         if (atmname .eq. ' HT3')  atmname = ' H3 '
         if (atmname .eq. ' O1 ')  atmname = ' O  '
         if (atmname .eq. ' OT1')  atmname = ' O  '
         if (atmname .eq. 'OCT1')  atmname = ' O  '
         if (atmname .eq. ' O2 ')  atmname = ' OXT'
         if (atmname .eq. ' OT2')  atmname = ' OXT'
         if (atmname .eq. 'OCT2')  atmname = ' OXT'
         if (atmname .eq. ' OT ')  atmname = ' OXT'
      end if
c
c     convert unusual names common to many nucleotides
c
      if (restype .eq. 'NUCLEIC') then
         if (atmname .eq. ' O1P')  atmname = ' OP1'
         if (atmname .eq. ' O2P')  atmname = ' OP2'
         if (atmname .eq. ' O3P')  atmname = ' OP3'
         if (atmname .eq. '2HOP')  atmname = 'HOP2'
         if (atmname .eq. '3HOP')  atmname = 'HOP3'
         if (atmname .eq. ' C1*')  atmname = ' C1'''
         if (atmname .eq. ' C2*')  atmname = ' C2'''
         if (atmname .eq. ' C3*')  atmname = ' C3'''
         if (atmname .eq. ' C4*')  atmname = ' C4'''
         if (atmname .eq. ' C5*')  atmname = ' C5'''
         if (atmname .eq. ' O2*')  atmname = ' O2'''
         if (atmname .eq. ' O3*')  atmname = ' O3'''
         if (atmname .eq. ' O4*')  atmname = ' O4'''
         if (atmname .eq. ' O5*')  atmname = ' O5'''
         if (atmname .eq. ' H1*')  atmname = ' H1'''
         if (atmname .eq. ' H2*')  atmname = ' H2'''
         if (atmname .eq. '1H2*')  atmname = ' H2'''
         if (atmname .eq. '2H2*')  atmname = 'H2'''''
         if (atmname .eq. ' H3*')  atmname = ' H3'''
         if (atmname .eq. ' H4*')  atmname = ' H4'''
         if (atmname .eq. '1H5*')  atmname = ' H5'''
         if (atmname .eq. '2H5*')  atmname = 'H5'''''
         if (atmname .eq. '2HO*')  atmname = 'HO2'''
      end if
c
c     convert unusual names in terminal nucleotides
c
      if (restype .eq. 'NUCLEIC') then
         if (atmname .eq. ' H5T')  atmname = 'HO5'''
         if (atmname .eq. ' H3T')  atmname = 'HO3'''
      end if
c
c     glycine residue  (GLY)
c
      if (resname .eq. 'GLY') then
         if (atmname .eq. '1HA ')  atmname = ' HA2'
         if (atmname .eq. ' HA1')  atmname = ' HA3'
         if (atmname .eq. '2HA ')  atmname = ' HA3'
c
c     alanine residue  (ALA)
c
      else if (resname .eq. 'ALA') then
         if (atmname .eq. '1HB ')  atmname = ' HB1'
         if (atmname .eq. '2HB ')  atmname = ' HB2'
         if (atmname .eq. '3HB ')  atmname = ' HB3'
c
c     valine residue  (VAL)
c
      else if (resname .eq. 'VAL') then
         if (atmname .eq. '1HG1')  atmname = 'HG11'
         if (atmname .eq. '2HG1')  atmname = 'HG12'
         if (atmname .eq. '3HG1')  atmname = 'HG13'
         if (atmname .eq. '1HG2')  atmname = 'HG21'
         if (atmname .eq. '2HG2')  atmname = 'HG22'
         if (atmname .eq. '3HG2')  atmname = 'HG23'
c
c     leucine residue  (LEU)
c
      else if (resname .eq. 'LEU') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. '1HD1')  atmname = 'HD11'
         if (atmname .eq. '2HD1')  atmname = 'HD12'
         if (atmname .eq. '3HD1')  atmname = 'HD13'
         if (atmname .eq. '1HD2')  atmname = 'HD21'
         if (atmname .eq. '2HD2')  atmname = 'HD22'
         if (atmname .eq. '3HD2')  atmname = 'HD23'
c
c     isoleucine residue  (ILE)
c
      else if (resname .eq. 'ILE') then
         if (atmname .eq. ' CD ')  atmname = ' CD1'
         if (atmname .eq. '1HG1')  atmname = 'HG12'
         if (atmname .eq. 'HG11')  atmname = 'HG13'
         if (atmname .eq. '2HG1')  atmname = 'HG13'
         if (atmname .eq. '1HG2')  atmname = 'HG21'
         if (atmname .eq. '2HG2')  atmname = 'HG22'
         if (atmname .eq. '3HG2')  atmname = 'HG23'
         if (atmname .eq. '1HD1')  atmname = 'HD11'
         if (atmname .eq. ' HD1')  atmname = 'HD11'
         if (atmname .eq. '2HD1')  atmname = 'HD12'
         if (atmname .eq. ' HD2')  atmname = 'HD12'
         if (atmname .eq. '3HD1')  atmname = 'HD13'
         if (atmname .eq. ' HD3')  atmname = 'HD13'
c
c     serine residue  (SER)
c
      else if (resname .eq. 'SER') then
         if (atmname .eq. ' OG1')  atmname = ' OG '
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. ' HG1')  atmname = ' HG '
         if (atmname .eq. ' HOG')  atmname = ' HG '
c
c     threonine residue  (THR)
c
      else if (resname .eq. 'THR') then
         if (atmname .eq. ' OG ')  atmname = ' OG1'
         if (atmname .eq. ' CG ')  atmname = ' CG2'
         if (atmname .eq. ' HOG')  atmname = ' HG1'
         if (atmname .eq. 'HOG1')  atmname = ' HG1'
         if (atmname .eq. '1HG2')  atmname = 'HG21'
         if (atmname .eq. '2HG2')  atmname = 'HG22'
         if (atmname .eq. '3HG2')  atmname = 'HG23'
c
c     cysteine residue  (CYS)
c
      else if (resname .eq. 'CYS') then
         if (atmname .eq. ' SG1')  atmname = ' SG '
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. ' HG1')  atmname = ' HG '
         if (atmname .eq. ' HSG')  atmname = ' HG '
c
c     proline residue  (PRO)
c
      else if (resname .eq. 'PRO') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. '1HG ')  atmname = ' HG2'
         if (atmname .eq. ' HG1')  atmname = ' HG3'
         if (atmname .eq. '2HG ')  atmname = ' HG3'
         if (atmname .eq. '1HD ')  atmname = ' HD2'
         if (atmname .eq. ' HD1')  atmname = ' HD3'
         if (atmname .eq. '2HD ')  atmname = ' HD3'
         if (atmname .eq. ' HT1')  atmname = ' H2 '
         if (atmname .eq. ' HT2')  atmname = ' H3 '
c
c     phenylalanine residue  (PHE)
c
      else if (resname .eq. 'PHE') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
c
c     tyrosine residue  (TYR)
c
      else if (resname .eq. 'TYR') then
         if (atmname .eq. ' HOH')  atmname = ' HH '
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
c
c     tryptophan residue  (TRP)
c
      else if (resname .eq. 'TRP') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. ' HNE')  atmname = ' HE1'
c
c     histidine (HD and HE) residue  (HIS)
c
      else if (resname .eq. 'HIS') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. ' HD ')  atmname = ' HD2'
         if (atmname .eq. ' HE ')  atmname = ' HE1'
         if (atmname .eq. ' HND')  atmname = ' HD1'
         if (atmname .eq. 'HND1')  atmname = ' HD1'
         if (atmname .eq. ' HNE')  atmname = ' HE2'
         if (atmname .eq. 'HNE2')  atmname = ' HE2'
c
c     histidine (HD only) residue  (HID)
c
      else if (resname .eq. 'HID') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. ' HD ')  atmname = ' HD2'
         if (atmname .eq. ' HE ')  atmname = ' HE1'
         if (atmname .eq. ' HND')  atmname = ' HD1'
         if (atmname .eq. 'HND1')  atmname = ' HD1'
c
c     histidine (HE only) residue  (HIE)
c
      else if (resname .eq. 'HIE') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. ' HD ')  atmname = ' HD2'
         if (atmname .eq. ' HE ')  atmname = ' HE1'
         if (atmname .eq. ' HNE')  atmname = ' HE2'
         if (atmname .eq. 'HNE2')  atmname = ' HE2'
c
c     aspartate residue  (ASP)
c
      else if (resname .eq. 'ASP') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
c
c     asparagine residue  (ASN)
c
      else if (resname .eq. 'ASN') then
         if (atmname .eq. ' OD ')  atmname = ' OD1'
         if (atmname .eq. ' ND ')  atmname = ' ND2'
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. '1HD2')  atmname = 'HD21'
         if (atmname .eq. 'HND1')  atmname = 'HD21'
         if (atmname .eq. '2HD2')  atmname = 'HD22'
         if (atmname .eq. 'HND2')  atmname = 'HD22'
c
c     glutamate residue  (GLU)
c
      else if (resname .eq. 'GLU') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. '1HG ')  atmname = ' HG2'
         if (atmname .eq. ' HG1')  atmname = ' HG3'
         if (atmname .eq. '2HG ')  atmname = ' HG3'
c
c     glutamine residue  (GLN)
c
      else if (resname .eq. 'GLN') then
         if (atmname .eq. ' OE ')  atmname = ' OE1'
         if (atmname .eq. ' NE ')  atmname = ' NE2'
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. '1HG ')  atmname = ' HG2'
         if (atmname .eq. ' HG1')  atmname = ' HG3'
         if (atmname .eq. '2HG ')  atmname = ' HG3'
         if (atmname .eq. '1HE2')  atmname = 'HE21'
         if (atmname .eq. 'HNE1')  atmname = 'HE21'
         if (atmname .eq. '2HE2')  atmname = 'HE22'
         if (atmname .eq. 'HNE2')  atmname = 'HE22'
c
c     methionine residue  (MET)
c
      else if (resname .eq. 'MET') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. '1HG ')  atmname = ' HG2'
         if (atmname .eq. ' HG1')  atmname = ' HG3'
         if (atmname .eq. '2HG ')  atmname = ' HG3'
         if (atmname .eq. '1HE ')  atmname = ' HE1'
         if (atmname .eq. '2HE ')  atmname = ' HE2'
         if (atmname .eq. '3HE ')  atmname = ' HE3'
c
c     lysine residue  (LYS)
c
      else if (resname .eq. 'LYS') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. '1HG ')  atmname = ' HG2'
         if (atmname .eq. ' HG1')  atmname = ' HG3'
         if (atmname .eq. '2HG ')  atmname = ' HG3'
         if (atmname .eq. '1HD ')  atmname = ' HD2'
         if (atmname .eq. ' HD1')  atmname = ' HD3'
         if (atmname .eq. '2HD ')  atmname = ' HD3'
         if (atmname .eq. '1HE ')  atmname = ' HE2'
         if (atmname .eq. ' HE1')  atmname = ' HE3'
         if (atmname .eq. '2HE ')  atmname = ' HE3'
         if (atmname .eq. '1HZ ')  atmname = ' HZ1'
         if (atmname .eq. 'HNZ1')  atmname = ' HZ1'
         if (atmname .eq. '2HZ ')  atmname = ' HZ2'
         if (atmname .eq. 'HNZ2')  atmname = ' HZ2'
         if (atmname .eq. '3HZ ')  atmname = ' HZ3'
         if (atmname .eq. 'HNZ3')  atmname = ' HZ3'
c
c     arginine residue  (ARG)
c
      else if (resname .eq. 'ARG') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. '1HG ')  atmname = ' HG2'
         if (atmname .eq. ' HG1')  atmname = ' HG3'
         if (atmname .eq. '2HG ')  atmname = ' HG3'
         if (atmname .eq. '1HD ')  atmname = ' HD2'
         if (atmname .eq. ' HD1')  atmname = ' HD3'
         if (atmname .eq. '2HD ')  atmname = ' HD3'
         if (atmname .eq. '1HH1')  atmname = 'HH11'
         if (atmname .eq. 'HN11')  atmname = 'HH11'
         if (atmname .eq. '2HH1')  atmname = 'HH12'
         if (atmname .eq. 'HN12')  atmname = 'HH12'
         if (atmname .eq. '1HH2')  atmname = 'HH21'
         if (atmname .eq. 'HN21')  atmname = 'HH21'
         if (atmname .eq. '2HH2')  atmname = 'HH22'
         if (atmname .eq. 'HN22')  atmname = 'HH22'
c
c     ornithine residue  (ORN)
c
      else if (resname .eq. 'ORN') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. '1HG ')  atmname = ' HG2'
         if (atmname .eq. ' HG1')  atmname = ' HG3'
         if (atmname .eq. '2HG ')  atmname = ' HG3'
         if (atmname .eq. '1HD ')  atmname = ' HD2'
         if (atmname .eq. ' HD1')  atmname = ' HD3'
         if (atmname .eq. '2HD ')  atmname = ' HD3'
         if (atmname .eq. '1HE ')  atmname = ' HE1'
         if (atmname .eq. 'HNE1')  atmname = ' HE1'
         if (atmname .eq. '2HE ')  atmname = ' HE2'
         if (atmname .eq. 'HNE2')  atmname = ' HE2'
         if (atmname .eq. '3HE ')  atmname = ' HE3'
         if (atmname .eq. 'HNE3')  atmname = ' HE3'
c
c     methylalanine residue  (AIB)
c
      else if (resname .eq. 'AIB') then
         if (atmname .eq. '1HB1')  atmname = 'HB11'
         if (atmname .eq. '2HB1')  atmname = 'HB12'
         if (atmname .eq. '3HB1')  atmname = 'HB13'
         if (atmname .eq. '1HB2')  atmname = 'HB21'
         if (atmname .eq. '2HB2')  atmname = 'HB22'
         if (atmname .eq. '3HB2')  atmname = 'HB23'
c
c     pyroglutamic acid residue  (PCA)
c
      else if (resname .eq. 'PCA') then
         if (atmname .eq. '1HB ')  atmname = ' HB2'
         if (atmname .eq. ' HB1')  atmname = ' HB3'
         if (atmname .eq. '2HB ')  atmname = ' HB3'
         if (atmname .eq. '1HG ')  atmname = ' HG2'
         if (atmname .eq. ' HG1')  atmname = ' HG3'
         if (atmname .eq. '2HG ')  atmname = ' HG3'
c
c     N-terminal acetyl residue  (ACE)
c
      else if (resname .eq. 'ACE') then
         if (atmname .eq. ' CY ')  atmname = ' C  '
         if (atmname .eq. ' CAY')  atmname = ' CH3'
         if (atmname .eq. ' CA ')  atmname = ' CH3'
         if (atmname .eq. ' OY ')  atmname = ' O  '
         if (atmname .eq. '1H  ')  atmname = ' H1 '
         if (atmname .eq. ' HY1')  atmname = ' H1 '
         if (atmname .eq. '1HH3')  atmname = ' H1 '
         if (atmname .eq. 'HH31')  atmname = ' H1 '
         if (atmname .eq. '2H  ')  atmname = ' H2 '
         if (atmname .eq. ' HY2')  atmname = ' H2 '
         if (atmname .eq. '2HH3')  atmname = ' H2 '
         if (atmname .eq. 'HH32')  atmname = ' H2 '
         if (atmname .eq. '3H  ')  atmname = ' H3 '
         if (atmname .eq. ' HY3')  atmname = ' H3 '
         if (atmname .eq. '3HH3')  atmname = ' H3 '
         if (atmname .eq. 'HH33')  atmname = ' H3 '
c
c     N-terminal formyl residue  (FOR)
c
      else if (resname .eq. 'FOR') then
         if (atmname .eq. ' CY ')  atmname = ' C  '
         if (atmname .eq. ' OY ')  atmname = ' O  '
         if (atmname .eq. ' HY ')  atmname = ' H  '
c
c     C-terminal N-methylamide residue  (NME)
c
      else if (resname .eq. 'NME') then
         if (atmname .eq. ' NT ')  atmname = ' N  '
         if (atmname .eq. ' CT ')  atmname = ' C  '
         if (atmname .eq. ' CAT')  atmname = ' C  '
         if (atmname .eq. ' CA ')  atmname = ' C  '
         if (atmname .eq. ' CH3')  atmname = ' C  '
         if (atmname .eq. ' HNT')  atmname = ' H  '
         if (atmname .eq. '1H  ')  atmname = ' H1 '
         if (atmname .eq. '1HA ')  atmname = ' H1 '
         if (atmname .eq. ' HT1')  atmname = ' H1 '
         if (atmname .eq. '1HH3')  atmname = ' H1 '
         if (atmname .eq. 'HH31')  atmname = ' H1 '
         if (atmname .eq. '2H  ')  atmname = ' H2 '
         if (atmname .eq. '2HA ')  atmname = ' H2 '
         if (atmname .eq. ' HT2')  atmname = ' H2 '
         if (atmname .eq. '2HH3')  atmname = ' H2 '
         if (atmname .eq. 'HH32')  atmname = ' H2 '
         if (atmname .eq. '3H  ')  atmname = ' H3 '
         if (atmname .eq. '3HA ')  atmname = ' H3 '
         if (atmname .eq. ' HT3')  atmname = ' H3 '
         if (atmname .eq. '3HH3')  atmname = ' H3 '
         if (atmname .eq. 'HH33')  atmname = ' H3 '
c
c     C-terminal amide residue  (NH2)
c
      else if (resname .eq. 'NH2') then
         if (atmname .eq. ' NT ')  atmname = ' N  '
         if (atmname .eq. '1H  ')  atmname = ' H1 '
         if (atmname .eq. '2H  ')  atmname = ' H2 '
         if (atmname .eq. ' HT1')  atmname = ' H1 '
         if (atmname .eq. ' HT2')  atmname = ' H2 '
c
c     adenosine residue  (A)
c
      else if (resname .eq. '  A') then
         if (atmname .eq. '1H6 ')  atmname = ' H61'
         if (atmname .eq. '2H6 ')  atmname = ' H62'
c
c     guanosine residue  (G)
c
      else if (resname .eq. '  G') then
         if (atmname .eq. '1H2 ')  atmname = ' H21'
         if (atmname .eq. '2H2 ')  atmname = ' H22'
c
c     cytidine residue  (C)
c
      else if (resname .eq. '  C') then
         if (atmname .eq. '1H4 ')  atmname = ' H41'
         if (atmname .eq. '2H4 ')  atmname = ' H42'
c
c     deoxyadenosine residue  (DA)
c
      else if (resname .eq. ' DA') then
         if (atmname .eq. '1H6 ')  atmname = ' H61'
         if (atmname .eq. '2H6 ')  atmname = ' H62'
c
c     deoxyguanosine residue  (DG)
c
      else if (resname .eq. ' DG') then
         if (atmname .eq. '1H2 ')  atmname = ' H21'
         if (atmname .eq. '2H2 ')  atmname = ' H22'
c
c     deoxycytidine residue  (DC)
c
      else if (resname .eq. ' DC') then
         if (atmname .eq. '1H4 ')  atmname = ' H41'
         if (atmname .eq. '2H4 ')  atmname = ' H42'
c
c     deoxythymidine residue  (DT)
c
      else if (resname .eq. ' DT') then
         if (atmname .eq. ' C5M')  atmname = ' C7 '
         if (atmname .eq. '1H5M')  atmname = ' H71'
         if (atmname .eq. '2H5M')  atmname = ' H72'
         if (atmname .eq. '3H5M')  atmname = ' H73'
c
c     water molecules (HOH)
c
      else if (resname .eq. 'HOH') then
         if (atmname .eq. ' OT ')  atmname = ' O  '
         if (atmname .eq. ' OW ')  atmname = ' O  '
         if (atmname .eq. ' OH2')  atmname = ' O  '
         if (atmname .eq. ' OD2')  atmname = ' O  '
         if (atmname .eq. ' HT ')  atmname = ' H  '
         if (atmname .eq. ' HW ')  atmname = ' H  '
         if (atmname .eq. ' HW1')  atmname = ' H  '
         if (atmname .eq. ' HW2')  atmname = ' H  '
         if (atmname .eq. ' H1 ')  atmname = ' H  '
         if (atmname .eq. ' H2 ')  atmname = ' H  '
         if (atmname .eq. ' DT ')  atmname = ' H  '
         if (atmname .eq. ' DW ')  atmname = ' H  '
         if (atmname .eq. ' DW1')  atmname = ' H  '
         if (atmname .eq. ' DW2')  atmname = ' H  '
         if (atmname .eq. ' D1 ')  atmname = ' H  '
         if (atmname .eq. ' D2 ')  atmname = ' H  '
         if (atmname .eq. ' M  ')  atmname = ' EP '
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine readprm  --  input of force field parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "readprm" processes the potential energy parameter file
c     in order to define the default force field parameters
c
c
      subroutine readprm
      use fields
      use iounit
      use kanang
      use kangs
      use kantor
      use katoms
      use kbonds
      use kcflux
      use kchrge
      use kcpen
      use kctrn
      use kdipol
      use kdsp
      use kexpl
      use khbond
      use kiprop
      use kitors
      use kmulti
      use kopbnd
      use kopdst
      use korbs
      use kpitor
      use kpolpr
      use kpolr
      use krepl
      use ksolut
      use kstbnd
      use ksttor
      use ktorsn
      use ktrtor
      use kurybr
      use kvdws
      use kvdwpr
      use merck
      use params
      implicit none
      integer i,j,iprm
      integer ia,ib,ic,id
      integer ie,if,ig,ih
      integer ii,imin
      integer size,next
      integer length,trimtext
      integer nb,nb5,nb4
      integer nb3,nel
      integer na,na5,na4
      integer na3,nap,naf
      integer nsb,nu,nopb,nopd
      integer ndi,nti,nt,nt5,nt4
      integer npt,nbt,nat,ntt,nvp
      integer nhb,nd,nd5,nd4,nd3
      integer nmp,npp,ncfb,ncfa
      integer npi,npi5,npi4
      integer cls,atn,lig
      integer nx,ny,nxy
      integer bt,at,sbt,tt
      integer ilpr
      integer ft(6)
      integer pg(maxval)
      integer tkey(maxtgrd2)
      real*8 wght,rd
      real*8 ep,rdn
      real*8 spr,apr,epr
      real*8 cdp,adp
      real*8 an1,an2,an3
      real*8 ba1,ba2
      real*8 aa1,aa2,aa3
      real*8 bt1,bt2,bt3
      real*8 bt4,bt5,bt6
      real*8 bt7,bt8,bt9
      real*8 at1,at2,at3
      real*8 at4,at5,at6
      real*8 an,pr,ds,dk
      real*8 vd,cg,dp,ps
      real*8 fc,bd,dl
      real*8 pt,pel,pal
      real*8 pol,thl,thd
      real*8 kpr,ppr,dpr
      real*8 ctrn,atrn
      real*8 cfb,cfb1,cfb2
      real*8 cfa1,cfa2
      real*8 pbrd,csrd
      real*8 gkrd,snek
      real*8 el,iz,rp
      real*8 ss,ts
      real*8 abc,cba
      real*8 gi,alphi
      real*8 nni,factor
      real*8 vt(6),st(6)
      real*8 pl(13)
      real*8 tx(maxtgrd2)
      real*8 ty(maxtgrd2)
      real*8 tf(maxtgrd2)
      real*8 tind(maxtgrd2)
      logical header,swap
      character*1 da1
      character*3 ttag
      character*4 pa,pb,pc
      character*4 pd,pe
      character*8 axt
      character*20 keyword
      character*20 text
      character*240 record
      character*240 string
c
c
c     initialize the counters for some parameter types
c
      nb = 0
      nb5 = 0
      nb4 = 0
      nb3 = 0
      nel = 0
      na = 0
      na5 = 0
      na4 = 0
      na3 = 0
      nap = 0
      naf = 0
      nsb = 0
      nu = 0
      nopb = 0
      nopd = 0
      ndi = 0
      nti = 0
      nt = 0
      nt5 = 0
      nt4 = 0
      npt = 0
      nbt = 0
      nat = 0
      ntt = 0
      nvp = 0
      nhb = 0
      nd = 0
      nd5 = 0
      nd4 = 0
      nd3 = 0
      nmp = 0
      npp = 0
      ncfb = 0
      ncfa = 0
      npi = 0
      npi5 = 0
      npi4 = 0
c
c     number of characters in an atom number text string
c
      size = 4
c
c     set blank line header before echoed comment lines
c
      header = .true.
c
c     process each line of the parameter file, first
c     extract the keyword at the start of each line
c
      iprm = 0
      do while (iprm .lt. nprm)
         iprm = iprm + 1
         record = prmline(iprm)
         next = 1
         call gettext (record,keyword,next)
         call upcase (keyword)
c
c     check for a force field modification keyword
c
         call prmkey (record)
c
c     comment line to be echoed to the output
c
         if (keyword(1:5) .eq. 'ECHO ') then
            string = record(next:240)
            length = trimtext (string)
            if (header) then
               header = .false.
               write (iout,10)
   10          format ()
            end if
            if (length .eq. 0) then
               write (iout,20)
   20          format ()
            else
               write (iout,30)  string(1:length)
   30          format (a)
            end if
c
c     atom type definitions and parameters
c
         else if (keyword(1:5) .eq. 'ATOM ') then
            ia = 0
            cls = 0
            atn = 0
            wght = 0.0d0
            lig = 0
            call getnumb (record,ia,next)
            call getnumb (record,cls,next)
            if (cls .eq. 0)  cls = ia
            atmcls(ia) = cls
            if (ia .ge. maxtyp) then
               write (iout,40)
   40          format (/,' READPRM  --  Too many Atom Types;',
     &                    ' Increase MAXTYP')
               call fatal
            else if (cls .ge. maxclass) then
               write (iout,50)
   50          format (/,' READPRM  --  Too many Atom Classes;',
     &                    ' Increase MAXCLASS')
               call fatal
            end if
            if (ia .ne. 0) then
               call gettext (record,symbol(ia),next)
               call getstring (record,describe(ia),next)
               string = record(next:240)
               read (string,*,err=60,end=60)  atn,wght,lig
   60          continue
               atmnum(ia) = atn
               weight(ia) = wght
               ligand(ia) = lig
            end if
c
c     bond stretching parameters
c
         else if (keyword(1:5) .eq. 'BOND ') then
            ia = 0
            ib = 0
            fc = 0.0d0
            bd = 0.0d0
            string = record(next:240)
            read (string,*,err=70,end=70)  ia,ib,fc,bd
   70       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nb = nb + 1
            if (ia .le. ib) then
               kb(nb) = pa//pb
            else
               kb(nb) = pb//pa
            end if
            bcon(nb) = fc
            blen(nb) = bd
c
c     bond stretching parameters for 5-membered rings
c
         else if (keyword(1:6) .eq. 'BOND5 ') then
            ia = 0
            ib = 0
            fc = 0.0d0
            bd = 0.0d0
            string = record(next:240)
            read (string,*,err=80,end=80)  ia,ib,fc,bd
   80       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nb5 = nb5 + 1
            if (ia .le. ib) then
               kb5(nb5) = pa//pb
            else
               kb5(nb5) = pb//pa
            end if
            bcon5(nb5) = fc
            blen5(nb5) = bd
c
c     bond stretching parameters for 4-membered rings
c
         else if (keyword(1:6) .eq. 'BOND4 ') then
            ia = 0
            ib = 0
            fc = 0.0d0
            bd = 0.0d0
            string = record(next:240)
            read (string,*,err=90,end=90)  ia,ib,fc,bd
   90       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nb4 = nb4 + 1
            if (ia .le. ib) then
               kb4(nb4) = pa//pb
            else
               kb4(nb4) = pb//pa
            end if
            bcon4(nb4) = fc
            blen4(nb4) = bd
c
c     bond stretching parameters for 3-membered rings
c
         else if (keyword(1:6) .eq. 'BOND3 ') then
            ia = 0
            ib = 0
            fc = 0.0d0
            bd = 0.0d0
            string = record(next:240)
            read (string,*,err=100,end=100)  ia,ib,fc,bd
  100       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nb3 = nb3 + 1
            if (ia .le. ib) then
               kb3(nb3) = pa//pb
            else
               kb3(nb3) = pb//pa
            end if
            bcon3(nb3) = fc
            blen3(nb3) = bd
c
c     electronegativity bond length correction parameters
c
         else if (keyword(1:9) .eq. 'ELECTNEG ') then
            ia = 0
            ib = 0
            ic = 0
            dl = 0.0d0
            string = record(next:240)
            read (string,*,err=110,end=110)  ia,ib,ic,dl
  110       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            nel = nel + 1
            if (ia .le. ic) then
               kel(nel) = pa//pb//pc
            else
               kel(nel) = pc//pb//pa
            end if
            dlen(nel) = dl
c
c     bond angle bending parameters
c
         else if (keyword(1:6) .eq. 'ANGLE ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            an2 = 0.0d0
            an3 = 0.0d0
            string = record(next:240)
            read (string,*,err=120,end=120)  ia,ib,ic,fc,an1,an2,an3
  120       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            na = na + 1
            if (ia .le. ic) then
               ka(na) = pa//pb//pc
            else
               ka(na) = pc//pb//pa
            end if
            acon(na) = fc
            ang(1,na) = an1
            ang(2,na) = an2
            ang(3,na) = an3
c
c     angle bending parameters for 5-membered rings
c
         else if (keyword(1:7) .eq. 'ANGLE5 ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            an2 = 0.0d0
            an3 = 0.0d0
            string = record(next:240)
            read (string,*,err=130,end=130)  ia,ib,ic,fc,an1,an2,an3
  130       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            na5 = na5 + 1
            if (ia .le. ic) then
               ka5(na5) = pa//pb//pc
            else
               ka5(na5) = pc//pb//pa
            end if
            acon5(na5) = fc
            ang5(1,na5) = an1
            ang5(2,na5) = an2
            ang5(3,na5) = an3
c
c     angle bending parameters for 4-membered rings
c
         else if (keyword(1:7) .eq. 'ANGLE4 ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            an2 = 0.0d0
            an3 = 0.0d0
            string = record(next:240)
            read (string,*,err=140,end=140)  ia,ib,ic,fc,an1,an2,an3
  140       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            na4 = na4 + 1
            if (ia .le. ic) then
               ka4(na4) = pa//pb//pc
            else
               ka4(na4) = pc//pb//pa
            end if
            acon4(na4) = fc
            ang4(1,na4) = an1
            ang4(2,na4) = an2
            ang4(3,na4) = an3
c
c     angle bending parameters for 3-membered rings
c
         else if (keyword(1:7) .eq. 'ANGLE3 ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            an2 = 0.0d0
            an3 = 0.0d0
            string = record(next:240)
            read (string,*,err=150,end=150)  ia,ib,ic,fc,an1,an2,an3
  150       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            na3 = na3 + 1
            if (ia .le. ic) then
               ka3(na3) = pa//pb//pc
            else
               ka3(na3) = pc//pb//pa
            end if
            acon3(na3) = fc
            ang3(1,na3) = an1
            ang3(2,na3) = an2
            ang3(3,na3) = an3
c
c     in-plane projected angle bending parameters
c
         else if (keyword(1:7) .eq. 'ANGLEP ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            an2 = 0.0d0
            string = record(next:240)
            read (string,*,err=160,end=160)  ia,ib,ic,fc,an1,an2
  160       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            nap = nap + 1
            if (ia .le. ic) then
               kap(nap) = pa//pb//pc
            else
               kap(nap) = pc//pb//pa
            end if
            aconp(nap) = fc
            angp(1,nap) = an1
            angp(2,nap) = an2
c
c     Fourier bond angle bending parameters
c
         else if (keyword(1:7) .eq. 'ANGLEF ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an = 0.0d0
            pr = 0.0d0
            string = record(next:240)
            read (string,*,err=170,end=170)  ia,ib,ic,fc,an,pr
  170       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            naf = naf + 1
            if (ia .le. ic) then
               kaf(naf) = pa//pb//pc
            else
               kaf(naf) = pc//pb//pa
            end if
            aconf(naf) = fc
            angf(1,naf) = an
            angf(2,naf) = pr
c
c     stretch-bend parameters
c
         else if (keyword(1:7) .eq. 'STRBND ') then
            ia = 0
            ib = 0
            ic = 0
            ba1 = 0.0d0
            ba2 = 0.0d0
            string = record(next:240)
            read (string,*,err=180,end=180)  ia,ib,ic,ba1,ba2
  180       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            nsb = nsb + 1
            if (ia .le. ic) then
               ksb(nsb) = pa//pb//pc
               stbn(1,nsb) = ba1
               stbn(2,nsb) = ba2
            else
               ksb(nsb) = pc//pb//pa
               stbn(1,nsb) = ba2
               stbn(2,nsb) = ba1
            end if
c
c     Urey-Bradley parameters
c
         else if (keyword(1:9) .eq. 'UREYBRAD ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            ds = 0.0d0
            string = record(next:240)
            read (string,*,err=190,end=190)  ia,ib,ic,fc,ds
  190       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            nu = nu + 1
            if (ia .le. ic) then
               ku(nu) = pa//pb//pc
            else
               ku(nu) = pc//pb//pa
            end if
            ucon(nu) = fc
            dst13(nu) = ds
c
c     angle-angle parameters
c
         else if (keyword(1:7) .eq. 'ANGANG ') then
            ia = 0
            aa1 = 0.0d0
            aa2 = 0.0d0
            aa3 = 0.0d0
            string = record(next:240)
            read (string,*,err=200,end=200)  ia,aa1,aa2,aa3
  200       continue
            if (ia .ne. 0) then
               anan(1,ia) = aa1
               anan(2,ia) = aa2
               anan(3,ia) = aa3
            end if
c
c     out-of-plane bend parameters
c
         else if (keyword(1:7) .eq. 'OPBEND ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            fc = 0.0d0
            string = record(next:240)
            read (string,*,err=210,end=210)  ia,ib,ic,id,fc
  210       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            nopb = nopb + 1
            if (ic .le. id) then
               kopb(nopb) = pa//pb//pc//pd
            else
               kopb(nopb) = pa//pb//pd//pc
            end if
            opbn(nopb) = fc
c
c     out-of-plane distance parameters
c
         else if (keyword(1:7) .eq. 'OPDIST ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            fc = 0.0d0
            string = record(next:240)
            read (string,*,err=220,end=220)  ia,ib,ic,id,fc
  220       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            nopd = nopd + 1
            imin = min(ib,ic,id)
            if (ib .eq. imin) then
               if (ic .le. id) then
                  kopd(nopd) = pa//pb//pc//pd
               else
                  kopd(nopd) = pa//pb//pd//pc
               end if
            else if (ic .eq. imin) then
               if (ib .le. id) then
                  kopd(nopd) = pa//pc//pb//pd
               else
                  kopd(nopd) = pa//pc//pd//pb
               end if
            else if (id .eq. imin) then
               if (ib .le. ic) then
                  kopd(nopd) = pa//pd//pb//pc
               else
                  kopd(nopd) = pa//pd//pc//pb
               end if
            end if
            opds(nopd) = fc
c
c     improper dihedral parameters
c
         else if (keyword(1:9) .eq. 'IMPROPER ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            dk = 0.0d0
            vd = 0.0d0
            string = record(next:240)
            read (string,*,err=230,end=230)  ia,ib,ic,id,dk,vd
  230       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            ndi = ndi + 1
            kdi(ndi) = pa//pb//pc//pd
            dcon(ndi) = dk
            tdi(ndi) = vd
c
c     improper torsional parameters
c
         else if (keyword(1:8) .eq. 'IMPTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do i = 1, 6
               vt(i) = 0.0d0
               st(i) = 0.0d0
               ft(i) = 0
            end do
            string = record(next:240)
            read (string,*,err=240,end=240)  ia,ib,ic,id,
     &                                       (vt(j),st(j),ft(j),j=1,6)
  240       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            nti = nti + 1
            kti(nti) = pa//pb//pc//pd
            call torphase (ft,vt,st)
            ti1(1,nti) = vt(1)
            ti1(2,nti) = st(1)
            ti2(1,nti) = vt(2)
            ti2(2,nti) = st(2)
            ti3(1,nti) = vt(3)
            ti3(2,nti) = st(3)
c
c     torsional parameters
c
         else if (keyword(1:8) .eq. 'TORSION ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do i = 1, 6
               vt(i) = 0.0d0
               st(i) = 0.0d0
               ft(i) = 0
            end do
            string = record(next:240)
            read (string,*,err=250,end=250)  ia,ib,ic,id,
     &                                       (vt(j),st(j),ft(j),j=1,6)
  250       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            nt = nt + 1
            if (ib .lt. ic) then
               kt(nt) = pa//pb//pc//pd
            else if (ic .lt. ib) then
               kt(nt) = pd//pc//pb//pa
            else if (ia .le. id) then
               kt(nt) = pa//pb//pc//pd
            else if (id .lt. ia) then
               kt(nt) = pd//pc//pb//pa
            end if
            call torphase (ft,vt,st)
            t1(1,nt) = vt(1)
            t1(2,nt) = st(1)
            t2(1,nt) = vt(2)
            t2(2,nt) = st(2)
            t3(1,nt) = vt(3)
            t3(2,nt) = st(3)
            t4(1,nt) = vt(4)
            t4(2,nt) = st(4)
            t5(1,nt) = vt(5)
            t5(2,nt) = st(5)
            t6(1,nt) = vt(6)
            t6(2,nt) = st(6)
c
c     torsional parameters for 5-membered rings
c
         else if (keyword(1:9) .eq. 'TORSION5 ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do i = 1, 6
               vt(i) = 0.0d0
               st(i) = 0.0d0
               ft(i) = 0
            end do
            string = record(next:240)
            read (string,*,err=260,end=260)  ia,ib,ic,id,
     &                                       (vt(j),st(j),ft(j),j=1,6)
  260       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            nt5 = nt5 + 1
            if (ib .lt. ic) then
               kt5(nt5) = pa//pb//pc//pd
            else if (ic .lt. ib) then
               kt5(nt5) = pd//pc//pb//pa
            else if (ia .le. id) then
               kt5(nt5) = pa//pb//pc//pd
            else if (id .lt. ia) then
               kt5(nt5) = pd//pc//pb//pa
            end if
            call torphase (ft,vt,st)
            t15(1,nt5) = vt(1)
            t15(2,nt5) = st(1)
            t25(1,nt5) = vt(2)
            t25(2,nt5) = st(2)
            t35(1,nt5) = vt(3)
            t35(2,nt5) = st(3)
            t45(1,nt5) = vt(4)
            t45(2,nt5) = st(4)
            t55(1,nt5) = vt(5)
            t55(2,nt5) = st(5)
            t65(1,nt5) = vt(6)
            t65(2,nt5) = st(6)
c
c     torsional parameters for 4-membered rings
c
         else if (keyword(1:9) .eq. 'TORSION4 ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do i = 1, 6
               vt(i) = 0.0d0
               st(i) = 0.0d0
               ft(i) = 0
            end do
            string = record(next:240)
            read (string,*,err=270,end=270)  ia,ib,ic,id,
     &                                       (vt(i),st(i),ft(i),i=1,6)
  270       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            nt4 = nt4 + 1
            if (ib .lt. ic) then
               kt4(nt4) = pa//pb//pc//pd
            else if (ic .lt. ib) then
               kt4(nt4) = pd//pc//pb//pa
            else if (ia .le. id) then
               kt4(nt4) = pa//pb//pc//pd
            else if (id .lt. ia) then
               kt4(nt4) = pd//pc//pb//pa
            end if
            call torphase (ft,vt,st)
            t14(1,nt4) = vt(1)
            t14(2,nt4) = st(1)
            t24(1,nt4) = vt(2)
            t24(2,nt4) = st(2)
            t34(1,nt4) = vt(3)
            t34(2,nt4) = st(3)
            t44(1,nt4) = vt(4)
            t44(2,nt4) = st(4)
            t54(1,nt4) = vt(5)
            t54(2,nt4) = st(5)
            t64(1,nt4) = vt(6)
            t64(2,nt4) = st(6)
c
c     pi-system torsion parameters
c
         else if (keyword(1:7) .eq. 'PITORS ') then
            ia = 0
            ib = 0
            pt = 0.0d0
            string = record(next:240)
            read (string,*,err=280,end=280)  ia,ib,pt
  280       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            npt = npt + 1
            if (ia .le. ib) then
               kpt(npt) = pa//pb
            else
               kpt(npt) = pb//pa
            end if
            ptcon(npt) = pt
c
c     stretch-torsion parameters
c
         else if (keyword(1:8) .eq. 'STRTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            bt1 = 0.0d0
            bt2 = 0.0d0
            bt3 = 0.0d0
            bt4 = 0.0d0
            bt5 = 0.0d0
            bt6 = 0.0d0
            bt7 = 0.0d0
            bt8 = 0.0d0
            bt9 = 0.0d0
            string = record(next:240)
            read (string,*,err=290,end=290)  ia,ib,ic,id,bt1,bt2,bt3,
     &                                       bt4,bt5,bt6,bt7,bt8,bt9
  290       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            nbt = nbt + 1
            if (ib .lt. ic) then
               kbt(nbt) = pa//pb//pc//pd
               swap = .false.
            else if (ic .lt. ib) then
               kbt(nbt) = pd//pc//pb//pa
               swap = .true.
            else if (ia .le. id) then
               kbt(nbt) = pa//pb//pc//pd
               swap = .false.
            else if (id .lt. ia) then
               kbt(nbt) = pd//pc//pb//pa
               swap = .true.
            end if
            btcon(4,nbt) = bt4
            btcon(5,nbt) = bt5
            btcon(6,nbt) = bt6
            if (swap) then
               btcon(1,nbt) = bt7
               btcon(2,nbt) = bt8
               btcon(3,nbt) = bt9
               btcon(7,nbt) = bt1
               btcon(8,nbt) = bt2
               btcon(9,nbt) = bt3
            else
               btcon(1,nbt) = bt1
               btcon(2,nbt) = bt2
               btcon(3,nbt) = bt3
               btcon(7,nbt) = bt7
               btcon(8,nbt) = bt8
               btcon(9,nbt) = bt9
            end if
c
c     angle-torsion parameters
c
         else if (keyword(1:8) .eq. 'ANGTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            at1 = 0.0d0
            at2 = 0.0d0
            at3 = 0.0d0
            at4 = 0.0d0
            at5 = 0.0d0
            at6 = 0.0d0
            string = record(next:240)
            read (string,*,err=300,end=300)  ia,ib,ic,id,at1,at2,
     &                                       at3,at4,at5,at6
  300       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            nat = nat + 1
            if (ib .lt. ic) then
               kat(nat) = pa//pb//pc//pd
               swap = .false.
            else if (ic .lt. ib) then
               kat(nat) = pd//pc//pb//pa
               swap = .true.
            else if (ia .le. id) then
               kat(nat) = pa//pb//pc//pd
               swap = .false.
            else if (id .lt. ia) then
               kat(nat) = pd//pc//pb//pa
               swap = .true.
            end if
            if (swap) then
               atcon(1,nat) = at4
               atcon(2,nat) = at5
               atcon(3,nat) = at6
               atcon(4,nat) = at1
               atcon(5,nat) = at2
               atcon(6,nat) = at3
            else
               atcon(1,nat) = at1
               atcon(2,nat) = at2
               atcon(3,nat) = at3
               atcon(4,nat) = at4
               atcon(5,nat) = at5
               atcon(6,nat) = at6
            end if
c
c     torsion-torsion parameters
c
         else if (keyword(1:8) .eq. 'TORTORS ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            ie = 0
            nx = 0
            ny = 0
            nxy = 0
            ttag = '   '
            do i = 1, maxtgrd2
               tx(i) = 0.0d0
               ty(i) = 0.0d0
               tf(i) = 0.0d0
            end do
            string = record(next:240)
            read (string,*,err=340,end=340)  ia,ib,ic,id,ie,nx,ny
            nxy = nx * ny
            call getword (record,ttag,next)
            i = 0
            dowhile (i .lt. nxy)
               iprm = iprm + 1
               record = prmline(iprm)
               read (record,*,err=310,end=310)  tx(i+1),ty(i+1),tf(i+1),
     &                                          tx(i+2),ty(i+2),tf(i+2),
     &                                          tx(i+3),ty(i+3),tf(i+3)
               i = i + 3
               goto 330
  310          continue
               read (record,*,err=320,end=320)  tx(i+1),ty(i+1),tf(i+1),
     &                                          tx(i+2),ty(i+2),tf(i+2)
               i = i + 2
               goto 330
  320          continue
               read (record,*,err=340,end=340)  tx(i+1),ty(i+1),tf(i+1)
               i = i + 1
  330          continue
            end do
  340       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            call numeral (ie,pe,size)
            ntt = ntt + 1
            ktt(ntt) = pa//pb//pc//pd//pe
            ttier(ntt) = ttag
            do i = 1, nxy
               tind(i) = 360.0d0*ty(i) + tx(i)
               tkey(i) = i
            end do
            call sort2 (nxy,tind,tkey)
            do i = 1, nxy
               tbf(i,ntt) = tf(tkey(i))
            end do
            nx = nxy
            call sort9 (nx,tx)
            tnx(ntt) = nx
            do i = 1, nx
               ttx(i,ntt) = tx(i)
            end do
            ny = nxy
            call sort9 (ny,ty)
            tny(ntt) = ny
            do i = 1, ny
               tty(i,ntt) = ty(i)
            end do
c
c     van der Waals parameters for individual atom types
c
         else if (keyword(1:4) .eq. 'VDW ') then
            ia = 0
            rd = 0.0d0
            ep = 0.0d0
            rdn = 0.0d0
            string = record(next:240)
            read (string,*,err=350,end=350)  ia,rd,ep,rdn
  350       continue
            if (ia .ne. 0) then
               rad(ia) = rd
               eps(ia) = ep
               reduct(ia) = rdn
            end if
c
c     van der Waals 1-4 parameters for individual atom types
c
         else if (keyword(1:6) .eq. 'VDW14 ') then
            ia = 0
            rd = 0.0d0
            ep = 0.0d0
            string = record(next:240)
            read (string,*,err=360,end=360)  ia,rd,ep
  360       continue
            if (ia .ne. 0) then
               rad4(ia) = rd
               eps4(ia) = ep
            end if
c
c     van der Waals parameters for specific atom pairs
c
         else if (keyword(1:8) .eq. 'VDWPAIR ' .or.
     &            keyword(1:6) .eq. 'VDWPR ') then
            ia = 0
            ib = 0
            rd = 0.0d0
            ep = 0.0d0
            string = record(next:240)
            read (string,*,err=370,end=370)  ia,ib,rd,ep
  370       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nvp = nvp + 1
            if (ia .le. ib) then
               kvpr(nvp) = pa//pb
            else
               kvpr(nvp) = pb//pa
            end if
            radpr(nvp) = rd
            epspr(nvp) = ep
c
c     van der Waals parameters for hydrogen bonding pairs
c
         else if (keyword(1:6) .eq. 'HBOND ') then
            ia = 0
            ib = 0
            rd = 0.0d0
            ep = 0.0d0
            string = record(next:240)
            read (string,*,err=380,end=380)  ia,ib,rd,ep
  380       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nhb = nhb + 1
            if (ia .le. ib) then
               khb(nhb) = pa//pb
            else
               khb(nhb) = pb//pa
            end if
            radhb(nhb) = rd
            epshb(nhb) = ep
c
c     Pauli repulsion parameters
c
         else if (keyword(1:10) .eq. 'REPULSION ') then
            ia = 0
            spr = 0.0d0
            apr = 0.0d0
            epr = 0.0d0
            string = record(next:240)
            read (string,*,err=390,end=390)  ia,spr,apr,epr
  390       continue
            if (ia .ne. 0) then
               prsiz(ia) = spr
               prdmp(ia) = apr
               prele(ia) = -abs(epr)
            end if
c
c     damped dispersion parameters
c
         else if (keyword(1:11) .eq. 'DISPERSION ') then
            ia = 0
            cdp = 0.0d0
            adp = 0.0d0
            string = record(next:240)
            read (string,*,err=400,end=400)  ia,cdp,adp
  400       continue
            if (ia .ne. 0) then
               dspsix(ia) = cdp
               dspdmp(ia) = adp
            end if
c
c     atomic partial charge parameters
c
         else if (keyword(1:7) .eq. 'CHARGE ') then
            ia = 0
            cg = 0.0d0
            string = record(next:240)
            read (string,*,err=410,end=410)  ia,cg
  410       continue
            if (ia .ne. 0)  chg(ia) = cg
c
c     bond dipole moment parameters
c
         else if (keyword(1:7) .eq. 'DIPOLE ') then
            ia = 0
            ib = 0
            dp = 0.0d0
            ps = 0.5d0
            string = record(next:240)
            read (string,*,err=420,end=420)  ia,ib,dp,ps
  420       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nd = nd + 1
            if (ia .le. ib) then
               kd(nd) = pa//pb
               dpl(nd) = dp
               pos(nd) = ps
            else
               kd(nd) = pb//pa
               dpl(nd) = -dp
               pos(nd) = 1.0d0 - ps
            end if
c
c     bond dipole moment parameters for 5-membered rings
c
         else if (keyword(1:8) .eq. 'DIPOLE5 ') then
            ia = 0
            ib = 0
            dp = 0.0d0
            ps = 0.5d0
            string = record(next:240)
            read (string,*,err=430,end=430)  ia,ib,dp,ps
  430       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nd5 = nd5 + 1
            if (ia .le. ib) then
               kd5(nd5) = pa//pb
               dpl5(nd5) = dp
               pos5(nd5) = ps
            else
               kd5(nd5) = pb//pa
               dpl5(nd5) = -dp
               pos5(nd5) = 1.0d0 - ps
            end if
c
c     bond dipole moment parameters for 4-membered rings
c
         else if (keyword(1:8) .eq. 'DIPOLE4 ') then
            ia = 0
            ib = 0
            dp = 0.0d0
            ps = 0.5d0
            string = record(next:240)
            read (string,*,err=440,end=440)  ia,ib,dp,ps
  440       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nd4 = nd4 + 1
            if (ia .le. ib) then
               kd4(nd4) = pa//pb
               dpl4(nd4) = dp
               pos4(nd4) = ps
            else
               kd4(nd4) = pb//pa
               dpl4(nd4) = -dp
               pos4(nd4) = 1.0d0 - ps
            end if
c
c     bond dipole moment parameters for 3-membered rings
c
         else if (keyword(1:8) .eq. 'DIPOLE3 ') then
            ia = 0
            ib = 0
            dp = 0.0d0
            ps = 0.5d0
            string = record(next:240)
            read (string,*,err=450,end=450)  ia,ib,dp,ps
  450       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nd3 = nd3 + 1
            if (ia .le. ib) then
               kd3(nd3) = pa//pb
               dpl3(nd3) = dp
               pos3(nd3) = ps
            else
               kd3(nd3) = pb//pa
               dpl3(nd3) = -dp
               pos3(nd3) = 1.0d0 - ps
            end if
c
c     atomic multipole moment parameters
c
         else if (keyword(1:10) .eq. 'MULTIPOLE ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            axt = 'Z-then-X'
            do i = 1, 13
               pl(i) = 0.0d0
            end do
            string = record(next:240)
            read (string,*,err=460,end=460)  ia,ib,ic,id,pl(1)
            goto 490
  460       continue
            id = 0
            read (string,*,err=470,end=470)  ia,ib,ic,pl(1)
            goto 490
  470       continue
            ic = 0
            read (string,*,err=480,end=480)  ia,ib,pl(1)
            goto 490
  480       continue
            ib = 0
            read (string,*,err=500,end=500)  ia,pl(1)
  490       continue
            iprm = iprm + 1
            record = prmline(iprm)
            read (record,*,err=500,end=500)  pl(2),pl(3),pl(4)
            iprm = iprm + 1
            record = prmline(iprm)
            read (record,*,err=500,end=500)  pl(5)
            iprm = iprm + 1
            record = prmline(iprm)
            read (record,*,err=500,end=500)  pl(8),pl(9)
            iprm = iprm + 1
            record = prmline(iprm)
            read (record,*,err=500,end=500)  pl(11),pl(12),pl(13)
  500       continue
            if (ib .eq. 0)  axt = 'None'
            if (ib.ne.0 .and. ic.eq.0)  axt = 'Z-Only'
            if (ib.lt.0 .or. ic.lt.0)  axt = 'Bisector'
            if (ic.lt.0 .and. id.lt.0)  axt = 'Z-Bisect'
            if (max(ib,ic,id) .lt. 0)  axt = '3-Fold'
            ib = abs(ib)
            ic = abs(ic)
            id = abs(id)
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            nmp = nmp + 1
            kmp(nmp) = pa//pb//pc//pd
            mpaxis(nmp) = axt
            multip(1,nmp) = pl(1)
            multip(2,nmp) = pl(2)
            multip(3,nmp) = pl(3)
            multip(4,nmp) = pl(4)
            multip(5,nmp) = pl(5)
            multip(6,nmp) = pl(8)
            multip(7,nmp) = pl(11)
            multip(8,nmp) = pl(8)
            multip(9,nmp) = pl(9)
            multip(10,nmp) = pl(12)
            multip(11,nmp) = pl(11)
            multip(12,nmp) = pl(12)
            multip(13,nmp) = pl(13)
c
c     charge penetration parameters
c
         else if (keyword(1:7) .eq. 'CHGPEN ') then
            ia = 0
            pel = 0.0d0
            pal = 0.0d0
            string = record(next:240)
            read (string,*,err=510,end=510)  ia,pel,pal
  510       continue
            if (ia .ne. 0) then
               cpele(ia) = abs(pel)
               cpalp(ia) = pal
            end if
c
c     atomic dipole polarizability parameters
c
         else if (keyword(1:9) .eq. 'POLARIZE ') then
            ia = 0
            pol = 0.0d0
            thl = 0.0d0
            thd = 0.0d0
            do i = 1, maxval
               pg(i) = 0
            end do
            string = record(1:240)
            call getnumb (string,ia,next)
            call gettext (string,text,next)
            read (text,*,err=520,end=520)  pol
            call gettext (string,text,next)
            i = 1
            call getnumb (text,pg(1),i)
            if (pg(1) .eq. 0) then
               read (text,*,err=520,end=520)  thl
               call gettext (string,text,next)
               i = 1
               call getnumb (text,pg(1),i)
               string = string(next:240)
               if (pg(1) .eq. 0) then
                  read (text,*,err=520,end=520)  thd
                  read (string,*,err=520,end=520)  (pg(i),i=1,maxval)
               else
                  read (string,*,err=520,end=520)  (pg(i),i=2,maxval)
               end if
            else
               string = string(next:240)
               read (string,*,err=520,end=520)  (pg(i),i=2,maxval)
            end if
  520       continue
            if (ia .ne. 0) then
               polr(ia) = pol
               athl(ia) = thl
               dthl(ia) = thd
               do i = 1, maxval
                  pgrp(i,ia) = pg(i)
               end do
            end if
c
c     polarization parameters for specific atom pairs
c
         else if (keyword(1:8) .eq. 'POLPAIR ') then
            ia = 0
            ib = 0
            thl = 0.0d0
            thd = 0.0d0
            string = record(next:240)
            read (string,*,err=530,end=530)  ia,ib,thl,thd
  530       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            npp = npp + 1
            if (ia .le. ib) then
               kppr(npp) = pa//pb
            else
               kppr(npp) = pb//pa
            end if
            thlpr(npp) = thl
            thdpr(npp) = thd
c
c     exchange polarization parameters
c
         else if (keyword(1:8) .eq. 'EXCHPOL ') then
            ia = 0
            kpr = 0.0d0
            ppr = 0.0d0
            dpr = 0.0d0
            ilpr = 0
            string = record(next:240)
            read (string,*,err=540,end=540)  ia,kpr,ppr,dpr,ilpr
  540       continue
            if (ia .ne. 0) then
               pepk(ia) = kpr
               peppre(ia) = ppr
               pepdmp(ia) = dpr
               if (ilpr .ne. 0) then
                  pepl(ia) = .true.
               else
                  pepl(ia) = .false.
               end if
            end if
c
c     charge transfer parameters
c
         else if (keyword(1:7) .eq. 'CHGTRN ') then
            ia = 0
            ctrn = 0.0d0
            atrn = 0.0d0
            string = record(next:240)
            read (string,*,err=550,end=550)  ia,ctrn,atrn
  550       continue
            if (ia .ne. 0) then
               ctchg(ia) = ctrn
               ctdmp(ia) = atrn
            end if
c
c     bond charge flux parameters
c
         else if (keyword(1:9) .eq. 'BNDCFLUX ') then
            ia = 0
            ib = 0
            cfb = 0.0d0
            string = record(next:240)
            read (string,*,err=560,end=560)  ia,ib,cfb
  560       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            ncfb = ncfb + 1
            if (ia .lt. ib) then
               kcfb(ncfb) = pa//pb
               cflb(ncfb) = cfb
            else if (ib .lt. ia) then
               kcfb(ncfb) = pb//pa
               cflb(ncfb) = -cfb
            else
               kcfb(ncfb) = pa//pb
               cflb(ncfb) = 0.0d0
            end if
c
c     angle charge flux parameters
c
         else if (keyword(1:9) .eq. 'ANGCFLUX ') then
            ia = 0
            ib = 0
            ic = 0
            cfa1 = 0.0d0
            cfa2 = 0.0d0
            cfb1 = 0.0d0
            cfb2 = 0.0d0
            string = record(next:240)
            read (string,*,err=570,end=570)  ia,ib,ic,cfa1,cfa2,
     &                                       cfb1,cfb2
  570       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            ncfa = ncfa + 1
            if (ia .le. ic) then
               kcfa(ncfa) = pa//pb//pc
               cfla(1,ncfa) = cfa1
               cfla(2,ncfa) = cfa2
               cflab(1,ncfa) = cfb1
               cflab(2,ncfa) = cfb2
            else
               kcfa(ncfa) = pc//pb//pa
               cfla(1,ncfa) = cfa2
               cfla(2,ncfa) = cfa1
               cflab(1,ncfa) = cfb2
               cflab(2,ncfa) = cfb1
            end if
c
c     implicit solvation parameters
c
         else if (keyword(1:7) .eq. 'SOLUTE ') then
            ia = 0
            pbrd = 0.0d0
            csrd = 0.0d0
            gkrd = 0.0d0
            snek = 0.0d0
            string = record(next:240)
            read (string,*,err=580,end=580) ia,pbrd,csrd,gkrd,snek
  580       continue
            if (ia .ne. 0) then
               pbr(ia) = 0.5d0 * pbrd
               csr(ia) = 0.5d0 * csrd
               gkr(ia) = 0.5d0 * gkrd
               snk(ia) = snek
            end if
c
c     conjugated pisystem atom parameters
c
         else if (keyword(1:7) .eq. 'PIATOM ') then
            ia = 0
            el = 0.0d0
            iz = 0.0d0
            rp = 0.0d0
            string = record(next:240)
            read (string,*,err=590,end=590)  ia,el,iz,rp
  590       continue
            if (ia .ne. 0) then
               electron(ia) = el
               ionize(ia) = iz
               repulse(ia) = rp
            end if
c
c     conjugated pisystem bond parameters
c
         else if (keyword(1:7) .eq. 'PIBOND ') then
            ia = 0
            ib = 0
            ss = 0.0d0
            ts = 0.0d0
            string = record(next:240)
            read (string,*,err=600,end=600)  ia,ib,ss,ts
  600       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            npi = npi + 1
            if (ia .le. ib) then
               kpi(npi) = pa//pb
            else
               kpi(npi) = pb//pa
            end if
            sslope(npi) = ss
            tslope(npi) = ts
c
c     conjugated pisystem bond parameters for 5-membered rings
c
         else if (keyword(1:8) .eq. 'PIBOND5 ') then
            ia = 0
            ib = 0
            ss = 0.0d0
            ts = 0.0d0
            string = record(next:240)
            read (string,*,err=610,end=610)  ia,ib,ss,ts
  610       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            npi5 = npi5 + 1
            if (ia .le. ib) then
               kpi5(npi5) = pa//pb
            else
               kpi5(npi5) = pb//pa
            end if
            sslope5(npi5) = ss
            tslope5(npi5) = ts
c
c     conjugated pisystem bond parameters for 4-membered rings
c
         else if (keyword(1:8) .eq. 'PIBOND4 ') then
            ia = 0
            ib = 0
            ss = 0.0d0
            ts = 0.0d0
            string = record(next:240)
            read (string,*,err=620,end=620)  ia,ib,ss,ts
  620       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            npi4 = npi4 + 1
            if (ia .le. ib) then
               kpi4(npi4) = pa//pb
            else
               kpi4(npi4) = pb//pa
            end if
            sslope4(npi4) = ss
            tslope4(npi4) = ts
c
c     metal ligand field splitting parameters
c
         else if (keyword(1:6) .eq. 'METAL ') then
            string = record(next:240)
            read (string,*,err=630,end=630)  ia
  630       continue
c
c     biopolymer atom type conversion definitions
c
         else if (keyword(1:8) .eq. 'BIOTYPE ') then
            ia = 0
            ib = 0
            string = record(next:240)
            read (string,*,err=640,end=640)  ia
            call getword (record,string,next)
            call getstring (record,string,next)
            string = record(next:240)
            read (string,*,err=640,end=640)  ib
  640       continue
            if (ia .ge. maxbio) then
               write (iout,650)
  650          format (/,' READPRM  --  Too many Biopolymer Types;',
     &                    ' Increase MAXBIO')
               call fatal
            end if
            if (ia .gt. 0)  biotyp(ia) = ib
c
c     MMFF atom class equivalency parameters
c
         else if (keyword(1:10) .eq. 'MMFFEQUIV ') then
            string = record(next:240)
            ia = 1000
            ib = 1000
            ic = 1000
            id = 1000
            ie = 1000
            if = 0
            read (string,*,err=660,end=660)  ia,ib,ic,id,ie,if
  660       continue
            eqclass(if,1) = ia
            eqclass(if,2) = ib
            eqclass(if,3) = ic
            eqclass(if,4) = id
            eqclass(if,5) = ie
c
c     MMFF covalent radius and electronegativity parameters
c
         else if (keyword(1:11) .eq. 'MMFFCOVRAD ') then
            ia = 0
            fc = 0.0d0
            bd = 0.0d0
            string = record(next:240)
            read (string,*,err=670,end=670)  ia,fc,bd
  670       continue
            rad0(ia) = fc
            paulel(ia) = bd
c
c     MMFF atom class property parameters
c
         else if (keyword(1:9) .eq. 'MMFFPROP ') then
            string = record(next:240)
            ia = 1000
            ib = 1000
            ic = 1000
            id = 1000
            ie = 1000
            if = 1000
            ig = 1000
            ih = 1000
            ii = 1000
            read (string,*,err=680,end=680)  ia,ib,ic,id,ie,
     &                                       if,ig,ih,ii
  680       continue
            crd(ia) = ic
            val(ia) = id
            pilp(ia) = ie
            mltb(ia) = if
            arom(ia) = ig
            lin(ia) = ih
            sbmb(ia) = ii
c
c     MMFF bond stretching parameters
c
         else if (keyword(1:9) .eq. 'MMFFBOND ') then
            ia = 0
            ib = 0
            fc = 0.0d0
            bd = 0.0d0
            bt = 2
            string = record(next:240)
            read (string,*,err=690,end=690)  ia,ib,fc,bd,bt
  690       continue
            nb = nb + 1
            if (bt .eq. 0) then
               mmff_kb(ia,ib) = fc
               mmff_kb(ib,ia) = fc
               mmff_b0(ia,ib) = bd
               mmff_b0(ib,ia) = bd
            else if (bt .eq. 1) then
               mmff_kb1(ia,ib) = fc
               mmff_kb1(ib,ia) = fc
               mmff_b1(ia,ib) = bd
               mmff_b1(ib,ia) = bd
            end if
c
c     MMFF bond stretching empirical rule parameters
c
         else if (keyword(1:11) .eq. 'MMFFBONDER ') then
            ia = 0
            ib = 0
            fc = 0.0d0
            bd = 0.0d0
            string = record(next:240)
            read (string,*,err=700,end=700)  ia,ib,fc,bd
  700       continue
            r0ref(ia,ib) = fc
            r0ref(ib,ia) = fc
            kbref(ia,ib) = bd
            kbref(ib,ia) = bd
c
c     MMFF bond angle bending parameters
c
         else if (keyword(1:10) .eq. 'MMFFANGLE ') then
            ia = 0
            ib = 0
            ic = 0
            fc = 0.0d0
            an1 = 0.0d0
            at = 3
            string = record(next:240)
            read (string,*,err=710,end=710)  ia,ib,ic,fc,an1,at
  710       continue
            na = na + 1
            if (an1 .ne. 0.0d0) then
               if (at .eq. 0) then
                  mmff_ka(ia,ib,ic) = fc
                  mmff_ka(ic,ib,ia) = fc
                  mmff_ang0(ia,ib,ic) = an1
                  mmff_ang0(ic,ib,ia) = an1
               else if (at .eq. 1) then
                  mmff_ka1(ia,ib,ic) = fc
                  mmff_ka1(ic,ib,ia) = fc
                  mmff_ang1(ia,ib,ic) = an1
                  mmff_ang1(ic,ib,ia) = an1
               else if (at .eq. 2) then
                  mmff_ka2(ia,ib,ic) = fc
                  mmff_ka2(ic,ib,ia) = fc
                  mmff_ang2(ia,ib,ic) = an1
                  mmff_ang2(ic,ib,ia) = an1
               else if (at .eq. 3) then
                  mmff_ka3(ia,ib,ic) = fc
                  mmff_ka3(ic,ib,ia) = fc
                  mmff_ang3(ia,ib,ic) = an1
                  mmff_ang3(ic,ib,ia) = an1
               else if (at .eq. 4) then
                  mmff_ka4(ia,ib,ic) = fc
                  mmff_ka4(ic,ib,ia) = fc
                  mmff_ang4(ia,ib,ic) = an1
                  mmff_ang4(ic,ib,ia) = an1
               else if (at .eq. 5) then
                  mmff_ka5(ia,ib,ic) = fc
                  mmff_ka5(ic,ib,ia) = fc
                  mmff_ang5(ia,ib,ic) = an1
                  mmff_ang5(ic,ib,ia) = an1
               else if (at .eq. 6) then
                  mmff_ka6(ia,ib,ic) = fc
                  mmff_ka6(ic,ib,ia) = fc
                  mmff_ang6(ia,ib,ic) = an1
                  mmff_ang6(ic,ib,ia) = an1
               else if (at .eq. 7) then
                  mmff_ka7(ia,ib,ic) = fc
                  mmff_ka7(ic,ib,ia) = fc
                  mmff_ang7(ia,ib,ic) = an1
                  mmff_ang7(ic,ib,ia) = an1
               else if (at .eq. 8) then
                  mmff_ka8(ia,ib,ic) = fc
                  mmff_ka8(ic,ib,ia) = fc
                  mmff_ang8(ia,ib,ic) = an1
                  mmff_ang8(ic,ib,ia) = an1
               end if
            end if
c
c     MMFF stretch-bend parameters
c
         else if (keyword(1:11) .eq. 'MMFFSTRBND ') then
            ia = 0
            ib = 0
            ic = 0
            abc = 0.0d0
            cba = 0.0d0
            sbt = 4
            string = record(next:240)
            read (string,*,err=720,end=720)  ia,ib,ic,abc,cba,sbt
  720       continue
            if (ia .ne. 0) then
               if (sbt .eq. 0) then
                  stbn_abc(ia,ib,ic) = abc
                  if (ic .ne. ia)  stbn_abc(ic,ib,ia) = cba
                  stbn_cba(ia,ib,ic) = cba
                  if (ic .ne. ia)  stbn_cba(ic,ib,ia) = abc
               else if (sbt .eq. 1) then
                  stbn_abc1(ia,ib,ic) = abc
                  if (ic .ne. ia)  stbn_abc1(ic,ib,ia) = cba
                  stbn_cba1(ia,ib,ic) = cba
                  if (ic .ne. ia)  stbn_cba1(ic,ib,ia) = abc
               else if (sbt .eq. 2) then
                  stbn_abc2(ia,ib,ic) = abc
                  if (ic .ne. ia)  stbn_abc2(ic,ib,ia) = cba
                  stbn_cba2(ia,ib,ic) = cba
                  if (ic .ne. ia)  stbn_cba2(ic,ib,ia) = abc
               else if (sbt .eq. 3) then
                  stbn_abc3(ia,ib,ic) = abc
                  if (ic .ne. ia)  stbn_abc3(ic,ib,ia) = cba
                  stbn_cba3(ia,ib,ic) = cba
                  if (ic .ne. ia)  stbn_cba3(ic,ib,ia) = abc
               else if (sbt .eq. 4) then
                  stbn_abc4(ia,ib,ic) = abc
                  if (ic .ne. ia)  stbn_abc4(ic,ib,ia) = cba
                  stbn_cba4(ia,ib,ic) = cba
                  if (ic .ne. ia)  stbn_cba4(ic,ib,ia) = abc
               else if (sbt .eq. 5) then
                  stbn_abc5(ia,ib,ic) = abc
                  if (ic .ne. ia)  stbn_abc5(ic,ib,ia) = cba
                  stbn_cba5(ia,ib,ic) = cba
                  if (ic .ne. ia)  stbn_cba5(ic,ib,ia) = abc
               else if (sbt .eq. 6) then
                  stbn_abc6(ia,ib,ic) = abc
                  if (ic .ne. ia)  stbn_abc6(ic,ib,ia) = cba
                  stbn_cba6(ia,ib,ic) = cba
                  if (ic .ne. ia)  stbn_cba6(ic,ib,ia) = abc
               else if (sbt .eq. 7) then
                  stbn_abc7(ia,ib,ic) = abc
                  if (ic .ne. ia)  stbn_abc7(ic,ib,ia) = cba
                  stbn_cba7(ia,ib,ic) = cba
                  if (ic .ne. ia)  stbn_cba7(ic,ib,ia) = abc
               else if (sbt .eq. 8) then
                  stbn_abc8(ia,ib,ic) = abc
                  if (ic .ne. ia)  stbn_abc8(ic,ib,ia) = cba
                  stbn_cba8(ia,ib,ic) = cba
                  if (ic .ne. ia)  stbn_cba8(ic,ib,ia) = abc
               else if (sbt .eq. 9) then
                  stbn_abc9(ia,ib,ic) = abc
                  if (ic .ne. ia)  stbn_abc9(ic,ib,ia) = cba
                  stbn_cba9(ia,ib,ic) = cba
                  if (ic .ne. ia)  stbn_cba9(ic,ib,ia) = abc
               else if (sbt .eq. 10) then
                  stbn_abc10(ia,ib,ic) = abc
                  if (ic .ne. ia)  stbn_abc10(ic,ib,ia) = cba
                  stbn_cba10(ia,ib,ic) = cba
                  if (ic .ne. ia)  stbn_cba10(ic,ib,ia) = abc
               else if (sbt .eq. 11) then
                  stbn_abc11(ia,ib,ic) = abc
                  if (ic .ne. ia)  stbn_abc11(ic,ib,ia) = cba
                  stbn_cba11(ia,ib,ic) = cba
                  if (ic .ne. ia)  stbn_cba11(ic,ib,ia) = abc
               end if
            end if
c
c     MMFF default stretch-bend parameters
c
         else if (keyword(1:12) .eq. 'MMFFDEFSTBN ') then
            string = record(next:240)
            ia = 1000
            ib = 1000
            ic = 1000
            abc = 0.0d0
            cba = 0.0d0
            read (string,*,err=730,end=730)  ia,ib,ic,abc,cba
  730       continue
            defstbn_abc(ia,ib,ic) = abc
            defstbn_cba(ia,ib,ic) = cba
            defstbn_abc(ic,ib,ia) = cba
            defstbn_cba(ic,ib,ia) = abc
c
c     MMFF out-of-plane bend parameters
c
         else if (keyword(1:11) .eq. 'MMFFOPBEND ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            fc = 0.0d0
            string = record(next:240)
            read (string,*,err=740,end=740)  ia,ib,ic,id,fc
  740       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            nopb = nopb + 1
            if (ic .le. id) then
               kopb(nopb) = pa//pb//pc//pd
            else
               kopb(nopb) = pa//pb//pd//pc
            end if
            opbn(nopb) = fc
c           if (ic.gt.0 .or. id.gt.0) then
c              nopb = nopb + 1
c              if (ib .le. id) then
c                 kopb(nopb) = pc//pb//pb//pd
c              else
c                 kopb(nopb) = pc//pb//pd//pb
c              end if
c              opbn(nopb) = fc
c              nopb = nopb + 1
c              if (ia .le. ic) then
c                 kopb(nopb) = pd//pb//pa//pc
c              else
c                 kopb(nopb) = pd//pb//pc//pa
c              end if
c              opbn(nopb) = fc
c           end if
c
c     MMFF torsional parameters
c
         else if (keyword(1:12) .eq. 'MMFFTORSION ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            do i = 1, 6
               vt(i) = 0.0d0
               st(i) = 0.0d0
               ft(i) = 0
            end do
            tt = 3
            string = record(next:240)
            read (string,*,err=750,end=750)  ia,ib,ic,id,(vt(j),
     &                                       st(j),ft(j),j=1,3),tt
  750       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            nt = nt + 1
            if (tt .eq. 0) then
               if (ib .lt. ic) then
                  kt(nt) = pa//pb//pc//pd
               else if (ic .lt. ib) then
                  kt(nt) = pd//pc//pb//pa
               else if (ia .le. id) then
                  kt(nt) = pa//pb//pc//pd
               else if (id .lt. ia) then
                  kt(nt) = pd//pc//pb//pa
               end if
               call torphase (ft,vt,st)
               t1(1,nt) = vt(1)
               t1(2,nt) = st(1)
               t2(1,nt) = vt(2)
               t2(2,nt) = st(2)
               t3(1,nt) = vt(3)
               t3(2,nt) = st(3)
            else if (tt .eq. 1) then
               if (ib .lt. ic) then
                  kt_1(nt) = pa//pb//pc//pd
               else if (ic .lt. ib) then
                  kt_1(nt) = pd//pc//pb//pa
               else if (ia .le. id) then
                  kt_1(nt) = pa//pb//pc//pd
               else if (id .lt. ia) then
                  kt_1(nt) = pd//pc//pb//pa
               end if
               call torphase (ft,vt,st)
               t1_1(1,nt) = vt(1)
               t1_1(2,nt) = st(1)
               t2_1(1,nt) = vt(2)
               t2_1(2,nt) = st(2)
               t3_1(1,nt) = vt(3)
               t3_1(2,nt) = st(3)
            else if (tt .eq. 2) then
               if (ib .lt. ic) then
                  kt_2(nt) = pa//pb//pc//pd
               else if (ic .lt. ib) then
                  kt_2(nt) = pd//pc//pb//pa
               else if (ia .le. id) then
                  kt_2(nt) = pa//pb//pc//pd
               else if (id .lt. ia) then
                  kt_2(nt) = pd//pc//pb//pa
               end if
               call torphase (ft,vt,st)
               t1_2(1,nt) = vt(1)
               t1_2(2,nt) = st(1)
               t2_2(1,nt) = vt(2)
               t2_2(2,nt) = st(2)
               t3_2(1,nt) = vt(3)
               t3_2(2,nt) = st(3)
            else if (tt .eq. 4) then
               nt4 = nt4 + 1
               if (ib .lt. ic) then
                  kt4(nt4) = pa//pb//pc//pd
               else if (ic .lt. ib) then
                  kt4(nt4) = pd//pc//pb//pa
               else if (ia .le. id) then
                  kt4(nt4) = pa//pb//pc//pd
               else if (id .lt. ia) then
                  kt4(nt4) = pd//pc//pb//pa
               end if
               call torphase (ft,vt,st)
               t14(1,nt4) = vt(1)
               t14(2,nt4) = st(1)
               t24(1,nt4) = vt(2)
               t24(2,nt4) = st(2)
               t34(1,nt4) = vt(3)
               t34(2,nt4) = st(3)
            else if (tt .eq. 5) then
               nt5 = nt5 + 1
               if (ib .lt. ic) then
                  kt5(nt5) = pa//pb//pc//pd
               else if (ic .lt. ib) then
                  kt5(nt5) = pd//pc//pb//pa
               else if (ia .le. id) then
                  kt5(nt5) = pa//pb//pc//pd
               else if (id .lt. ia) then
                  kt5(nt5) = pd//pc//pb//pa
               end if
               call torphase (ft,vt,st)
               t15(1,nt5) = vt(1)
               t15(2,nt5) = st(1)
               t25(1,nt5) = vt(2)
               t25(2,nt5) = st(2)
               t35(1,nt5) = vt(3)
               t35(2,nt5) = st(3)
            end if
c
c     MMFF van der Waals parameters
c
         else if (keyword(1:8) .eq. 'MMFFVDW ') then
            ia = 0
            rd = 0.0d0
            ep = 0.0d0
            rdn = 0.0d0
            da1 = 'C'
            string = record(next:240)
            read (string,*,err=760,end=760)  ia,rd,alphi,nni,gi,da1
  760       continue
            if (ia .ne. 0) then
               rad(ia) = rd
               g(ia) = gi
               alph(ia) = alphi
               nn(ia) = nni
               da(ia) = da1
            end if
c
c     MMFF bond charge increment parameters
c
         else if (keyword(1:8) .eq. 'MMFFBCI ') then
            ia = 0
            ib = 0
            cg = 1000.0d0
            bt = 2
            string = record(next:240)
            read (string,*,err=770,end=770)  ia,ib,cg,bt
  770       continue
            if (ia .ne. 0) then
               if (bt .eq. 0) then
                  bci(ia,ib) = cg
                  bci(ib,ia) = -cg
               else if (bt .eq. 1) then
                  bci_1(ia,ib) = cg
                  bci_1(ib,ia) = -cg
               end if
            end if
c
c     MMFF partial bond charge increment parameters
c
         else if (keyword(1:9) .eq. 'MMFFPBCI ') then
            ia = 0
            string = record(next:240)
            read (string,*,err=780,end=780)  ia,cg,factor
  780       continue
            if (ia .ne. 0) then
               pbci(ia) = cg
               fcadj(ia) = factor
            end if
c
c     MMFF aromatic ion parameters
c
         else if (keyword(1:9) .eq. 'MMFFAROM ') then
            string = record(next:240)
            read (string,*,err=790,end=790)  ia,ib,ic,id,ie,if
  790       continue
            if (ie.eq.0 .and. id.eq.0) then
               mmffarom(ia,if) = ic
            else if (id .eq. 1) then
               mmffaromc(ia,if) = ic
            else if (ie .eq. 1) then
               mmffaroma(ia,if) = ic
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine readseq  --  read biopolymer sequence file  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "readseq" gets a biopolymer sequence containing one or more
c     separate chains from an external file; all lines containing
c     sequence must begin with the starting sequence number, the
c     actual sequence is read from subsequent nonblank characters
c
c
      subroutine readseq (iseq)
      use files
      use iounit
      use resdue
      use sequen
      implicit none
      integer i,j,k,iseq
      integer length,number
      integer start,stop
      integer next,trimtext
      logical exist,opened,done
      character*1 letter
      character*3 word
      character*240 seqfile
      character*240 record
c
c
c     open the input file if it has not already been done
c
      inquire (unit=iseq,opened=opened)
      if (.not. opened) then
         seqfile = filename(1:leng)//'.seq'
         call version (seqfile,'old')
         inquire (file=seqfile,exist=exist)
         if (exist) then
            open (unit=iseq,file=seqfile,status='old')
            rewind (unit=iseq)
         else
            write (iout,10)
   10       format (/,' READSEQ  --  Unable to Find the Biopolymer',
     &                 ' Sequence File')
            call fatal
         end if
      end if
c
c     zero out the number and type of residues
c
      nseq = 0
      nchain = 0
      do i = 1, maxres
         seq(i) = '   '
      end do
c
c     read in the biopolymer sequence file
c
      do while (.true.)
         read (iseq,20,err=30,end=30)  record
   20    format (a240)
         length = trimtext (record)
         next = 1
         call gettext (record,letter,next)
         if (letter.ge.'0' .and. letter.le.'9') then
            next = 1
            letter = ' '
         end if
         call getnumb (record,number,next)
         if (number .eq. 1) then
            nchain = nchain + 1
            ichain(1,nchain) = nseq + 1
            chnnam(nchain) = letter
         end if
         done = .false.
         do while (.not. done)
            call getword (record,word,next)
            call justify (word)
            if (word .eq. '   ') then
               done = .true.
            else
               nseq = nseq + 1
               seq(nseq) = word
            end if
         end do
      end do
   30 continue
c
c     set the last residue in each sequence chain
c
      do i = 1, nchain-1
         ichain(2,i) = ichain(1,i+1) - 1
      end do
      if (nchain .ne. 0)  ichain(2,nchain) = nseq
c
c     find residue types and species present in each chain
c
      do i = 1, nchain
         start = ichain(1,i)
         stop = ichain(2,i)
         chntyp(i) = 'GENERIC'
         do j = start, stop
            do k = 1, maxamino
               if (seq(j) .eq. amino(k)) then
                  seqtyp(j) = k
                  chntyp(i) = 'PEPTIDE'
                  goto 40
               end if
            end do
            chntyp(i) = 'GENERIC'
            goto 50
   40       continue
         end do
   50    continue
         if (chntyp(i) .eq. 'GENERIC') then
            do j = start, stop
               do k = 1, maxnuc
                  if (seq(j) .eq. nuclz(k)) then
                     seqtyp(j) = k
                     chntyp(i) = 'NUCLEIC'
                     goto 60
                  end if
               end do
               chntyp(i) = 'GENERIC'
               goto 70
   60          continue
            end do
   70       continue
         end if
         if (chntyp(i) .eq. 'GENERIC') then
            do j = start, stop
               seqtyp(j) = 0
            end do
         end if
      end do
      if (.not. opened)  close (unit=iseq)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine readxyz  --  input of XYZ-format coordinates  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "readxyz" gets a set of Cartesian coordinates from an external
c     file in either Tinker XYZ format or simple generic XYZ format
c
c
      subroutine readxyz (ixyz)
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use files
      use inform
      use iounit
      use titles
      implicit none
      integer i,j,k,m
      integer ixyz,nmax
      integer next,size
      integer first,last
      integer nexttext
      integer trimtext
      integer, allocatable :: list(:)
      real*8 xtmp,ytmp,ztmp
      real*8 atmp,btmp,gtmp
      logical exist,opened
      logical done,quit
      logical simple,clash
      logical reorder
      character*240 xyzfile
      character*240 record
      character*240 string
c
c
c     open the input file if it has not already been done
c
      inquire (unit=ixyz,opened=opened)
      if (.not. opened) then
         xyzfile = filename(1:leng)//'.xyz'
         call version (xyzfile,'old')
         inquire (file=xyzfile,exist=exist)
         if (exist) then
            open (unit=ixyz,file=xyzfile,status='old')
            rewind (unit=ixyz)
         else
            write (iout,10)
   10       format (/,' READXYZ  --  Unable to Find the Cartesian',
     &                 ' Coordinates File')
            call fatal
         end if
      end if
c
c     read first line and return if already at end of file
c
      quit = .false.
      abort = .true.
      simple = .false.
      size = 0
      do while (size .eq. 0)
         read (ixyz,20,err=130,end=130)  record
   20    format (a240)
         size = trimtext (record)
      end do
      abort = .false.
      quit = .true.
c
c     parse the first line to get the total number of atoms
c
      n = 0
      next = 1
      call gettext (record,string,next)
      read (string,*,err=130,end=130)  n
c
c     extract the title and determine its length
c
      string = record(next:240)
      first = nexttext (string)
      last = trimtext (string)
      if (last .eq. 0) then
         title = ' '
         ltitle = 0
      else
         title = string(first:last)
         ltitle = trimtext (title)
      end if
c
c     check for too few or too many total atoms in the file
c
      if (n .le. 0) then
         write (iout,30)
   30    format (/,' READXYZ  --  The Coordinate File Does Not',
     &              ' Contain Any Atoms')
         call fatal
      else if (n .gt. maxatm) then
         write (iout,40)  maxatm
   40    format (/,' READXYZ  --  The Maximum of',i9,' Atoms',
     &              ' has been Exceeded')
         call fatal
      end if
c
c     initialize coordinates and connectivities for each atom
c
      do i = 1, n
         tag(i) = 0
         name(i) = '   '
         x(i) = 0.0d0
         y(i) = 0.0d0
         z(i) = 0.0d0
         type(i) = 0
         n12(i) = 0
         do j = 1, maxval
            i12(j,i) = 0
         end do
      end do
c
c     read second and following lines until atom lines begin
c
      call unitcell
      done = .false.
      dowhile (.not. done)
         read (ixyz,50,err=130,end=130)  record
   50    format (a240)
         size = trimtext (record)
         if (size .ne. 0) then
c
c     check for an initial atom in the Tinker XYZ format
c
            if (.not. done) then
               read (record,*,err=70,end=70)  tag(1)
               next = 1
               call getword (record,name(1),next)
               if (name(1) .eq. '   ')  goto 70
               string = record(next:240)
               read (string,*,err=60,end=60)  x(1),y(1),z(1),type(1),
     &                                        (i12(j,1),j=1,maxval)
   60          continue
               done = .true.
   70          continue
            end if
c
c     check for an initial atom in the simple XYZ format
c
            if (.not. done) then
               tag(1) = 1
               next = 1
               call getword (record,name(1),next)
               if (next .eq. 1)  goto 80
               string = record(next:240)
               read (string,*,err=80,end=80)  x(1),y(1),z(1)
               done = .true.
               simple = .true.
   80          continue
            end if
c
c     check for optional dimensions of the periodic box
c
            if (.not. done) then
               xtmp = 0.0d0
               ytmp = 0.0d0
               ztmp = 0.0d0
               atmp = 0.0d0
               btmp = 0.0d0
               gtmp = 0.0d0
               read (record,*,err=90,end=90)  xtmp,ytmp,ztmp,
     &                                        atmp,btmp,gtmp
   90          continue
               if (xtmp .ne. 0.0d0) then
                  use_bounds = .true.
                  xbox = xtmp
                  ybox = ytmp
                  zbox = ztmp
                  alpha = atmp
                  beta = btmp
                  gamma = gtmp
                  if (ytmp .eq. 0.0d0)  ybox = xbox
                  if (ztmp .eq. 0.0d0)  zbox = xbox
                  if (atmp .eq. 0.0d0)  alpha = 90.0d0
                  if (btmp .eq. 0.0d0)  beta = 90.0d0
                  if (gtmp .eq. 0.0d0)  gamma = 90.0d0
                  call lattice
               end if
            end if
         end if
      end do
c
c     read second and following atom lines from input file
c
      if (simple) then
         do i = 2, n
            read (ixyz,100,err=130,end=130)  record
  100       format (a240)
            tag(i) = i
            next = 1
            call getword (record,name(i),next)
            string = record(next:240)
            read (string,*,err=130,end=130)  x(i),y(i),z(i)
         end do
         quit = .false.
      else
         do i = 2, n
            read (ixyz,110,err=130,end=130)  record
  110       format (a240)
            read (record,*,err=130,end=130)  tag(i)
            next = 1
            call getword (record,name(i),next)
            string = record(next:240)
            read (string,*,err=120,end=120)  x(i),y(i),z(i),type(i),
     &                                       (i12(j,i),j=1,maxval)
  120       continue
         end do
         quit = .false.
      end if
  130 continue
      if (.not. opened)  close (unit=ixyz)
c
c     an error occurred in reading the coordinate file
c
      if (quit) then
         write (iout,140)  i
  140    format (/,' READXYZ  --  Error in Coordinate File at Atom',i9)
         call fatal
      end if
c
c     for each atom, count and sort its attached atoms
c
      if (.not. abort) then
         do i = 1, n
            do j = maxval, 1, -1
               if (i12(j,i) .ne. 0) then
                  n12(i) = j
                  goto 150
               end if
            end do
  150       continue
            call sort (n12(i),i12(1,i))
         end do
c
c     perform dynamic allocation of some local arrays
c
         nmax = 0
         do i = 1, n
            nmax = max(tag(i),nmax)
            do j = 1, n12(i)
               nmax = max(i12(j,i),nmax)
            end do
         end do
         allocate (list(nmax))
c
c     check for scrambled atom order and attempt to renumber
c
         reorder = .false.
         do i = 1, n
            list(tag(i)) = i
            if (tag(i) .ne. i)  reorder = .true.
         end do
         if (reorder) then
            write (iout,160)
  160       format (/,' READXYZ  --  Atom Labels not Sequential,',
     &                 ' Attempting to Renumber')
            do i = 1, n
               tag(i) = i
               do j = 1, n12(i)
                  i12(j,i) = list(i12(j,i))
               end do
               call sort (n12(i),i12(1,i))
            end do
         end if
c
c     perform deallocation of some local arrays
c
         deallocate (list)
c
c     check for atom pairs with identical coordinates
c
         clash = .false.
         if (n .le. 10000)  call chkxyz (clash)
c
c     make sure all atom connectivities are bidirectional
c
         do i = 1, n
            do j = 1, n12(i)
               k = i12(j,i)
               do m = 1, n12(k)
                  if (i12(m,k) .eq. i)  goto 180
               end do
               write (iout,170)  k,i
  170          format (/,' READXYZ  --  Check Connection of Atoms',
     &                    i9,' and',i9)
               call fatal
  180          continue
            end do
         end do
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module refer  --  reference atomic coordinate storage  ##
c     ##                                                         ##
c     #############################################################
c
c
c     nref        total number of atoms in each reference system
c     refltitle   length in characters of reference title lines
c     refleng     length in characters of reference base filenames
c     reftyp      atom types of the atoms in each reference system
c     n12ref      number of atoms bonded to each reference atom
c     i12ref      atom numbers of atoms 1-2 connected to each atom
c     xboxref     reference a-axis length of periodic box
c     yboxref     reference b-axis length of periodic box
c     zboxref     reference c-axis length of periodic box
c     alpharef    reference angle between b- and c-axes of box
c     betaref     reference angle between a- and c-axes of box
c     gammaref    reference angle between a- and b-axes of box
c     xref        reference x-coordinates for atoms in each system
c     yref        reference y-coordinates for atoms in each system
c     zref        reference z-coordinates for atoms in each system
c     refnam      atom names of the atoms in each reference system
c     reffile     full filename for each reference system
c     reftitle    title used to describe each reference system
c
c
      module refer
      use sizes
      implicit none
      integer nref(maxref)
      integer refltitle(maxref)
      integer refleng(maxref)
      integer, allocatable :: reftyp(:,:)
      integer, allocatable :: n12ref(:,:)
      integer, allocatable :: i12ref(:,:,:)
      real*8 xboxref(maxref)
      real*8 yboxref(maxref)
      real*8 zboxref(maxref)
      real*8 alpharef(maxref)
      real*8 betaref(maxref)
      real*8 gammaref(maxref)
      real*8, allocatable :: xref(:,:)
      real*8, allocatable :: yref(:,:)
      real*8, allocatable :: zref(:,:)
      character*3, allocatable :: refnam(:,:)
      character*240 reffile(maxref)
      character*240 reftitle(maxref)
      save
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module repel  --  Pauli repulsion for current structure  ##        
c     ##                                                           ##
c     ###############################################################
c
c
c     nrep      total number of repulsion sites in the system
c     irep      number of the atom for each repulsion site
c     replist   repulsion multipole site for each atom (0=none)
c     sizpr     Pauli repulsion size parameter value for each atom
c     dmppr     Pauli repulsion alpha damping value for each atom
c     elepr     Pauli repulsion valence electrons for each atom
c     repole    repulsion Cartesian multipoles in the local frame
c     rrepole   repulsion Cartesian multipoles in the global frame
c
c
      module repel
      implicit none
      integer nrep
      integer, allocatable :: irep(:)
      integer, allocatable :: replist(:)
      real*8, allocatable :: sizpr(:)
      real*8, allocatable :: dmppr(:)
      real*8, allocatable :: elepr(:)
      real*8, allocatable :: repole(:,:)
      real*8, allocatable :: rrepole(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2000  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine replica  --  periodicity via cell replication  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "replica" decides between images and replicates for generation
c     of periodic boundary conditions, and sets the cell replicate
c     list if the replicates method is to be used
c
c
      subroutine replica (cutoff)
      use bound
      use boxes
      use cell
      use inform
      use iounit
      use math
      implicit none
      integer i,j,k
      integer nx,ny,nz
      real*8 cutoff,maximage
      real*8 xlimit,ylimit,zlimit
c
c
c     only necessary if periodic boundaries are in use
c
      ncell = 1
      if (.not. use_bounds)  return
c
c     find the maximum sphere radius inscribed in periodic box
c
      if (orthogonal) then
         xlimit = xbox2
         ylimit = ybox2
         zlimit = zbox2
      else if (monoclinic) then
         xlimit = xbox2 * beta_sin
         ylimit = ybox2
         zlimit = zbox2 * beta_sin
      else if (triclinic) then
         xlimit = volbox / (2.0d0*ybox*zbox*alpha_sin)
         ylimit = volbox / (2.0d0*xbox*zbox*beta_sin)
         zlimit = volbox / (2.0d0*xbox*ybox*gamma_sin)
      else if (octahedron) then
         xlimit = 0.5d0 * root3 * xbox2
         ylimit = xlimit
         zlimit = xlimit
      else if (dodecadron) then
         xlimit = xbox2
         ylimit = xlimit
         zlimit = xlimit
      end if
      maximage = min(xlimit,ylimit,zlimit)
c
c     use replicate method to handle cutoffs too large for images
c
      if (cutoff .le. maximage) then
         use_replica = .false.
      else
         use_replica = .true.
      end if
c
c     non-prism periodic cells cannot use the replicates method
c
      if (use_replica) then
         if (nonprism) then
            write (iout,10)
   10       format (/,' REPLICA  --  Non-Parallelepiped Cells',
     &                 ' cannot be Replicated')
            call fatal
         end if
      end if
c
c     find the number of replicates needed based on cutoff
c
      nx = int(cutoff/xlimit)
      ny = int(cutoff/ylimit)
      nz = int(cutoff/zlimit)
      if (cutoff .gt. dble(nx)*xlimit)  nx = nx + 1
      if (cutoff .gt. dble(ny)*ylimit)  ny = ny + 1
      if (cutoff .gt. dble(nz)*zlimit)  nz = nz + 1
      if (nx .lt. 1)  nx = 1
      if (ny .lt. 1)  ny = 1
      if (nz .lt. 1)  nz = 1
c
c     set the replicated cell length and the half width
c
      xcell = dble(nx) * xbox
      ycell = dble(ny) * ybox
      zcell = dble(nz) * zbox
      xcell2 = 0.5d0 * xcell
      ycell2 = 0.5d0 * ycell
      zcell2 = 0.5d0 * zcell
c
c     perform dynamic allocation of some global arrays
c
      ncell = nx*ny*nz
      if (allocated(icell)) then
         if (size(icell) .lt. 3*ncell) then
            deallocate (icell)
            allocate (icell(3,ncell))
         end if
      else
         allocate (icell(3,ncell))
      end if
c
c     assign indices to the required cell replicates
c
      ncell = 0
      do k = 0, nz-1
         do j = 0, ny-1
            do i = 0, nx-1
               ncell = ncell + 1
               icell(1,ncell) = i
               icell(2,ncell) = j
               icell(3,ncell) = k
            end do
         end do
      end do
c
c     print a message indicating the number of replicates used
c
      if (debug .and. ncell.gt.1) then
         if (max(nx,ny,nz) .lt. 10) then
            write (iout,20)  nx,ny,nz
   20       format (/,' REPLICA  --  Period Boundaries via',i2,' x',
     &                 i2,' x',i2,' Cell Replicate Set')
         else if (max(nx,ny,nz) .lt. 100) then
            write (iout,30)  nx,ny,nz
   30       format (/,' REPLICA  --  Period Boundaries via',i3,' x',
     &                 i3,' x',i3,' Cell Replicate Set')
         else
            write (iout,40)  nx,ny,nz
   40       format (/,' REPLICA  --  Period Boundaries via',i4,' x',
     &                 i4,' x',i4,' Cell Replicate Set')
         end if
      end if
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder  ##
c     ##                   All Rights Reserved                  ##
c     ############################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module reppot  --  repulsion functional form details  ##
c     ##                                                        ##
c     ############################################################
c
c
c     r2scale    scale factor for 1-2 repulsion energy interactions
c     r3scale    scale factor for 1-3 repulsion energy interactions
c     r4scale    scale factor for 1-4 repulsion energy interactions
c     r5scale    scale factor for 1-5 repulsion energy interactions
c
c
      module reppot
      implicit none
      real*8 r2scale
      real*8 r3scale
      real*8 r4scale
      real*8 r5scale
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module resdue  --  amino acid & nucleotide residue names  ##
c     ##                                                            ##
c     ################################################################
c
c
c     maxamino  maximum number of amino acid residue types
c     maxnuc    maximum number of nucleic acid residue types
c
c     ntyp      biotypes for mid-chain peptide backbone N atoms
c     catyp     biotypes for mid-chain peptide backbone CA atoms
c     ctyp      biotypes for mid-chain peptide backbone C atoms
c     hntyp     biotypes for mid-chain peptide backbone HN atoms
c     otyp      biotypes for mid-chain peptide backbone O atoms
c     hatyp     biotypes for mid-chain peptide backbone HA atoms
c     cbtyp     biotypes for mid-chain peptide backbone CB atoms
c     nntyp     biotypes for N-terminal peptide backbone N atoms
c     cantyp    biotypes for N-terminal peptide backbone CA atoms
c     cntyp     biotypes for N-terminal peptide backbone C atoms
c     hnntyp    biotypes for N-terminal peptide backbone HN atoms
c     ontyp     biotypes for N-terminal peptide backbone O atoms
c     hantyp    biotypes for N-terminal peptide backbone HA atoms
c     nctyp     biotypes for C-terminal peptide backbone N atoms
c     cactyp    biotypes for C-terminal peptide backbone CA atoms
c     cctyp     biotypes for C-terminal peptide backbone C atoms
c     hnctyp    biotypes for C-terminal peptide backbone HN atoms
c     octyp     biotypes for C-terminal peptide backbone O atoms
c     hactyp    biotypes for C-terminal peptide backbone HA atoms
c     o5typ     biotypes for nucleotide backbone and sugar O5' atoms
c     c5typ     biotypes for nucleotide backbone and sugar C5' atoms
c     h51typ    biotypes for nucleotide backbone and sugar H5' atoms
c     h52typ    biotypes for nucleotide backbone and sugar H5'' atoms
c     c4typ     biotypes for nucleotide backbone and sugar C4' atoms
c     h4typ     biotypes for nucleotide backbone and sugar H4' atoms
c     o4typ     biotypes for nucleotide backbone and sugar O4' atoms
c     c1typ     biotypes for nucleotide backbone and sugar C1' atoms
c     h1typ     biotypes for nucleotide backbone and sugar H1' atoms
c     c3typ     biotypes for nucleotide backbone and sugar C3' atoms
c     h3typ     biotypes for nucleotide backbone and sugar H3' atoms
c     c2typ     biotypes for nucleotide backbone and sugar C2' atoms
c     h21typ    biotypes for nucleotide backbone and sugar H2' atoms
c     o2typ     biotypes for nucleotide backbone and sugar O2' atoms
c     h22typ    biotypes for nucleotide backbone and sugar H2'' atoms
c     o3typ     biotypes for nucleotide backbone and sugar O3' atoms
c     ptyp      biotypes for nucleotide backbone and sugar P atoms
c     optyp     biotypes for nucleotide backbone and sugar OP atoms
c     h5ttyp    biotypes for nucleotide backbone and sugar H5T atoms
c     h3ttyp    biotypes for nucleotide backbone and sugar H3T atoms
c     amino     three-letter abbreviations for amino acids types
c     nuclz     three-letter abbreviations for nucleic acids types
c     amino1    one-letter abbreviations for amino acids types
c     nuclz1    one-letter abbreviations for nucleic acids types
c
c
      module resdue
      implicit none
      integer maxamino
      integer maxnuc
      parameter (maxamino=38)
      parameter (maxnuc=12)
      integer ntyp(maxamino)
      integer catyp(maxamino)
      integer ctyp(maxamino)
      integer hntyp(maxamino)
      integer otyp(maxamino)
      integer hatyp(maxamino)
      integer cbtyp(maxamino)
      integer nntyp(maxamino)
      integer cantyp(maxamino)
      integer cntyp(maxamino)
      integer hnntyp(maxamino)
      integer ontyp(maxamino)
      integer hantyp(maxamino)
      integer nctyp(maxamino)
      integer cactyp(maxamino)
      integer cctyp(maxamino)
      integer hnctyp(maxamino)
      integer octyp(maxamino)
      integer hactyp(maxamino)
      integer o5typ(maxnuc)
      integer c5typ(maxnuc)
      integer h51typ(maxnuc)
      integer h52typ(maxnuc)
      integer c4typ(maxnuc)
      integer h4typ(maxnuc)
      integer o4typ(maxnuc)
      integer c1typ(maxnuc)
      integer h1typ(maxnuc)
      integer c3typ(maxnuc)
      integer h3typ(maxnuc)
      integer c2typ(maxnuc)
      integer h21typ(maxnuc)
      integer o2typ(maxnuc)
      integer h22typ(maxnuc)
      integer o3typ(maxnuc)
      integer ptyp(maxnuc)
      integer optyp(maxnuc)
      integer h5ttyp(maxnuc)
      integer h3ttyp(maxnuc)
      character*1 amino1(maxamino)
      character*1 nuclz1(maxnuc)
      character*3 amino(maxamino)
      character*3 nuclz(maxnuc)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2011  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine vrespa  --  Verlet r-RESPA molecular dynamics  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "vrespa" performs a multiple time step (MTS) molecular dynamics
c     step using the reversible reference system propagation algorithm
c     (r-RESPA) via a velocity Verlet recursion with the potential
c     split into fast- and slow-evolving components
c
c     literature references:
c
c     D. D. Humphreys, R. A. Friesner and B. J. Berne, "A Multiple-
c     Time-Step Molecular Dynamics Algorithm for Macromolecules",
c     Journal of Physical Chemistry, 98, 6885-6892 (1994)
c
c     X. Qian and T. Schlick, "Efficient Multiple-Time-Step Integrators
c     with Distance-Based Force Splitting for Particle-Mesh-Ewald
c     Molecular Dynamics Simulations", Journal of Chemical Physics,
c     115, 4019-4029 (2001)
c
c
      subroutine vrespa (istep,dt)
      use atomid
      use atoms
      use freeze
      use ielscf
      use mdstuf
      use moldyn
      use polar
      use units
      use usage
      use virial
      implicit none
      integer i,j,k,m
      integer istep
      real*8 dt,dt_2
      real*8 dta,dta_2
      real*8 epot,etot
      real*8 eksum,term
      real*8 temp,pres
      real*8 drespa,efast
      real*8 ekin(3,3)
      real*8 stress(3,3)
      real*8 virfast(3,3)
      real*8, allocatable :: xold(:)
      real*8, allocatable :: yold(:)
      real*8, allocatable :: zold(:)
      real*8, allocatable :: derivs(:,:)
c
c
c     set some time values for the dynamics integration
c
      drespa = dble(nrespa)
      dta = dt / drespa
      dt_2 = 0.5d0 * dt
      dta_2 = 0.5d0 * dta
c
c     find half-step velocities via velocity Verlet recursion
c
      do i = 1, nuse
         m = iuse(i)
         do j = 1, 3
            v(j,m) = v(j,m) + a(j,m)*dt_2
         end do
      end do
c
c     initialize virial from fast-evolving potential energy terms
c
      do i = 1, 3
         do j = 1, 3
            virfast(j,i) = 0.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (xold(n))
      allocate (yold(n))
      allocate (zold(n))
      allocate (derivs(3,n))
c
c     get fast-evolving velocities and positions via Verlet recursion
c
      do k = 1, nrespa
         do i = 1, nuse
            m = iuse(i)
            do j = 1, 3
               v(j,m) = v(j,m) + aalt(j,m)*dta_2
            end do
            xold(m) = x(m)
            yold(m) = y(m)
            zold(m) = z(m)
            x(m) = x(m) + v(1,m)*dta
            y(m) = y(m) + v(2,m)*dta
            z(m) = z(m) + v(3,m)*dta
         end do
         if (use_freeze)  call rattle (dta,xold,yold,zold)
c
c     find the fast-evolving potential energy and atomic forces
c
         call gradfast (efast,derivs)
c
c     use Newton's second law to get fast-evolving accelerations;
c     update fast-evolving velocities using Verlet recursion
c
         do i = 1, nuse
            m = iuse(i)
            do j = 1, 3
               aalt(j,m) = -ekcal * derivs(j,m) / mass(m)
               v(j,m) = v(j,m) + aalt(j,m)*dta_2
            end do
         end do
         if (use_freeze)  call rattle2 (dta)
c
c     find average virial from fast-evolving potential terms
c
         do i = 1, 3
            do j = 1, 3
               virfast(j,i) = virfast(j,i) + vir(j,i)/drespa
            end do
         end do
      end do
c
c     apply Verlet half-step updates for any auxiliary dipoles
c
      if (use_ielscf) then
         do i = 1, nuse
            m = iuse(i)
            do j = 1, 3
               vaux(j,m) = vaux(j,m) + aaux(j,m)*dt_2
               vpaux(j,m) = vpaux(j,m) + apaux(j,m)*dt_2
               uaux(j,m) = uaux(j,m) + vaux(j,m)*dt
               upaux(j,m) = upaux(j,m) + vpaux(j,m)*dt
            end do
         end do
      end if
c
c     get the slow-evolving potential energy and atomic forces
c
      call gradslow (epot,derivs)
      epot = epot + efast
c
c     compute and make the half-step temperature correction
c
      call temper2 (dt,temp)
c
c     use Newton's second law to get the slow accelerations;
c     find full-step velocities using Verlet recursion
c
      do i = 1, nuse
         m = iuse(i)
         do j = 1, 3
            a(j,m) = -ekcal * derivs(j,m) / mass(m)
            v(j,m) = v(j,m) + a(j,m)*dt_2
         end do
      end do
c
c     apply Verlet full-step updates for any auxiliary dipoles
c
      if (use_ielscf) then
         term = 2.0d0 / (dt*dt)
         do i = 1, nuse
            m = iuse(i)
            do j = 1, 3
               aaux(j,m) = term * (uind(j,m)-uaux(j,m))
               apaux(j,m) = term * (uinp(j,m)-upaux(j,m))
               vaux(j,m) = vaux(j,m) + aaux(j,m)*dt_2
               vpaux(j,m) = vpaux(j,m) + apaux(j,m)*dt_2
            end do
         end do
      end if
c
c     find the constraint-corrected full-step velocities
c
      if (use_freeze) then
         do i = 1, nuse
            m = iuse(i)
            xold(m) = x(m)
            yold(m) = y(m)
            zold(m) = z(m)
         end do
         call rattle2 (dt)
      end if
c
c     increment total virial from sum of fast and slow parts
c
      do i = 1, 3
         do j = 1, 3
            vir(j,i) = vir(j,i) + virfast(j,i)
         end do
      end do
c
c     compute full-step temperature and pressure corrections
c
      call temper (dt,eksum,ekin,temp)
      call pressure (dt,ekin,pres,stress)
      call pressure2 (epot,temp)
c
c     final constraint step to enforce position convergence
c
      if (use_freeze)  call shake (xold,yold,zold)
c
c     perform deallocation of some local arrays
c
      deallocate (xold)
      deallocate (yold)
      deallocate (zold)
      deallocate (derivs)
c
c     total energy is sum of kinetic and potential energies
c
      etot = eksum + epot
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,eksum,temp,pres)
      call mdsave (istep,dt,epot,eksum)
      call mdrest (istep)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine brespa  --  Beeman r-RESPA molecular dynamics  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "brespa" performs a multiple time step (MTS) molecular dynamics
c     step using the reversible reference system propagation algorithm
c     (r-RESPA) via a Beeman recursion with the potential split into
c     fast- and slow-evolving components
c
c     literature references:
c
c     D. D. Humphreys, R. A. Friesner and B. J. Berne, "A Multiple-
c     Time-Step Molecular Dynamics Algorithm for Macromolecules",
c     Journal of Physical Chemistry, 98, 6885-6892 (1994)
c
c     X. Qian and T. Schlick, "Efficient Multiple-Time-Step Integrators
c     with Distance-Based Force Splitting for Particle-Mesh-Ewald
c     Molecular Dynamics Simulations", Journal of Chemical Physics,
c     115, 4019-4029 (2001)
c
c     D. Beeman, "Some Multistep Methods for Use in Molecular
c     Dynamics Calculations", Journal of Computational Physics,
c     20, 130-139 (1976)
c
c
      subroutine brespa (istep,dt)
      use atomid
      use atoms
      use freeze
      use ielscf
      use mdstuf
      use moldyn
      use polar
      use units
      use usage
      use virial
      implicit none
      integer i,j,k,m
      integer istep
      real*8 dt,dt_2
      real*8 dmix,dta
      real*8 dtx,dtax
      real*8 epot,etot
      real*8 eksum,term
      real*8 temp,pres
      real*8 part1,part2
      real*8 drespa,efast
      real*8 ekin(3,3)
      real*8 stress(3,3)
      real*8 virfast(3,3)
      real*8, allocatable :: xold(:)
      real*8, allocatable :: yold(:)
      real*8, allocatable :: zold(:)
      real*8, allocatable :: derivs(:,:)
c
c
c     set some time values for the dynamics integration
c
      drespa = dble(nrespa)
      dmix = dble(bmnmix)
      part1 = 0.5d0*dmix + 1.0d0
      part2 = part1 - 2.0d0
      dtx = dt / dmix
      dta = dt / drespa
      dtax = dta / dmix
      dt_2 = 0.5d0 * dt
c
c     find half-step velocities via the Beeman recursion
c
      do i = 1, nuse
         m = iuse(i)
         do j = 1, 3
            v(j,m) = v(j,m) + (part1*a(j,m)-aslow(j,m))*dtx
         end do
      end do
c
c     initialize virial from fast-evolving potential energy terms
c
      do i = 1, 3
         do j = 1, 3
            virfast(j,i) = 0.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (xold(n))
      allocate (yold(n))
      allocate (zold(n))
      allocate (derivs(3,n))
c
c     get fast-evolving velocities and positions via Beeman recursion
c
      do k = 1, nrespa
         do i = 1, nuse
            m = iuse(i)
            do j = 1, 3
               v(j,m) = v(j,m) + (part1*aalt(j,m)-afast(j,m))*dtax
            end do
            xold(m) = x(m)
            yold(m) = y(m)
            zold(m) = z(m)
            x(m) = x(m) + v(1,m)*dta
            y(m) = y(m) + v(2,m)*dta
            z(m) = z(m) + v(3,m)*dta
         end do
         if (use_freeze)  call rattle (dta,xold,yold,zold)
c
c     find the fast-evolving potential energy and atomic forces
c
         call gradfast (efast,derivs)
c
c     use Newton's second law to get fast-evolving accelerations;
c     update fast-evolving velocities using Beeman recursion
c
         do i = 1, nuse
            m = iuse(i)
            do j = 1, 3
               afast(j,m) = aalt(j,m)
               aalt(j,m) = -ekcal * derivs(j,m) / mass(m)
               v(j,m) = v(j,m) + (part2*aalt(j,m)+afast(j,m))*dtax
            end do
         end do
         if (use_freeze)  call rattle2 (dta)
c
c     find average virial from fast-evolving potential terms
c
         do i = 1, 3
            do j = 1, 3
               virfast(j,i) = virfast(j,i) + vir(j,i)/drespa
            end do
         end do
      end do
c
c     apply Verlet half-step updates for any auxiliary dipoles
c
      if (use_ielscf) then
         do i = 1, nuse
            m = iuse(i)
            do j = 1, 3
               vaux(j,m) = vaux(j,m) + aaux(j,m)*dt_2
               vpaux(j,m) = vpaux(j,m) + apaux(j,m)*dt_2
               uaux(j,m) = uaux(j,m) + vaux(j,m)*dt
               upaux(j,m) = upaux(j,m) + vpaux(j,m)*dt
            end do
         end do
      end if
c
c     get the slow-evolving potential energy and atomic forces
c
      call gradslow (epot,derivs)
      epot = epot + efast
c
c     compute and make the half-step temperature correction
c
      call temper2 (dt,temp)
c
c     use Newton's second law to get the slow accelerations;
c     find full-step velocities using Beeman recursion
c
      do i = 1, nuse
         m = iuse(i)
         do j = 1, 3
            aslow(j,m) = a(j,m)
            a(j,m) = -ekcal * derivs(j,m) / mass(m)
            v(j,m) = v(j,m) + (part2*a(j,m)+aslow(j,m))*dtx
         end do
      end do
c
c     apply Verlet full-step updates for any auxiliary dipoles
c
      if (use_ielscf) then
         term = 2.0d0 / (dt*dt)
         do i = 1, nuse
            m = iuse(i)
            do j = 1, 3
               aaux(j,m) = term * (uind(j,m)-uaux(j,m))
               apaux(j,m) = term * (uinp(j,m)-upaux(j,m))
               vaux(j,m) = vaux(j,m) + aaux(j,m)*dt_2
               vpaux(j,m) = vpaux(j,m) + apaux(j,m)*dt_2
            end do
         end do
      end if
c
c     find the constraint-corrected full-step velocities
c
      if (use_freeze) then
         do i = 1, nuse
            m = iuse(i)
            xold(m) = x(m)
            yold(m) = y(m)
            zold(m) = z(m)
         end do
         call rattle2 (dt)
      end if
c
c     increment total virial from sum of fast and slow parts
c
      do i = 1, 3
         do j = 1, 3
            vir(j,i) = vir(j,i) + virfast(j,i)
         end do
      end do
c
c     compute full-step temperature and pressure corrections
c
      call temper (dt,eksum,ekin,temp)
      call pressure (dt,ekin,pres,stress)
      call pressure2 (epot,temp)
c
c     final constraint step to enforce position convergence
c
      if (use_freeze)  call shake (xold,yold,zold)
c
c     perform deallocation of some local arrays
c
      deallocate (xold)
      deallocate (yold)
      deallocate (zold)
      deallocate (derivs)
c
c     total energy is sum of kinetic and potential energies
c
      etot = eksum + epot
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,eksum,temp,pres)
      call mdsave (istep,dt,epot,eksum)
      call mdrest (istep)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine srespa  --  BAOAB r-RESPA stochastic dynamics  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "srespa" performs a multiple time step (MTS) stochastic dynamics
c     step using the reversible reference system propagation algorithm
c     (r-RESPA) via a BAOAB recursion with the potential split into
c     fast- and slow-evolving components
c
c     literature reference:
c
c     D. D. Humphreys, R. A. Friesner and B. J. Berne, "A Multiple-
c     Time-Step Molecular Dynamics Algorithm for Macromolecules",
c     Journal of Physical Chemistry, 98, 6885-6892 (1994)
c
c     B. Leimkuhler and C. Matthews, "Efficient Molecular Dynamics
c     Using Geodesic Integration and Solvent-Solute Splitting",
c     Proceedings of the Royal Society A, 472, 20160138 (2016)
c
c
      subroutine srespa (istep,dt)
      use atomid
      use atoms
      use freeze
      use mdstuf
      use moldyn
      use units
      use usage
      use virial
      implicit none
      integer i,j,k,m
      integer istep
      integer nrattle
      real*8 dt,dt_2
      real*8 dta,dta_2
      real*8 dtar,dtar_2
      real*8 etot,epot
      real*8 eksum,eksave
      real*8 temp,tave,pres
      real*8 drespa,efast
      real*8 drattle
      real*8 ekin(3,3)
      real*8 ekave(3,3)
      real*8 stress(3,3)
      real*8 virrat(3,3)
      real*8 virfast(3,3)
      real*8, allocatable :: xold(:)
      real*8, allocatable :: yold(:)
      real*8, allocatable :: zold(:)
      real*8, allocatable :: vfric(:)
      real*8, allocatable :: vrand(:,:)
      real*8, allocatable :: derivs(:,:)
c
c
c     set some time values for the dynamics integration
c
      drespa = dble(nrespa)
      nrattle = 1
      if (use_freeze)  nrattle = 3
      drattle = dble(nrattle)
      dta = dt / drespa
      dtar = dta / drattle
      dt_2 = 0.5d0 * dt
      dta_2 = 0.5d0 * dta
      dtar_2 = 0.5d0 * dtar
c
c     perform dynamic allocation of some local arrays
c
      allocate (xold(n))
      allocate (yold(n))
      allocate (zold(n))
      allocate (vfric(n))
      allocate (vrand(3,n))
      allocate (derivs(3,n))
c
c     use outer B step to find half-step slow velocities
c
      do i = 1, nuse
         m = iuse(i)
         do j = 1, 3
            v(j,m) = v(j,m) + a(j,m)*dt_2
         end do
      end do
c
c     initialize kinetic energy and virial from fast potentials
c
      eksave = 0.0d0
      do i = 1, 3
         do j = 1, 3
            ekave(j,i) = 0.0d0
            virfast(j,i) = 0.0d0
         end do
      end do
      tave = 0.0d0
c
c     use inner B step to find half-step fast velocities
c
      do k = 1, nrespa
         do i = 1, nuse
            m = iuse(i)
            do j = 1, 3
               v(j,m) = v(j,m) + aalt(j,m)*dta_2
            end do
         end do
c
c     take an inner A step to get fast half-step positions
c
         do j = 1, nrattle
            do i = 1, nuse
               m = iuse(i)
               xold(m) = x(m)
               yold(m) = y(m)
               zold(m) = z(m)
               x(m) = x(m) + v(1,m)*dtar_2
               y(m) = y(m) + v(2,m)*dtar_2
               z(m) = z(m) + v(3,m)*dtar_2
            end do
            if (use_freeze) then
               call rattle (dtar_2,xold,yold,zold)
               call rattle2 (dtar_2)
               do i = 1, 3
                  do m = 1, 3
                     vir(m,i) = 0.0d0
                  end do
               end do
            end if
         end do
c
c     use inner O step to get frictional and random components
c
         call oprep (dta,vfric,vrand)
         do i = 1, nuse
            m = iuse(i)
            do j = 1, 3 
               v(j,m) = v(j,m)*vfric(m) + vrand(j,m)
            end do
         end do
         if (use_freeze) then
            call rattle2 (dta)
            do i = 1, 3
               do j = 1, 3
                  virrat(j,i) = vir(j,i)
                  vir(j,i) = 0.0d0
               end do
            end do
         end if
c
c     take second inner A step to get the full-step positions
c
         do j = 1, nrattle
            do i = 1, nuse
               m = iuse(i)
               xold(m) = x(m)
               yold(m) = y(m)
               zold(m) = z(m)
               x(m) = x(m) + v(1,m)*dtar_2
               y(m) = y(m) + v(2,m)*dtar_2
               z(m) = z(m) + v(3,m)*dtar_2
            end do
            if (use_freeze) then
               call rattle (dtar_2,xold,yold,zold)
               call rattle2 (dtar_2)
               do i = 1, 3
                  do m = 1, 3
                     virrat(m,i) = virrat(m,i) + vir(m,i)/drattle
                     vir(m,i) = 0.0d0
                  end do
               end do
            end if
         end do
c
c     get the fast-evolving potential energy and atomic forces
c 
         call gradfast (efast,derivs)
c
c     find average kinetic energy from fast-evolving potentials
c
         call kinetic (eksum,ekin,temp)
         eksave = eksave + eksum/drespa
         do i = 1, 3
            do j = 1, 3
               ekave(j,i) = ekave(j,i) + ekin(j,i)/drespa
            end do
         end do
         tave = tave + temp/drespa
c
c     inner B step for fast accelerations and full-step velocities
c
         do i = 1, nuse
            m = iuse(i)
            do j = 1, 3
               aalt(j,m) = -ekcal * derivs(j,m) / mass(m)
               v(j,m) = v(j,m) + aalt(j,m)*dta_2
            end do
         end do 
         if (use_freeze) then
            call rattle2 (dta)
            do i = 1, 3
               do j = 1, 3
                  vir(j,i) = vir(j,i) + virrat(j,i)
               end do
            end do
         end if
c
c     average the virial from fast-evolving potential terms
c
         do i = 1, 3
            do j = 1, 3
               virfast(j,i) = virfast(j,i) + vir(j,i)/drespa
            end do
         end do
      end do
c
c     transfer average kinetic energy and temperature values
c
      eksum = eksave
      do i = 1, 3
         do j = 1, 3
            ekin(j,i) = ekave(j,i)
         end do
      end do
      temp = tave
c
c     get the slow-evolving potential energy and atomic forces
c 
      call gradslow (epot,derivs)
      epot = epot + efast
c
c     outer B step for slow accelerations and full-step velocities
c
      do i = 1, nuse
         m = iuse(i)
         do j = 1, 3
            a(j,m) = -ekcal * derivs(j,m) / mass(m)
            v(j,m) = v(j,m) + a(j,m)*dt_2
         end do
      end do 
      if (use_freeze) then
         call rattle2 (dt)
         do i = 1, nuse
            m = iuse(i)
            xold(m) = x(m)
            yold(m) = y(m)
            zold(m) = z(m)
         end do
      end if
c
c     increment total virial from sum of fast and slow parts
c
      do i = 1, 3
         do j = 1, 3
            vir(j,i) = vir(j,i) + virfast(j,i)
         end do
      end do
c
c     compute full-step kinetic energy and pressure correction;
c     prior kinetic energy gives better pressure control
c
c     call kinetic (eksum,ekin,temp)
      call pressure (dt,ekin,pres,stress)
      call pressure2 (epot,temp)
c
c     final constraint step to enforce position convergence
c
      if (use_freeze)  call shake (xold,yold,zold)
c
c     perform deallocation of some local arrays
c
      deallocate (xold)
      deallocate (yold)
      deallocate (zold)
      deallocate (vfric)
      deallocate (vrand)
      deallocate (derivs)
c
c     total energy is sum of kinetic and potential energies
c
      etot = eksum + epot
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,eksum,temp,pres)
      call mdsave (istep,dt,epot,eksum)
      call mdrest (istep)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine gradfast  --  fast energy & gradient components  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "gradfast" calculates the potential energy and first derivatives
c     for the fast-evolving local valence potential energy terms
c
c
      subroutine gradfast (energy,derivs)
      use limits
      use potent
      implicit none
      real*8 energy
      real*8 derivs(3,*)
      logical save_vdw,save_repel
      logical save_disp,save_charge
      logical save_chgdpl,save_dipole
      logical save_mpole,save_polar
      logical save_chgtrn,save_rxnfld
      logical save_solv,save_list
c
c
c     save the original state of slow-evolving potentials
c
      save_vdw = use_vdw
      save_repel = use_repel
      save_disp = use_disp
      save_charge = use_charge
      save_chgdpl = use_chgdpl
      save_dipole = use_dipole
      save_mpole = use_mpole
      save_polar = use_polar
      save_chgtrn = use_chgtrn
      save_rxnfld = use_rxnfld
      save_solv = use_solv
      save_list = use_list
c
c     turn off slow-evolving nonbonded potential energy terms
c
      use_vdw = .false.
      use_repel = .false.
      use_disp = .false.
      use_charge = .false.
      use_chgdpl = .false.
      use_dipole = .false.
      use_mpole = .false.
      use_polar = .false.
      use_chgtrn = .false.
      use_rxnfld = .false.
      use_solv = .false.
      use_list = .false.
c
c     get energy and gradient for fast-evolving potential terms
c
      call gradient (energy,derivs)
c
c     restore the original state of slow-evolving potentials
c
      use_vdw = save_vdw
      use_repel = save_repel
      use_disp = save_disp
      use_charge = save_charge
      use_chgdpl = save_chgdpl
      use_dipole = save_dipole
      use_mpole = save_mpole
      use_polar = save_polar
      use_chgtrn = save_chgtrn
      use_rxnfld = save_rxnfld
      use_solv = save_solv
      use_list = save_list
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine gradslow  --  slow energy & gradient components  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "gradslow" calculates the potential energy and first derivatives
c     for the slow-evolving nonbonded potential energy terms
c
c
      subroutine gradslow (energy,derivs)
      use potent
      implicit none
      real*8 energy
      real*8 derivs(3,*)
      logical save_bond,save_angle
      logical save_strbnd,save_urey
      logical save_angang,save_opbend
      logical save_opdist,save_improp
      logical save_imptor,save_tors
      logical save_pitors,save_strtor
      logical save_angtor,save_tortor
      logical save_geom,save_metal
      logical save_extra
c
c
c     save the original state of fast-evolving potentials
c
      save_bond = use_bond
      save_angle = use_angle
      save_strbnd = use_strbnd
      save_urey = use_urey
      save_angang = use_angang
      save_opbend = use_opbend
      save_opdist = use_opdist
      save_improp = use_improp
      save_imptor = use_imptor
      save_tors = use_tors
      save_pitors = use_pitors
      save_strtor = use_strtor
      save_angtor = use_angtor
      save_tortor = use_tortor
      save_geom = use_geom
      save_metal = use_metal
      save_extra = use_extra
c
c     turn off fast-evolving valence potential energy terms
c
      use_bond = .false.
      use_angle = .false.
      use_strbnd = .false.
      use_urey = .false.
      use_angang = .false.
      use_opbend = .false.
      use_opdist = .false.
      use_improp = .false.
      use_imptor = .false.
      use_tors = .false.
      use_pitors = .false.
      use_strtor = .false.
      use_angtor = .false.
      use_tortor = .false.
      use_geom = .false.
      use_metal = .false.
      use_extra = .false.
c
c     get energy and gradient for slow-evolving potential terms
c
      call gradient (energy,derivs)
c
c     restore the original state of fast-evolving potentials
c
      use_bond = save_bond
      use_angle = save_angle
      use_strbnd = save_strbnd
      use_urey = save_urey
      use_angang = save_angang
      use_opbend = save_opbend
      use_opdist = save_opdist
      use_improp = save_improp
      use_imptor = save_imptor
      use_tors = save_tors
      use_pitors = save_pitors
      use_strtor = save_strtor
      use_angtor = save_angtor
      use_tortor = save_tortor
      use_geom = save_geom
      use_metal = save_metal
      use_extra = save_extra
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module restrn  --  parameters for geometrical restraints  ##
c     ##                                                            ##
c     ################################################################
c
c
c     maxfix     maximum number of geometric restraint entries
c
c     npfix      number of position restraints to be applied
c     ndfix      number of distance restraints to be applied
c     nafix      number of angle restraints to be applied
c     ntfix      number of torsional restraints to be applied
c     ngfix      number of group distance restraints to be applied
c     nchir      number of chirality restraints to be applied
c     ipfix      atom number involved in each position restraint
c     kpfix      flags to use x-, y-, z-coordinate position restraints
c     idfix      atom numbers defining each distance restraint
c     iafix      atom numbers defining each angle restraint
c     itfix      atom numbers defining each torsional restraint
c     igfix      group numbers defining each group distance restraint
c     ichir      atom numbers defining each chirality restraint
c     depth      depth of shallow Gaussian basin restraint
c     width      exponential width coefficient of Gaussian basin
c     rflat      flat bottom radius for Gaussian basin restraint
c     rwall      radius of spherical droplet boundary restraint
c     xpfix      x-coordinate target for each restrained position
c     ypfix      y-coordinate target for each restrained position
c     zpfix      z-coordinate target for each restrained position
c     pfix       force constant and flat-well range for each position
c     dfix       force constant and target range for each distance
c     afix       force constant and target range for each angle
c     tfix       force constant and target range for each torsion
c     gfix       force constant and target range for each group distance
c     chir       force constant and target range for chiral centers
c     use_basin  logical flag governing use of Gaussian basin
c     use_wall   logical flag governing use of droplet boundary
c
c
      module restrn
      implicit none
      integer maxfix
      integer npfix,ndfix
      integer nafix,ntfix
      integer ngfix,nchir
      integer, allocatable :: ipfix(:)
      integer, allocatable :: kpfix(:,:)
      integer, allocatable :: idfix(:,:)
      integer, allocatable :: iafix(:,:)
      integer, allocatable :: itfix(:,:)
      integer, allocatable :: igfix(:,:)
      integer, allocatable :: ichir(:,:)
      real*8 depth,width
      real*8 rflat,rwall
      real*8, allocatable :: xpfix(:)
      real*8, allocatable :: ypfix(:)
      real*8, allocatable :: zpfix(:)
      real*8, allocatable :: pfix(:,:)
      real*8, allocatable :: dfix(:,:)
      real*8, allocatable :: afix(:,:)
      real*8, allocatable :: tfix(:,:)
      real*8, allocatable :: gfix(:,:)
      real*8, allocatable :: chir(:,:)
      logical use_basin,use_wall
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2001  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module rgddyn  --  rigid body MD velocities and momenta  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     xcmo    x-component from each atom to center of rigid body
c     ycmo    y-component from each atom to center of rigid body
c     zcmo    z-component from each atom to center of rigid body
c     vcm     current translational velocity of each rigid body
c     wcm     current angular velocity of each rigid body
c     lm      current angular momentum of each rigid body
c     vc      half-step translational velocity for kinetic energy
c     wc      half-step angular velocity for kinetic energy
c     linear  logical flag to mark group as linear or nonlinear
c
c
      module rgddyn
      implicit none
      real*8, allocatable :: xcmo(:)
      real*8, allocatable :: ycmo(:)
      real*8, allocatable :: zcmo(:)
      real*8, allocatable :: vcm(:,:)
      real*8, allocatable :: wcm(:,:)
      real*8, allocatable :: lm(:,:)
      real*8, allocatable :: vc(:,:)
      real*8, allocatable :: wc(:,:)
      logical, allocatable :: linear(:)
      save
      end
c
c
c     ###########################################################
c     ##                 COPYRIGHT (C) 2001 by                 ##
c     ##  Andrey Kutepov, Marina A. Vorobieva & Jay W. Ponder  ##
c     ##                  All Rights Reserved                  ##
c     ###########################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine rgdstep  --  rigid body molecular dynamics step  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "rgdstep" performs a molecular dynamics time step via a rigid
c     body integration algorithm
c
c     literature reference:
c
c     W. Smith, "Hail Euler and Farewell: Rotational Motion in the
c     Laboratory Frame", CCP5 Newsletter, February 2005
c
c     based on an original algorithm developed by Andrey Kutapov
c     and Marina A. Vorobieva, VNIITF, Russian Federal Nuclear
c     Center, Chelyabinsk, Russia, February 2001
c
c
      subroutine rgdstep (istep,dt)
      use atomid
      use atoms
      use bound
      use group
      use iounit
      use rgddyn
      use units
      use virial
      implicit none
      integer i,j,k
      integer istep,size
      integer start,stop
      integer iter,maxiter
      real*8 dt,epot,etot
      real*8 eksum,weigh
      real*8 eps,delta
      real*8 temp,pres
      real*8 xr,yr,zr
      real*8 x2,y2,z2
      real*8 fx,fy,fz
      real*8 fc(3),tc(3)
      real*8 inert(6)
      real*8 rc(3),rcold(3)
      real*8 dfi(3),dfiold(3)
      real*8 vcp(3),wcp(3)
      real*8 ekin(3,3)
      real*8 stress(3,3)
      real*8 arot(3,3)
      real*8, allocatable :: xp(:)
      real*8, allocatable :: yp(:)
      real*8, allocatable :: zp(:)
      real*8, allocatable :: derivs(:,:)
c
c
c     set iteration limit and tolerance for angular momenta
c
      maxiter = 15
      eps = 1.0d-12
c
c     perform dynamic allocation of some local arrays
c
      allocate (xp(n))
      allocate (yp(n))
      allocate (zp(n))
      allocate (derivs(3,n))
c
c     get the energy and atomic forces prior to the step
c
      call gradient (epot,derivs)
c
c     perform the integration step for each rigid body
c
      do i = 1, ngrp
         start = igrp(1,i)
         stop = igrp(2,i)
         size = stop - start + 1
         do j = 1, 3
            rc(j) = 0.0d0
         end do
         do j = start, stop
            k = kgrp(j)
            weigh = mass(k)
            rc(1) = rc(1) + x(k)*weigh
            rc(2) = rc(2) + y(k)*weigh
            rc(3) = rc(3) + z(k)*weigh
         end do
         do j = 1, 3
            rc(j) = rc(j) / grpmass(i)
         end do
c
c     find center of mass offsets only for first step
c
         if (istep .eq. 1) then
            do j = start, stop
               k = kgrp(j)
               xcmo(k) = x(k) - rc(1)
               ycmo(k) = y(k) - rc(2)
               zcmo(k) = z(k) - rc(3)
            end do
         end if
c
c     compute the force and torque components for rigid body
c
         do j = 1, 3
            fc(j) = 0.0d0
            tc(j) = 0.0d0
         end do
         do j = start, stop
            k = kgrp(j)
            xr = x(k) - rc(1)
            yr = y(k) - rc(2)
            zr = z(k) - rc(3)
            fx = -ekcal * derivs(1,k)
            fy = -ekcal * derivs(2,k)
            fz = -ekcal * derivs(3,k)
            fc(1) = fc(1) + fx
            fc(2) = fc(2) + fy
            fc(3) = fc(3) + fz
            tc(1) = tc(1) + yr*fz - zr*fy
            tc(2) = tc(2) + zr*fx - xr*fz
            tc(3) = tc(3) + xr*fy - yr*fx
         end do
c
c     update the translational velocity of the center of mass
c
         do j = 1, 3
            vcp(j) = vcm(j,i) + dt*fc(j)/grpmass(i)
            vc(j,i) = 0.5d0 * (vcm(j,i)+vcp(j))
            vcm(j,i) = vcp(j)
         end do
c
c     update the coordinates of the group center of mass
c
         do j = 1, 3
            rcold(j) = rc(j)
            rc(j) = rc(j) + dt*vcp(j)
         end do
c
c     single atom groups are treated as a separate case
c
         if (size .eq. 1) then
            k = kgrp(igrp(1,i))
            x(k) = rc(1)
            y(k) = rc(2)
            z(k) = rc(3)
            do j = 1, 3
               wcm(j,i) = 0.0d0
               lm(j,i) = 0.0d0
            end do
c
c     get impulse moment in fixed space coordinate system
c
         else
            do j = 1, 3
               lm(j,i) = lm(j,i) + dt*tc(j)
               dfi(j) = dt * wcm(j,i)
               dfiold(j) = dfi(j)
            end do
c
c     use iterative scheme to converge the angular momenta
c
            iter = 0
            delta = 1.0d0
            do while (delta.gt.eps .and. iter.lt.maxiter)
               iter = iter + 1
               call rotrgd (dfi,arot)
c
c     calculate the inertia tensor from rotated coordinates
c
               do j = 1, 6
                  inert(j) = 0.0d0
               end do
               do j = start, stop
                  k = kgrp(j)
                  xr = arot(1,1)*xcmo(k) + arot(1,2)*ycmo(k)
     &                    + arot(1,3)*zcmo(k)
                  yr = arot(2,1)*xcmo(k) + arot(2,2)*ycmo(k)
     &                    + arot(2,3)*zcmo(k)
                  zr = arot(3,1)*xcmo(k) + arot(3,2)*ycmo(k)
     &                    + arot(3,3)*zcmo(k)
                  x2 = xr * xr
                  y2 = yr * yr
                  z2 = zr * zr
                  weigh = mass(k)
                  inert(1) = inert(1) + weigh*(y2+z2)
                  inert(2) = inert(2) - weigh*xr*yr
                  inert(3) = inert(3) - weigh*xr*zr
                  inert(4) = inert(4) + weigh*(x2+z2)
                  inert(5) = inert(5) - weigh*yr*zr
                  inert(6) = inert(6) + weigh*(x2+y2)
                  xp(k) = xr
                  yp(k) = yr
                  zp(k) = zr
               end do
c
c     compute the angular velocity from the relation L=Iw
c
               do j = 1, 3
                  wcp(j) = lm(j,i)
               end do
               if (linear(i)) then
                  call linbody (i,inert,wcp)
               else
                  call cholesky (3,inert,wcp)
               end if
               delta = 0.d0
               do j = 1, 3
                  dfi(j) = 0.5d0 * dt * (wcm(j,i)+wcp(j))
                  delta = delta + abs(dfi(j)-dfiold(j))
                  dfiold(j) = dfi(j)
               end do
            end do
c
c     check to make sure the angular momenta converged
c
            if (delta .gt. eps) then
               write (iout,10)
   10          format (/,' RGDSTEP  --  Angular Momentum Convergence',
     &                    ' Failure')
               call prterr
               call fatal
            end if
c
c     set the final angular velocity and atomic coordinates
c
            do j = 1, 3
               dfi(j) = dt * wcp(j)
            end do
            call rotrgd (dfi,arot)
            do j = start, stop
               k = kgrp(j)
               xr = x(k) - rcold(1)
               yr = y(k) - rcold(2)
               zr = z(k) - rcold(3)
               x(k) = arot(1,1)*xr + arot(1,2)*yr + arot(1,3)*zr + rc(1)
               y(k) = arot(2,1)*xr + arot(2,2)*yr + arot(2,3)*zr + rc(2)
               z(k) = arot(3,1)*xr + arot(3,2)*yr + arot(3,3)*zr + rc(3)
            end do
            do j = 1, 3
               wc(j,i) = 0.5d0 * (wcm(j,i)+wcp(j))
               wcm(j,i) = wcp(j)
            end do
         end if
      end do
c
c     update the distance to center of mass for each atom
c
      do i = 1, n
         xcmo(i) = xp(i)
         ycmo(i) = yp(i)
         zcmo(i) = zp(i)
      end do
c
c     make center of mass correction to virial for rigid body
c
      do i = 1, n
         vir(1,1) = vir(1,1) - xcmo(i)*derivs(1,i)
         vir(2,1) = vir(2,1) - ycmo(i)*derivs(1,i)
         vir(3,1) = vir(3,1) - zcmo(i)*derivs(1,i)
         vir(1,2) = vir(1,2) - xcmo(i)*derivs(2,i)
         vir(2,2) = vir(2,2) - ycmo(i)*derivs(2,i)
         vir(3,2) = vir(3,2) - zcmo(i)*derivs(2,i)
         vir(1,3) = vir(1,3) - xcmo(i)*derivs(3,i)
         vir(2,3) = vir(2,3) - ycmo(i)*derivs(3,i)
         vir(3,3) = vir(3,3) - zcmo(i)*derivs(3,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xp)
      deallocate (yp)
      deallocate (zp)
      deallocate (derivs)
c
c     make any temperature and pressure corrections
c
      call temper (dt,eksum,ekin,temp)
      call pressure (dt,ekin,pres,stress)
      call temper2 (dt,temp)
      call pressure2 (epot,temp)
c
c     total energy is sum of kinetic and potential energies
c
      etot = eksum + epot
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,eksum,temp,pres)
      call mdsave (istep,dt,epot,eksum)
      call mdrest (istep)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine rotrgd  --  rigid dynamics rotation matrix  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "rotrgd" finds the rotation matrix for a rigid body due
c     to a single step of dynamics
c
c
      subroutine rotrgd (dfi,arot)
      implicit none
      real*8 x,xc,xs
      real*8 y,yc,ys
      real*8 z,zc,zs
      real*8 cosine,sine
      real*8 anorm,coterm
      real*8 dfi(3)
      real*8 arot(3,3)
c
c
c     construct rotation matrix from angular distance
c
      anorm = sqrt(dfi(1)**2 + dfi(2)**2 + dfi(3)**2)
      cosine = cos(anorm)
      sine = sin(anorm)
      coterm = 1.0d0 - cosine
      if (anorm .le. 0.0d0)  anorm = 1.0d0
      x = dfi(1) / anorm
      y = dfi(2) / anorm
      z = dfi(3) / anorm
      xc = x * coterm
      yc = y * coterm
      zc = z * coterm
      xs = x * sine
      ys = y * sine
      zs = z * sine
      arot(1,1) = xc*x + cosine
      arot(2,1) = xc*y + zs
      arot(3,1) = xc*z - ys
      arot(1,2) = yc*x - zs
      arot(2,2) = yc*y + cosine
      arot(3,2) = yc*z + xs
      arot(1,3) = zc*x + ys
      arot(2,3) = zc*y - xs
      arot(3,3) = zc*z + cosine
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine linbody  --  angular velocity of linear body  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "linbody" finds the angular velocity of a linear rigid body
c     given the inertia tensor and angular momentum
c
c
      subroutine linbody (i,inert,wcp)
      use atoms
      use group
      implicit none
      integer i,j,k
      real*8 rinv,rmin
      real*8 a11,a12,a22
      real*8 b1,b2,w1,w2
      real*8 wcp(3),rmol(3)
      real*8 r1(3),r2(3),r3(3)
      real*8 inert(6)
c
c
c     construct a normalized vector along the molecular axis
c
      j = kgrp(igrp(1,i))
      k = kgrp(igrp(2,i))
      rmol(1) = x(k) - x(j)
      rmol(2) = y(k) - y(j)
      rmol(3) = z(k) - z(j)
      rinv = 1.0d0 / sqrt(rmol(1)**2+rmol(2)**2+rmol(3)**2)
      do j = 1, 3
         rmol(j) = rmol(j) * rinv
      end do
c
c     find two orthogonal vectors to complete coordinate frame
c
      k = 1
      rmin = abs(rmol(1))
      do j = 2, 3
         if (abs(rmol(j)) .lt. rmin) then
            k = j
            rmin = abs(rmol(j))
         end if
      end do
      do j = 1, 3
         r1(j) = -rmol(k) * rmol(j)
      end do
      r1(k) = 1.0d0 + r1(k)
      rinv = 1.0d0 / sqrt(r1(1)**2+r1(2)**2+r1(3)**2)
      do j = 1, 3
         r1(j) = r1(j) * rinv
      end do
      r2(1) = r1(2)*rmol(3) - r1(3)*rmol(2)
      r2(2) = r1(3)*rmol(1) - r1(1)*rmol(3)
      r2(3) = r1(1)*rmol(2) - r1(2)*rmol(1)
c
c     solve the 2-by-2 linear system for angular velocity
c
      r3(1) = inert(1)*r1(1) + inert(2)*r1(2) + inert(3)*r1(3)
      r3(2) = inert(2)*r1(1) + inert(4)*r1(2) + inert(5)*r1(3)
      r3(3) = inert(3)*r1(1) + inert(5)*r1(2) + inert(6)*r1(3)
      a11 = r1(1)*r3(1) + r1(2)*r3(2) + r1(3)*r3(3)
      r3(1) = inert(1)*r2(1) + inert(2)*r2(2) + inert(3)*r2(3)
      r3(2) = inert(2)*r2(1) + inert(4)*r2(2) + inert(5)*r2(3)
      r3(3) = inert(3)*r2(1) + inert(5)*r2(2) + inert(6)*r2(3)
      a12 = r1(1)*r3(1) + r1(2)*r3(2) + r1(3)*r3(3)
      a22 = r2(1)*r3(1) + r2(2)*r3(2) + r2(3)*r3(3)
      b1 = r1(1)*wcp(1) + r1(2)*wcp(2) + r1(3)*wcp(3)
      b2 = r2(1)*wcp(1) + r2(2)*wcp(2) + r2(3)*wcp(3)
      w1 = (a12*b2-a22*b1) / (a12*a12-a11*a22)
      w2 = (b2-a12*w1) / a22
      do j = 1, 3
         wcp(j) = w1*r1(j) + w2*r2(j)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine richmond  --  find the accessible surface area  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "richmond" performs an analytical computation of the weighted
c     solvent accessible surface area of each atom and the first
c     derivatives of the area with respect to Cartesian coordinates
c     using the method of Tim Richmond
c
c     literature references:
c
c     T. J. Richmond, "Solvent Accessible Surface Area and
c     Excluded Volume in Proteins", Journal of Molecular Biology,
c     178, 63-89 (1984)
c
c     L. Wesson and D. Eisenberg, "Atomic Solvation Parameters
c     Applied to Molecular Dynamics of Proteins in Solution",
c     Protein Science, 1, 227-235 (1992)
c
c     variables and parameters:
c
c     n        total number of atoms in the current system
c     x        current x-coordinate for each atom in the system
c     y        current y-coordinate for each atom in the system
c     z        current z-coordinate for each atom in the system
c     rad      radius value in Angstroms for each sphere
c     weight   weight value for each sphere in the system
c     probe    radius value in Angstroms of the probe sphere
c     total    total surface area of the whole structure
c     area     accessible surface area of each atom
c
c     delta    tolerance used in the tests for sphere overlaps
c                and for colinearity
c     reps     connectivity errors can usually be avoided if the
c                offending atom is shifted by this small amount
c
c
      subroutine richmond (n,x,y,z,rad,weight,probe,total,area)
      use inform
      use iounit
      use math
      use usage
      implicit none
      integer maxarc
      parameter (maxarc=1000)
      integer i,j,k,l,m,n
      integer ii,ib,jb
      integer io,ir
      integer mi,ni,narc
      integer key(maxarc)
      integer intag(maxarc)
      integer intag1(maxarc)
      integer lt(maxarc)
      integer kent(maxarc)
      integer kout(maxarc)
      real*8 total,wght
      real*8 delta,delta2
      real*8 eps,reps,dsql
      real*8 probe,arcsum
      real*8 cosine
      real*8 axx,axy,axz
      real*8 ayx,ayy,azx
      real*8 azy,azz
      real*8 uxl,uyl,uzl
      real*8 tx,ty,tz
      real*8 txb,tyb,td
      real*8 tr2,tr,txr,tyr
      real*8 tk1,tk2
      real*8 thec,the
      real*8 t,tb,txk,tyk,tzk
      real*8 t1,ti,tf,tt
      real*8 txl,tyl,tzl
      real*8 arclen,exang
      real*8 xr,yr,zr
      real*8 rr,rrx2,rrsq
      real*8 rplus,rminus
      real*8 ccsq,cc,xysq
      real*8 bk,gi,bsqk
      real*8 pix2,pix4,pid2
      real*8 therk,dk,gk
      real*8 risqk,rik
      real*8 rvec(3)
      real*8 x(*)
      real*8 y(*)
      real*8 z(*)
      real*8 rad(*)
      real*8 weight(*)
      real*8 area(*)
      real*8 ri(maxarc),risq(maxarc)
      real*8 bsq(maxarc),bsq1(maxarc)
      real*8 dsq(maxarc),dsq1(maxarc)
      real*8 arci(maxarc),arcf(maxarc)
      real*8 ex(maxarc),gr(maxarc)
      real*8 b(maxarc),b1(maxarc)
      real*8 bg(maxarc),ther(maxarc)
      real*8 xc(maxarc),xc1(maxarc)
      real*8 yc(maxarc),yc1(maxarc)
      real*8 zc(maxarc),zc1(maxarc)
      real*8 ux(maxarc),uy(maxarc)
      real*8 uz(maxarc)
      real*8, allocatable :: r(:)
      logical moved,top,komit
      logical omit(maxarc)
      logical, allocatable :: skip(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (r(n))
      allocate (skip(n))
c
c     zero the area and derivatives, and set the sphere radii
c
      total = 0.0d0
      do i = 1, n
         area(i) = 0.0d0
         r(i) = rad(i)
         if (r(i) .ne. 0.0d0)  r(i) = r(i) + probe
      end do
c
c     set pi multiples, overlap criterion and tolerances
c
      pix2 = 2.0d0 * pi
      pix4 = 4.0d0 * pi
      pid2 = 0.5d0 * pi
      delta = 1.0d-8
      delta2 = delta * delta
      eps = 1.0d-8
      reps = 1.0d-6
c
c     exclude atoms that do not overlap any active atom
c
      do i = 1, n
         skip(i) = .true.
      end do
      do i = 1, n
         if (use(i)) then
            xr = x(i)
            yr = y(i)
            zr = z(i)
            rr = r(i)
            do k = 1, n
               rplus = (rr + r(k))**2
               ccsq = (x(k)-xr)**2 + (y(k)-yr)**2 + (z(k)-zr)**2
               if (ccsq .le. rplus)  skip(k) = .false.
            end do
         end if
      end do
c
c     compute the accessible surface area of current "ir" sphere
c
      do ir = 1, n
         if (skip(ir))  goto 180
         xr = x(ir)
         yr = y(ir)
         zr = z(ir)
         rr = r(ir)
         rrx2 = 2.0d0 * rr
         rrsq = rr * rr
         wght = weight(ir)
         moved = .false.
c
c     initialize some counters and sums for the "ir" sphere
c
   10    continue
         io = 0
         jb = 0
         ib = 0
         arclen = 0.0d0
         exang = 0.0d0
c
c     test each sphere to see if it overlaps the "ir" sphere
c
         do i = 1, n
            if (i .eq. ir)  goto 30
            rplus = rr + r(i)
            tx = x(i) - xr
            if (abs(tx) .ge. rplus)  goto 30
            ty = y(i) - yr
            if (abs(ty) .ge. rplus)  goto 30
            tz = z(i) - zr
            if (abs(tz) .ge. rplus)  goto 30
c
c     check for sphere overlap by testing interatomic
c     distance against sum and difference of radii
c
            xysq = tx**2 + ty**2
            if (xysq .lt. delta2) then
               tx = delta
               ty = 0.0d0
               xysq = delta2
            end if
            ccsq = xysq + tz**2
            cc = sqrt(ccsq)
            if (rplus-cc .le. delta)  goto 30
            rminus = rr - r(i)
c
c     check for a completely buried "ir" sphere
c
            if (cc-abs(rminus) .le. delta) then
               if (rminus .le. 0.0d0)  goto 180
               goto 30
            end if
c
c     calculate overlap parameters between "i" and "ir" sphere
c
            io = io + 1
            xc1(io) = tx
            yc1(io) = ty
            zc1(io) = tz
            dsq1(io) = xysq
            bsq1(io) = ccsq
            b1(io) = cc
            gr(io) = (ccsq+rplus*rminus) / (rrx2*b1(io))
            intag1(io) = i
            if (io .gt. maxarc) then
               write (iout,20)
   20          format (/,' RICHMOND  --  Increase the Value of MAXARC')
               call fatal
            end if
   30       continue
         end do
c
c     case where no other spheres overlap the current sphere
c
         if (io .eq. 0) then
            area(ir) = pix4
            goto 160
         end if
c
c     case where only one sphere overlaps the current sphere
c
         if (io .eq. 1) then
            k = 1
            txk = xc1(1)
            tyk = yc1(1)
            tzk = zc1(1)
            bsqk = bsq1(1)
            bk = b1(1)
            intag(1) = intag1(1)
            arcsum = pix2
            ib = ib + 1
            arclen = arclen + gr(k)*arcsum
            goto 150
         end if
c
c     general case where more than one sphere intersects the
c     current sphere; sort intersecting spheres by their degree
c     of overlap with the current main sphere
c
         call sort2 (io,gr,key)
         do i = 1, io
            k = key(i)
            intag(i) = intag1(k)
            xc(i) = xc1(k)
            yc(i) = yc1(k)
            zc(i) = zc1(k)
            dsq(i) = dsq1(k)
            b(i) = b1(k)
            bsq(i) = bsq1(k)
            omit(i) = .false.
         end do
c
c     radius of the each circle on the surface of the "ir" sphere
c
         do i = 1, io
            gi = gr(i) * rr
            bg(i) = b(i) * gi
            risq(i) = rrsq - gi**2
            ri(i) = sqrt(risq(i))
            ther(i) = pid2 - asin(min(1.0d0,max(-1.0d0,gr(i))))
         end do
c
c     find boundary of inaccessible area on "ir" sphere
c
         do k = 1, io-1
            if (.not. omit(k)) then
               txk = xc(k)
               tyk = yc(k)
               tzk = zc(k)
               bk = b(k)
               therk = ther(k)
               do j = k+1, io
                  if (omit(j))  goto 60
c
c     check to see if J circle is intersecting K circle;
c     get distance between circle centers and sum of radii
c
                  cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j))
                  cc = acos(min(1.0d0,max(-1.0d0,cc)))
                  td = therk + ther(j)
c
c     check to see if circles enclose separate regions
c
                  if (cc .ge. td)  goto 60
c
c     check for circle J completely inside circle K
c
                  if (cc+ther(j) .lt. therk)  goto 40
c
c     check for circles essentially parallel
c
                  if (cc .gt. delta)  goto 50
   40             continue
                  omit(j) = .true.
                  goto 60
c
c     check for "ir" sphere completely buried
c
   50             continue
                  if (pix2-cc .le. td)  goto 180
   60             continue
               end do
            end if
         end do
c
c     find T value of circle intersections
c
         do k = 1, io
            if (omit(k))  goto 110
            komit = omit(k)
            omit(k) = .true.
            narc = 0
            top = .false.
            txk = xc(k)
            tyk = yc(k)
            tzk = zc(k)
            dk = sqrt(dsq(k))
            bsqk = bsq(k)
            bk = b(k)
            gk = gr(k) * rr
            risqk = risq(k)
            rik = ri(k)
            therk = ther(k)
c
c     rotation matrix elements
c
            t1 = tzk / (bk*dk)
            axx = txk * t1
            axy = tyk * t1
            axz = dk / bk
            ayx = tyk / dk
            ayy = txk / dk
            azx = txk / bk
            azy = tyk / bk
            azz = tzk / bk
            do l = 1, io
               if (.not. omit(l)) then
                  txl = xc(l)
                  tyl = yc(l)
                  tzl = zc(l)
c
c     rotate spheres so K vector colinear with z-axis
c
                  uxl = txl*axx + tyl*axy - tzl*axz
                  uyl = tyl*ayy - txl*ayx
                  uzl = txl*azx + tyl*azy + tzl*azz
                  cosine = min(1.0d0,max(-1.0d0,uzl/b(l)))
                  if (acos(cosine) .lt. therk+ther(l)) then
                     dsql = uxl**2 + uyl**2
                     tb = uzl*gk - bg(l)
                     txb = uxl * tb
                     tyb = uyl * tb
                     td = rik * dsql
                     tr2 = risqk*dsql - tb**2
                     tr2 = max(eps,tr2)
                     tr = sqrt(tr2)
                     txr = uxl * tr
                     tyr = uyl * tr
c
c     get T values of intersection for K circle
c
                     tb = (txb+tyr) / td
                     tb = min(1.0d0,max(-1.0d0,tb))
                     tk1 = acos(tb)
                     if (tyb-txr .lt. 0.0d0)  tk1 = pix2 - tk1
                     tb = (txb-tyr) / td
                     tb = min(1.0d0,max(-1.0d0,tb))
                     tk2 = acos(tb)
                     if (tyb+txr .lt. 0.0d0)  tk2 = pix2 - tk2
                     thec = (rrsq*uzl-gk*bg(l)) / (rik*ri(l)*b(l))
                     if (abs(thec) .lt. 1.0d0) then
                        the = -acos(thec)
                     else if (thec .ge. 1.0d0) then
                        the = 0.0d0
                     else if (thec .le. -1.0d0) then
                        the = -pi
                     end if
c
c     see if "tk1" is entry or exit point; check t=0 point;
c     "ti" is exit point, "tf" is entry point
c
                     cosine = min(1.0d0,max(-1.0d0,
     &                               (uzl*gk-uxl*rik)/(b(l)*rr)))
                     if ((acos(cosine)-ther(l))*(tk2-tk1)
     &                          .le. 0.0d0) then
                        ti = tk2
                        tf = tk1
                     else
                        ti = tk1
                        tf = tk2
                     end if
                     narc = narc + 1
                     if (narc .ge. maxarc) then
                        write (iout,70)
   70                   format (/,' RICHMOND  --  Increase the Value',
     &                             ' of MAXARC')
                        call fatal
                     end if
                     if (tf .le. ti) then
                        arcf(narc) = tf
                        arci(narc) = 0.0d0
                        tf = pix2
                        lt(narc) = l
                        ex(narc) = the
                        top = .true.
                        narc = narc + 1
                     end if
                     arcf(narc) = tf
                     arci(narc) = ti
                     lt(narc) = l
                     ex(narc) = the
                     ux(l) = uxl
                     uy(l) = uyl
                     uz(l) = uzl
                  end if
               end if
            end do
            omit(k) = komit
c
c     special case; K circle without intersections
c
            if (narc .le. 0)  goto 90
c
c     general case; sum up arclength and set connectivity code
c
            call sort2 (narc,arci,key)
            arcsum = arci(1)
            mi = key(1)
            t = arcf(mi)
            ni = mi
            if (narc .gt. 1) then
               do j = 2, narc
                  m = key(j)
                  if (t .lt. arci(j)) then
                     arcsum = arcsum + arci(j) - t
                     exang = exang + ex(ni)
                     jb = jb + 1
                     if (jb .ge. maxarc) then
                        write (iout,80)
   80                   format (/,' RICHMOND  --  Increase the Value',
     &                             ' of MAXARC')
                        call fatal
                     end if
                     l = lt(ni)
                     kent(jb) = maxarc*l + k
                     l = lt(m)
                     kout(jb) = maxarc*k + l
                  end if
                  tt = arcf(m)
                  if (tt .ge. t) then
                     t = tt
                     ni = m
                  end if
               end do
            end if
            arcsum = arcsum + pix2 - t
            if (.not. top) then
               exang = exang + ex(ni)
               jb = jb + 1
               l = lt(ni)
               kent(jb) = maxarc*l + k
               l = lt(mi)
               kout(jb) = maxarc*k + l
            end if
            goto 100
   90       continue
            arcsum = pix2
            ib = ib + 1
  100       continue
            arclen = arclen + gr(k)*arcsum
  110       continue
         end do
         if (arclen .eq. 0.0d0)  goto 180
         if (jb .eq. 0)  goto 150
c
c     find number of independent boundaries and check connectivity
c
         j = 0
         do k = 1, jb
            if (kout(k) .ne. 0) then
               i = k
  120          continue
               m = kout(i)
               kout(i) = 0
               j = j + 1
               do ii = 1, jb
                  if (m .eq. kent(ii)) then
                     if (ii .eq. k) then
                        ib = ib + 1
                        if (j .eq. jb)  goto 150
                        goto 130
                     end if
                     i = ii
                     goto 120
                  end if
               end do
  130          continue
            end if
         end do
         ib = ib + 1
c
c     attempt to fix connectivity error by moving atom slightly
c
         if (moved) then
            write (iout,140)  ir
  140       format (/,' RICHMOND  --  Connectivity Error at Atom',i6)
            call fatal
         else
            moved = .true.
            call ranvec (rvec)
            xr = xr + reps*rvec(1)
            yr = yr + reps*rvec(2)
            zr = zr + reps*rvec(3)
            goto 10
         end if
c
c     form the accessible area for the current atom
c
  150    continue
         area(ir) = ib*pix2 + exang + arclen
         area(ir) = mod(area(ir),pix4)
  160    continue
         area(ir) = area(ir) * rrsq
c
c     attempt to fix negative area by moving atom slightly
c
         if (area(ir) .lt. 0.0d0) then
            if (moved) then
               write (iout,170)  ir
  170          format (/,' RICHMOND  --  Negative Area at Atom',i6)
               call fatal
            else
               moved = .true.
               call ranvec (rvec)
               xr = xr + reps*rvec(1)
               yr = yr + reps*rvec(2)
               zr = zr + reps*rvec(3)
               goto 10
            end if
         end if
c
c     weight the accessible area by the scale factor
c
         area(ir) = area(ir) * wght
         total = total + area(ir)
  180    continue
      end do
c
c     print out the surface area values for each atom
c
      if (debug) then
         write (iout,190)
  190    format (/,' Weighted Atomic Surface Areas Values :',
     &           //,4x,'Atom',7x,'Area Term',6x,'Weight',/)
         do i = 1, n
            if (.not. skip(i)) then
               write (iout,200)  i,area(i),weight(i)
  200          format (i8,4x,2f12.4)
            end if
         end do
         write (iout,210)  total
  210    format (/,' Total Weighted Surface Area :',5x,f16.4)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (r)
      deallocate (skip)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine richmond1  --  accessible surface area & derivs  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "richmond1" performs an analytical computation of the weighted
c     solvent accessible surface area of each atom and the first
c     derivatives of the area with respect to Cartesian coordinates
c     using the method of Tim Richmond
c
c     literature references:
c
c     T. J. Richmond, "Solvent Accessible Surface Area and
c     Excluded Volume in Proteins", Journal of Molecular Biology,
c     178, 63-89 (1984)
c
c     L. Wesson and D. Eisenberg, "Atomic Solvation Parameters
c     Applied to Molecular Dynamics of Proteins in Solution",
c     Protein Science, 1, 227-235 (1992)
c
c     variables and parameters:
c
c     n        total number of atoms in the current system
c     x        current x-coordinate for each atom in the system
c     y        current y-coordinate for each atom in the system
c     z        current z-coordinate for each atom in the system
c     rad      radius value in Angstroms for each sphere
c     weight   weight value for each sphere in the system
c     probe    radius value in Angstroms of the probe sphere
c     total    total surface area of the whole structure
c     area     accessible surface area of each atom
c     darea    x,y,z components of the gradient of the area of
c                the molecule with respect to atomic coordinates
c
c     delta    tolerance used in the tests for sphere overlaps
c                and for colinearity
c     reps     connectivity errors can usually be avoided if the
c                offending atom is shifted by this small amount
c
c
      subroutine richmond1 (n,x,y,z,rad,weight,probe,
     &                         total,area,darea)
      use inform
      use iounit
      use math
      use usage
      implicit none
      integer maxarc
      parameter (maxarc=1000)
      integer i,j,k,l,m,n
      integer ii,ib,jb
      integer in,io,ir
      integer mi,ni,narc
      integer key(maxarc)
      integer intag(maxarc)
      integer intag1(maxarc)
      integer lt(maxarc)
      integer kent(maxarc)
      integer kout(maxarc)
      integer ider(maxarc)
      integer sign_yder(maxarc)
      real*8 total,wght
      real*8 delta,delta2
      real*8 eps,reps,dsql
      real*8 probe,arcsum
      real*8 cosine
      real*8 wxl,wxlsq
      real*8 p,s,v,rcn
      real*8 axx,axy,axz
      real*8 ayx,ayy,azx
      real*8 azy,azz
      real*8 uxl,uyl,uzl
      real*8 tx,ty,tz
      real*8 txb,tyb,t2,td
      real*8 tr2,tr,txr,tyr
      real*8 tk1,tk2
      real*8 thec,the
      real*8 t,tb,txk,tyk,tzk
      real*8 t1,ti,tf,tt
      real*8 txl,tyl,tzl
      real*8 arclen,exang
      real*8 xr,yr,zr
      real*8 rr,rrx2,rrsq
      real*8 rplus,rminus
      real*8 ccsq,cc,xysq
      real*8 bgl,bsqk,bsql
      real*8 bk,gi,gl
      real*8 pix2,pix4,pid2
      real*8 dax,day,daz
      real*8 deal,decl
      real*8 dtkal,dtkcl
      real*8 dtlal,dtlcl
      real*8 therk,dk,gk
      real*8 risqk,rik,risql
      real*8 faca,facb,facc
      real*8 gaca,gacb
      real*8 rvec(3)
      real*8 x(*)
      real*8 y(*)
      real*8 z(*)
      real*8 rad(*)
      real*8 weight(*)
      real*8 area(*)
      real*8 darea(3,*)
      real*8 ri(maxarc),risq(maxarc)
      real*8 bsq(maxarc),bsq1(maxarc)
      real*8 dsq(maxarc),dsq1(maxarc)
      real*8 arci(maxarc),arcf(maxarc)
      real*8 ex(maxarc),gr(maxarc)
      real*8 b(maxarc),b1(maxarc)
      real*8 bg(maxarc),ther(maxarc)
      real*8 xc(maxarc),xc1(maxarc)
      real*8 yc(maxarc),yc1(maxarc)
      real*8 zc(maxarc),zc1(maxarc)
      real*8 ux(maxarc),uy(maxarc)
      real*8 uz(maxarc)
      real*8, allocatable :: r(:)
      logical moved,top,komit
      logical omit(maxarc)
      logical, allocatable :: skip(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (r(n))
      allocate (skip(n))
c
c     zero the area and derivatives, and set the sphere radii
c
      total = 0.0d0
      do i = 1, n
         area(i) = 0.0d0
         darea(1,i) = 0.0d0
         darea(2,i) = 0.0d0
         darea(3,i) = 0.0d0
         r(i) = rad(i)
         if (r(i) .ne. 0.0d0)  r(i) = r(i) + probe
      end do
c
c     set pi multiples, overlap criterion and tolerances
c
      pix2 = 2.0d0 * pi
      pix4 = 4.0d0 * pi
      pid2 = 0.5d0 * pi
      delta = 1.0d-8
      delta2 = delta * delta
      eps = 1.0d-8
      reps = 1.0d-6
      do i = 1, maxarc
         ider(i) = 0
         sign_yder(i) = 0
      end do
c
c     exclude atoms that do not overlap any active atom
c
      do i = 1, n
         skip(i) = .true.
      end do
      do i = 1, n
         if (use(i)) then
            xr = x(i)
            yr = y(i)
            zr = z(i)
            rr = r(i)
            do k = 1, n
               rplus = (rr + r(k))**2
               ccsq = (x(k)-xr)**2 + (y(k)-yr)**2 + (z(k)-zr)**2
               if (ccsq .le. rplus)  skip(k) = .false.
            end do
         end if
      end do
c
c     compute the area and derivatives of current "ir" sphere
c
      do ir = 1, n
         if (skip(ir))  goto 180
         xr = x(ir)
         yr = y(ir)
         zr = z(ir)
         rr = r(ir)
         rrx2 = 2.0d0 * rr
         rrsq = rr * rr
         wght = weight(ir)
         moved = .false.
c
c     initialize some counters and sums for the "ir" sphere
c
   10    continue
         io = 0
         jb = 0
         ib = 0
         arclen = 0.0d0
         exang = 0.0d0
c
c     test each sphere to see if it overlaps the "ir" sphere
c
         do i = 1, n
            if (i .eq. ir)  goto 30
            rplus = rr + r(i)
            tx = x(i) - xr
            if (abs(tx) .ge. rplus)  goto 30
            ty = y(i) - yr
            if (abs(ty) .ge. rplus)  goto 30
            tz = z(i) - zr
            if (abs(tz) .ge. rplus)  goto 30
c
c     check for sphere overlap by testing interatomic
c     distance against sum and difference of radii
c
            xysq = tx**2 + ty**2
            if (xysq .lt. delta2) then
               tx = delta
               ty = 0.0d0
               xysq = delta2
            end if
            ccsq = xysq + tz**2
            cc = sqrt(ccsq)
            if (rplus-cc .le. delta)  goto 30
            rminus = rr - r(i)
c
c     check for a completely buried "ir" sphere
c
            if (cc-abs(rminus) .le. delta) then
               if (rminus .le. 0.0d0)  goto 180
               goto 30
            end if
c
c     calculate overlap parameters between "i" and "ir" sphere
c
            io = io + 1
            xc1(io) = tx
            yc1(io) = ty
            zc1(io) = tz
            dsq1(io) = xysq
            bsq1(io) = ccsq
            b1(io) = cc
            gr(io) = (ccsq+rplus*rminus) / (rrx2*b1(io))
            intag1(io) = i
            if (io .gt. maxarc) then
               write (iout,20)
   20          format (/,' RICHMOND1  --  Increase the Value of MAXARC')
               call fatal
            end if
   30       continue
         end do
c
c     case where no other spheres overlap the current sphere
c
         if (io .eq. 0) then
            area(ir) = pix4
            goto 160
         end if
c
c     case where only one sphere overlaps the current sphere
c
         if (io .eq. 1) then
            k = 1
            txk = xc1(1)
            tyk = yc1(1)
            tzk = zc1(1)
            bsqk = bsq1(1)
            bk = b1(1)
            intag(1) = intag1(1)
            arcsum = pix2
            ib = ib + 1
            arclen = arclen + gr(k)*arcsum
            if (.not. moved) then
               in = intag(k)
               t1 = arcsum*rrsq*(bsqk-rrsq+r(in)**2) / (rrx2*bsqk*bk)
               darea(1,ir) = darea(1,ir) - txk*t1*wght
               darea(2,ir) = darea(2,ir) - tyk*t1*wght
               darea(3,ir) = darea(3,ir) - tzk*t1*wght
               darea(1,in) = darea(1,in) + txk*t1*wght
               darea(2,in) = darea(2,in) + tyk*t1*wght
               darea(3,in) = darea(3,in) + tzk*t1*wght
            end if
            goto 150
         end if
c
c     general case where more than one sphere intersects the
c     current sphere; sort intersecting spheres by their degree
c     of overlap with the current main sphere
c
         call sort2 (io,gr,key)
         do i = 1, io
            k = key(i)
            intag(i) = intag1(k)
            xc(i) = xc1(k)
            yc(i) = yc1(k)
            zc(i) = zc1(k)
            dsq(i) = dsq1(k)
            b(i) = b1(k)
            bsq(i) = bsq1(k)
            omit(i) = .false.
         end do
c
c     radius of the each circle on the surface of the "ir" sphere
c
         do i = 1, io
            gi = gr(i) * rr
            bg(i) = b(i) * gi
            risq(i) = rrsq - gi**2
            ri(i) = sqrt(risq(i))
            ther(i) = pid2 - asin(min(1.0d0,max(-1.0d0,gr(i))))
         end do
c
c     find boundary of inaccessible area on "ir" sphere
c
         do k = 1, io-1
            if (.not. omit(k)) then
               txk = xc(k)
               tyk = yc(k)
               tzk = zc(k)
               bk = b(k)
               therk = ther(k)
               do j = k+1, io
                  if (omit(j))  goto 60
c
c     check to see if J circle is intersecting K circle;
c     get distance between circle centers and sum of radii
c
                  cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j))
                  cc = acos(min(1.0d0,max(-1.0d0,cc)))
                  td = therk + ther(j)
c
c     check to see if circles enclose separate regions
c
                  if (cc .ge. td)  goto 60
c
c     check for circle J completely inside circle K
c
                  if (cc+ther(j) .lt. therk)  goto 40
c
c     check for circles essentially parallel
c
                  if (cc .gt. delta)  goto 50
   40             continue
                  omit(j) = .true.
                  goto 60
c
c     check for "ir" sphere completely buried
c
   50             continue
                  if (pix2-cc .le. td)  goto 180
   60             continue
               end do
            end if
         end do
c
c     find T value of circle intersections
c
         do k = 1, io
            if (omit(k))  goto 110
            komit = omit(k)
            omit(k) = .true.
            narc = 0
            top = .false.
            txk = xc(k)
            tyk = yc(k)
            tzk = zc(k)
            dk = sqrt(dsq(k))
            bsqk = bsq(k)
            bk = b(k)
            gk = gr(k) * rr
            risqk = risq(k)
            rik = ri(k)
            therk = ther(k)
c
c     rotation matrix elements
c
            t1 = tzk / (bk*dk)
            axx = txk * t1
            axy = tyk * t1
            axz = dk / bk
            ayx = tyk / dk
            ayy = txk / dk
            azx = txk / bk
            azy = tyk / bk
            azz = tzk / bk
            do l = 1, io
               if (.not. omit(l)) then
                  txl = xc(l)
                  tyl = yc(l)
                  tzl = zc(l)
c
c     rotate spheres so K vector colinear with z-axis
c
                  uxl = txl*axx + tyl*axy - tzl*axz
                  uyl = tyl*ayy - txl*ayx
                  uzl = txl*azx + tyl*azy + tzl*azz
                  cosine = min(1.0d0,max(-1.0d0,uzl/b(l)))
                  if (acos(cosine) .lt. therk+ther(l)) then
                     dsql = uxl**2 + uyl**2
                     tb = uzl*gk - bg(l)
                     txb = uxl * tb
                     tyb = uyl * tb
                     td = rik * dsql
                     tr2 = risqk*dsql - tb**2
                     tr2 = max(eps,tr2)
                     tr = sqrt(tr2)
                     txr = uxl * tr
                     tyr = uyl * tr
c
c     get T values of intersection for K circle
c
                     tb = (txb+tyr) / td
                     tb = min(1.0d0,max(-1.0d0,tb))
                     tk1 = acos(tb)
                     if (tyb-txr .lt. 0.0d0)  tk1 = pix2 - tk1
                     tb = (txb-tyr) / td
                     tb = min(1.0d0,max(-1.0d0,tb))
                     tk2 = acos(tb)
                     if (tyb+txr .lt. 0.0d0)  tk2 = pix2 - tk2
                     thec = (rrsq*uzl-gk*bg(l)) / (rik*ri(l)*b(l))
                     if (abs(thec) .lt. 1.0d0) then
                        the = -acos(thec)
                     else if (thec .ge. 1.0d0) then
                        the = 0.0d0
                     else if (thec .le. -1.0d0) then
                        the = -pi
                     end if
c
c     see if "tk1" is entry or exit point; check t=0 point;
c     "ti" is exit point, "tf" is entry point
c
                     cosine = min(1.0d0,max(-1.0d0,
     &                               (uzl*gk-uxl*rik)/(b(l)*rr)))
                     if ((acos(cosine)-ther(l))*(tk2-tk1)
     &                          .le. 0.0d0) then
                        ti = tk2
                        tf = tk1
                     else
                        ti = tk1
                        tf = tk2
                     end if
                     narc = narc + 1
                     if (narc .ge. maxarc) then
                        write (iout,70)
   70                   format (/,' RICHMOND1  --  Increase the Value',
     &                             ' of MAXARC')
                        call fatal
                     end if
                     if (tf .le. ti) then
                        arcf(narc) = tf
                        arci(narc) = 0.0d0
                        tf = pix2
                        lt(narc) = l
                        ex(narc) = the
                        top = .true.
                        narc = narc + 1
                     end if
                     arcf(narc) = tf
                     arci(narc) = ti
                     lt(narc) = l
                     ex(narc) = the
                     ux(l) = uxl
                     uy(l) = uyl
                     uz(l) = uzl
                  end if
               end if
            end do
            omit(k) = komit
c
c     special case; K circle without intersections
c
            if (narc .le. 0)  goto 90
c
c     general case; sum up arclength and set connectivity code
c
            call sort2 (narc,arci,key)
            arcsum = arci(1)
            mi = key(1)
            t = arcf(mi)
            ni = mi
            if (narc .gt. 1) then
               do j = 2, narc
                  m = key(j)
                  if (t .lt. arci(j)) then
                     arcsum = arcsum + arci(j) - t
                     exang = exang + ex(ni)
                     jb = jb + 1
                     if (jb .ge. maxarc) then
                        write (iout,80)
   80                   format (/,' RICHMOND1  --  Increase the Value',
     &                             ' of MAXARC')
                        call fatal
                     end if
                     l = lt(ni)
                     ider(l) = ider(l) + 1
                     sign_yder(l) = sign_yder(l) + 1
                     kent(jb) = maxarc*l + k
                     l = lt(m)
                     ider(l) = ider(l) + 1
                     sign_yder(l) = sign_yder(l) - 1
                     kout(jb) = maxarc*k + l
                  end if
                  tt = arcf(m)
                  if (tt .ge. t) then
                     t = tt
                     ni = m
                  end if
               end do
            end if
            arcsum = arcsum + pix2 - t
            if (.not. top) then
               exang = exang + ex(ni)
               jb = jb + 1
               l = lt(ni)
               ider(l) = ider(l) + 1
               sign_yder(l) = sign_yder(l) + 1
               kent(jb) = maxarc*l + k
               l = lt(mi)
               ider(l) = ider(l) + 1
               sign_yder(l) = sign_yder(l) - 1
               kout(jb) = maxarc*k + l
            end if
c
c     calculate the surface area derivatives
c
            do l = 1, io
               if (ider(l) .ne. 0) then
                  rcn = ider(l) * rrsq
                  ider(l) = 0
                  uzl = uz(l)
                  gl = gr(l) * rr
                  bgl = bg(l)
                  bsql = bsq(l)
                  risql = risq(l)
                  wxlsq = bsql - uzl**2
                  wxl = sqrt(wxlsq)
                  p = bgl - gk*uzl
                  v = risqk*wxlsq - p**2
                  v = max(eps,v)
                  v = sqrt(v)
                  t1 = rr * (gk*(bgl-bsql)+uzl*(bgl-rrsq))
     &                             / (v*risql*bsql)
                  deal = -wxl*t1
                  decl = -uzl*t1 - rr/v
                  dtkal = (wxlsq-p) / (wxl*v)
                  dtkcl = (uzl-gk) / v
                  s = gk*b(l) - gl*uzl
                  t1 = 2.0d0*gk - uzl
                  t2 = rrsq - bgl
                  dtlal = -(risql*wxlsq*b(l)*t1
     &                         -s*(wxlsq*t2+risql*bsql))
     &                             / (risql*wxl*bsql*v)
                  dtlcl = -(risql*b(l)*(uzl*t1-bgl)-uzl*t2*s)
     &                              / (risql*bsql*v)
                  gaca = rcn * (deal-(gk*dtkal-gl*dtlal)/rr) / wxl
                  gacb = (gk-uzl*gl/b(l)) * sign_yder(l) * rr / wxlsq
                  sign_yder(l) = 0
                  if (.not. moved) then
                     faca = ux(l)*gaca - uy(l)*gacb
                     facb = uy(l)*gaca + ux(l)*gacb
                     facc = rcn * (decl-(gk*dtkcl-gl*dtlcl)/rr)
                     dax = axx*faca - ayx*facb + azx*facc
                     day = axy*faca + ayy*facb + azy*facc
                     daz = azz*facc - axz*faca
                     in = intag(l)
                     darea(1,ir) = darea(1,ir) + dax*wght
                     darea(2,ir) = darea(2,ir) + day*wght
                     darea(3,ir) = darea(3,ir) + daz*wght
                     darea(1,in) = darea(1,in) - dax*wght
                     darea(2,in) = darea(2,in) - day*wght
                     darea(3,in) = darea(3,in) - daz*wght
                  end if
               end if
            end do
            goto 100
   90       continue
            arcsum = pix2
            ib = ib + 1
  100       continue
            arclen = arclen + gr(k)*arcsum
            if (.not. moved) then
               in = intag(k)
               t1 = arcsum*rrsq*(bsqk-rrsq+r(in)**2) / (rrx2*bsqk*bk)
               darea(1,ir) = darea(1,ir) - txk*t1*wght
               darea(2,ir) = darea(2,ir) - tyk*t1*wght
               darea(3,ir) = darea(3,ir) - tzk*t1*wght
               darea(1,in) = darea(1,in) + txk*t1*wght
               darea(2,in) = darea(2,in) + tyk*t1*wght
               darea(3,in) = darea(3,in) + tzk*t1*wght
            end if
  110       continue
         end do
         if (arclen .eq. 0.0d0)  goto 180
         if (jb .eq. 0)  goto 150
c
c     find number of independent boundaries and check connectivity
c
         j = 0
         do k = 1, jb
            if (kout(k) .ne. 0) then
               i = k
  120          continue
               m = kout(i)
               kout(i) = 0
               j = j + 1
               do ii = 1, jb
                  if (m .eq. kent(ii)) then
                     if (ii .eq. k) then
                        ib = ib + 1
                        if (j .eq. jb)  goto 150
                        goto 130
                     end if
                     i = ii
                     goto 120
                  end if
               end do
  130          continue
            end if
         end do
         ib = ib + 1
c
c     attempt to fix connectivity error by moving atom slightly
c
         if (moved) then
            write (iout,140)  ir
  140       format (/,' RICHMOND1  --  Connectivity Error at Atom',i6)
            call fatal
         else
            moved = .true.
            call ranvec (rvec)
            xr = xr + reps*rvec(1)
            yr = yr + reps*rvec(2)
            zr = zr + reps*rvec(3)
            goto 10
         end if
c
c     form the accessible area for the current atom
c
  150    continue
         area(ir) = ib*pix2 + exang + arclen
         area(ir) = mod(area(ir),pix4)
  160    continue
         area(ir) = area(ir) * rrsq
c
c     attempt to fix negative area by moving atom slightly
c
         if (area(ir) .lt. 0.0d0) then
            if (moved) then
               write (iout,170)  ir
  170          format (/,' RICHMOND1  --  Negative Area at Atom',i6)
               call fatal
            else
               moved = .true.
               call ranvec (rvec)
               xr = xr + reps*rvec(1)
               yr = yr + reps*rvec(2)
               zr = zr + reps*rvec(3)
               goto 10
            end if
         end if
c
c     weight the accessible area by the scale factor
c
         area(ir) = area(ir) * wght
         total = total + area(ir)
  180    continue
      end do
c
c     zero out the area derivatives for the inactive atoms
c
      do i = 1, n
         if (.not. use(i)) then
            darea(1,i) = 0.0d0
            darea(2,i) = 0.0d0
            darea(3,i) = 0.0d0
         end if
      end do
c
c     print out the surface area and derivatives for each atom
c
      if (debug) then
         write (iout,190)
  190    format (/,' Weighted Atomic Surface Areas and Derivatives :',
     &           //,4x,'Atom',7x,'Area Term',10x,'dA/dx',
     &              7x,'dA/dy',7x,'dA/dz',6x,'Weight',/)
         do i = 1, n
            if (.not. skip(i)) then
               write (iout,200)  i,area(i),(darea(j,i),j=1,3),weight(i)
  200          format (i8,4x,f12.4,3x,3f12.4,f12.4)
            end if
         end do
         write (iout,210)  total
  210    format (/,' Total Weighted Surface Area :',5x,f16.4)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (r)
      deallocate (skip)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module rigid  --  rigid body coordinates for atom groups  ##
c     ##                                                            ##
c     ################################################################
c
c
c     xrb         rigid body reference x-coordinate for each atom
c     yrb         rigid body reference y-coordinate for each atom
c     zrb         rigid body reference z-coordinate for each atom
c     rbc         current rigid body coordinates for each group
c     use_rigid   flag to mark use of rigid body coordinate system
c
c
      module rigid
      implicit none
      real*8, allocatable :: xrb(:)
      real*8, allocatable :: yrb(:)
      real*8, allocatable :: zrb(:)
      real*8, allocatable :: rbc(:,:)
      logical use_rigid
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module ring  --  number and location of ring structures  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     nring3   total number of 3-membered rings in the system
c     nring4   total number of 4-membered rings in the system
c     nring5   total number of 5-membered rings in the system
c     nring6   total number of 6-membered rings in the system
c     nring7   total number of 7-membered rings in the system
c     iring3   numbers of the atoms involved in each 3-ring
c     iring4   numbers of the atoms involved in each 4-ring
c     iring5   numbers of the atoms involved in each 5-ring
c     iring6   numbers of the atoms involved in each 6-ring
c     iring7   numbers of the atoms involved in each 7-ring
c
c
      module ring
      implicit none
      integer nring3
      integer nring4
      integer nring5
      integer nring6
      integer nring7
      integer, allocatable :: iring3(:,:)
      integer, allocatable :: iring4(:,:)
      integer, allocatable :: iring5(:,:)
      integer, allocatable :: iring6(:,:)
      integer, allocatable :: iring7(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine rings  --  locate and store small rings  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "rings" searches the structure for small rings and stores
c     their constituent atoms, and optionally reduces rings into
c     their component smaller rings
c
c     note by default reducible rings are not removed since they
c     are needed for force field parameter assignment
c
c
      subroutine rings
      use angbnd
      use atoms
      use bitor
      use bndstr
      use couple
      use inform
      use iounit
      use ring
      use tettor
      use tors
      use tritor
      implicit none
      integer i,j,k,imin
      integer ia,ib,ic,id
      integer ie,ig,ih
      integer list1,list2
      integer list3,list4
      integer, allocatable :: list(:)
      logical reduce
c
c
c     zero out the number of small rings in the structure
c
      reduce = .false.
      nring3 = 0
      nring4 = 0
      nring5 = 0
      nring6 = 0
      nring7 = 0
c
c     parse to find bonds, angles, torsions and bitorsions
c
      if (nbond .eq. 0)  call bonds
      if (nangle .eq. 0)  call angles
      if (ntors .eq. 0)  call torsions
      if (nbitor .eq. 0)  call bitors
      if (ntritor .eq. 0)  call tritors
      if (ntettor .eq. 0)  call tettors
c
c     initial count of the total number of each ring size
c
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         if (ia .gt. ic) then
            ia = iang(3,i)
            ic = iang(1,i)
         end if
         imin = min(ia,ib,ic)
         if (ia.eq.imin .and. ib.lt.ic) then
            do j = 1, n12(ia)
               if (i12(j,ia) .eq. ic) then
                  nring3 = nring3 + 1
                  goto 10
               end if
            end do
   10       continue
         end if
      end do
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         if (ia .gt. id) then
            ia = itors(4,i)
            ib = itors(3,i)
            ic = itors(2,i)
            id = itors(1,i)
         end if
         imin = min(ia,ib,ic,id)
         if (ia.eq.imin .and. ib.lt.id) then
            do j = 1, n12(ia)
               if (i12(j,ia) .eq. id) then
                  nring4 = nring4 + 1
                  goto 20
               end if
            end do
   20       continue
         end if
      end do
      do i = 1, nbitor
         ia = ibitor(1,i)
         ib = ibitor(2,i)
         ic = ibitor(3,i)
         id = ibitor(4,i)
         ie = ibitor(5,i)
         if (ia .gt. ie) then
            ia = ibitor(5,i)
            ib = ibitor(4,i)
            id = ibitor(2,i)
            ie = ibitor(1,i)
         end if
         imin = min(ia,ib,ic,id,ie)
         if (ia.eq.imin .and. ib.le.ie) then
            do j = 1, n12(ia)
               if (i12(j,ia) .eq. ie) then
                  nring5 = nring5 + 1
                  goto 30
               end if
            end do
   30       continue
         end if
      end do
      do i = 1, ntritor
         ia = itritor(1,i)
         ib = itritor(2,i)
         ic = itritor(3,i)
         id = itritor(4,i)
         ie = itritor(5,i)
         ig = itritor(6,i)
         if (ia .gt. ig) then
            ia = itritor(6,i)
            ib = itritor(5,i)
            ic = itritor(4,i)
            id = itritor(3,i)
            ie = itritor(2,i)
            ig = itritor(1,i)
         end if
         imin = min(ia,ib,ic,id,ie,ig)
         if (ia.eq.imin .and. ib.lt.ig) then
            do j = 1, n12(ia)
               if (i12(j,ia) .eq. ig) then
                  nring6 = nring6 + 1
                  goto 40
               end if
            end do
   40       continue
         end if
      end do
      do i = 1, ntettor
         ia = itettor(1,i)
         ib = itettor(2,i)
         ic = itettor(3,i)
         id = itettor(4,i)
         ie = itettor(5,i)
         ig = itettor(6,i)
         ih = itettor(7,i)
         if (ia .gt. ih) then
            ia = itettor(7,i)
            ib = itettor(6,i)
            ic = itettor(5,i)
            ie = itettor(3,i)
            ig = itettor(2,i)
            ih = itettor(1,i)
         end if
         imin = min(ia,ib,ic,id,ie,ig,ih)
         if (ia.eq.imin .and. ib.lt.ih) then
            do j = 1, n12(ia)
               if (i12(j,ia) .eq. ih) then
                  nring7 = nring7 + 1
                  goto 50
               end if
            end do
   50       continue
         end if
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(iring3))  deallocate (iring3)
      if (allocated(iring4))  deallocate (iring4)
      if (allocated(iring5))  deallocate (iring5)
      if (allocated(iring6))  deallocate (iring6)
      if (allocated(iring7))  deallocate (iring7)
      allocate (iring3(3,nring3))
      allocate (iring4(4,nring4))
      allocate (iring5(5,nring5))
      allocate (iring6(6,nring6))
      allocate (iring7(7,nring7))
c
c     search for and store all of the 3-membered rings
c
      if (nring3 .ne. 0) then
         nring3 = 0
         do i = 1, nangle
            ia = iang(1,i)
            ib = iang(2,i)
            ic = iang(3,i)
            if (ia .gt. ic) then
               ia = iang(3,i)
               ic = iang(1,i)
            end if
            imin = min(ia,ib,ic)
            if (ia.eq.imin .and. ib.lt.ic) then
               do j = 1, n12(ia)
                  if (i12(j,ia) .eq. ic) then
                     nring3 = nring3 + 1
                     iring3(1,nring3) = ia
                     iring3(2,nring3) = ib
                     iring3(3,nring3) = ic
                     goto 60
                  end if
               end do
   60          continue
            end if
         end do
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
c
c     search for and store all of the 4-membered rings
c
      if (nring4 .ne. 0) then
         nring4 = 0
         do i = 1, n
            list(i) = 0
         end do
         do i = 1, ntors
            ia = itors(1,i)
            ib = itors(2,i)
            ic = itors(3,i)
            id = itors(4,i)
            if (ia .gt. id) then
               ia = itors(4,i)
               ib = itors(3,i)
               ic = itors(2,i)
               id = itors(1,i)
            end if
            imin = min(ia,ib,ic,id)
            if (ia.eq.imin .and. ib.lt.id) then
               do j = 1, n12(ia)
                  if (i12(j,ia) .eq. id) then
                     nring4 = nring4 + 1
                     iring4(1,nring4) = ia
                     iring4(2,nring4) = ib
                     iring4(3,nring4) = ic
                     iring4(4,nring4) = id
                     if (reduce) then
                        list(ia) = nring4
                        list(ib) = nring4
                        list(ic) = nring4
                        list(id) = nring4
                        do k = 1, nring3
                           list1 = list(iring3(1,k))
                           list2 = list(iring3(2,k))
                           list3 = list(iring3(3,k))
                           if (list1.eq.nring4 .and. list2.eq.nring4
     &                            .and. list3.eq.nring4) then
                              nring4 = nring4 - 1
                              list(ia) = 0
                              list(ib) = 0
                              list(ic) = 0
                              list(id) = 0
                              goto 70
                           end if
                        end do
                     end if
                     goto 70
                  end if
               end do
   70          continue
            end if
         end do
      end if
c
c     search for and store all of the 5-membered rings
c
      if (nring5 .ne. 0) then
         nring5 = 0
         do i = 1, n
             list(i) = 0
         end do
         do i = 1, nbitor
            ia = ibitor(1,i)
            ib = ibitor(2,i)
            ic = ibitor(3,i)
            id = ibitor(4,i)
            ie = ibitor(5,i)
            if (ia .gt. ie) then
               ia = ibitor(5,i)
               ib = ibitor(4,i)
               id = ibitor(2,i)
               ie = ibitor(1,i)
            end if
            imin = min(ia,ib,ic,id,ie)
            if (ia.eq.imin .and. ib.lt.ie) then
               do j = 1, n12(ia)
                  if (i12(j,ia) .eq. ie) then
                     nring5 = nring5 + 1
                     iring5(1,nring5) = ia
                     iring5(2,nring5) = ib
                     iring5(3,nring5) = ic
                     iring5(4,nring5) = id
                     iring5(5,nring5) = ie
                     if (reduce) then
                        list(ia) = nring5
                        list(ib) = nring5
                        list(ic) = nring5
                        list(id) = nring5
                        list(ie) = nring5
                        do k = 1, nring3
                           list1 = list(iring3(1,k))
                           list2 = list(iring3(2,k))
                           list3 = list(iring3(3,k))
                           if (list1.eq.nring5 .and. list2.eq.nring5
     &                            .and. list3.eq.nring5) then
                              nring5 = nring5 - 1
                              list(ia) = 0
                              list(ib) = 0
                              list(ic) = 0
                              list(id) = 0
                              list(ie) = 0
                              goto 80
                           end if
                        end do
                     end if
                     goto 80
                  end if
               end do
   80          continue
            end if
         end do
      end if
c
c     search for and store all of the 6-membered rings
c
      if (nring6 .ne. 0) then
         nring6 = 0
         do i = 1, n
            list(i) = 0
         end do
         do i = 1, ntritor
            ia = itritor(1,i)
            ib = itritor(2,i)
            ic = itritor(3,i)
            id = itritor(4,i)
            ie = itritor(5,i)
            ig = itritor(6,i)
            if (ia .gt. ig) then
               ia = itritor(6,i)
               ib = itritor(5,i)
               ic = itritor(4,i)
               id = itritor(3,i)
               ie = itritor(2,i)
               ig = itritor(1,i)
            end if
            imin = min(ia,ib,ic,id,ie,ig)
            if (ia.eq.imin .and. ib.lt.ig) then
               do j = 1, n12(ia)
                  if (i12(j,ia) .eq. ig) then
                     nring6 = nring6 + 1
                     iring6(1,nring6) = ia
                     iring6(2,nring6) = ib
                     iring6(3,nring6) = ic
                     iring6(4,nring6) = id
                     iring6(5,nring6) = ie
                     iring6(6,nring6) = ig
                     if (reduce) then
                        list(ia) = nring6
                        list(ib) = nring6
                        list(ic) = nring6
                        list(id) = nring6
                        list(ie) = nring6
                        list(ig) = nring6
                        do k = 1, nring3
                           list1 = list(iring3(1,k))
                           list2 = list(iring3(2,k))
                           list3 = list(iring3(3,k))
                           if (list1.eq.nring6 .and. list2.eq.nring6
     &                            .and. list3.eq.nring6) then
                              nring6 = nring6 - 1
                              list(ia) = 0
                              list(ib) = 0
                              list(ic) = 0
                              list(id) = 0
                              list(ie) = 0
                              list(ig) = 0
                              goto 90
                           end if
                        end do
                        do k = 1, nring4
                           list1 = list(iring4(1,k))
                           list2 = list(iring4(2,k))
                           list3 = list(iring4(3,k))
                           list4 = list(iring4(4,k))
                           if (list1.eq.nring6 .and. list2.eq.nring6
     &                            .and. list3.eq.nring6
     &                            .and. list4.eq.nring6) then
                              nring6 = nring6 - 1
                              list(ia) = 0
                              list(ib) = 0
                              list(ic) = 0
                              list(id) = 0
                              list(ie) = 0
                              list(ig) = 0
                              goto 90
                           end if
                        end do
                     end if
                     goto 90
                  end if
               end do
   90          continue
            end if
         end do
      end if
c
c     search for and store all of the 7-membered rings
c
      if (nring7 .ne. 0) then
         nring7 = 0
         do i = 1, n
            list(i) = 0
         end do
         do i = 1, ntettor
            ia = itettor(1,i)
            ib = itettor(2,i)
            ic = itettor(3,i)
            id = itettor(4,i)
            ie = itettor(5,i)
            ig = itettor(6,i)
            ih = itettor(7,i)
            if (ia .gt. ih) then
               ia = itettor(7,i)
               ib = itettor(6,i)
               ic = itettor(5,i)
               ie = itettor(3,i)
               ig = itettor(2,i)
               ih = itettor(1,i)
            end if
            imin = min(ia,ib,ic,id,ie,ig,ih)
            if (ia.eq.imin .and. ib.lt.ih) then
               do j = 1, n12(ia)
                  if (i12(j,ia) .eq. ih) then
                     nring7 = nring7 + 1
                     iring7(1,nring7) = ia
                     iring7(2,nring7) = ib
                     iring7(3,nring7) = ic
                     iring7(4,nring7) = id
                     iring7(5,nring7) = ie
                     iring7(6,nring7) = ig
                     iring7(7,nring7) = ih
                     if (reduce) then
                        list(ia) = nring7
                        list(ib) = nring7
                        list(ic) = nring7
                        list(id) = nring7
                        list(ie) = nring7
                        list(ig) = nring7
                        list(ih) = nring7
                        do k = 1, nring3
                           list1 = list(iring3(1,k))
                           list2 = list(iring3(2,k))
                           list3 = list(iring3(3,k))
                           if (list1.eq.nring7 .and. list2.eq.nring7
     &                            .and. list3.eq.nring7) then
                              nring7 = nring7 - 1
                              list(ia) = 0
                              list(ib) = 0
                              list(ic) = 0
                              list(id) = 0
                              list(ie) = 0
                              list(ig) = 0
                              list(ih) = 0
                              goto 100
                           end if
                        end do
                        do k = 1, nring4
                           list1 = list(iring4(1,k))
                           list2 = list(iring4(2,k))
                           list3 = list(iring4(3,k))
                           list4 = list(iring4(4,k))
                           if (list1.eq.nring7 .and. list2.eq.nring7
     &                            .and. list3.eq.nring7
     &                            .and. list4.eq.nring7) then
                              nring7 = nring7 - 1
                              list(ia) = 0
                              list(ib) = 0
                              list(ic) = 0
                              list(id) = 0
                              list(ie) = 0
                              list(ig) = 0
                              list(ih) = 0
                              goto 100
                           end if
                        end do
                     end if
                     goto 100
                  end if
               end do
  100          continue
            end if
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (list)
c
c     print out lists of the small rings in the structure
c
      if (debug) then
         if (nring3 .gt. 0) then
            write (iout,110)
  110       format (/,' Three-Membered Rings in the Structure :',
     &              //,3x,'Ring',14x,'Atoms in Ring',/)
            do i = 1, nring3
               write (iout,120)  i,(iring3(j,i),j=1,3)
  120          format (i6,7x,3i7)
            end do
         end if
         if (nring4 .gt. 0) then
            write (iout,130)
  130       format (/,' Four-Membered Rings in the Structure :',
     &              //,3x,'Ring',17x,'Atoms in Ring',/)
            do i = 1, nring4
               write (iout,140)  i,(iring4(j,i),j=1,4)
  140          format (i6,7x,4i7)
            end do
         end if
         if (nring5 .gt. 0) then
            write (iout,150)
  150       format (/,' Five-Membered Rings in the Structure :',
     &              //,3x,'Ring',20x,'Atoms in Ring',/)
            do i = 1, nring5
               write (iout,160)  i,(iring5(j,i),j=1,5)
  160          format (i6,7x,5i7)
            end do
         end if
         if (nring6 .gt. 0) then
            write (iout,170)
  170       format (/,' Six-Membered Rings in the Structure :',
     &              //,3x,'Ring',23x,'Atoms in Ring',/)
            do i = 1, nring6
               write (iout,180)  i,(iring6(j,i),j=1,6)
  180          format (i6,7x,6i7)
            end do
         end if
         if (nring7 .gt. 0) then
            write (iout,190)
  190       format (/,' Seven-Membered Rings in the Structure :',
     &              //,3x,'Ring',26x,'Atoms in Ring',/)
            do i = 1, nring7
               write (iout,200)  i,(iring7(j,i),j=1,7)
  200          format (i6,7x,7i7)
            end do
         end if
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  function rmsfit  --  rms deviation for paired atoms  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "rmsfit" computes the rms fit of two coordinate sets
c
c
      function rmsfit (x1,y1,z1,x2,y2,z2)
      use align
      implicit none
      integer i,i1,i2
      real*8 rmsfit,rmsterm
      real*8 xr,yr,zr,dist2
      real*8 weigh,norm
      real*8 x1(*),x2(*)
      real*8 y1(*),y2(*)
      real*8 z1(*),z2(*)
c
c
c     compute the rms fit over superimposed atom pairs
c
      rmsfit = 0.0d0
      norm = 0.0d0
      do i = 1, nfit
         i1 = ifit(1,i)
         i2 = ifit(2,i)
         weigh = wfit(i)
         xr = x1(i1) - x2(i2)
         yr = y1(i1) - y2(i2)
         zr = z1(i1) - z2(i2)
         dist2 = xr**2 + yr**2 + zr**2
         norm = norm + weigh
         rmsterm = dist2 * weigh
         rmsfit = rmsfit + rmsterm
      end do
      rmsfit = sqrt(rmsfit/norm)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module rotbnd  --  molecule partitions for bond rotation  ##
c     ##                                                            ##
c     ################################################################
c
c
c     nrot        total number of atoms moving when bond rotates
c     rot         atom numbers of atoms moving when bond rotates
c     use_short   logical flag governing use of shortest atom list
c
c
      module rotbnd
      implicit none
      integer nrot
      integer, allocatable :: rot(:)
      logical use_short
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine rotlist  --  find atoms on one side of a bond  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "rotlist" generates the minimum list of all the atoms lying
c     to one side of a pair of directly bonded atoms; optionally
c     finds the minimal list by choosing the side with fewer atoms
c
c
      subroutine rotlist (base,partner)
      use atoms
      use couple
      use iounit
      use molcul
      use rotbnd
      use zclose
      implicit none
      integer i,k,ia,ib,swap
      integer base,partner
      integer mark,test
      integer nattach
      integer, allocatable :: list(:)
      logical bonded
c
c
c     initialize the number of atoms to one side of the bond
c
      nrot = 0
c
c     remove any bonds needed for intramolecular ring closures
c
      do i = 1, nadd
         ia = iadd(1,i)
         ib = iadd(2,i)
         if (molcule(ia) .eq. molcule(ib)) then
            do k = 1, n12(ia)
               if (i12(k,ia) .eq. ib)  i12(k,ia) = 0
            end do
            do k = 1, n12(ib)
               if (i12(k,ib) .eq. ia)  i12(k,ib) = 0
            end do
         end if
      end do
c
c     add any links needed to make intermolecular connections
c
      do i = 1, ndel
         ia = idel(1,i)
         ib = idel(2,i)
         if (molcule(ia) .ne. molcule(ib)) then
            if (n12(ia).eq.maxval .or. n12(ib).eq.maxval) then
               write (iout,10)
   10          format (/,' ROTLIST  --  Maximum Valence Exceeded;',
     &                    ' Increase MAXVAL')
               call fatal
            end if
            n12(ia) = n12(ia) + 1
            i12(n12(ia),ia) = ib
            n12(ib) = n12(ib) + 1
            i12(n12(ib),ib) = ia
         end if
      end do
c
c     check to see if the two atoms are still directly bonded
c
      bonded = .false.
      do i = 1, n12(base)
         if (i12(i,base) .eq. partner)  bonded = .true.
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(rot))  allocate (rot(n))
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(0:n))
c
c     make a list of atoms to one side of this pair of atoms,
c     taking note of any rings in which the atom pair resides
c
      if (bonded) then
         list(0) = 1
         do i = 1, n
            rot(i) = 0
         end do
   20    continue
         nrot = 0
         do i = 1, n
            list(i) = 0
         end do
         list(base) = 1
         list(partner) = 1
         nattach = n12(base)
         do i = 1, nattach
            test = i12(i,base)
            if (list(test) .eq. 0) then
               nrot = nrot + 1
               if (use_short .and. nrot.ge.n/2)  goto 30
               rot(nrot) = test
               list(test) = 1
            end if
         end do
         do i = 1, n
            mark = rot(i)
            if (mark .eq. 0)  goto 40
            nattach = n12(mark)
            if (nattach .gt. 1) then
               do k = 1, nattach
                  test = i12(k,mark)
                  if (list(test) .eq. 0) then
                     nrot = nrot + 1
                     if (use_short .and. nrot.ge.n/2)  goto 30
                     rot(nrot) = test
                     list(test) = 1
                  end if
               end do
            end if
         end do
c
c     the list contains over half the total number of atoms,
c     so reverse the base and partner atoms, then start over
c
   30    continue
         swap = base
         base = partner
         partner = swap
         do i = 1, nrot
            rot(i) = 0
         end do
         goto 20
      end if
   40 continue
c
c     perform deallocation of some local arrays
c
      deallocate (list)
c
c     remove links added to make intermolecular connections
c
      do i = 1, ndel
         ia = idel(1,i)
         ib = idel(2,i)
         if (molcule(ia) .ne. molcule(ib)) then
            n12(ia) = n12(ia) - 1
            n12(ib) = n12(ib) - 1
         end if
      end do
c
c     add any bonds required for intramolecular ring closures
c
      do i = 1, nadd
         ia = iadd(1,i)
         ib = iadd(2,i)
         if (molcule(ia) .eq. molcule(ib)) then
            do k = 1, n12(ia)
               if (i12(k,ia) .eq. 0) then
                  i12(k,ia) = ib
                  goto 50
               end if
            end do
   50       continue
            do k = 1, n12(ib)
               if (i12(k,ib) .eq. 0) then
                  i12(k,ib) = ia
                  goto 60
               end if
            end do
   60       continue
         end if
      end do
      return
      end
c
c
c     ############################################################
c     ##  COPYRIGHT (C) 1995 by Yong Kong & Jay William Ponder  ##
c     ##                  All Rights Reserved                   ##
c     ############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine rotpole  --  rotate multipoles to global frame  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "rotpole" constructs the global atomic multipoles by applying
c     a rotation matrix to convert from local to global frame
c
c
      subroutine rotpole (poltype)
      use atoms
      use mpole
      use repel
      implicit none
      integer i
      real*8 a(3,3)
      logical planar
      character*5 poltype
c
c
c     rotate local multipoles to global frame at each site
c
      call upcase (poltype)
      if (poltype .eq. 'MPOLE') then
         do i = 1, n
            if (pollist(i) .ne. 0) then
               call rotmat (i,a,planar)
               call rotsite (i,a,planar,pole,rpole)
            end if
         end do
      else if (poltype .eq. 'REPEL') then
         do i = 1, n
            if (replist(i) .ne. 0) then
               call rotmat (i,a,planar)
               call rotsite (i,a,planar,repole,rrepole)
            end if
         end do
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine rotrpole  --  rotate multipoles to local frame  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "rotrpole" constructs the local atomic multipoles by applying
c     a rotation matrix to convert from global to local frame
c
c
      subroutine rotrpole (poltype)
      use atoms
      use mpole
      use repel
      implicit none
      integer i
      real*8 a(3,3)
      logical planar
      character*5 poltype
c
c
c     rotate global multipoles to local frame at each site
c
      call upcase (poltype)
      if (poltype .eq. 'MPOLE') then
         do i = 1, n
            if (pollist(i) .ne. 0) then
               call rotmat (i,a,planar)
               call invert (3,a)
               planar = .false.
               call rotsite (i,a,planar,rpole,pole)
            end if
         end do
      else if (poltype .eq. 'REPEL') then
         do i = 1, n
            if (replist(i) .ne. 0) then
               call rotmat (i,a,planar)
               call invert (3,a)
               planar = .false.
               call rotsite (i,a,planar,rrepole,repole)
            end if
         end do
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine rotmat  --  local-to-global rotation matrix  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "rotmat" finds the rotation matrix that rotates the local
c     coordinate system into the global frame at a specified atom
c
c
      subroutine rotmat (i,a,planar)
      use atoms
      use math
      use mpole
      implicit none
      integer i,ix,iy,iz
      real*8 r,dot
      real*8 eps,angle
      real*8 xi,yi,zi
      real*8 dx,dy,dz
      real*8 dx1,dy1,dz1
      real*8 dx2,dy2,dz2
      real*8 dx3,dy3,dz3
      real*8 dx4,dy4,dz4
      real*8 a(3,3)
      logical planar
      character*8 axetyp
c
c
c     get coordinates and frame definition for multipole site
c
      xi = x(i)
      yi = y(i)
      zi = z(i)
      iz = zaxis(i)
      ix = xaxis(i)
      iy = abs(yaxis(i))
      axetyp = polaxe(i)
      planar = .false.
c
c     use the identity matrix as the default rotation matrix
c
      a(1,1) = 1.0d0
      a(2,1) = 0.0d0
      a(3,1) = 0.0d0
      a(1,2) = 0.0d0
      a(2,2) = 1.0d0
      a(3,2) = 0.0d0
      a(1,3) = 0.0d0
      a(2,3) = 0.0d0
      a(3,3) = 1.0d0
c
c     get Z-Only rotation matrix elements for z-axis only
c
      if (axetyp .eq. 'Z-Only') then
         dx = x(iz) - xi
         dy = y(iz) - yi
         dz = z(iz) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,3) = dx / r
         a(2,3) = dy / r
         a(3,3) = dz / r
         dx = 1.0d0
         dy = 0.0d0
         dz = 0.0d0
         dot = a(1,3)
         eps = 0.707d0
         if (abs(dot) .gt. eps) then
            dx = 0.0d0
            dy = 1.0d0
            dot = a(2,3)
         end if
         dx = dx - dot*a(1,3)
         dy = dy - dot*a(2,3)
         dz = dz - dot*a(3,3)
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,1) = dx / r
         a(2,1) = dy / r
         a(3,1) = dz / r
c
c     get Z-then-X rotation matrix elements for z- and x-axes
c
      else if (axetyp .eq. 'Z-then-X') then
         dx = x(iz) - xi
         dy = y(iz) - yi
         dz = z(iz) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,3) = dx / r
         a(2,3) = dy / r
         a(3,3) = dz / r
         dx = x(ix) - xi
         dy = y(ix) - yi
         dz = z(ix) - zi
         dot = dx*a(1,3) + dy*a(2,3) + dz*a(3,3)
         dx = dx - dot*a(1,3)
         dy = dy - dot*a(2,3)
         dz = dz - dot*a(3,3)
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,1) = dx / r
         a(2,1) = dy / r
         a(3,1) = dz / r
c
c     get Bisector rotation matrix elements for z- and x-axes
c
      else if (axetyp .eq. 'Bisector') then
         dx = x(iz) - xi
         dy = y(iz) - yi
         dz = z(iz) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx1 = dx / r
         dy1 = dy / r
         dz1 = dz / r
         dx = x(ix) - xi
         dy = y(ix) - yi
         dz = z(ix) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx2 = dx / r
         dy2 = dy / r
         dz2 = dz / r
         dx = dx1 + dx2
         dy = dy1 + dy2
         dz = dz1 + dz2
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,3) = dx / r
         a(2,3) = dy / r
         a(3,3) = dz / r
         dot = dx2*a(1,3) + dy2*a(2,3) + dz2*a(3,3)
         dx = dx2 - dot*a(1,3)
         dy = dy2 - dot*a(2,3)
         dz = dz2 - dot*a(3,3)
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,1) = dx / r
         a(2,1) = dy / r
         a(3,1) = dz / r
c
c     get Z-Bisect rotation matrix elements for z- and x-axes;
c     use alternate x-axis if central atom is close to planar
c
      else if (axetyp .eq. 'Z-Bisect') then
         dx = x(iz) - xi
         dy = y(iz) - yi
         dz = z(iz) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,3) = dx / r
         a(2,3) = dy / r
         a(3,3) = dz / r
         dx = x(ix) - xi
         dy = y(ix) - yi
         dz = z(ix) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx1 = dx / r
         dy1 = dy / r
         dz1 = dz / r
         dx = x(iy) - xi
         dy = y(iy) - yi
         dz = z(iy) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx2 = dx / r
         dy2 = dy / r
         dz2 = dz / r
         dx = dx1 + dx2
         dy = dy1 + dy2
         dz = dz1 + dz2
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx = dx / r
         dy = dy / r
         dz = dz / r
         dot = dx*a(1,3) + dy*a(2,3) + dz*a(3,3)
         angle = 180.0d0 - radian*acos(dot)
c        eps = 15.0d0
         eps = 0.0d0
         if (angle .lt. eps) then
            planar = .true.
            dx = dy1*dz2 - dz1*dy2
            dy = dz1*dx2 - dx1*dz2
            dz = dx1*dy2 - dy1*dx2
            dot = dx*a(1,3) + dy*a(2,3) + dz*a(3,3)
            if (dot .lt. 0.0d0) then
               dx = -dx
               dy = -dy
               dz = -dz
               dot = -dot
            end if
         end if
         dx = dx - dot*a(1,3)
         dy = dy - dot*a(2,3)
         dz = dz - dot*a(3,3)
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,1) = dx / r
         a(2,1) = dy / r
         a(3,1) = dz / r
c
c     get 3-Fold rotation matrix elements for z- and x-axes;
c     use alternate z-axis if central atom is close to planar
c
      else if (axetyp .eq. '3-Fold') then
         dx = x(iz) - xi
         dy = y(iz) - yi
         dz = z(iz) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx1 = dx / r
         dy1 = dy / r
         dz1 = dz / r
         dx = x(ix) - xi
         dy = y(ix) - yi
         dz = z(ix) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx2 = dx / r
         dy2 = dy / r
         dz2 = dz / r
         dx = x(iy) - xi
         dy = y(iy) - yi
         dz = z(iy) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx3 = dx / r
         dy3 = dy / r
         dz3 = dz / r
         dx = dx1 + dx2 + dx3
         dy = dy1 + dy2 + dy3
         dz = dz1 + dz2 + dz3
         r = sqrt(dx*dx + dy*dy + dz*dz)
c        eps = 0.15d0
         eps = 0.0d0
         if (r .lt. eps) then
            planar = .true.
            dx2 = x(ix) - x(iz)
            dy2 = y(ix) - y(iz)
            dz2 = z(ix) - z(iz)
            dx3 = x(iy) - x(iz)
            dy3 = y(iy) - y(iz)
            dz3 = z(iy) - z(iz)
            dx4 = dy2*dz3 - dz2*dy3
            dy4 = dz2*dx3 - dx2*dz3
            dz4 = dx2*dy3 - dy2*dx3
            dot = dx4*dx + dy4*dy + dz4*dz
            if (dot .gt. 0.0d0) then
               dx = dx4
               dy = dy4
               dz = dz4
            else
               dx = -dx4
               dy = -dy4
               dz = -dz4
            end if
            r = sqrt(dx*dx + dy*dy + dz*dz)
         end if
         a(1,3) = dx / r
         a(2,3) = dy / r
         a(3,3) = dz / r
         dot = dx1*a(1,3) + dy1*a(2,3) + dz1*a(3,3)
         dx = dx1 - dot*a(1,3)
         dy = dy1 - dot*a(2,3)
         dz = dz1 - dot*a(3,3)
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,1) = dx / r
         a(2,1) = dy / r
         a(3,1) = dz / r
      end if
c
c     finally, find rotation matrix elements for the y-axis
c
      a(1,2) = a(3,1)*a(2,3) - a(2,1)*a(3,3)
      a(2,2) = a(1,1)*a(3,3) - a(3,1)*a(1,3)
      a(3,2) = a(2,1)*a(1,3) - a(1,1)*a(2,3)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine rotsite  --  rotate input multipoles to final  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "rotsite" rotates atomic multipoles from the input to final
c     frame at a specified atom by applying a rotation matrix
c
c
      subroutine rotsite (ii,a,planar,inpole,outpole)
      use mpole
      implicit none
      integer i,j,k,m,ii
      real*8 spole(maxpole)
      real*8 a(3,3)
      real*8 mp(3,3)
      real*8 rp(3,3)
      real*8 inpole(maxpole,*)
      real*8 outpole(maxpole,*)
      logical planar
      character*8 axetyp
c
c
c     copy input multipoles and modify at planar sites
c
      do i = 1, maxpole
         spole(i) = inpole(i,ii)
      end do
      if (planar) then
         axetyp = polaxe(ii)
         if (axetyp .eq. 'Z-Bisect') then
            spole(2) = 0.0d0
            spole(7) = 0.0d0
            spole(11) = 0.0d0
            spole(5) = 0.5d0 * (spole(5)+spole(9))
            spole(9) = spole(5)
         else if (axetyp .eq. '3-Fold') then
            do i = 2, maxpole
               spole(i) = 0.0d0
            end do
         end if
      end if
c
c     monopoles are the same in any coordinate frame
c
      outpole(1,ii) = spole(1)
c
c     rotate input dipoles to final coordinate frame
c
      do i = 2, 4
         outpole(i,ii) = 0.0d0
         do j = 2, 4
            outpole(i,ii) = outpole(i,ii) + spole(j)*a(i-1,j-1)
         end do
      end do
c
c     rotate input quadrupoles to final coordinate frame
c
      k = 5
      do i = 1, 3
         do j = 1, 3
            mp(i,j) = spole(k)
            rp(i,j) = 0.0d0
            k = k + 1
         end do
      end do
      do i = 1, 3
         do j = 1, 3
            if (j .lt. i) then
               rp(i,j) = rp(j,i)
            else
               do k = 1, 3
                  do m = 1, 3
                     rp(i,j) = rp(i,j) + a(i,k)*a(j,m)*mp(k,m)
                  end do
               end do
            end if
         end do
      end do
      k = 5
      do i = 1, 3
         do j = 1, 3
            outpole(k,ii) = rp(i,j)
            k = k + 1
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module rxnfld  --  reaction field matrix and indices  ##
c     ##                                                        ##
c     ############################################################
c
c
c     ijk   indices into the reaction field element arrays
c     b1    first reaction field matrix element array
c     b2    second reaction field matrix element array
c
c
      module rxnfld
      implicit none
      integer ijk(0:5,0:5,0:5)
      real*8 b1(40,13)
      real*8 b2(40,13)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module rxnpot  --  reaction field functional form details  ##
c     ##                                                             ##
c     #################################################################
c
c
c     rfsize    radius of reaction field sphere centered at origin
c     rfbulkd   bulk dielectric constant of reaction field continuum
c     rfterms   number of terms to use in reaction field summation
c
c
      module rxnpot
      implicit none
      integer rfterms
      real*8 rfsize
      real*8 rfbulkd
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program saddle  --  find conformational transition state  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "saddle" finds a transition state between two conformational
c     minima using a combination of ideas from the synchronous transit
c     (Halgren-Lipscomb) and quadratic path (Bell-Crighton) methods
c
c
      program saddle
      use atoms
      use iounit
      use keys
      use linmin
      use syntrn
      use titles
      use zcoord
      implicit none
      integer i,its,next
      integer nvar,freeunit
      integer ncalls,niter
      integer ninner,nouter
      integer ncycle,maxcycle
      integer maxinner,maxouter
      real*8 f,g_rms,g_tan,g2
      real*8 saddle1,grdmin
      real*8 reduce,diverge
      real*8 beta,sg,sg0
      real*8 gamma,gammamin
      real*8 x_move,f_move
      real*8 hg,f_old,g2_old
      real*8 f_0,f_1,f_2,f_3
      real*8 p,delta,epsilon
      real*8 angle,rmsvalue
      real*8 energy1,energy2
      real*8, allocatable :: x1(:)
      real*8, allocatable :: y1(:)
      real*8, allocatable :: z1(:)
      real*8, allocatable :: zbond1(:)
      real*8, allocatable :: zang1(:)
      real*8, allocatable :: ztors1(:)
      real*8, allocatable :: x2(:)
      real*8, allocatable :: y2(:)
      real*8, allocatable :: z2(:)
      real*8, allocatable :: zbond2(:)
      real*8, allocatable :: zang2(:)
      real*8, allocatable :: ztors2(:)
      real*8, allocatable :: xx(:)
      real*8, allocatable :: g(:)
      real*8, allocatable :: x_old(:)
      real*8, allocatable :: g_old(:)
      real*8, allocatable :: tan(:)
      real*8, allocatable :: dgdt(:)
      real*8, allocatable :: s0(:)
      real*8, allocatable :: s(:)
      real*8, allocatable :: h0(:)
      logical exist,terminate
      logical scan,spanned
      logical done,newcycle
      character*1 answer
      character*9 status
      character*20 keyword
      character*240 tsfile
      character*240 record
      character*240 string
      external saddle1
c
c
c     set default parameters for the saddle point method
c
      call initial
      terminate = .false.
      ncalls = 0
      nouter = 0
      maxouter = 100
      maxinner = 50
      maxcycle = 4
      epsilon = 0.5d0
      gammamin = 0.00001d0
      diverge = 0.005d0
      reduce = 0.0d0
c
c     set default parameters for the line search
c
      stpmin = 1.0d-16
      stpmax = 2.0d0
      cappa = 0.1d0
      slpmax = 10000.0d0
      angmax = 180.0d0
      intmax = 5
c
c     get coordinates for the first endpoint structure
c
      call getxyz
c
c     perform dynamic allocation of some local arrays
c
      allocate (x1(n))
      allocate (y1(n))
      allocate (z1(n))
      allocate (zbond1(n))
      allocate (zang1(n))
      allocate (ztors1(n))
c
c     store coordinates for the first endpoint structure
c
      do i = 1, n
         x1(i) = x(i)
         y1(i) = y(i)
         z1(i) = z(i)
      end do
c
c     get coordinates for the second endpoint structure
c
      call getxyz
c
c     perform dynamic allocation of some local arrays
c
      allocate (x2(n))
      allocate (y2(n))
      allocate (z2(n))
      allocate (zbond2(n))
      allocate (zang2(n))
      allocate (ztors2(n))
c
c     store coordinates for the second endpoint structure
c
      do i = 1, n
         x2(i) = x(i)
         y2(i) = y(i)
         z2(i) = z(i)
      end do
c
c     setup for the subsequent energy computations
c
      call mechanic
c
c     get any altered values from the keyword file
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:8) .eq. 'DIVERGE ') then
            read (string,*,err=10,end=10)  diverge
         else if (keyword(1:7) .eq. 'REDUCE ') then
            read (string,*,err=10,end=10)  reduce
         else if (keyword(1:9) .eq. 'GAMMAMIN ') then
            read (string,*,err=10,end=10)  gammamin
         end if
   10    continue
      end do
c
c     get termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=20,end=20)  grdmin
   20 continue
      if (grdmin .le. 0.0d0) then
         write (iout,30)
   30    format (/,' Enter RMS Gradient per Atom Criterion [0.1] :  ',$)
         read (input,40)  grdmin
   40    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.1d0
c
c     find out whether syncronous transit scans are desired
c
      scan = .false.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,50)
   50    format (/,' Perform Synchronous Transit Pathway Scans',
     &              ' [N] :  ',$)
         read (input,60)  record
   60    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'Y')  scan = .true.
c
c     superimpose the two conformational endpoints
c
      call impose (n,x1,y1,z1,n,x2,y2,z2,rmsvalue)
      write (iout,70)  rmsvalue
   70 format (/,' RMS Fit for All Atoms of Both Structures :',f10.4)
c
c     perform dynamic allocation of some global arrays
c
      nvar = 3 * n
      if (.not. allocated(xmin1))  allocate (xmin1(nvar))
      if (.not. allocated(xmin2))  allocate (xmin2(nvar))
      if (.not. allocated(xm))  allocate (xm(nvar))
c
c     copy the superimposed structures into vectors
c
      do i = 1, n
         xmin1(3*i-2) = x1(i)
         xmin1(3*i-1) = y1(i)
         xmin1(3*i) = z1(i)
         xmin2(3*i-2) = x2(i)
         xmin2(3*i-1) = y2(i)
         xmin2(3*i) = z2(i)
      end do
c
c     get and store internal coordinates for first endpoint
c
      do i = 1, n
         x(i) = x1(i)
         y(i) = y1(i)
         z(i) = z1(i)
      end do
      call makeint (0)
      do i = 1, n
         zbond1(i) = zbond(i)
         zang1(i) = zang(i)
         ztors1(i) = ztors(i)
      end do
c
c     get and store internal coordinates for second endpoint
c
      do i = 1, n
         x(i) = x2(i)
         y(i) = y2(i)
         z(i) = z2(i)
      end do
      call makeint (2)
      do i = 1, n
         zbond2(i) = zbond(i)
         zang2(i) = zang(i)
         ztors2(i) = ztors(i)
         if (ztors1(i)-ztors2(i) .gt. 180.0d0) then
            ztors2(i) = ztors2(i) + 360.0d0
         else if (ztors1(i)-ztors2(i) .lt. -180.0d0) then
            ztors1(i) = ztors1(i) + 360.0d0
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nvar))
      allocate (g(nvar))
      allocate (x_old(nvar))
      allocate (g_old(nvar))
      allocate (tan(nvar))
      allocate (dgdt(nvar))
      allocate (s0(nvar))
      allocate (s(nvar))
      allocate (h0(nvar))
c
c     get the energies for the two endpoint structures
c
      ncalls = ncalls + 2
      energy1 = saddle1 (xmin1,g)
      energy2 = saddle1 (xmin2,g)
      write (iout,80)  energy1,energy2
   80 format (/,' Energy Value for Endpoint Structure 1 :',f13.4,
     &        /,' Energy Value for Endpoint Structure 2 :',f13.4)
c
c     make a guess at the transition state structure;
c     or use the current guess if one is around
c
      inquire (file='tstate.xyz',exist=exist)
      if (exist) then
         write (iout,90)
   90    format (/,' Using TSTATE.XYZ as the Transition State Estimate')
         its = freeunit ()
         tsfile = 'tstate.xyz'
         call version (tsfile,'old')
         open (unit=its,file=tsfile,status='old')
         rewind (unit=its)
         call readxyz (its)
         close (unit=its)
         do i = 1, n
            xx(3*i-2) = x(i)
            xx(3*i-1) = y(i)
            xx(3*i) = z(i)
         end do
      else
         tpath = 0.5d0
         do i = 1, n
            zbond(i) = (1.0d0-tpath)*zbond1(i) + tpath*zbond2(i)
            zang(i) = (1.0d0-tpath)*zang1(i) + tpath*zang2(i)
            ztors(i) = (1.0d0-tpath)*ztors1(i) + tpath*ztors2(i)
         end do
         call makexyz
         do i = 1, n
            xx(3*i-2) = x(i)
            xx(3*i-1) = y(i)
            xx(3*i) = z(i)
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (x1)
      deallocate (y1)
      deallocate (z1)
      deallocate (zbond1)
      deallocate (zang1)
      deallocate (ztors1)
      deallocate (x2)
      deallocate (y2)
      deallocate (z2)
      deallocate (zbond2)
      deallocate (zang2)
      deallocate (ztors2)
c
c     save the initial estimate of the transition state
c
      do i = 1, n
         x(i) = xx(3*i-2)
         y(i) = xx(3*i-1)
         z(i) = xx(3*i)
      end do
      if (.not. exist) then
         title = 'Transition State Structure'
         ltitle = 26
      end if
      its = freeunit ()
      tsfile = 'tstate.xyz'
      call version (tsfile,'new')
      open (unit=its,file=tsfile,status='new')
      call prtxyz (its)
      close (unit=its)
c
c     start of the major loop for transition state location;
c     first, find the value of the transit path coordinate
c
  100 continue
      nouter = nouter + 1
      call pathval (nvar,xx)
c
c     make a scan along the synchronous transit pathway
c
      if (scan) then
         call pathscan (nvar,xmin1,xmin2,ncalls)
      end if
c
c     set parameters for use in quadratic line maximization
c
      done = .false.
      niter = 1
      ncycle = 1
      delta = 0.01d0
c
c     compute initial point for quadratic line maximization
c
      tpath = ppath
      call pathpnt (nvar,tpath,xx,xmin1,xmin2)
      ncalls = ncalls + 3
      f = saddle1 (xx,g)
      call tangent (nvar,xx,g,g_rms,tan,g_tan,gamma,dgdt)
      write (iout,110)
  110 format (/,' Search for a Maximum along Synchronous Transit :',
     &        /' ST Iter    F Value       Path      RMS G',
     &          '      G Tan      Gamma   FG Call',/)
      write (iout,120)  niter,f,tpath,g_rms,g_tan,gamma,ncalls
  120 format (i6,f13.4,f11.4,f11.4,f11.4,f11.5,i8)
c
c     make an iterative search for quadratic line maximum
c
      do while (.not. done)
         f_0 = f
         tpath = tpath + delta
         call pathpnt (nvar,tpath,xx,xmin1,xmin2)
         ncalls = ncalls + 1
         f_1 = saddle1 (xx,g)
         tpath = tpath - 2.0d0*delta
         call pathpnt (nvar,tpath,xx,xmin1,xmin2)
         tpath = tpath + delta
         ncalls = ncalls + 1
         f_2 = saddle1 (xx,g)
         if (f_1.gt.f_0 .and. f_2.gt.f_0) then
            goto 150
         else if (f_1 .gt. f_0) then
            tpath = tpath + delta
            p = 1.0d0
         else if (f_2 .gt. f_0) then
            tpath = tpath - delta
            p = -1.0d0
            f_1 = f_2
         else
            tpath = tpath + 0.5d0*delta*(f_2-f_1)/(f_1-2.0d0*f_0+f_2)
            goto 130
         end if
         spanned = .false.
         do while (.not. spanned)
            p = 2.0d0 * p
            tpath = tpath + p*delta
            if (tpath .le. 0.0d0) then
               tpath = 0.0d0
               f_2 = energy1
            else if (tpath .ge. 1.0d0) then
               tpath = 1.0d0
               f_2 = energy2
            else
               call pathpnt (nvar,tpath,xx,xmin1,xmin2)
               ncalls = ncalls + 1
               f_2 = saddle1 (xx,g)
            end if
            if (f_2 .gt. f_1) then
               f_0 = f_1
               f_1 = f_2
            else
               spanned = .true.
            end if
         end do
         p = 0.5d0 * p
         tpath = tpath - p*delta
         if (tpath .le. 0.0d0) then
            tpath = 0.0d0
            f_3 = energy1
         else if (tpath .ge. 1.0d0) then
            tpath = 1.0d0
            f_3 = energy2
         else
            call pathpnt (nvar,tpath,xx,xmin1,xmin2)
            ncalls = ncalls + 1
            f_3 = saddle1 (xx,g)
         end if
         if (f_3 .gt. f_1) then
            tpath = tpath + 0.5d0*abs(p)*delta*(f_1-f_2)
     &                         / (f_2-2.0d0*f_3+f_1)
         else
            tpath = tpath - p*delta
            tpath = tpath + 0.5d0*abs(p)*delta*(f_0-f_3)
     &                         / (f_3-2.0d0*f_1+f_0)
         end if
  130    continue
         niter = niter + 1
         call pathpnt (nvar,tpath,xx,xmin1,xmin2)
         ncalls = ncalls + 3
         f = saddle1 (xx,g)
         call tangent (nvar,xx,g,g_rms,tan,g_tan,gamma,dgdt)
         write (iout,140)  niter,f,tpath,g_rms,g_tan,gamma,ncalls
  140    format (i6,f13.4,f11.4,f11.4,f11.4,f11.5,i8)
         if (ncycle.ge.maxcycle .or. gamma.lt.gammamin) then
            done = .true.
         end if
  150    continue
         ncycle = ncycle + 1
         delta = delta * epsilon
      end do
c
c     if the path maximum is too near to an endpoint,
c     then negative curvature has probably been lost
c
      if (tpath.le.0.05d0 .or. tpath.ge.0.95d0) then
         if (.not. scan)  call pathscan (nvar,xmin1,xmin2,ncalls)
         write (iout,160)
  160    format (/,' SADDLE  --  Termination due to Loss',
     &              ' of Negative Curvature')
         call fatal
      end if
c
c     save the current maximum as the transition state estimate
c
      do i = 1, n
         x(i) = xx(3*i-2)
         y(i) = xx(3*i-1)
         z(i) = xx(3*i)
      end do
      its = freeunit ()
      tsfile = 'tstate.xyz'
      call version (tsfile,'old')
      open (unit=its,file=tsfile,status='old')
      rewind (unit=its)
      call prtxyz (its)
      close (unit=its)
c
c     the maximum is located, get ready for minimization
c
      sg = 0.0d0
      do i = 1, nvar
         s0(i) = tan(i)
         sg = sg + s0(i)*dgdt(i)
      end do
      do i = 1, nvar
         h0(i) = dgdt(i) / sg
      end do
c
c     set the initial conjugate direction for minimization
c
      ninner = 0
      g2 = 0.0d0
      hg = 0.0d0
      f_move = 1000000.0d0
      do i = 1, nvar
         g2 = g2 + g(i)**2
         hg = hg + h0(i)*g(i)
      end do
      do i = 1, nvar
         s(i) = -g(i) + hg*s0(i)
      end do
      g_rms = sqrt(g2/dble(n))
      write (iout,170)
  170 format (/,' Search for a Minimum in Conjugate Directions :',
     &        /,' CG Iter    F Value      RMS G     F Move',
     &           '    X Move    Angle   FG Call  Comment',/)
      write (iout,180)  ninner,f,g_rms,ncalls
  180 format (i6,f13.4,f11.4,30x,i7)
c
c     check the termination criterion
c
      if (g_rms .lt. grdmin) then
         terminate = .true.
         write (iout,190)
  190    format (/,' SADDLE  --  Normal Termination at',
     &              ' Transition State')
      end if
c
c     line search to find minimum in conjugate direction
c
      do while (.not. terminate)
         ninner = ninner + 1
         f_old = f
         g2_old = g2
         do i = 1, nvar
            x_old(i) = xx(i)
            g_old(i) = g(i)
         end do
         status = '         '
         angmax = 90.0d0
         call search (nvar,f,g,xx,s,f_move,angle,
     &                  ncalls,saddle1,status)
c
c     if search direction points uphill, use its negative
c
         if (status .eq. 'WideAngle') then
            do i = 1, nvar
               s(i) = -s(i)
            end do
            call search (nvar,f,g,xx,s,f_move,angle,
     &                     ncalls,saddle1,status)
         end if
c
c     compute movement and gradient following line search
c
         f_move = f_old - f
         x_move = 0.0d0
         g2 = 0.0d0
         do i = 1, nvar
            x_move = x_move + (xx(i)-x_old(i))**2
            g2 = g2 + g(i)**2
         end do
         x_move = sqrt(x_move/dble(n))
         g_rms = sqrt(g2/dble(n))
         write (iout,200)  ninner,f,g_rms,f_move,
     &                     x_move,angle,ncalls,status
  200    format (i6,f13.4,f11.4,f11.4,f10.4,f9.2,i7,3x,a9)
c
c     check the termination criteria
c
         if (g_rms .lt. grdmin) then
            terminate = .true.
            write (iout,210)
  210       format (/,' SADDLE  --  Normal Termination at',
     &                 ' Transition State')
         else if (nouter .ge. maxouter) then
            terminate = .true.
            write (iout,220)
  220       format (/,' SADDLE  --  Termination due to Maximum',
     &                 ' Iteration Limit')
         end if
c
c     check to see if another maximization is needed
c
         if (.not. terminate) then
            sg0 = 0.0d0
            do i = 1, nvar
               sg0 = sg0 + s0(i)*g(i)
            end do
            newcycle = .false.
            if (ninner .ge. maxinner)  newcycle = .true.
            if (sg0*sg0/g2 .gt. diverge)  newcycle = .true.
            if (status .ne. ' Success ')  newcycle = .true.
c
c     unfortunately, a new maximization is needed; first save
c     the current minimum as the transition state estimate
c
            if (newcycle) then
               do i = 1, n
                  x(i) = xx(3*i-2)
                  y(i) = xx(3*i-1)
                  z(i) = xx(3*i)
               end do
               its = freeunit ()
               tsfile = 'tstate.xyz'
               call version (tsfile,'old')
               open (unit=its,file=tsfile,status='old')
               rewind (unit=its)
               call prtxyz (its)
               close (unit=its)
c
c     move the path endpoints toward current transition state;
c     then jump to the start of the next maximization cycle
c
               if (reduce .ne. 0.0d0) then
                  call pathval (nvar,xx)
                  tpath = reduce * ppath
                  call pathpnt (nvar,tpath,x_old,xmin1,xmin2)
                  do i = 1, nvar
                     xmin1(i) = x_old(i)
                  end do
                  ncalls = ncalls + 1
                  energy1 = saddle1 (xmin1,g)
                  tpath = 1.0d0 - reduce*(1.0d0-ppath)
                  call pathpnt (nvar,tpath,x_old,xmin1,xmin2)
                  do i = 1, nvar
                     xmin2(i) = x_old(i)
                  end do
                  ncalls = ncalls + 1
                  energy2 = saddle1 (xmin2,g)
               end if
               goto 100
            end if
c
c     find the next conjugate search direction to search;
c     choice of "beta" is Fletcher-Reeves or Polak-Ribiere
c
            hg = 0.0d0
            do i = 1, nvar
               hg = hg + h0(i)*g(i)
            end do
            beta = 0.0d0
            do i = 1, nvar
c              beta = beta + g(i) * g(i)
               beta = beta + g(i) * (g(i)-g_old(i))
            end do
            beta = beta / g2_old
            do i = 1, nvar
               s(i) = -g(i) + hg*s0(i) + beta*s(i)
            end do
         end if
      end do
c
c     write out the final transition state structure
c
      do i = 1, n
         x(i) = xx(3*i-2)
         y(i) = xx(3*i-1)
         z(i) = xx(3*i)
      end do
      its = freeunit ()
      tsfile = 'tstate.xyz'
      call version (tsfile,'old')
      open (unit=its,file=tsfile,status='old')
      rewind (unit=its)
      call prtxyz (its)
      close (unit=its)
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      deallocate (g)
      deallocate (x_old)
      deallocate (g_old)
      deallocate (tan)
      deallocate (dgdt)
      deallocate (s0)
      deallocate (s)
      deallocate (h0)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine pathval  --  synchronous transit path values  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "pathval" computes the synchronous transit path value for
c     the specified structure
c
c
      subroutine pathval (nvar,xx)
      use atoms
      use syntrn
      implicit none
      integer i,nvar
      real*8 dr,dp,rmsvalue
      real*8 xx(*)
      real*8, allocatable :: x1(:)
      real*8, allocatable :: y1(:)
      real*8, allocatable :: z1(:)
      real*8, allocatable :: x2(:)
      real*8, allocatable :: y2(:)
      real*8, allocatable :: z2(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (x1(n))
      allocate (y1(n))
      allocate (z1(n))
      allocate (x2(n))
      allocate (y2(n))
      allocate (z2(n))
c
c     find the value of the transit path coordinate "ppath";
c     it is the ratio of the rms fits to the two endpoints
c
      do i = 1, n
         x1(i) = xmin1(3*i-2)
         y1(i) = xmin1(3*i-1)
         z1(i) = xmin1(3*i)
         x2(i) = xx(3*i-2)
         y2(i) = xx(3*i-1)
         z2(i) = xx(3*i)
      end do
      call impose (n,x1,y1,z1,n,x2,y2,z2,dr)
      do i = 1, n
         x1(i) = xmin2(3*i-2)
         y1(i) = xmin2(3*i-1)
         z1(i) = xmin2(3*i)
         x2(i) = xx(3*i-2)
         y2(i) = xx(3*i-1)
         z2(i) = xx(3*i)
      end do
      call impose (n,x1,y1,z1,n,x2,y2,z2,dp)
      ppath = dr / (dr+dp)
c
c     superimpose on linear transit structure of same path value
c
      do i = 1, n
         x1(i) = (1.0d0-ppath)*xmin1(3*i-2) + ppath*xmin2(3*i-2)
         y1(i) = (1.0d0-ppath)*xmin1(3*i-1) + ppath*xmin2(3*i-1)
         z1(i) = (1.0d0-ppath)*xmin1(3*i) + ppath*xmin2(3*i)
         x2(i) = xx(3*i-2)
         y2(i) = xx(3*i-1)
         z2(i) = xx(3*i)
      end do
      call impose (n,x1,y1,z1,n,x2,y2,z2,rmsvalue)
      do i = 1, n
         xx(3*i-2) = x2(i)
         xx(3*i-1) = y2(i)
         xx(3*i) = z2(i)
      end do
      do i = 1, nvar
         xm(i) = xx(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (x1)
      deallocate (y1)
      deallocate (z1)
      deallocate (x2)
      deallocate (y2)
      deallocate (z2)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine pathscan  --  scan along the transit pathway  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "pathscan" makes a scan of a synchronous transit pathway by
c     computing structures and energies for specific path values
c
c
      subroutine pathscan (nvar,x0,x1,ncalls)
      use iounit
      use syntrn
      implicit none
      integer i,nvar,ncalls
      real*8 energy,gamma
      real*8 g_rms,g_tan
      real*8 saddle1
      real*8 x0(*)
      real*8 x1(*)
      real*8, allocatable :: xx(:)
      real*8, allocatable :: g(:)
      real*8, allocatable :: tan(:)
      real*8, allocatable :: dgdt(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nvar))
      allocate (g(nvar))
      allocate (tan(nvar))
      allocate (dgdt(nvar))
c
c     make a scan along the synchronous transit pathway
c
      write (iout,10)
   10 format (/,' Scan of the Synchronous Transit Pathway :',
     &        /,' N Scan     F Value       Path      RMS G',
     &           '      G Tan      Gamma   FG Call',/)
      do i = 0, 10
         tpath = 0.1d0 * dble(i)
         call pathpnt (nvar,tpath,xx,x0,x1)
         ncalls = ncalls + 3
         energy = saddle1 (xx,g)
         call tangent (nvar,xx,g,g_rms,tan,g_tan,gamma,dgdt)
         write (iout,20)  i,energy,tpath,g_rms,g_tan,gamma,ncalls
   20    format (i6,f13.4,f11.4,f11.4,f11.4,f11.5,i8)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      deallocate (g)
      deallocate (tan)
      deallocate (dgdt)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine pathpnt  --  get coordinates of path point  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "pathpnt" finds a structure on the synchronous transit path
c     with the specified path value "tpath"
c
c
      subroutine pathpnt (nvar,tpath,xx,x0,x1)
      use inform
      use minima
      implicit none
      integer i,nvar
      real*8 tpath
      real*8 value
      real*8 grdmin
      real*8 transit
      real*8 xx(*)
      real*8 x0(*)
      real*8 x1(*)
      external transit
      external optsave
c
c
c     initialize some parameters for the upcoming optimization
c
      if (debug) then
         iprint = 1
      else
         iprint = 0
      end if
      iwrite = 0
      maxiter = 1000
      grdmin = 0.00001d0
c
c     interpolate coordinates to give initial estimate
c
      do i = 1, nvar
         xx(i) = (1.0d0-tpath)*x0(i) + tpath*x1(i)
      end do
c
c     optimize the synchronous transit function
c
c     call lbfgs (nvar,xx,value,grdmin,transit,optsave)
      call ocvm (nvar,xx,value,grdmin,transit,optsave)
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine tangent  --  synchronous transit tangent  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "tangent" finds the projected gradient on the synchronous
c     transit path for a point along the transit pathway
c
c
      subroutine tangent (nvar,xx,g,g_rms,tan,g_tan,gamma,dgdt)
      use atoms
      use syntrn
      implicit none
      integer i,nvar
      real*8 g_rms,g_tan
      real*8 gamma,delta
      real*8 t0,g2,tan_norm
      real*8 energy,saddle1
      real*8 xx(*)
      real*8 g(*)
      real*8 tan(*)
      real*8 dgdt(*)
      real*8, allocatable :: xf(:)
      real*8, allocatable :: xb(:)
      real*8, allocatable :: gf(:)
      real*8, allocatable :: gb(:)
c
c
c     set the finite difference path increment
c
      delta = 0.01d0
c
c     store the initial pathpnt and compute gradient norm
c
      t0 = tpath
      g2 = 0.0d0
      do i = 1, nvar
         g2 = g2 + g(i)**2
      end do
      g_rms = sqrt(g2/dble(n))
c
c     perform dynamic allocation of some local arrays
c
      allocate (xf(nvar))
      allocate (xb(nvar))
      allocate (gf(nvar))
      allocate (gb(nvar))
c
c     compute the forward difference
c
      do i = 1, nvar
         xf(i) = xx(i)
      end do
      tpath = t0 + delta
      call pathpnt (nvar,tpath,xf,xf,xf)
      energy = saddle1 (xf,gf)
c
c     compute the backward difference
c
      do i = 1, nvar
         xb(i) = xx(i)
      end do
      tpath = t0 - delta
      call pathpnt (nvar,tpath,xb,xb,xb)
      energy = saddle1 (xb,gb)
      tpath = t0
c
c     compute tangent to the path, and projected gradient
c
      tan_norm = 0.0d0
      do i = 1, nvar
         tan(i) = xf(i) - xb(i)
         tan_norm = tan_norm + tan(i)**2
         dgdt(i) = gf(i) - gb(i)
      end do
      tan_norm = sqrt(tan_norm)
      g_tan = 0.0d0
      do i = 1, nvar
         tan(i) = tan(i) / tan_norm
         g_tan = g_tan + g(i)*tan(i)
      end do
      g_tan = g_tan / sqrt(dble(n))
      gamma = (g_tan/g_rms)**2
c
c     perform deallocation of some local arrays
c
      deallocate (xf)
      deallocate (xb)
      deallocate (gf)
      deallocate (gb)
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  function transit  --  synchronous transit evaluation  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "transit" evaluates the synchronous transit function and
c     gradient; linear and quadratic transit paths are available
c
c
      function transit (xx,g)
      use atoms
      use syntrn
      implicit none
      integer i,j,nvar
      integer ix,iy,iz
      integer jx,jy,jz
      real*8 transit,value
      real*8 xci,yci,zci
      real*8 xcd,ycd,zcd
      real*8 x1i,y1i,z1i
      real*8 x1d,y1d,z1d
      real*8 x2i,y2i,z2i
      real*8 x2d,y2d,z2d
      real*8 xmi,ymi,zmi
      real*8 xmd,ymd,zmd
      real*8 gamma,term
      real*8 termx,termy,termz
      real*8 cutoff,cutoff2
      real*8 r1,r2,rc,rm
      real*8 ri,ri4,rd
      real*8 wi,wc,wd
      real*8 tq,pq
      real*8 xx(*)
      real*8 g(*)
      character*9 mode
c
c
c     zero out the synchronous transit function and gradient
c
      value = 0.0d0
      nvar = 3 * n
      do i = 1, nvar
         g(i) = 0.0d0
      end do
      tq = 1.0d0 - tpath
c
c     set the cutoff distance for interatomic distances
c
      cutoff = 1000.0d0
      cutoff2 = cutoff**2
c
c     set the type of synchronous transit path to be used
c
      if (ppath .eq. 0.0d0) then
         mode = 'LINEAR'
      else
         mode = 'QUADRATIC'
         pq = 1.0d0 - ppath
      end if
c
c     portion based on interpolated interatomic distances
c
      do i = 1, n-1
         iz = 3 * i
         iy = iz - 1
         ix = iz - 2
         xci = xx(ix)
         yci = xx(iy)
         zci = xx(iz)
         x1i = xmin1(ix)
         y1i = xmin1(iy)
         z1i = xmin1(iz)
         x2i = xmin2(ix)
         y2i = xmin2(iy)
         z2i = xmin2(iz)
         if (mode .eq. 'QUADRATIC') then
            xmi = xm(ix)
            ymi = xm(iy)
            zmi = xm(iz)
         end if
         do j = i+1, n
            jz = 3 * j
            jy = jz - 1
            jx = jz - 2
            xcd = xci - xx(jx)
            ycd = yci - xx(jy)
            zcd = zci - xx(jz)
            x1d = x1i - xmin1(jx)
            y1d = y1i - xmin1(jy)
            z1d = z1i - xmin1(jz)
            x2d = x2i - xmin2(jx)
            y2d = y2i - xmin2(jy)
            z2d = z2i - xmin2(jz)
            rc = xcd**2 + ycd**2 + zcd**2
            r1 = x1d**2 + y1d**2 + z1d**2
            r2 = x2d**2 + y2d**2 + z2d**2
            if (min(rc,r1,r2) .lt. cutoff2) then
               rc = sqrt(rc)
               r1 = sqrt(r1)
               r2 = sqrt(r2)
               ri = tq*r1 + tpath*r2
               if (mode .eq. 'QUADRATIC') then
                  xmd = xmi - xm(jx)
                  ymd = ymi - xm(jy)
                  zmd = zmi - xm(jz)
                  rm = sqrt(xmd**2+ymd**2+zmd**2)
                  gamma = (rm-pq*r1-ppath*r2) / (ppath*pq)
                  ri = ri + gamma*tpath*tq
               end if
               ri4 = ri**4
               rd = rc - ri
               value = value + rd**2/ri4
               term = 2.0d0 * rd/(ri4*rc)
               termx = term * xcd
               termy = term * ycd
               termz = term * zcd
               g(ix) = g(ix) + termx
               g(iy) = g(iy) + termy
               g(iz) = g(iz) + termz
               g(jx) = g(jx) - termx
               g(jy) = g(jy) - termy
               g(jz) = g(jz) - termz
            end if
         end do
      end do
c
c     portion used to supress rigid rotations and translations
c
      do i = 1, nvar
         wc = xx(i)
         wi = tq*xmin1(i) + tpath*xmin2(i)
         wd = wc - wi
         value = value + 0.000001d0*wd**2
         g(i) = g(i) + 0.000002d0*wd
      end do
      transit = value
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  function saddle1  --  energy and gradient for saddle  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "saddle1" is a service routine that computes the energy and
c     gradient for transition state optimization
c
c
      function saddle1 (xx,g)
      use atoms
      implicit none
      integer i
      real*8 e,saddle1
      real*8 xx(*)
      real*8 g(*)
c
c
c     copy optimization values to coordinates and find gradient
c
      do i = 1, n
         x(i) = xx(3*i-2)
         y(i) = xx(3*i-1)
         z(i) = xx(3*i)
      end do
      call gradient (e,g)
      saddle1 = e
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module scales  --  optimization parameter scale factors  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     scale      multiplicative factor for each optimization parameter
c     set_scale  logical flag to show if scale factors have been set
c
c
      module scales
      implicit none
      real*8, allocatable :: scale(:)
      logical set_scale
      save
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 1998 by Rohit Pappu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program scan  --  maps minima on potential energy surface  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "scan" attempts to find all the local minima on a potential
c     energy surface via an iterative series of local searches along
c     normal mode directions
c
c     literature reference:
c
c     I. Kolossvary and W. C. Guida, "Low-Mode Conformational Search
c     Elucidated: Application to C39H80 and Flexible Docking of
c     9-Deazaguanine Inhibitors into PNP, Journal of Computational
c     Chemistry, 20, 1671-1684 (1999)
c
c
      program scan
      use files
      use inform
      use iounit
      use omega
      use output
      implicit none
      integer maxmap
      parameter (maxmap=100000)
      integer i,ixyz
      integer lext,freeunit
      integer nmap,niter
      integer nvec,neigen
      real*8 minimum,grdmin,range
      real*8 emap(maxmap)
      logical exist
      character*7 ext
      character*240 xyzfile
      character*240 string
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     initialize the number of minima and coordinate type
c
      nmap = 0
      coordtype = 'CARTESIAN'
c
c     get the rotatable bonds for torsional local search
c
      call makeint (0)
      call initrot
      call active
c
c     get the number of eigenvectors to use for the local search
c
      neigen = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  neigen
   10 continue
      nvec = min(nomega,5)
      if (neigen .le. 0) then
         write (iout,20)  nvec
   20    format(/,' Enter the Number of Eigenvectors for Local',
     &             ' Search [',i1,'] :  ',$)
         read (input,30)  neigen
   30    format (i10)
         if (neigen .le. 0)  neigen = nvec
      end if
      neigen = min(neigen,nvec)
c
c     get the energy threshold criterion for map membership
c
      range = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=40,end=40)  range
   40 continue
      if (range .le. 0.0d0) then
         write (iout,50)
   50    format (/,' Enter the Energy Threshold for Local Minima',
     &              ' [100.0] :  ',$)
         read (input,60)  range
   60    format (f20.0)
      end if
      if (range .le. 0.0d0)  range = 100.0d0
c
c     get the termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=70,end=70)  grdmin
   70 continue
      if (grdmin .le. 0.0d0) then
         write (iout,80)
   80    format (/,' Enter RMS Gradient per Atom Criterion',
     &              ' [0.0001] :  ',$)
         read (input,90)  grdmin
   90    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.0001d0
c
c     set the energy output precision via convergence criterion
c
      if (grdmin .le. 0.000001d0)  digits = 6
      if (grdmin .le. 0.00000001d0)  digits = 8
c
c     create and open an output file if using archive mode
c
      if (archive) then
         ixyz = freeunit ()
         xyzfile = filename(1:leng)
         call suffix (xyzfile,'arc','new')
         open (unit=ixyz,file=xyzfile,status='new')
         close (unit=ixyz)
      end if
c
c     find the first map point from the input structure
c
      write (iout,100)
  100 format (/,' Generating Seed Point for Potential Energy',
     &           ' Surface Scan',/)
      call localmin (minimum,grdmin)
      call mapcheck (nmap,emap,range,minimum,grdmin)
c
c     use normal mode local search to explore adjacent minima
c
      niter = 0
      do while (niter .lt. nmap)
         niter = niter + 1
         write (iout,110)  niter
  110    format (/,' Normal Mode Local Search',7x,'Minimum',i7,/)
         ixyz = freeunit ()
         if (archive) then
            xyzfile = filename(1:leng)
            call suffix (xyzfile,'arc','old')
            open (unit=ixyz,file=xyzfile,status='old')
            do i = 1, niter-1
               call readxyz (ixyz)
            end do
         else
            lext = 3
            call numeral (niter,ext,lext)
            xyzfile = filename(1:leng)//'.'//ext(1:lext)
            call version (xyzfile,'old')
            open (unit=ixyz,file=xyzfile,status='old')
         end if
         call readxyz (ixyz)
         close (unit=ixyz)
         call modesrch (nmap,emap,range,neigen,grdmin)
      end do
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine mapcheck  --  addition to local minimum list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "mapcheck" checks the current minimum energy structure
c     for possible addition to the master list of local minima
c
c
      subroutine mapcheck (nmap,emap,range,minimum,grdmin)
      use files
      use inform
      use iounit
      use output
      implicit none
      integer i,ixyz,lext
      integer nmap,freeunit
      real*8 minimum,grdmin
      real*8 delta,eps,range
      real*8 emap(*)
      logical unique,exist
      character*7 ext
      character*240 xyzfile
c
c
c     check to see if the current minimum was previously found
c
      eps = grdmin
      unique = .true.
      do i = 1, nmap
         delta = minimum - emap(i)
         if (abs(delta) .lt. eps)  unique = .false.
         if (delta .gt. range)  unique = .false.
      end do
c
c     add minimum to master list if it was not previously known
c
      if (unique) then
         nmap = nmap + 1
         emap(nmap) = minimum
         if (digits .ge. 8) then
            write (iout,10)  nmap,minimum
   10       format (/,4x,'Potential Surface Map',7x,'Minimum',
     &                 i7,6x,f20.8,/)
         else if (digits .ge. 6) then
            write (iout,20)  nmap,minimum
   20       format (/,4x,'Potential Surface Map',7x,'Minimum',
     &                 i7,6x,f18.6,/)
         else
            write (iout,30)  nmap,minimum
   30       format (/,4x,'Potential Surface Map',7x,'Minimum',
     &                 i7,6x,f16.4,/)
         end if
c
c     write the coordinates of the new minimum to a file
c
         ixyz = freeunit ()
         if (archive) then
            xyzfile = filename(1:leng)
            call suffix (xyzfile,'arc','old')
            inquire (file=xyzfile,exist=exist)
            if (exist) then
               call openend (ixyz,xyzfile)
            else
               open (unit=ixyz,file=xyzfile,status='new')
            end if
         else
            lext = 3
            call numeral (nmap,ext,lext)
            xyzfile = filename(1:leng)//'.'//ext(1:lext)
            call version (xyzfile,'new')
            open (unit=ixyz,file=xyzfile,status='new')
         end if
         call prtxyz (ixyz)
         close (unit=ixyz)
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  function scan1  --  energy and gradient values for scan  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "scan1" is a service routine that computes the energy and
c     gradient during exploration of a potential energy surface
c     via iterative local search
c
c
      function scan1 (xx,g)
      use atoms
      implicit none
      integer i,nvar
      real*8 scan1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the energy and gradient
c
      call gradient (e,derivs)
      scan1 = e
c
c     convert gradient components to optimization parameters
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         g(nvar) = derivs(1,i)
         nvar = nvar + 1
         g(nvar) = derivs(2,i)
         nvar = nvar + 1
         g(nvar) = derivs(3,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine scan2  --  Hessian matrix values for scan  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "scan2" is a service routine that computes the sparse matrix
c     Hessian elements during exploration of a potential energy
c     surface via iterative local search
c
c
      subroutine scan2 (mode,xx,h,hinit,hstop,hindex,hdiag)
      use atoms
      implicit none
      integer i,nvar
      integer hinit(*)
      integer hstop(*)
      integer hindex(*)
      real*8 xx(*)
      real*8 hdiag(*)
      real*8 h(*)
      character*4 mode
c
c
c     translate optimization parameters to atomic coordinates
c
      if (mode .eq. 'NONE')  return
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     compute and store the Hessian elements
c
      call hessian (h,hinit,hstop,hindex,hdiag)
      return
      end
c
c
c     #########################################################
c     ##                                                     ##
c     ##  subroutine modesrch  --  normal mode local search  ##
c     ##                                                     ##
c     #########################################################
c
c
      subroutine modesrch (nmap,emap,range,neigen,grdmin)
      use iounit
      use omega
      implicit none
      integer i,k,nsearch
      integer nmap,neigen
      real*8 minimum,grdmin,range
      real*8 emap(*)
      real*8, allocatable :: step(:)
      real*8, allocatable :: eigen(:)
      real*8, allocatable :: vects(:,:)
c
c
c     store the current coordinates as the reference set
c
      call makeref (1)
c
c     perform dynamic allocation of some local arrays
c
      allocate (step(nomega))
      allocate (eigen(nomega))
      allocate (vects(nomega,nomega))
c
c     convert to internal coordinates and find torsional modes
c
      call makeint (0)
      call eigenrot (eigen,vects)
c
c     search both directions along each torsional eigenvector
c
      nsearch = 0
      do i = 1, neigen
         do k = 1, nomega
            step(k) = vects(k,nomega-i+1)
         end do
         nsearch = nsearch + 1
         call climber (nsearch,minimum,step,grdmin)
         call mapcheck (nmap,emap,range,minimum,grdmin)
         do k = 1, nomega
            step(k) = -vects(k,nomega-i+1)
         end do
         nsearch = nsearch + 1
         call climber (nsearch,minimum,step,grdmin)
         call mapcheck (nmap,emap,range,minimum,grdmin)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (step)
      deallocate (eigen)
      deallocate (vects)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eigenrot  --  torsional Hessian eigenvectors  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine eigenrot (eigen,vects)
      use atoms
      use omega
      implicit none
      integer i,j,ihess
      real*8 vnorm
      real*8 eigen(*)
      real*8, allocatable :: matrix(:)
      real*8 vects(nomega,*)
      real*8, allocatable :: hrot(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (matrix(nomega*(nomega+1)/2))
      allocate (hrot(nomega,nomega))
c
c     compute the Hessian in torsional space
c
      call hessrot ('FULL',hrot)
c
c     place Hessian elements into triangular form
c
      ihess = 0
      do i = 1, nomega
         do j = i, nomega
            ihess = ihess + 1
            matrix(ihess) = hrot(i,j)
         end do
      end do
c
c     diagonalize the Hessian to obtain eigenvalues
c
      call diagq (nomega,nomega,matrix,eigen,vects)
c
c     perform deallocation of some local arrays
c
      deallocate (matrix)
      deallocate (hrot)
c
c     normalize the torsional Hessian eigenvectors
c
      do i = 1, nomega
         vnorm = 0.0d0
         do j = 1, nomega
            vnorm = vnorm + vects(j,i)**2
         end do
         vnorm = sqrt(vnorm)
         do j = 1, nomega
            vects(j,i) = vects(j,i) / vnorm
         end do
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine climber  --  explore single search direction  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine climber (nsearch,minimum,step,grdmin)
      use inform
      use iounit
      use math
      use omega
      use potent
      use zcoord
      implicit none
      integer maxstep
      parameter (maxstep=500)
      integer i,kstep
      integer nstep,nsearch
      real*8 minimum,grdmin
      real*8 big,energy,size
      real*8 estep(0:maxstep)
      real*8 step(*)
      logical done
      logical oldpolar
c
c
c     convert current reference coordinates to a Z-matrix
c
      call getref (1)
      call makeint (0)
c
c     set the maximum number of steps and the step size
c
      done = .false.
      big = 100000.0d0
      minimum = big
      kstep = 0
      nstep = 65
      size = 0.1d0 * radian
      do i = 1, nomega
         step(i) = size * step(i)
      end do
c
c     scan the search direction for a minimization candidate
c
      do while (.not. done)
         if (kstep .ne. 0) then
            do i = 1, nomega
               ztors(zline(i)) = ztors(zline(i)) + step(i)
            end do
         end if
         call makexyz
         oldpolar = use_polar
         use_polar = .false.
         estep(kstep) = energy ()
         use_polar = oldpolar
         if (kstep .ge. 2) then
            if (estep(kstep) .lt. estep(kstep-2) .and.
     &          estep(kstep-1) .lt. estep(kstep-2)) then
               done = .true.
               do i = 1, nomega
                  ztors(zline(i)) = ztors(zline(i)) - step(i)
               end do
               call makexyz
               call localmin (minimum,grdmin)
               if (minimum .le. -big) then
                  minimum = big
                  write (iout,10)  nsearch
   10             format (4x,'Search Direction',i4,38x,'<<<<<<')
               else if (minimum .ge. big) then
                  minimum = big
                  write (iout,20)  nsearch
   20             format (4x,'Search Direction',i4,38x,'>>>>>>')
               else
                  if (digits .ge. 8) then
                     write (iout,30)  nsearch,kstep-1,minimum
   30                format (4x,'Search Direction',i4,11x,'Step',
     &                          i7,6x,f20.8)
                  else if (digits .ge. 6) then
                     write (iout,40)  nsearch,kstep-1,minimum
   40                format (4x,'Search Direction',i4,11x,'Step',
     &                          i7,6x,f18.6)
                  else
                     write (iout,50)  nsearch,kstep-1,minimum
   50                format (4x,'Search Direction',i4,11x,'Step',
     &                          i7,6x,f16.4)
                  end if
               end if
            end if
         end if
         if (kstep.ge.nstep .and. .not.done) then
            done = .true.
            write (iout,60)  nsearch
   60       format (4x,'Search Direction',i4,38x,'------')
         end if
         kstep = kstep + 1
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine localmin  --  optimize local search candidate  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "localmin" is used during normal mode local search to
c     perform a Cartesian coordinate energy minimization
c
c
      subroutine localmin (minimum,grdmin)
      use atoms
      use inform
      use minima
      use output
      use potent
      use scales
      implicit none
      integer i,j,nvar
      real*8 minimum,scan1
      real*8 grdmin,oldgrd
      real*8 gnorm,grms,big
      real*8, allocatable :: xx(:)
      real*8, allocatable :: derivs(:,:)
      logical oldverb,oldpolar
      character*6 mode,method
      external scan1,scan2
      external optsave
c
c
c     initialize optimization output and maximum energy
c
      iwrite = 0
      iprint = 0
      big = 100000.0d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(3*n))
c
c     convert atomic coordinates to optimization parameters
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         xx(nvar) = x(i)
         nvar = nvar + 1
         xx(nvar) = y(i)
         nvar = nvar + 1
         xx(nvar) = z(i)
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (.not. set_scale) then
         if (.not. allocated(scale))  allocate (scale(nvar))
c
c     set scaling parameters to unity due to mixed optimization
c
         set_scale = .true.
         do i = 1, nvar
            scale(i) = 1.0d0
         end do
      end if
c
c     adjust polarization and set initial optimization values
c
      oldverb = verbose
      oldpolar = use_polar
      oldgrd = grdmin
      verbose = .false.
      use_polar = .false.
      grdmin = 3.0
c
c     initial optimizaton to get close to approximate minimum
c
      call lbfgs (nvar,xx,minimum,grdmin,scan1,optsave)
c
c     secondary optimization to reach the exact local minimum
c
      use_polar = oldpolar
      grdmin = oldgrd
      mode = 'AUTO'
      method = 'AUTO'
      call tncg (mode,method,nvar,xx,minimum,
     &           grdmin,scan1,scan2,optsave)
      verbose = oldverb
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     independently check the gradient convergence criterion
c
      call gradient (minimum,derivs)
      gnorm = 0.0d0
      do i = 1, n
         do j = 1, 3
            gnorm = gnorm + derivs(j,i)**2
         end do
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(n))
      if (grms .gt. grdmin)  minimum = big
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 1998 by Rohit Pappu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine sdstep  --  Verlet stochastic dynamics step  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "sdstep" performs a stochastic dynamics time step via the
c     velocity Verlet-based algorithm of Guarnieri and Still
c
c     literature references:
c
c     M. P. Allen, "Brownian Dynamics Simulation of a Chemical
c     Reaction in Solution", Molecular Physics, 40, 1073-1087 (1980)
c
c     F. Guarnieri and W. C. Still, "A Rapidly Convergent Simulation
c     Method: Mixed Monte Carlo/Stochastic Dynamics", Journal of
c     Computational Chemistry, 15, 1302-1310 (1994)
c
c
      subroutine sdstep (istep,dt)
      use atomid
      use atoms
      use freeze
      use moldyn
      use units
      use usage
      use virial
      implicit none
      integer i,j,k
      integer istep
      real*8 dt,term
      real*8 epot,etot
      real*8 eksum
      real*8 temp,pres
      real*8 vxx,vyy,vzz
      real*8 vyx,vzx,vzy
      real*8 ekin(3,3)
      real*8 stress(3,3)
      real*8, allocatable :: xold(:)
      real*8, allocatable :: yold(:)
      real*8, allocatable :: zold(:)
      real*8, allocatable :: pfric(:)
      real*8, allocatable :: vfric(:)
      real*8, allocatable :: afric(:)
      real*8, allocatable :: prand(:,:)
      real*8, allocatable :: vrand(:,:)
      real*8, allocatable :: derivs(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xold(n))
      allocate (yold(n))
      allocate (zold(n))
      allocate (pfric(n))
      allocate (vfric(n))
      allocate (afric(n))
      allocate (prand(3,n))
      allocate (vrand(3,n))
      allocate (derivs(3,n))
c
c     get frictional and random terms for position and velocity
c
      call sdterm (istep,dt,pfric,vfric,afric,prand,vrand)
c
c     store the current atom positions, then find full-step
c     positions and half-step velocities via modified Verlet
c
      do i = 1, nuse
         k = iuse(i)
         xold(k) = x(k)
         yold(k) = y(k)
         zold(k) = z(k)
         x(k) = x(k) + v(1,k)*vfric(k) + a(1,k)*afric(k) + prand(1,k)
         y(k) = y(k) + v(2,k)*vfric(k) + a(2,k)*afric(k) + prand(2,k)
         z(k) = z(k) + v(3,k)*vfric(k) + a(3,k)*afric(k) + prand(3,k)
         do j = 1, 3
            v(j,k) = v(j,k)*pfric(k) + 0.5d0*a(j,k)*vfric(k)
         end do
      end do
c
c     get constraint-corrected positions and half-step velocities
c
      if (use_freeze)  call rattle (dt,xold,yold,zold)
c
c     get the potential energy and atomic forces
c
      call gradient (epot,derivs)
c
c     correct internal virial to account for frictional forces
c
      do i = 1, nuse
         k = iuse(i)
         term = vfric(k)/dt - 1.0d0
         vxx = term * x(k) * derivs(1,k)
         vyx = 0.5d0 * term * (y(k)*derivs(1,k)+x(k)*derivs(2,k))
         vzx = 0.5d0 * term * (z(k)*derivs(1,k)+x(k)*derivs(3,k))
         vyy = term * y(k) * derivs(2,k)
         vzy = 0.5d0 * term * (z(k)*derivs(2,k)+y(k)*derivs(3,k))
         vzz = term * z(k) * derivs(3,k)
         vir(1,1) = vir(1,1) + vxx
         vir(2,1) = vir(2,1) + vyx
         vir(3,1) = vir(3,1) + vzx
         vir(1,2) = vir(1,2) + vyx
         vir(2,2) = vir(2,2) + vyy
         vir(3,2) = vir(3,2) + vzy
         vir(1,3) = vir(1,3) + vzx
         vir(2,3) = vir(2,3) + vzy
         vir(3,3) = vir(3,3) + vzz
      end do
c
c     compute the kinetic energy from half-step velocities
c
c     call kinetic (eksum,ekin,temp)
c
c     use Newton's second law to get the next accelerations;
c     find the full-step velocities using modified Verlet
c
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            a(j,k) = -ekcal * derivs(j,k) / mass(k)
            v(j,k) = v(j,k) + 0.5d0*a(j,k)*vfric(k) + vrand(j,k)
         end do
      end do
c
c     find the constraint-corrected full-step velocities
c
      if (use_freeze) then
         call rattle2 (dt)
         do i = 1, nuse
            k = iuse(i)
            xold(k) = x(k)
            yold(k) = y(k)
            zold(k) = z(k)
         end do
      end if
c
c     compute full-step kinetic energy and pressure correction
c
      call kinetic (eksum,ekin,temp)
      call pressure (dt,ekin,pres,stress)
      call pressure2 (epot,temp)
c
c     final constraint step to enforce position convergence
c
      if (use_freeze)  call shake (xold,yold,zold)
c
c     perform deallocation of some local arrays
c
      deallocate (xold)
      deallocate (yold)
      deallocate (zold)
      deallocate (pfric)
      deallocate (vfric)
      deallocate (afric)
      deallocate (prand)
      deallocate (vrand)
      deallocate (derivs)
c
c     total energy is sum of kinetic and potential energies
c
      etot = eksum + epot
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,eksum,temp,pres)
      call mdsave (istep,dt,epot,eksum)
      call mdrest (istep)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine sdterm  --  SD friction & fluctuation terms  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "sdterm" finds the friction and fluctuation terms needed to
c     update positions and velocities during  stochastic dynamics
c     via the method of Guarnieri and Still
c
c
      subroutine sdterm (istep,dt,pfric,vfric,afric,prand,vrand)
      use atoms
      use atomid
      use bath
      use stodyn
      use units
      use usage
      implicit none
      integer i,j,k
      integer istep
      real*8 dt,ktm
      real*8 gdt,egdt
      real*8 gdt2,gdt3
      real*8 gdt4,gdt5
      real*8 gdt6,gdt7
      real*8 gdt8,gdt9
      real*8 pterm,vterm
      real*8 pnorm,vnorm
      real*8 normal
      real*8 psig,vsig
      real*8 rho,rhoc
      real*8 pfric(*)
      real*8 vfric(*)
      real*8 afric(*)
      real*8 prand(3,*)
      real*8 vrand(3,*)
      logical first
      external normal
      save first
      data first  / .true. /
c
c
c     perform dynamic allocation of some global arrays
c
      if (first) then
         first = .false.
         if (.not. allocated(fgamma))  allocate (fgamma(n))
c
c     set the atomic friction coefficients to the global value
c
         do i = 1, n
            fgamma(i) = friction
         end do
      end if
c
c     set the value of the friction coefficient for each atom
c
      if (use_sdarea)  call sdarea (istep)
c
c     get the frictional and random terms for stochastic dynamics
c
      do i = 1, nuse
         k = iuse(i)
         gdt = fgamma(k) * dt
c
c     stochastic dynamics reduces to simple MD for zero friction
c
         if (gdt .le. 0.0d0) then
            pfric(k) = 1.0d0
            vfric(k) = dt
            afric(k) = 0.5d0 * dt * dt
            do j = 1, 3
               prand(j,k) = 0.0d0
               vrand(j,k) = 0.0d0
            end do
c
c     analytical expressions when friction coefficient is large
c
         else
            if (gdt .ge. 0.05d0) then
               egdt = exp(-gdt)
               pfric(k) = egdt
               vfric(k) = (1.0d0-egdt) / fgamma(k)
               afric(k) = (dt-vfric(k)) / fgamma(k)
               pterm = 2.0d0*gdt - 3.0d0 + (4.0d0-egdt)*egdt
               vterm = 1.0d0 - egdt**2
               rho = (1.0d0-egdt)**2 / sqrt(pterm*vterm)
c
c     use series expansions when friction coefficient is small
c
            else
               gdt2 = gdt * gdt
               gdt3 = gdt * gdt2
               gdt4 = gdt2 * gdt2
               gdt5 = gdt2 * gdt3
               gdt6 = gdt3 * gdt3
               gdt7 = gdt3 * gdt4
               gdt8 = gdt4 * gdt4
               gdt9 = gdt4 * gdt5
               afric(k) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0
     &                       - gdt5/120.0d0 + gdt6/720.0d0
     &                       - gdt7/5040.0d0 + gdt8/40320.0d0
     &                       - gdt9/362880.0d0) / fgamma(k)**2
               vfric(k) = dt - fgamma(k)*afric(k)
               pfric(k) = 1.0d0 - fgamma(k)*vfric(k)
               pterm = 2.0d0*gdt3/3.0d0 - gdt4/2.0d0
     &                    + 7.0d0*gdt5/30.0d0 - gdt6/12.0d0
     &                    + 31.0d0*gdt7/1260.0d0 - gdt8/160.0d0
     &                    + 127.0d0*gdt9/90720.0d0
               vterm = 2.0d0*gdt - 2.0d0*gdt2 + 4.0d0*gdt3/3.0d0
     &                    - 2.0d0*gdt4/3.0d0 + 4.0d0*gdt5/15.0d0
     &                    - 4.0d0*gdt6/45.0d0 + 8.0d0*gdt7/315.0d0
     &                    - 2.0d0*gdt8/315.0d0 + 4.0d0*gdt9/2835.0d0
               rho = sqrt(3.0d0) * (0.5d0 - gdt/16.0d0
     &                    - 17.0d0*gdt2/1280.0d0
     &                    + 17.0d0*gdt3/6144.0d0
     &                    + 40967.0d0*gdt4/34406400.0d0
     &                    - 57203.0d0*gdt5/275251200.0d0
     &                    - 1429487.0d0*gdt6/13212057600.0d0
     &                    + 1877509.0d0*gdt7/105696460800.0d0)
            end if
c
c     compute random terms to thermostat the nonzero friction case
c
            ktm = boltzmann * kelvin / mass(k)
            psig = sqrt(ktm*pterm) / fgamma(k)
            vsig = sqrt(ktm*vterm)
            rhoc = sqrt(1.0d0 - rho*rho)
            do j = 1, 3
               pnorm = normal ()
               vnorm = normal ()
               prand(j,k) = psig * pnorm
               vrand(j,k) = vsig * (rho*pnorm+rhoc*vnorm)
            end do
         end if
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine sdarea  --  scale SD friction coefficients  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "sdarea" optionally scales the atomic friction coefficient
c     of each atom based on its accessible surface area
c
c     literature reference:
c
c     S. Yun-Yi, W. Lu and W. F. van Gunsteren, "On the Approximation
c     of Solvent Effects on the Conformation and Dynamics of
c     Cyclosporin A by Stochastic Dynamics Simulation Techniques",
c     Molecular Simulation, 1, 369-383 (1988)
c
c
      subroutine sdarea (istep)
      use atoms
      use atomid
      use couple
      use kvdws
      use math
      use stodyn
      use usage
      implicit none
      integer i,k
      integer istep
      integer resurf
      integer modstep
      real*8 probe,ratio,area
      real*8, allocatable :: radius(:)
c
c
c     determine new friction coefficients every few SD steps
c
      resurf = 100
      modstep = mod(istep,resurf)
      if (modstep .ne. 1)  return
c
c     perform dynamic allocation of some local arrays
c
      allocate (radius(n))
c
c     set the atomic radii to estimates of sigma values
c
      probe = 0.0d0
      do i = 1, n
         radius(i) = rad(class(i)) / twosix
         if (radius(i) .ne. 0.0d0)  radius(i) = radius(i) + probe
      end do
c
c     scale atomic friction coefficients by accessible area
c
      do i = 1, nuse
         k = iuse(i)
         if (radius(k) .ne. 0.0d0) then
            call surfatom (k,area,radius)
            ratio = area / (4.0d0*pi*radius(k)**2)
            fgamma(k) = ratio * friction
         end if
      end do
c
c     monovalent atoms with zero radius get attached atom value
c
      do i = 1, nuse
         k = iuse(i)
         if (radius(k).eq.0.0d0 .and. n12(k).eq.1) then
            fgamma(k) = fgamma(i12(1,k))
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (radius)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine search  --  perform unidirectional line search  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "search" is a unidirectional line search based upon parabolic
c     extrapolation and cubic interpolation using both function and
c     gradient values
c
c     variables used by the routine :
c
c     f       function value at the best line search point
c     x       current values of variables during line search
c     g       gradient at the current point during line search
c     p       initial search vector, unchanged by this routine
c     s       scaled search vector at current line search point
c     angle   angle between search and negative gradient vector
c
c     parameters used by the routine :
c
c     stpmin   minimum step length in current line search direction
c     stpmax   maximum step length in current line search direction
c     cappa    stringency of line search (0=tight < cappa < 1=loose)
c     slpmax   projected gradient above which stepsize is reduced
c     angmax   maximum angle between search direction and -gradient
c     intmax   maximum number of interpolations during line search
c
c     status codes upon return :
c
c     Success     normal termination after satisfying "cappa" test
c     ScaleStep   normal termination after a step size rescaling
c     ReSearch    normal termination after a reinterpolation
c     WideAngle   large angle between search direction and -gradient
c     BadIntpln   unsatisfied "cappa" test after two searches
c     IntplnErr   function value increase or serious gradient error
c
c
      subroutine search (nvar,f,g,x,p,f_move,angle,ncalls,
     &                          fgvalue,status)
      use linmin
      use math
      implicit none
      integer i,nvar
      integer ncalls
      integer intpln
      real*8 fgvalue
      real*8 f,f_move
      real*8 s_norm,g_norm
      real*8 cosang,angle
      real*8 step,parab
      real*8 cube,cubstp
      real*8 sss,ttt
      real*8 f_0,f_1
      real*8 f_a,f_b,f_c
      real*8 sg_0,sg_1
      real*8 sg_a,sg_b,sg_c
      real*8 x(*)
      real*8 g(*)
      real*8 p(*)
      real*8, allocatable :: x_0(:)
      real*8, allocatable :: s(:)
      logical restart
      character*9 status
      character*9 blank
      external fgvalue
c
c
c     use default parameters for the line search if needed
c
      blank = '         '
      if (stpmin .eq. 0.0d0)  stpmin = 1.0d-16
      if (stpmax .eq. 0.0d0)  stpmax = 2.0d0
      if (cappa .eq. 0.0d0)  cappa = 0.1d0
      if (slpmax .eq. 0.0d0)  slpmax = 10000.0d0
      if (angmax .eq. 0.0d0)  angmax = 180.0d0
      if (intmax .eq. 0)  intmax = 5
c
c     perform dynamic allocation of some local arrays
c
      allocate (x_0(nvar))
      allocate (s(nvar))
c
c     copy the search direction into a new vector
c
      do i = 1, nvar
         s(i) = p(i)
      end do
c
c     compute the length of gradient and search direction
c
      g_norm = 0.0d0
      s_norm = 0.0d0
      do i = 1, nvar
         g_norm = g_norm + g(i)*g(i)
         s_norm = s_norm + s(i)*s(i)
      end do
      g_norm = sqrt(g_norm)
      s_norm = sqrt(s_norm)
c
c     store initial function, then normalize the
c     search vector and find projected gradient
c
      f_0 = f
      sg_0 = 0.0d0
      do i = 1, nvar
         x_0(i) = x(i)
         s(i) = s(i) / s_norm
         sg_0 = sg_0 + s(i)*g(i)
      end do
c
c     check the angle between the search direction
c     and the negative gradient vector
c
      cosang = -sg_0 / g_norm
      cosang = min(1.0d0,max(-1.0d0,cosang))
      angle = radian * acos(cosang)
      if (angle .gt. angmax) then
         status = 'WideAngle'
         deallocate (x_0)
         deallocate (s)
         return
      end if
c
c     set the initial stepsize to the length of the passed
c     search vector, or based on previous function decrease
c
      step = 2.0d0 * abs(f_move/sg_0)
      step = min(step,s_norm)
      if (step .gt. stpmax)  step = stpmax
      if (step .lt. stpmin)  step = stpmin
c
c     beginning of the parabolic extrapolation procedure
c
   10 continue
      restart = .true.
      intpln = 0
      f_b = f_0
      sg_b = sg_0
c
c     replace last point by latest and take another step
c
   20 continue
      f_a = f_b
      sg_a = sg_b
      do i = 1, nvar
         x(i) = x(i) + step*s(i)
      end do
c
c     get new function and projected gradient following a step
c
      ncalls = ncalls + 1
      f_b = fgvalue (x,g)
      sg_b = 0.0d0
      do i = 1, nvar
         sg_b = sg_b + s(i)*g(i)
      end do
c
c     scale stepsize if initial gradient change is too large
c
      if (abs(sg_b/sg_a).ge.slpmax .and. restart) then
         do i = 1, nvar
            x(i) = x_0(i)
         end do
         step = step / 10.0d0
         status = 'ScaleStep'
         goto 10
      end if
      restart = .false.
c
c     return if the gradient is small and function decreases
c
      if (abs(sg_b/sg_0).le.cappa .and. f_b.lt.f_a) then
         f = f_b
         if (status .eq. blank)  status = ' Success '
         deallocate (x_0)
         deallocate (s)
         return
      end if
c
c     interpolate if gradient changes sign or function increases
c
      if (sg_b*sg_a.lt.0.0d0 .or. f_b.gt.f_a)  goto 30
c
c     if the finite difference curvature is negative double the step;
c     or if (step < parabolic estimate < 4*step) use this estimate,
c     otherwise truncate to step or 4*step, respectively
c
      step = 2.0d0 * step
      if (sg_b .gt. sg_a) then
         parab = (f_a-f_b) / (sg_b-sg_a)
         if (parab .gt. 2.0d0*step)  parab = 2.0d0 * step
         if (parab .lt. 0.5d0*step)  parab = 0.5d0 * step
         step = parab
      end if
      if (step .gt. stpmax)  step = stpmax
      goto 20
c
c     beginning of the cubic interpolation procedure
c
   30 continue
      intpln = intpln + 1
      sss = 3.0d0*(f_b-f_a)/step - sg_a - sg_b
      ttt = sss*sss - sg_a*sg_b
      if (ttt .lt. 0.0d0) then
         f = f_b
         status = 'IntplnErr'
         deallocate (x_0)
         deallocate (s)
         return
      end if
      ttt = sqrt(ttt)
      cube = step * (sg_b+ttt+sss)/(sg_b-sg_a+2.0d0*ttt)
      if (cube.lt.0.0d0 .or. cube.gt.step) then
         f = f_b
         status = 'IntplnErr'
         deallocate (x_0)
         deallocate (s)
         return
      end if
      do i = 1, nvar
         x(i) = x(i) - cube*s(i)
      end do
c
c     get new function and gradient, then test for termination
c
      ncalls = ncalls + 1
      f_c = fgvalue (x,g)
      sg_c = 0.0d0
      do i = 1, nvar
         sg_c = sg_c + s(i)*g(i)
      end do
      if (abs(sg_c/sg_0) .le. cappa) then
         f = f_c
         if (status .eq. blank)  status = ' Success '
         deallocate (x_0)
         deallocate (s)
         return
      end if
c
c     get the next pair of bracketing points by replacing one
c     of the current brackets with the interpolated point
c
      if (f_c.le.f_a .or. f_c.le.f_b) then
         cubstp = min(abs(cube),abs(step-cube))
         if (cubstp.ge.stpmin .and. intpln.lt.intmax) then
c
c     if the current brackets have slopes of opposite sign,
c     then substitute the interpolated point for the bracket
c     point with slope of same sign as the interpolated point
c
            if (sg_a*sg_b .lt. 0.0d0) then
               if (sg_a*sg_c .lt. 0.0d0) then
                  f_b = f_c
                  sg_b = sg_c
                  step = step - cube
               else
                  f_a = f_c
                  sg_a = sg_c
                  step = cube
                  do i = 1, nvar
                     x(i) = x(i) + cube*s(i)
                  end do
               end if
c
c     if current brackets have slope of same sign, then replace
c     the far bracket if the interpolated point has a slope of
c     the opposite sign or a lower function value than the near
c     bracket, otherwise replace the near bracket point
c
            else
               if (sg_a*sg_c.lt.0.0d0 .or. f_a.le.f_c) then
                  f_b = f_c
                  sg_b = sg_c
                  step = step - cube
               else
                  f_a = f_c
                  sg_a = sg_c
                  step = cube
                  do i = 1, nvar
                     x(i) = x(i) + cube*s(i)
                  end do
               end if
            end if
            goto 30
         end if
      end if
c
c     interpolation has failed, reset to best current point
c
      f_1 = min(f_a,f_b,f_c)
      if (f_1 .eq. f_a) then
         sg_1 = sg_a
         do i = 1, nvar
            x(i) = x(i) + (cube-step)*s(i)
         end do
      else if (f_1 .eq. f_b) then
         sg_1 = sg_b
         do i = 1, nvar
            x(i) = x(i) + cube*s(i)
         end do
      else if (f_1 .eq. f_c) then
         sg_1 = sg_c
      end if
c
c     try to restart from best point with smaller stepsize
c
      if (f_1 .gt. f_0) then
         ncalls = ncalls + 1
         f = fgvalue (x,g)
         status = 'IntplnErr'
         deallocate (x_0)
         deallocate (s)
         return
      end if
      f_0 = f_1
      sg_0 = sg_1
      if (sg_1 .gt. 0.0d0) then
         do i = 1, nvar
            s(i) = -s(i)
         end do
         sg_0 = -sg_1
      end if
      step = max(cube,step-cube) / 10.0d0
      if (step .lt. stpmin)  step = stpmin
c
c     if already restarted once, then return with best point
c
      if (status .eq. ' ReSearch') then
         ncalls = ncalls + 1
         f = fgvalue (x,g)
         status = 'BadIntpln'
         deallocate (x_0)
         deallocate (s)
         return
      else
         status = ' ReSearch'
         goto 10
      end if
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module sequen  --  sequence information for biopolymer  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     nseq     total number of residues in biopolymer sequences
c     nchain   number of separate biopolymer sequence chains
c     ichain   first and last residue in each biopolymer chain
c     seqtyp   residue type for each residue in the sequence
c     seqatm   base atom number for each residue (Calpha or C4')
c     chnnam   one-letter identifier for each sequence chain
c     seq      three-letter code for each residue in the sequence
c     chntyp   contents of each chain (GENERIC, PEPTIDE or NUCLEIC)
c
c
      module sequen
      use sizes
      implicit none
      integer nseq
      integer nchain
      integer ichain(2,maxres)
      integer seqtyp(maxres)
      integer seqatm(maxres)
      character*1 chnnam(maxres)
      character*3 seq(maxres)
      character*7 chntyp(maxres)
      save
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2003 by Michael Schnieders & Jay W. Ponder  ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  routines below implement dummy versions of the socket  ##
c     ##  communication calls required for the transmission of   ##
c     ##  information between Tinker and Force Field Explorer;   ##
c     ##  functional C code is in "server.c", while the dummy    ##
c     ##  calls in this file are written in standard Fortran     ##
c     ##                                                         ##
c     #############################################################
c
c     ############################
c     ##                        ##
c     ##  subroutine chksocket  ##
c     ##                        ##
c     ############################
c
c
      subroutine chksocket (flag)
      implicit none
      integer flag
c
c
c     set flag that will disable socket communications
c
      flag = 0
      return
      end
c
c
c     ############################
c     ##                        ##
c     ##  subroutine createjvm  ##
c     ##                        ##
c     ############################
c
c
      subroutine createjvm (flag)
      implicit none
      integer flag
      return
      end
c
c
c     #############################
c     ##                         ##
c     ##  subroutine destroyjvm  ##
c     ##                         ##
c     #############################
c
c
      subroutine destroyjvm ()
      implicit none
      return
      end
c
c
c     ###############################
c     ##                           ##
c     ##  subroutine createserver  ##
c     ##                           ##
c     ###############################
c
c
      subroutine createserver (flag)
      implicit none
      integer flag
      return
      end
c
c
c     ################################
c     ##                            ##
c     ##  subroutine destroyserver  ##
c     ##                            ##
c     ################################
c
c
      subroutine destroyserver ()
      implicit none
      return
      end
c
c
c     ###############################
c     ##                           ##
c     ##  subroutine createsystem  ##
c     ##                           ##
c     ###############################
c
c
      subroutine createsystem (n,nkey,flag)
      implicit none
      integer n
      integer nkey
      integer flag
      return
      end
c
c
c     #############################
c     ##                         ##
c     ##  subroutine getmonitor  ##
c     ##                         ##
c     #############################
c
c
      subroutine getmonitor ()
      implicit none
      return
      end
c
c
c     #################################
c     ##                             ##
c     ##  subroutine releasemonitor  ##
c     ##                             ##
c     #################################
c
c
      subroutine releasemonitor ()
      implicit none
      return
      end
c
c
c     ###############################
c     ##                           ##
c     ##  subroutine createupdate  ##
c     ##                           ##
c     ###############################
c
c
      subroutine createupdate (n,mode,amoeba,flag)
      implicit none
      integer n
      integer mode
      integer amoeba
      integer flag
      return
      end
c
c
c     #############################
c     ##                         ##
c     ##  subroutine needupdate  ##
c     ##                         ##
c     #############################
c
c
      subroutine needupdate (flag)
      implicit none
      integer flag
      return
      end
c
c
c     #############################
c     ##                         ##
c     ##  subroutine setupdated  ##
c     ##                         ##
c     #############################
c
c
      subroutine setupdated ()
      implicit none
      return
      end
c
c
c     ##########################
c     ##                      ##
c     ##  subroutine setfile  ##
c     ##                      ##
c     ##########################
c
c
      subroutine setfile (filename)
      implicit none
      character*(*) filename
      return
      end
c
c
c     ################################
c     ##                            ##
c     ##  subroutine setforcefield  ##
c     ##                            ##
c     ################################
c
c
      subroutine setforcefield (forcefield)
      implicit none
      character*(*) forcefield
      return
      end
c
c
c     #############################
c     ##                         ##
c     ##  subroutine setkeyword  ##
c     ##                         ##
c     #############################
c
c
      subroutine setkeyword (i,keyline)
      implicit none
      integer i
      character*(*) keyline
      return
      end
c
c
c     ###############################
c     ##                           ##
c     ##  subroutine setatomtypes  ##
c     ##                           ##
c     ###############################
c
c
      subroutine setatomtypes (n,type)
      implicit none
      integer n
      integer type(*)
      return
      end
c
c
c     ############################
c     ##                        ##
c     ##  subroutine setatomic  ##
c     ##                        ##
c     ############################
c
c
      subroutine setatomic (n,atomic)
      implicit none
      integer n
      integer atomic(*)
      return
      end
c
c
c     ##########################
c     ##                      ##
c     ##  subroutine setmass  ##
c     ##                      ##
c     ##########################
c
c
      subroutine setmass (n,mass)
      implicit none
      integer n
      real*8 mass(*)
      return
      end
c
c
c     ############################
c     ##                        ##
c     ##  subroutine setcharge  ##
c     ##                        ##
c     ############################
c
c
      subroutine setcharge (n,charge)
      implicit none
      integer n
      real*8 charge(*)
      return
      end
c
c
c     ##################################
c     ##                              ##
c     ##  subroutine setconnectivity  ##
c     ##                              ##
c     ##################################
c
c
      subroutine setconnectivity (n,b1,b2,b3,b4)
      implicit none
      integer n
      integer b1(*)
      integer b2(*)
      integer b3(*)
      integer b4(*)
      return
      end
c
c
c     ##########################
c     ##                      ##
c     ##  subroutine setname  ##
c     ##                      ##
c     ##########################
c
c
      subroutine setname (i,name)
      implicit none
      integer i
      character*(*) name
      return
      end
c
c
c     ###########################
c     ##                       ##
c     ##  subroutine setstory  ##
c     ##                       ##
c     ###########################
c
c
      subroutine setstory (i,story)
      implicit none
      integer i
      character*(*) story
      return
      end
c
c
c     #################################
c     ##                             ##
c     ##  subroutine setcoordinates  ##
c     ##                             ##
c     #################################
c
c
      subroutine setcoordinates (n,x,y,z)
      implicit none
      integer n
      real*8 x(*)
      real*8 y(*)
      real*8 z(*)
      return
      end
c
c
c     ##########################
c     ##                      ##
c     ##  subroutine setstep  ##
c     ##                      ##
c     ##########################
c
c
      subroutine setstep (ncycle)
      implicit none
      integer ncycle
      return
      end
c
c
c     ############################
c     ##                        ##
c     ##  subroutine setmdtime  ##
c     ##                        ##
c     ############################
c
c
      subroutine setmdtime (time)
      implicit none
      real*8 time
      return
      end
c
c
c     ############################
c     ##                        ##
c     ##  subroutine setenergy  ##
c     ##                        ##
c     ############################
c
c
      subroutine setenergy (energy)
      implicit none
      real*8 energy
      return
      end
c
c
c     ###############################
c     ##                           ##
c     ##  subroutine setgradients  ##
c     ##                           ##
c     ###############################
c
c
      subroutine setgradients (n,dx,dy,dz)
      implicit none
      integer n
      real*8 dx(*)
      real*8 dy(*)
      real*8 dz(*)
      return
      end
c
c
c     ##############################
c     ##                          ##
c     ##  subroutine setvelocity  ##
c     ##                          ##
c     ##############################
c
c
      subroutine setvelocity (n,vx,vy,vz)
      implicit none
      integer n
      real*8 vx(*)
      real*8 vy(*)
      real*8 vz(*)
      return
      end
c
c
c     ##################################
c     ##                              ##
c     ##  subroutine setacceleration  ##
c     ##                              ##
c     ##################################
c
c
      subroutine setacceleration (n,ax,ay,az)
      implicit none
      integer n
      real*8 ax(*)
      real*8 ay(*)
      real*8 az(*)
      return
      end
c
c
c     #############################
c     ##                         ##
c     ##  subroutine setinduced  ##
c     ##                         ##
c     #############################
c
c
      subroutine setinduced (n,ux,uy,uz)
      implicit none
      integer n
      real*8 ux(*)
      real*8 uy(*)
      real*8 uz(*)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2022  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine setprm  --  allocate force field parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "setprm" counts and allocates memory space for force field
c     parameter values involving multiple atom types or classes as
c     found in the parameter file and keyfile
c
c
      subroutine setprm
      use atoms
      use couple
      use kangs
      use kantor
      use kbonds
      use kcflux
      use kdipol
      use keys
      use khbond
      use kiprop
      use kitors
      use kmulti
      use kopbnd
      use kopdst
      use korbs
      use kpitor
      use kpolpr
      use kstbnd
      use ksttor
      use ktorsn
      use ktrtor
      use kurybr
      use kvdwpr
      use params
      use restrn
      implicit none
      integer i,k,ia,ib,next
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     zero out the count of each force field parameter type
c
      maxnb = 0
      maxnb5 = 0
      maxnb4 = 0
      maxnb3 = 0
      maxnel = 0
      maxna = 0
      maxna5 = 0
      maxna4 = 0
      maxna3 = 0
      maxnap = 0
      maxnaf = 0
      maxnsb = 0
      maxnu = 0
      maxnopb = 0
      maxnopd = 0
      maxndi = 0
      maxnti = 0
      maxnt = 0
      maxnt5 = 0
      maxnt4 = 0
      maxnpt = 0
      maxnbt = 0
      maxnat = 0
      maxntt = 0
      maxnvp = 0
      maxnhb = 0
      maxnd = 0
      maxnd5 = 0
      maxnd4 = 0
      maxnd3 = 0
      maxnmp = 0
      maxnpp = 0
      maxncfb = 0
      maxncfa = 0
      maxnpi = 0
      maxnpi5 = 0
      maxnpi4 = 0
      maxfix = 0
c
c     find any parameter values found in the parameter file
c
      do i = 1, nprm
         record = prmline(i)
         next = 1
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:5) .eq. 'BOND ')  maxnb = maxnb + 1
         if (keyword(1:9) .eq. 'MMFFBOND ')  maxnb = maxnb + 1
         if (keyword(1:6) .eq. 'BOND5 ')  maxnb5 = maxnb5 + 1
         if (keyword(1:6) .eq. 'BOND4 ')  maxnb4 = maxnb4 + 1
         if (keyword(1:6) .eq. 'BOND3 ')  maxnb3 = maxnb3 + 1
         if (keyword(1:9) .eq. 'ELECTNEG ')  maxnel = maxnel + 1
         if (keyword(1:6) .eq. 'ANGLE ')  maxna = maxna + 1
         if (keyword(1:10) .eq. 'MMFFANGLE ')  maxna = maxna + 1
         if (keyword(1:7) .eq. 'ANGLE5 ')  maxna5 = maxna5 + 1
         if (keyword(1:7) .eq. 'ANGLE4 ')  maxna4 = maxna4 + 1
         if (keyword(1:7) .eq. 'ANGLE3 ')  maxna3 = maxna3 + 1
         if (keyword(1:7) .eq. 'ANGLEP ')  maxnap = maxnap + 1
         if (keyword(1:7) .eq. 'ANGLEF ')  maxnaf = maxnaf + 1
         if (keyword(1:7) .eq. 'STRBND ')  maxnsb = maxnsb + 1
         if (keyword(1:9) .eq. 'UREYBRAD ')  maxnu = maxnu + 1
         if (keyword(1:7) .eq. 'OPBEND ')  maxnopb = maxnopb + 1
         if (keyword(1:7) .eq. 'OPDIST ')  maxnopd = maxnopd + 1
         if (keyword(1:9) .eq. 'IMPROPER ')  maxndi = maxndi + 1
         if (keyword(1:8) .eq. 'IMPTORS ')  maxnti = maxnti + 1
         if (keyword(1:8) .eq. 'TORSION ')  maxnt = maxnt + 1
         if (keyword(1:12) .eq. 'MMFFTORSION ')  maxnt = maxnt + 1
         if (keyword(1:9) .eq. 'TORSION5 ')  maxnt5 = maxnt5 + 1
         if (keyword(1:9) .eq. 'TORSION4 ')  maxnt4 = maxnt4 + 1
         if (keyword(1:7) .eq. 'PITORS ')  maxnpt = maxnpt + 1
         if (keyword(1:8) .eq. 'STRTORS ')  maxnbt = maxnbt + 1
         if (keyword(1:8) .eq. 'ANGTORS ')  maxnat = maxnat + 1
         if (keyword(1:8) .eq. 'TORTORS ')  maxntt = maxntt + 1
         if (keyword(1:8) .eq. 'VDWPAIR ')  maxnvp = maxnvp + 1
         if (keyword(1:6) .eq. 'VDWPR ')  maxnvp = maxnvp + 1
         if (keyword(1:6) .eq. 'HBOND ')  maxnhb = maxnhb + 1
         if (keyword(1:7) .eq. 'DIPOLE ')  maxnd = maxnd + 1
         if (keyword(1:8) .eq. 'DIPOLE5 ')  maxnd5 = maxnd5 + 1
         if (keyword(1:8) .eq. 'DIPOLE4 ')  maxnd4 = maxnd4 + 1
         if (keyword(1:8) .eq. 'DIPOLE3 ')  maxnd3 = maxnd3 + 1
         if (keyword(1:10) .eq. 'MULTIPOLE ')  maxnmp = maxnmp + 1
         if (keyword(1:8) .eq. 'POLPAIR ')  maxnpp = maxnpp + 1
         if (keyword(1:9) .eq. 'BNDCFLUX ')  maxncfb = maxncfb + 1
         if (keyword(1:9) .eq. 'ANGCFLUX ')  maxncfa = maxncfa + 1
         if (keyword(1:7) .eq. 'PIBOND ')  maxnpi = maxnpi + 1
         if (keyword(1:8) .eq. 'PIBOND5 ')  maxnpi5 = maxnpi5 + 1
         if (keyword(1:8) .eq. 'PIBOND4 ')  maxnpi4 = maxnpi4 + 1
         if (keyword(1:9) .eq. 'RESTRAIN-') then
            maxfix = maxfix + 1
            if (keyword(10:18) .eq. 'POSITION ') then
               string = record(19:240)
               next = 1
               call getnumb (string,ia,next)
               if (ia.ge.-n .and. ia.le.-1) then
                  ia = abs(ia)
                  call getnumb (string,ib,next)
                  ib = min(abs(ib),n)
                  maxfix = maxfix + max(0,ib-ia)
               end if
            end if
         end if
         if (keyword(1:18) .eq. 'ENFORCE-CHIRALITY ') then
            do k = 1, n
               if (n12(k) .eq.4)  maxfix = maxfix + 1
            end do
         end if
      end do
c
c     find additional parameter values found in the keyfile
c
      do i = 1, nkey
         record = keyline(i)
         next = 1
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:5) .eq. 'BOND ')  maxnb = maxnb + 1
         if (keyword(1:9) .eq. 'MMFFBOND ')  maxnb = maxnb + 1
         if (keyword(1:6) .eq. 'BOND5 ')  maxnb5 = maxnb5 + 1
         if (keyword(1:6) .eq. 'BOND4 ')  maxnb4 = maxnb4 + 1
         if (keyword(1:6) .eq. 'BOND3 ')  maxnb3 = maxnb3 + 1
         if (keyword(1:9) .eq. 'ELECTNEG ')  maxnel = maxnel + 1
         if (keyword(1:6) .eq. 'ANGLE ')  maxna = maxna + 1
         if (keyword(1:10) .eq. 'MMFFANGLE ')  maxna = maxna + 1
         if (keyword(1:7) .eq. 'ANGLE5 ')  maxna5 = maxna5 + 1
         if (keyword(1:7) .eq. 'ANGLE4 ')  maxna4 = maxna4 + 1
         if (keyword(1:7) .eq. 'ANGLE3 ')  maxna3 = maxna3 + 1
         if (keyword(1:7) .eq. 'ANGLEP ')  maxnap = maxnap + 1
         if (keyword(1:7) .eq. 'ANGLEF ')  maxnaf = maxnaf + 1
         if (keyword(1:7) .eq. 'STRBND ')  maxnsb = maxnsb + 1
         if (keyword(1:9) .eq. 'UREYBRAD ')  maxnu = maxnu + 1
         if (keyword(1:7) .eq. 'OPBEND ')  maxnopb = maxnopb + 1
         if (keyword(1:7) .eq. 'OPDIST ')  maxnopd = maxnopd + 1
         if (keyword(1:9) .eq. 'IMPROPER ')  maxndi = maxndi + 1
         if (keyword(1:8) .eq. 'IMPTORS ')  maxnti = maxnti + 1
         if (keyword(1:8) .eq. 'TORSION ')  maxnt = maxnt + 1
         if (keyword(1:12) .eq. 'MMFFTORSION ')  maxnt = maxnt + 1
         if (keyword(1:9) .eq. 'TORSION5 ')  maxnt5 = maxnt5 + 1
         if (keyword(1:9) .eq. 'TORSION4 ')  maxnt4 = maxnt4 + 1
         if (keyword(1:7) .eq. 'PITORS ')  maxnpt = maxnpt + 1
         if (keyword(1:8) .eq. 'STRTORS ')  maxnbt = maxnbt + 1
         if (keyword(1:8) .eq. 'ANGTORS ')  maxnat = maxnat + 1
         if (keyword(1:8) .eq. 'TORTORS ')  maxntt = maxntt + 1
         if (keyword(1:8) .eq. 'VDWPAIR ')  maxnvp = maxnvp + 1
         if (keyword(1:6) .eq. 'VDWPR ')  maxnvp = maxnvp + 1
         if (keyword(1:6) .eq. 'HBOND ')  maxnhb = maxnhb + 1
         if (keyword(1:7) .eq. 'DIPOLE ')  maxnd = maxnd + 1
         if (keyword(1:8) .eq. 'DIPOLE5 ')  maxnd5 = maxnd5 + 1
         if (keyword(1:8) .eq. 'DIPOLE4 ')  maxnd4 = maxnd4 + 1
         if (keyword(1:8) .eq. 'DIPOLE3 ')  maxnd3 = maxnd3 + 1
         if (keyword(1:10) .eq. 'MULTIPOLE ')  maxnmp = maxnmp + 1
         if (keyword(1:8) .eq. 'POLPAIR ')  maxnpp = maxnpp + 1
         if (keyword(1:9) .eq. 'BNDCFLUX ')  maxncfb = maxncfb + 1
         if (keyword(1:9) .eq. 'ANGCFLUX ')  maxncfa = maxncfa + 1
         if (keyword(1:7) .eq. 'PIBOND ')  maxnpi = maxnpi + 1
         if (keyword(1:8) .eq. 'PIBOND5 ')  maxnpi5 = maxnpi5 + 1
         if (keyword(1:8) .eq. 'PIBOND4 ')  maxnpi4 = maxnpi4 + 1
         if (keyword(1:9) .eq. 'RESTRAIN-') then
            maxfix = maxfix + 1
            if (keyword(10:18) .eq. 'POSITION ') then
               string = record(19:240)
               next = 1
               call getnumb (string,ia,next)
               if (ia.ge.-n .and. ia.le.-1) then
                  ia = abs(ia)
                  call getnumb (string,ib,next)
                  ib = min(abs(ib),n)
                  maxfix = maxfix + max(0,ib-ia)
               end if
            end if
         end if
         if (keyword(1:18) .eq. 'ENFORCE-CHIRALITY ') then
            do k = 1, n
               if (n12(k) .eq.4)  maxfix = maxfix + 1
            end do
         end if
      end do
c
c     set the allocated memory for each parameter type
c
      maxnb = max(500,maxnb+100)
      maxnb5 = max(500,maxnb5+100)
      maxnb4 = max(500,maxnb4+100)
      maxnb3 = max(500,maxnb3+100)
      maxnel = max(500,maxnel+100)
      maxna = max(500,maxna+100)
      maxna5 = max(500,maxna5+100)
      maxna4 = max(500,maxna4+100)
      maxna3 = max(500,maxna3+100)
      maxnap = max(500,maxnap+100)
      maxnaf = max(500,maxnaf+100)
      maxnsb = max(500,maxnsb+100)
      maxnu = max(500,maxnu+100)
      maxnopb = max(500,maxnopb+100)
      maxnopd = max(500,maxnopd+100)
      maxndi = max(500,maxndi+100)
      maxnti = max(500,maxnti+100)
      maxnt = max(500,maxnt+100)
      maxnt5 = max(500,maxnt5+100)
      maxnt4 = max(500,maxnt4+100)
      maxnpt = max(500,maxnpt+100)
      maxnbt = max(500,maxnbt+100)
      maxnat = max(500,maxnat+100)
      maxntt = max(50,maxntt+10)
      maxnvp = max(500,maxnvp+100)
      maxnhb = max(500,maxnhb+100)
      maxnd = max(500,maxnd+100)
      maxnd5 = max(500,maxnd5+100)
      maxnd4 = max(500,maxnd4+100)
      maxnd3 = max(500,maxnd3+100)
      maxnmp = max(500,maxnmp+100)
      maxnpp = max(500,maxnpp+100)
      maxncfb = max(500,maxncfb+100)
      maxncfa = max(500,maxncfa+100)
      maxnpi = max(500,maxnpi+100)
      maxnpi5 = max(500,maxnpi5+100)
      maxnpi4 = max(500,maxnpi4+100)
      maxfix = max(500,maxfix+100)
c
c     allocate bond stretching forcefield parameters
c
      if (allocated(bcon))  deallocate (bcon)
      allocate (bcon(maxnb))
      if (allocated(bcon5))  deallocate (bcon5)
      allocate (bcon5(maxnb5))
      if (allocated(bcon4))  deallocate (bcon4)
      allocate (bcon4(maxnb4))
      if (allocated(bcon3))  deallocate (bcon3)
      allocate (bcon3(maxnb3))
      if (allocated(blen))  deallocate (blen)
      allocate (blen(maxnb))
      if (allocated(blen5))  deallocate (blen5)
      allocate (blen5(maxnb5))
      if (allocated(blen4))  deallocate (blen4)
      allocate (blen4(maxnb4))
      if (allocated(blen3))  deallocate (blen3)
      allocate (blen3(maxnb3))
      if (allocated(dlen))  deallocate (dlen)
      allocate (dlen(maxnel))
      if (allocated(kb))  deallocate (kb)
      allocate (kb(maxnb))
      if (allocated(kb5))  deallocate (kb5)
      allocate (kb5(maxnb5))
      if (allocated(kb4))  deallocate (kb4)
      allocate (kb4(maxnb4))
      if (allocated(kb3))  deallocate (kb3)
      allocate (kb3(maxnb3))
      if (allocated(kel))  deallocate (kel)
      allocate (kel(maxnel))
c
c     allocate bond angle bend forcefield parameters
c
      if (allocated(acon))  deallocate (acon)
      allocate (acon(maxna))
      if (allocated(acon5))  deallocate (acon5)
      allocate (acon5(maxna5))
      if (allocated(acon4))  deallocate (acon4)
      allocate (acon4(maxna4))
      if (allocated(acon3))  deallocate (acon3)
      allocate (acon3(maxna3))
      if (allocated(aconp))  deallocate (aconp)
      allocate (aconp(maxnap))
      if (allocated(aconf))  deallocate (aconf)
      allocate (aconf(maxnaf))
      if (allocated(ang))  deallocate (ang)
      allocate (ang(3,maxna))
      if (allocated(ang5))  deallocate (ang5)
      allocate (ang5(3,maxna5))
      if (allocated(ang4))  deallocate (ang4)
      allocate (ang4(3,maxna4))
      if (allocated(ang3))  deallocate (ang3)
      allocate (ang3(3,maxna3))
      if (allocated(angp))  deallocate (angp)
      allocate (angp(2,maxnap))
      if (allocated(angf))  deallocate (angf)
      allocate (angf(2,maxnaf))
      if (allocated(ka))  deallocate (ka)
      allocate (ka(maxna))
      if (allocated(ka5))  deallocate (ka5)
      allocate (ka5(maxna5))
      if (allocated(ka4))  deallocate (ka4)
      allocate (ka4(maxna4))
      if (allocated(ka3))  deallocate (ka3)
      allocate (ka3(maxna3))
      if (allocated(kap))  deallocate (kap)
      allocate (kap(maxnap))
      if (allocated(kaf))  deallocate (kaf)
      allocate (kaf(maxnaf))
c
c     allocate stretch-bend forcefield parameters
c
      if (allocated(stbn))  deallocate (stbn)
      allocate (stbn(2,maxnsb))
      if (allocated(ksb))  deallocate (ksb)
      allocate (ksb(maxnsb))
c
c     allocate Urey-Bradley term forcefield parameters
c
      if (allocated(ucon))  deallocate (ucon)
      allocate (ucon(maxnu))
      if (allocated(dst13))  deallocate (dst13)
      allocate (dst13(maxnu))
      if (allocated(ku))  deallocate (ku)
      allocate (ku(maxnu))
c
c     allocate out-of-plane bend forcefield parameters
c
      if (allocated(opbn))  deallocate (opbn)
      allocate (opbn(maxnopb))
      if (allocated(kopb))  deallocate (kopb)
      allocate (kopb(maxnopb))
c
c     allocate out-of-plane distance forcefield parameters
c
      if (allocated(opds))  deallocate (opds)
      allocate (opds(maxnopd))
      if (allocated(kopd))  deallocate (kopd)
      allocate (kopd(maxnopd))
c
c     allocate improper dihedral forcefield parameters
c
      if (allocated(dcon))  deallocate (dcon)
      allocate (dcon(maxndi))
      if (allocated(tdi))  deallocate (tdi)
      allocate (tdi(maxndi))
      if (allocated(kdi))  deallocate (kdi)
      allocate (kdi(maxndi))
c
c     allocate improper torsion forcefield parameters
c
      if (allocated(ti1))  deallocate (ti1)
      allocate (ti1(2,maxnti))
      if (allocated(ti2))  deallocate (ti2)
      allocate (ti2(2,maxnti))
      if (allocated(ti3))  deallocate (ti3)
      allocate (ti3(2,maxnti))
      if (allocated(kti))  deallocate (kti)
      allocate (kti(maxnti))
c
c     allocate torsion angle forcefield parameters
c
      if (allocated(t1))  deallocate (t1)
      allocate (t1(2,maxnt))
      if (allocated(t2))  deallocate (t2)
      allocate (t2(2,maxnt))
      if (allocated(t3))  deallocate (t3)
      allocate (t3(2,maxnt))
      if (allocated(t4))  deallocate (t4)
      allocate (t4(2,maxnt))
      if (allocated(t5))  deallocate (t5)
      allocate (t5(2,maxnt))
      if (allocated(t6))  deallocate (t6)
      allocate (t6(2,maxnt))
      if (allocated(t15))  deallocate (t15)
      allocate (t15(2,maxnt5))
      if (allocated(t25))  deallocate (t25)
      allocate (t25(2,maxnt5))
      if (allocated(t35))  deallocate (t35)
      allocate (t35(2,maxnt5))
      if (allocated(t45))  deallocate (t45)
      allocate (t45(2,maxnt5))
      if (allocated(t55))  deallocate (t55)
      allocate (t55(2,maxnt5))
      if (allocated(t65))  deallocate (t65)
      allocate (t65(2,maxnt5))
      if (allocated(t14))  deallocate (t14)
      allocate (t14(2,maxnt4))
      if (allocated(t24))  deallocate (t24)
      allocate (t24(2,maxnt4))
      if (allocated(t34))  deallocate (t34)
      allocate (t34(2,maxnt4))
      if (allocated(t44))  deallocate (t44)
      allocate (t44(2,maxnt4))
      if (allocated(t54))  deallocate (t54)
      allocate (t54(2,maxnt4))
      if (allocated(t64))  deallocate (t64)
      allocate (t64(2,maxnt4))
      if (allocated(kt))  deallocate (kt)
      allocate (kt(maxnt))
      if (allocated(kt5))  deallocate (kt5)
      allocate (kt5(maxnt5))
      if (allocated(kt4))  deallocate (kt4)
      allocate (kt4(maxnt4))
c
c     allocate pi-system torsion forcefield parameters
c
      if (allocated(ptcon))  deallocate (ptcon)
      allocate (ptcon(maxnpt))
      if (allocated(kpt))  deallocate (kpt)
      allocate (kpt(maxnpt))
c
c     allocate stretch-torsion forcefield parameters
c
      if (allocated(btcon))  deallocate (btcon)
      allocate (btcon(9,maxnbt))
      if (allocated(kbt))  deallocate (kbt)
      allocate (kbt(maxnbt))
c
c     allocate angle-torsion forcefield parameters
c
      if (allocated(atcon))  deallocate (atcon)
      allocate (atcon(6,maxnat))
      if (allocated(kat))  deallocate (kat)
      allocate (kat(maxnat))
c
c     allocate torsion-torsion forcefield parameters
c
      if (allocated(tnx))  deallocate (tnx)
      allocate (tnx(maxntt))
      if (allocated(tny))  deallocate (tny)
      allocate (tny(maxntt))
      if (allocated(ttx))  deallocate (ttx)
      allocate (ttx(maxtgrd,maxntt))
      if (allocated(tty))  deallocate (tty)
      allocate (tty(maxtgrd,maxntt))
      if (allocated(tbf))  deallocate (tbf)
      allocate (tbf(maxtgrd2,maxntt))
      if (allocated(tbx))  deallocate (tbx)
      allocate (tbx(maxtgrd2,maxntt))
      if (allocated(tby))  deallocate (tby)
      allocate (tby(maxtgrd2,maxntt))
      if (allocated(tbxy))  deallocate (tbxy)
      allocate (tbxy(maxtgrd2,maxntt))
      if (allocated(ttier))  deallocate (ttier)
      allocate (ttier(maxntt))
      if (allocated(ktt))  deallocate (ktt)
      allocate (ktt(maxntt))
c
c     allocate special vdw term forcefield parameters
c
      if (allocated(radpr))  deallocate (radpr)
      allocate (radpr(maxnvp))
      if (allocated(epspr))  deallocate (epspr)
      allocate (epspr(maxnvp))
      if (allocated(kvpr))  deallocate (kvpr)
      allocate (kvpr(maxnvp))
c
c     allocate H-bonding term forcefield parameters
c
      if (allocated(radhb))  deallocate (radhb)
      allocate (radhb(maxnhb))
      if (allocated(epshb))  deallocate (epshb)
      allocate (epshb(maxnhb))
      if (allocated(khb))  deallocate (khb)
      allocate (khb(maxnhb))
c
c     allocate bond dipole forcefield parameters
c
      if (allocated(dpl))  deallocate (dpl)
      allocate (dpl(maxnd))
      if (allocated(dpl5))  deallocate (dpl5)
      allocate (dpl5(maxnd5))
      if (allocated(dpl4))  deallocate (dpl4)
      allocate (dpl4(maxnd4))
      if (allocated(dpl3))  deallocate (dpl3)
      allocate (dpl3(maxnd3))
      if (allocated(pos))  deallocate (pos)
      allocate (pos(maxnd))
      if (allocated(pos5))  deallocate (pos5)
      allocate (pos5(maxnd5))
      if (allocated(pos4))  deallocate (pos4)
      allocate (pos4(maxnd4))
      if (allocated(pos3))  deallocate (pos3)
      allocate (pos3(maxnd3))
      if (allocated(kd))  deallocate (kd)
      allocate (kd(maxnd))
      if (allocated(kd5))  deallocate (kd5)
      allocate (kd5(maxnd5))
      if (allocated(kd4))  deallocate (kd4)
      allocate (kd4(maxnd4))
      if (allocated(kd3))  deallocate (kd3)
      allocate (kd3(maxnd3))
c
c     allocate atomic multipole forcefield parameters
c
      if (allocated(multip))  deallocate (multip)
      allocate (multip(13,maxnmp))
      if (allocated(mpaxis))  deallocate (mpaxis)
      allocate (mpaxis(maxnmp))
      if (allocated(kmp))  deallocate (kmp)
      allocate (kmp(maxnmp))
c
c     allocate special Thole forcefield parameters
c
      if (allocated(thlpr))  deallocate (thlpr)
      allocate (thlpr(maxnpp))
      if (allocated(thdpr))  deallocate (thdpr)
      allocate (thdpr(maxnpp))
      if (allocated(kppr))  deallocate (kppr)
      allocate (kppr(maxnpp))
c
c     allocate charge flux term forcefield parameters
c
      if (allocated(cflb))  deallocate (cflb)
      allocate (cflb(maxncfb))
      if (allocated(cfla))  deallocate (cfla)
      allocate (cfla(2,maxncfa))
      if (allocated(cflab))  deallocate (cflab)
      allocate (cflab(2,maxncfa))
      if (allocated(kcfb))  deallocate (kcfb)
      allocate (kcfb(maxncfb))
      if (allocated(kcfa))  deallocate (kcfa)
      allocate (kcfa(maxncfa))
c
c     allocate pisystem orbital forcefield parameters
c
      if (allocated(sslope))  deallocate (sslope)
      allocate (sslope(maxnpi))
      if (allocated(sslope5))  deallocate (sslope5)
      allocate (sslope5(maxnpi5))
      if (allocated(sslope4))  deallocate (sslope4)
      allocate (sslope4(maxnpi4))
      if (allocated(tslope))  deallocate (tslope)
      allocate (tslope(maxnpi))
      if (allocated(tslope5))  deallocate (tslope5)
      allocate (tslope5(maxnpi5))
      if (allocated(tslope4))  deallocate (tslope4)
      allocate (tslope4(maxnpi4))
      if (allocated(kpi))  deallocate (kpi)
      allocate (kpi(maxnpi))
      if (allocated(kpi5))  deallocate (kpi5)
      allocate (kpi5(maxnpi5))
      if (allocated(kpi4))  deallocate (kpi4)
      allocate (kpi4(maxnpi4))
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2025  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine settle  --  SETTLE distance constraint method  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "settle" implements the SETTLE algorithm by correcting atomic
c     positions to maintain rigid three-site water models
c
c     literature reference:
c
c     S. Miyamoto and P. A. Kollman, "SETTLE: An Analytical Version
c     of the SHAKE and RATTLE Algorithm for Rigid Water Models",
c     Journal of Computational Chemistry, 13, 952-962 (1992)
c
c
      subroutine settle (dt,xold,yold,zold)
      use atomid
      use atoms
      use freeze
      use math
      use moldyn
      implicit none
      integer i,ia,ib,ic
      real*8 dt,mtot
      real*8 mia,mib,mic
      real*8 ra,rb,rc
      real*8 rc2,rhh2
      real*8 xcom,ycom,zcom
      real*8 xia0,yia0,zia0
      real*8 xib0,yib0,zib0
      real*8 xic0,yic0,zic0
      real*8 xb0,yb0,zb0
      real*8 xc0,yc0,zc0
      real*8 xa1,ya1,za1
      real*8 xb1,yb1,zb1
      real*8 xc1,yc1,zc1
      real*8 xaksx,yaksx,zaksx
      real*8 xaksy,yaksy,zaksy
      real*8 xaksz,yaksz,zaksz
      real*8 rot11,rot12,rot13
      real*8 rot21,rot22,rot23
      real*8 rot31,rot32,rot33
      real*8 norm,za1d
      real*8 xb0d,yb0d
      real*8 xc0d,yc0d
      real*8 xb1d,yb1d,zb1d
      real*8 xc1d,yc1d,zc1d
      real*8 sinphi,cosphi
      real*8 sinpsi,cospsi
      real*8 ya2d,xb2d,yb2d
      real*8 yc2d,xb2d2
      real*8 alpa,beta,gama
      real*8 al2be2
      real*8 sintheta
      real*8 costheta
      real*8 xa3d,ya3d,za3d
      real*8 xb3d,yb3d,zb3d
      real*8 xc3d,yc3d,zc3d
      real*8 xold(*)
      real*8 yold(*)
      real*8 zold(*)
c
c
c     check for prior allocation of atomic velocities
c
      if (.not. allocated(v))  allocate (v(0,0))
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nwat,iwat,kwat,mass,
!$OMP& x,y,z,xold,yold,zold,dt)
!$OMP& shared(v)
!$OMP DO reduction(+:v)
c
c     get coordinates, masses and geometric parameters
c
      do i = 1, nwat
         ia = iwat(1,i)
         ib = iwat(2,i)
         ic = iwat(3,i)
         mia = mass(ia)
         mib = mass(ib)
         mic = mass(ic)
         mtot = mia + mib + mic
         ra = kwat(1,i) * cos(0.5d0*kwat(3,i)/radian)
         rb = ra * mia / mtot
         ra = ra - rb
         rc2 = kwat(2,i)
         rc = 0.5d0 * rc2
         rhh2 = rc2 * rc2
c
c     store current coordinates needed for velocity correction
c
         xia0 = x(ia)
         yia0 = y(ia)
         zia0 = z(ia)
         xib0 = x(ib)
         yib0 = y(ib)
         zib0 = z(ib)
         xic0 = x(ic)
         yic0 = y(ic)
         zic0 = z(ic)
c
c     find prior interatomic vectors and center of mass
c
         xb0 = xold(ib) - xold(ia)
         yb0 = yold(ib) - yold(ia)
         zb0 = zold(ib) - zold(ia)
         xc0 = xold(ic) - xold(ia)
         yc0 = yold(ic) - yold(ia)
         zc0 = zold(ic) - zold(ia)
         xcom = (mia*x(ia)+mib*x(ib)+mic*x(ic)) / mtot
         ycom = (mia*y(ia)+mib*y(ib)+mic*y(ic)) / mtot
         zcom = (mia*z(ia)+mib*z(ib)+mic*z(ic)) / mtot
         xa1 = x(ia) - xcom
         ya1 = y(ia) - ycom
         za1 = z(ia) - zcom
         xb1 = x(ib) - xcom
         yb1 = y(ib) - ycom
         zb1 = z(ib) - zcom
         xc1 = x(ic) - xcom
         yc1 = y(ic) - ycom
         zc1 = z(ic) - zcom
c
c     compute axes and rotation matrix for alternative frame
c
         xaksz = yb0*zc0 - zb0*yc0
         yaksz = zb0*xc0 - xb0*zc0
         zaksz = xb0*yc0 - yb0*xc0
         xaksx = ya1*zaksz - za1*yaksz
         yaksx = za1*xaksz - xa1*zaksz
         zaksx = xa1*yaksz - ya1*xaksz
         xaksy = yaksz*zaksx - zaksz*yaksx
         yaksy = zaksz*xaksx - xaksz*zaksx
         zaksy = xaksz*yaksx - yaksz*xaksx
         norm = sqrt(xaksx*xaksx + yaksx*yaksx + zaksx*zaksx)
         rot11 = xaksx / norm
         rot21 = yaksx / norm
         rot31 = zaksx / norm
         norm = sqrt(xaksy*xaksy + yaksy*yaksy + zaksy*zaksy)
         rot12 = xaksy / norm
         rot22 = yaksy / norm
         rot32 = zaksy / norm
         norm = sqrt(xaksz*xaksz + yaksz*yaksz + zaksz*zaksz)
         rot13 = xaksz / norm
         rot23 = yaksz / norm
         rot33 = zaksz / norm
         xb0d = rot11*xb0 + rot21*yb0 + rot31*zb0
         yb0d = rot12*xb0 + rot22*yb0 + rot32*zb0
         xc0d = rot11*xc0 + rot21*yc0 + rot31*zc0
         yc0d = rot12*xc0 + rot22*yc0 + rot32*zc0
         za1d = rot13*xa1 + rot23*ya1 + rot33*za1
         xb1d = rot11*xb1 + rot21*yb1 + rot31*zb1
         yb1d = rot12*xb1 + rot22*yb1 + rot32*zb1
         zb1d = rot13*xb1 + rot23*yb1 + rot33*zb1
         xc1d = rot11*xc1 + rot21*yc1 + rot31*zc1
         yc1d = rot12*xc1 + rot22*yc1 + rot32*zc1
         zc1d = rot13*xc1 + rot23*yc1 + rot33*zc1
c
c     transform via rotation about Y' (phi) and X' axis (psi)
c
         sinphi = za1d / ra
         cosphi = sqrt(1.0d0 - sinphi*sinphi)
         sinpsi = (zb1d-zc1d) / (rc2*cosphi)
         cospsi = sqrt(1.0d0 - sinpsi*sinpsi)
         ya2d = ra * cosphi
         xb2d = -rc * cospsi
         yb2d = -rb*cosphi - rc*sinpsi*sinphi
         yc2d = -rb*cosphi + rc*sinpsi*sinphi
         xb2d2 = xb2d * xb2d
         xb2d = -0.5d0 * sqrt(rhh2 - (yb2d-yc2d)*(yb2d-yc2d)
     &                          - (zb1d-zc1d)*(zb1d-zc1d))
c
c    transform via a rotation about the Z' axis (theta)
c
         alpa = (xb2d*(xb0d-xc0d) + yb0d*yb2d + yc0d*yc2d)
         beta = (xb2d*(yc0d-yb0d) + xb0d*yb2d + xc0d*yc2d)
         gama = xb0d*yb1d - xb1d*yb0d + xc0d*yc1d - xc1d*yc0d
         al2be2 = alpa*alpa + beta*beta
         sintheta = (alpa*gama - beta*sqrt(al2be2-gama*gama)) / al2be2
         costheta = sqrt(1.0d0 - sintheta*sintheta)
         xa3d = -ya2d * sintheta
         ya3d = ya2d * costheta
         za3d = za1d
         xb3d = xb2d*costheta - yb2d*sintheta
         yb3d = xb2d*sintheta + yb2d*costheta
         zb3d = zb1d
         xc3d = -xb2d*costheta - yc2d*sintheta
         yc3d = -xb2d*sintheta + yc2d*costheta
         zc3d = zc1d
c
c     translate and rotate back into original coordinate frame
c
         x(ia) = xcom + rot11*xa3d + rot12*ya3d + rot13*za3d
         y(ia) = ycom + rot21*xa3d + rot22*ya3d + rot23*za3d
         z(ia) = zcom + rot31*xa3d + rot32*ya3d + rot33*za3d
         x(ib) = xcom + rot11*xb3d + rot12*yb3d + rot13*zb3d
         y(ib) = ycom + rot21*xb3d + rot22*yb3d + rot23*zb3d
         z(ib) = zcom + rot31*xb3d + rot32*yb3d + rot33*zb3d
         x(ic) = xcom + rot11*xc3d + rot12*yc3d + rot13*zc3d
         y(ic) = ycom + rot21*xc3d + rot22*yc3d + rot23*zc3d
         z(ic) = zcom + rot31*xc3d + rot32*yc3d + rot33*zc3d
c
c     use velocity correction derived from position movement
c
         if (dt .ne. 0.0d0) then
            v(1,ia) = v(1,ia) + (x(ia)-xia0)/dt
            v(2,ia) = v(2,ia) + (y(ia)-yia0)/dt
            v(3,ia) = v(3,ia) + (z(ia)-zia0)/dt
            v(1,ib) = v(1,ib) + (x(ib)-xib0)/dt
            v(2,ib) = v(2,ib) + (y(ib)-yib0)/dt
            v(3,ib) = v(3,ib) + (z(ib)-zib0)/dt
            v(1,ic) = v(1,ic) + (x(ic)-xic0)/dt
            v(2,ic) = v(2,ic) + (y(ic)-yic0)/dt
            v(3,ic) = v(3,ic) + (z(ic)-zic0)/dt
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     set position and velocity for four-site water extra sites
c
      if (nwat4 .ne. 0) then
         call watfour (dt)
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine settle2  --  SETTLE atom velocity corrections  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "settle2" implements the second portion of the SETTLE algorithm
c     by correcting the full-step velocities in order to maintain
c     rigid three-site water models
c
c
      subroutine settle2 (dt)
      use atomid
      use atoms
      use freeze
      use moldyn
      use units
      use virial
      implicit none
      integer i,ia,ib,ic
      real*8 dt,norm
      real*8 mo,mh,moh,mhh
      real*8 mohoh,mhmh
      real*8 momoh,mhmhh
      real*8 momhh,mohmoh
      real*8 xab,yab,zab
      real*8 xbc,ybc,zbc
      real*8 xca,yca,zca
      real*8 xvab,yvab,zvab
      real*8 xvbc,yvbc,zvbc
      real*8 xvca,yvca,zvca
      real*8 vabab,vbcbc,vcaca
      real*8 cosa,cosb,cosc
      real*8 abmc,bcma,camb
      real*8 tab,tbc,tca
      real*8 denom,vterm
      real*8 dvax,dvay,dvaz
      real*8 dvbx,dvby,dvbz
      real*8 dvcx,dvcy,dvcz
      real*8 tax,tay,taz
      real*8 tbx,tby,tbz
      real*8 tcx,tcy,tcz
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(n,nwat,iwat,mass,x,y,z,v,dt)
!$OMP& shared(vir)
!$OMP DO reduction(+:vir)
c
c     find atoms in the molecule and mass combinations
c
      do i = 1, nwat
         ia = iwat(1,i)
         ib = iwat(2,i)
         ic = iwat(3,i)
         mo = mass(ia)
         mh = 0.5d0 * (mass(ib)+mass(ic))
         moh = mo + mh
         mhh = mh + mh
         mohoh = moh + moh
         mhmh = mh * mh
         momoh = mo * moh
         mhmhh = mh * mhh
         momhh = mo * mhh
         mohmoh = moh * moh
c
c     determine the normalized interactomic vectors
c
         xab = x(ib) - x(ia)
         yab = y(ib) - y(ia)
         zab = z(ib) - z(ia)
         norm = sqrt(xab*xab + yab*yab + zab*zab)
         xab = xab / norm
         yab = yab / norm
         zab = zab / norm
         xbc = x(ic) - x(ib)
         ybc = y(ic) - y(ib)
         zbc = z(ic) - z(ib)
         norm = sqrt(xbc*xbc + ybc*ybc + zbc*zbc)
         xbc = xbc / norm
         ybc = ybc / norm
         zbc = zbc / norm
         xca = x(ia) - x(ic)
         yca = y(ia) - y(ic)
         zca = z(ia) - z(ic)
         norm = sqrt(xca*xca + yca*yca + zca*zca)
         xca = xca / norm
         yca = yca / norm
         zca = zca / norm
c
c     compute angle cosines between interatomic vectors
c
         cosa = -xab*xca - yab*yca - zab*zca
         cosb = -xbc*xab - ybc*yab - zbc*zab
         cosc = -xca*xbc - yca*ybc - zca*zbc
c
c     find velocity difference vectors between adjacent atoms
c
         xvab = v(1,ib) - v(1,ia)
         yvab = v(2,ib) - v(2,ia)
         zvab = v(3,ib) - v(3,ia)
         xvbc = v(1,ic) - v(1,ib)
         yvbc = v(2,ic) - v(2,ib)
         zvbc = v(3,ic) - v(3,ib)
         xvca = v(1,ia) - v(1,ic)
         yvca = v(2,ia) - v(2,ic)
         zvca = v(3,ia) - v(3,ic)
c
c     get dot product of interatomic and velocity vectors
c
         vabab = xvab*xab + yvab*yab + zvab*zab
         vbcbc = xvbc*xbc + yvbc*ybc + zvbc*zbc
         vcaca = xvca*xca + yvca*yca + zvca*zca
c
c    intermediates for velocity constraint corrections
c
         abmc = mh*cosa*cosb - moh*cosc
         bcma = mo*cosb*cosc - mhh*cosa
         camb = mh*cosc*cosa - moh*cosb
         tab = vabab*(mohoh-mo*cosc*cosc) + vbcbc*camb + vcaca*bcma
         tbc = vbcbc*(mohmoh-mhmh*cosa*cosa)
     &            + vcaca*abmc*mo + vabab*camb*mo
         tca = vcaca*(mohoh-mo*cosb*cosb) + vabab*bcma + vbcbc*abmc
         denom = 2.0d0*mohmoh + momhh*cosa*cosb*cosc
     &              - mhmhh*cosa*cosa - momoh*(cosb*cosb+cosc*cosc)
c
c     construct the velocity constraint correction components
c
         dvax = (xab*tab-xca*tca)*mh / denom
         dvay = (yab*tab-yca*tca)*mh / denom
         dvaz = (zab*tab-zca*tca)*mh / denom
         dvbx = (xbc*tbc-xab*tab*mo) / denom
         dvby = (ybc*tbc-yab*tab*mo) / denom
         dvbz = (zbc*tbc-zab*tab*mo) / denom
         dvcx = (xca*tca*mo-xbc*tbc) / denom
         dvcy = (yca*tca*mo-ybc*tbc) / denom
         dvcz = (zca*tca*mo-zbc*tbc) / denom
c
c     modify velocity components with constraint corrections
c
         v(1,ia) = v(1,ia) + dvax
         v(2,ia) = v(2,ia) + dvay
         v(3,ia) = v(3,ia) + dvaz
         v(1,ib) = v(1,ib) + dvbx
         v(2,ib) = v(2,ib) + dvby
         v(3,ib) = v(3,ib) + dvbz
         v(1,ic) = v(1,ic) + dvcx
         v(2,ic) = v(2,ic) + dvcy
         v(3,ic) = v(3,ic) + dvcz
c
c     increment the internal virial tensor components
c
         vterm = -2.0d0 / (dt*ekcal)
         tax = vterm * x(ia) * mo
         tay = vterm * y(ia) * mo
         taz = vterm * z(ia) * mo
         tbx = vterm * x(ib) * mh
         tby = vterm * y(ib) * mh
         tbz = vterm * z(ib) * mh
         tcx = vterm * x(ic) * mh
         tcy = vterm * y(ic) * mh
         tcz = vterm * z(ic) * mh
         vir(1,1) = vir(1,1) + tax*dvax + tbx*dvbx + tcx*dvcx
         vir(2,1) = vir(2,1) + tay*dvax + tby*dvbx + tcy*dvcx
         vir(3,1) = vir(3,1) + taz*dvax + tbz*dvbx + tcz*dvcx
         vir(1,2) = vir(1,2) + tax*dvay + tbx*dvby + tcx*dvcy
         vir(2,2) = vir(2,2) + tay*dvay + tby*dvby + tcy*dvcy
         vir(3,2) = vir(3,2) + taz*dvay + tbz*dvby + tcz*dvcy
         vir(1,3) = vir(1,3) + tax*dvaz + tbx*dvbz + tcx*dvcz
         vir(2,3) = vir(2,3) + tay*dvaz + tby*dvbz + tcy*dvcz
         vir(3,3) = vir(3,3) + taz*dvaz + tbz*dvbz + tcz*dvcz
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine settleg  --  SETTLE gradient vector correction  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "settleg" modifies the gradient to remove components along any
c     holonomic distance contraints for rigid three-site water using
c     a variant of the SETTLE algorithm
c
c
      subroutine settleg (derivs)
      use atoms
      use freeze
      implicit none
      integer i,j,ia,ib,ic
      real*8 r1x,r1y,r1z
      real*8 r2x,r2y,r2z
      real*8 r3x,r3y,r3z
      real*8 gxO,gyO,gzO
      real*8 gx1,gy1,gz1
      real*8 gx2,gy2,gz2
      real*8 c1o(3),c1h1(3),c1h2(3)
      real*8 c2o(3),c2h1(3),c2h2(3)
      real*8 c3o(3),c3h1(3),c3h2(3)
      real*8 a(3,3),b(3),p(3)
      real*8 derivs(3,*)
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nwat,iwat,x,y,z,derivs)
!$OMP DO
c
c     determine the atom numbers and interactomic vectors
c
      do i = 1, nwat
         ia = iwat(1,i)
         ib = iwat(2,i)
         ic = iwat(3,i)
         r1x = x(ib) - x(ia)
         r1y = y(ib) - y(ia)
         r1z = z(ib) - z(ia)
         r2x = x(ic) - x(ia)
         r2y = y(ic) - y(ia)
         r2z = z(ic) - z(ia)
         r3x = x(ic) - x(ib)
         r3y = y(ic) - y(ib)
         r3z = z(ic) - z(ib)
c
c     construct the vectors for each of the constraints
c
         c1o(1) = -2.0d0 * r1x
         c1o(2) = -2.0d0 * r1y
         c1o(3) = -2.0d0 * r1z
         c1h1(1) = 2.0d0 * r1x
         c1h1(2) = 2.0d0 * r1y
         c1h1(3) = 2.0d0 * r1z
         c1h2(1) = 0.0d0
         c1h2(2) = 0.0d0
         c1h2(3) = 0.0d0
         c2o(1) = -2.0d0 * r2x
         c2o(2) = -2.0d0 * r2y
         c2o(3) = -2.0d0 * r2z
         c2h1(1) = 0.0d0
         c2h1(2) = 0.0d0
         c2h1(3) = 0.0d0
         c2h2(1) = 2.0d0 * r2x
         c2h2(2) = 2.0d0 * r2y
         c2h2(3) = 2.0d0 * r2z
         c3o(1) = 0.0d0
         c3o(2) = 0.0d0
         c3o(3) = 0.0d0
         c3h1(1) = -2.0d0 * r3x
         c3h1(2) = -2.0d0 * r3y
         c3h1(3) = -2.0d0 * r3z
         c3h2(1) = 2.0d0 * r3x
         c3h2(2) = 2.0d0 * r3y
         c3h2(3) = 2.0d0 * r3z
c
c     build the individual element of the constraint matrix
c
         a(1,1) = c1o(1)*c1o(1) + c1o(2)*c1o(2)
     &               + c1o(3)*c1o(3) + c1h1(1)*c1h1(1)
     &               + c1h1(2)*c1h1(2) + c1h1(3)*c1h1(3)
         a(1,2) = c1o(1)*c2o(1) + c1o(2)*c2o(2)
     &               + c1o(3)*c2o(3) + c1h1(1)*c2h1(1)
     &               + c1h1(2)*c2h1(2) + c1h1(3)*c2h1(3)
     &               + c1h2(1)*c2h2(1) + c1h2(2)*c2h2(2)
     &               + c1h2(3)*c2h2(3)
         a(1,3) = c1o(1)*c3o(1) + c1o(2)*c3o(2)
     &               + c1o(3)*c3o(3) + c1h1(1)*c3h1(1)
     &               + c1h1(2)*c3h1(2) + c1h1(3)*c3h1(3)
     &               + c1h2(1)*c3h2(1) + c1h2(2)*c3h2(2)
     &               + c1h2(3)*c3h2(3)
         a(2,1) = a(1,2)
         a(2,2) = c2o(1)*c2o(1) + c2o(2)*c2o(2)
     &               + c2o(3)*c2o(3) + c2h2(1)*c2h2(1)
     &               + c2h2(2)*c2h2(2) + c2h2(3)*c2h2(3)
         a(2,3) = c2o(1)*c3o(1) + c2o(2)*c3o(2)
     &               + c2o(3)*c3o(3) + c2h1(1)*c3h1(1)
     &               + c2h1(2)*c3h1(2) + c2h1(3)*c3h1(3)
     &               + c2h2(1)*c3h2(1) + c2h2(2)*c3h2(2)
     &               + c2h2(3)*c3h2(3)
         a(3,1) = a(1,3)
         a(3,2) = a(2,3)
         a(3,3) = c3h1(1)*c3h1(1) + c3h1(2)*c3h1(2)
     &               + c3h1(3)*c3h1(3) + c3h2(1)*c3h2(1)
     &               + c3h2(2)*c3h2(2) + c3h2(3)*c3h2(3)
c
c     copy the current gradient values into local variables
c
         gxO = -derivs(1,ia)
         gyO = -derivs(2,ia)
         gzO = -derivs(3,ia)
         gx1 = -derivs(1,ib)
         gy1 = -derivs(2,ib)
         gz1 = -derivs(3,ib)
         gx2 = -derivs(1,ic)
         gy2 = -derivs(2,ic)
         gz2 = -derivs(3,ic)
c
c     evaluate the constraint-gradient dot product sums
c
         b(1) = c1o(1)*gxO + c1o(2)*gyO + c1o(3)*gzO
     &             + c1h1(1)*gx1 + c1h1(2)*gy1 + c1h1(3)*gz1
     &             + c1h2(1)*gx2 + c1h2(2)*gy2 + c1h2(3)*gz2
         b(2) = c2o(1)*gxO + c2o(2)*gyO + c2o(3)*gzO
     &             + c2h1(1)*gx1 + c2h1(2)*gy1 + c2h1(3)*gz1
     &             + c2h2(1)*gx2 + c2h2(2)*gy2 + c2h2(3)*gz2
         b(3) = c3o(1)*gxO + c3o(2)*gyO + c3o(3)*gzO
     &             + c3h1(1)*gx1 + c3h1(2)*gy1 + c3h1(3)*gz1
     &             + c3h2(1)*gx2 + c3h2(2)*gy2 + c3h2(3)*gz2
c
c     use a 3x3 Gaussian elimination to solve A * p = b
c
         call solve3 (a,b,p)
c
c     gradient correction to remove projection on constraints
c
         derivs(1,ia) = derivs(1,ia) + p(1)*c1o(1)
     &                     + p(2)*c2o(1) + p(3)*c3o(1)
         derivs(2,ia) = derivs(2,ia) + p(1)*c1o(2)
     &                     + p(2)*c2o(2) + p(3)*c3o(2)
         derivs(3,ia) = derivs(3,ia) + p(1)*c1o(3)
     &                     + p(2)*c2o(3) + p(3)*c3o(3)
         derivs(1,ib) = derivs(1,ib) + p(1)*c1h1(1)
     &                     + p(2)*c2h1(1) + p(3)*c3h1(1)
         derivs(2,ib) = derivs(2,ib) + p(1)*c1h1(2)
     &                     + p(2)*c2h1(2) + p(3)*c3h1(2)
         derivs(3,ib) = derivs(3,ib) + p(1)*c1h1(3)
     &                     + p(2)*c2h1(3) + p(3)*c3h1(3)
         derivs(1,ic) = derivs(1,ic) + p(1)*c1h2(1)
     &                     + p(2)*c2h2(1) + p(3)*c3h2(1)
         derivs(2,ic) = derivs(2,ic) + p(1)*c1h2(2)
     &                     + p(2)*c2h2(2) + p(3)*c3h2(2)
         derivs(3,ic) = derivs(3,ic) + p(1)*c1h2(3)
     &                     + p(2)*c2h2(3) + p(3)*c3h2(3)

      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine solve3  --  3x3 Gaussian elimination with pivot  ## 
c     ##                                                              ##
c     ##################################################################
c
c
c     "solve3" uses 3x3 Gaussian elimination with pivoting to solve
c     A * p = b as a utility to find gradient corrections for rigid
c     three-site water models under the SETTLE algorithm
c
c     note the inputs "a" and "b" are overwritten, and must be saved
c     upon entering this routine if needed upon return; the solution
c     is returned in "p"
c
c
      subroutine solve3 (a,b,p)
      implicit none
      integer i,j,k
      integer pivot
      real*8 b(3)
      real*8 p(3)
      real*8 a(3,3)
      real*8 eps,amax
      real*8 swap,factor
c
c
c     use Gaussian elimination with partial pivoting
c
      eps = 0.00000001d0
      do k = 1, 2
         pivot = k
         amax = abs(a(k,k))
         do i = k+1, 3
            if (abs(a(i,k)) .gt. amax) then
               amax = abs(a(i,k))
               pivot = i
            end if
         end do
c
c     swap rows k and pivot in the "a" matrix and "b" vector
c
         if (pivot .ne. k) then
            do j = k, 3
               swap = a(k,j)
               a(k,j) = a(pivot,j)
               a(pivot,j) = swap
            end do
            swap = b(k)
            b(k) = b(pivot)
            b(pivot) = swap
         end if
c
c     if small pivot, then near singular and use zero solution
c
         if (abs(a(k,k)) .lt. eps) then
            p(1) = 0.0d0
            p(2) = 0.0d0
            p(3) = 0.0d0
            return
         end if
c
c     eliminate the row or rows below
c
         do i = k+1, 3
            factor = a(i,k) / a(k,k)
            a(i,k) = 0.0d0
            do j = k+1, 3
               a(i,j) = a(i,j) - factor*a(k,j)
            end do
            b(i) = b(i) - factor*b(k)
         end do
      end do
c
c     perform the back substitution phase
c
      if (abs(a(3,3)) .lt. eps) then
         p(1) = 0.0d0
         p(2) = 0.0d0
         p(3) = 0.0d0
      else
         p(3) = b(3) / a(3,3)
         p(2) = (b(2)-a(2,3)*p(3)) / a(2,2)
         p(1) = (b(1)-a(1,2)*p(2)-a(1,3)*p(3)) / a(1,1)
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine watfour  --  set 4-site water extra position  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "watfour" sets the position and zeros the velocity of the
c     extra site of rigid planar four-site water molecules 
c
c
      subroutine watfour (dt)
      use atoms
      use freeze
      use moldyn
      implicit none
      integer i
      integer ia,ib,ic,id
      real*8 dt
      real*8 oterm,hterm
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nwat4,iwat4,kwat4,x,y,z,v,dt)
!$OMP DO
c
c     set the position of four-site water extra centers
c
      do i = 1, nwat4
         ia = iwat4(1,i)
         ib = iwat4(2,i)
         ic = iwat4(3,i)
         id = iwat4(4,i)
         oterm = kwat4(1,i)
         hterm = kwat4(2,i)
         x(id) = oterm*x(ia) + hterm*(x(ib)+x(ic))
         y(id) = oterm*y(ia) + hterm*(y(ib)+y(ic))
         z(id) = oterm*z(ia) + hterm*(z(ib)+z(ic))
         if (dt .ne. 0.0d0) then
            v(1,id) = 0.0d0
            v(2,id) = 0.0d0
            v(3,id) = 0.0d0
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine watfour2  --  distribute 4-site water gradient  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "watfour2" transfers gradient components on the extra site of
c     rigid planar four-site water molecules to the H-O-H atoms
c
c
      subroutine watfour2 (derivs)
      use freeze
      implicit none
      integer i,j
      integer ia,ib,ic,id
      real*8 oterm,hterm
      real*8 derivs(3,*)
c
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nwat4,iwat4,kwat4,derivs)
!$OMP DO
c
c     distribute the gradient on four-site water extra centers
c
      do i = 1, nwat4
         ia = iwat4(1,i)
         ib = iwat4(2,i)
         ic = iwat4(3,i)
         id = iwat4(4,i)
         oterm = kwat4(1,i)
         hterm = kwat4(2,i)
         do j = 1, 3
            derivs(j,ia) = derivs(j,ia) + oterm*derivs(j,id)
            derivs(j,ib) = derivs(j,ib) + hterm*derivs(j,id)
            derivs(j,ic) = derivs(j,ic) + hterm*derivs(j,id)
            derivs(j,id) = 0.0d0
         end do
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2018  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine shake  --  SHAKE distance constraint method  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "shake" implements the SHAKE algorithm by correcting atomic
c     positions to maintain interatomic distance and absolute spatial
c     constraints
c
c     literature reference:
c
c     J. P. Ryckaert, G. Ciccotti and H. J. C. Berendsen, "Numerical
c     Integration of the Cartesian Equations of Motion of a System
c     with Constraints: Molecular Dynamics of n-Alkanes", Journal of
c     Computational Physics, 23, 327-341 (1977)
c
c
      subroutine shake (xold,yold,zold)
      use atomid
      use atoms
      use freeze
      use group
      use inform
      use iounit
      use usage
      implicit none
      integer i,j,k
      integer ia,ib,mode
      integer niter,maxiter
      integer start,stop
      real*8 eps,sor,dt
      real*8 xr,yr,zr
      real*8 xo,yo,zo
      real*8 dot,rma,rmb
      real*8 weigh,dist2
      real*8 delta,term
      real*8 xterm,yterm,zterm
      real*8 xold(*)
      real*8 yold(*)
      real*8 zold(*)
      logical done
      logical, allocatable :: moved(:)
      logical, allocatable :: update(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (moved(n))
      allocate (update(n))
c
c     initialize the lists of atoms previously corrected
c
      do i = 1, n
         if (use(i)) then
            moved(i) = .true.
         else
            moved(i) = .false.
         end if
         update(i) = .false.
      end do
c
c     set the iteration counter, termination and tolerance
c
      maxiter = 500
      sor = 1.25d0
      eps = rateps
c
c     apply SHAKE to adjust distances to constraint values
c
      niter = 0
      done = .false.
      do while (.not.done .and. niter.lt.maxiter)
         niter = niter + 1
         done = .true.
         do i = 1, nrat
            ia = irat(1,i)
            ib = irat(2,i)
            if (moved(ia) .or. moved(ib)) then
               xr = x(ib) - x(ia)
               yr = y(ib) - y(ia)
               zr = z(ib) - z(ia)
               if (frzimage(i))  call image (xr,yr,zr)
               dist2 = xr*xr + yr*yr + zr*zr
               delta = krat(i)**2 - dist2
               if (abs(delta) .gt. eps) then
                  done = .false.
                  update(ia) = .true.
                  update(ib) = .true.
                  xo = xold(ib) - xold(ia)
                  yo = yold(ib) - yold(ia)
                  zo = zold(ib) - zold(ia)
                  if (frzimage(i))  call image (xo,yo,zo)
                  dot = xr*xo + yr*yo + zr*zo
                  rma = 1.0d0 / mass(ia)
                  rmb = 1.0d0 / mass(ib)
                  term = 0.5d0 * sor * delta / ((rma+rmb) * dot)
                  xterm = xo * term
                  yterm = yo * term
                  zterm = zo * term
                  x(ia) = x(ia) - xterm*rma
                  y(ia) = y(ia) - yterm*rma
                  z(ia) = z(ia) - zterm*rma
                  x(ib) = x(ib) + xterm*rmb
                  y(ib) = y(ib) + yterm*rmb
                  z(ib) = z(ib) + zterm*rmb
               end if
            end if
         end do
         do i = 1, n
            moved(i) = update(i)
            update(i) = .false.
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (moved)
      deallocate (update)
c
c     write information on the number of iterations needed
c
      if (niter .eq. maxiter) then
         write (iout,10)
   10    format (/,' SHAKE  --  Warning, Distance Constraints',
     &              ' not Satisfied')
         call prterr
         call fatal
      else if (debug) then
         write (iout,20)  niter
   20    format (' SHAKE   --  Distance Constraints met at',i6,
     &              ' Iterations')
      end if
c
c     any rigid planar water molecules are handled separately
c
      dt = 0.0d0
      call settle (dt,xold,yold,zold)
c
c     apply any group position constraints via exact reset
c
      do i = 1, nratx
         ia = iratx(i)
         mode = kratx(i)
         xr = 0.0d0
         yr = 0.0d0
         zr = 0.0d0
         start = igrp(1,ia)
         stop = igrp(2,ia)
         do j = start, stop
            k = kgrp(j)
            weigh = mass(k) / grpmass(ia)
            if (mode .gt. 2) then
               xr = xr + x(k)*weigh
            end if
            if (mode .gt. 1) then
               yr = yr + y(k)*weigh
            end if
            zr = zr + z(k)*weigh
         end do
         do j = start, stop
            k = kgrp(j)
            x(k) = x(k) - xr
            y(k) = y(k) - yr
            z(k) = z(k) - zr
         end do
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine shakeg  --  SHAKE gradient vector correction  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "shakeg" modifies the gradient to remove components along any
c     holonomic distance contraints using a variant of SHAKE
c
c     literature reference:
c
c     Y. Duan, S. Kumar, J. M. Rosenberg and P. A. Kollman, "Gradient
c     SHAKE: An Improved Method for Constrained Energy Minimization in
c     Macromolecular Simulations", Journal of Computational Chemistry,
c     16, 1351-1356 (1995)
c
c
      subroutine shakeg (derivs)
      use atoms
      use freeze
      use inform
      use iounit
      use usage
      implicit none
      integer i,ia,ib
      integer niter,maxiter
      real*8 eps,sor
      real*8 xr,yr,zr
      real*8 xf,yf,zf
      real*8 dist2,delta,term
      real*8 xterm,yterm,zterm
      real*8 derivs(3,*)
      logical done
      logical, allocatable :: moved(:)
      logical, allocatable :: update(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (moved(n))
      allocate (update(n))
c
c     initialize the lists of atoms previously corrected
c
      do i = 1, n
         if (use(i)) then
            moved(i) = .true.
         else
            moved(i) = .false.
         end if
         update(i) = .false.
      end do
c
c     set the iteration counter, termination and tolerance
c
      maxiter = 500
      sor = 1.15d0
      eps = rateps
c
c     adjust the gradient to remove constraint components
c
      niter = 0
      done = .false.
      do while (.not.done .and. niter.lt.maxiter)
         niter = niter + 1
         done = .true.
         do i = 1, nrat
            ia = irat(1,i)
            ib = irat(2,i)
            if (moved(ia) .or. moved(ib)) then
               xr = x(ib) - x(ia)
               yr = y(ib) - y(ia)
               zr = z(ib) - z(ia)
               if (frzimage(i))  call image (xr,yr,zr)
               dist2 = xr*xr + yr*yr + zr*zr
               xf = derivs(1,ib) - derivs(1,ia)
               yf = derivs(2,ib) - derivs(2,ia)
               zf = derivs(3,ib) - derivs(3,ia)
               delta = xr*xf + yr*yf + zr*zf
               if (abs(delta) .gt. eps) then
                  done = .false.
                  update(ia) = .true.
                  update(ib) = .true.
                  term = 0.5d0 * sor * delta / dist2
                  xterm = xr * term
                  yterm = yr * term
                  zterm = zr * term
                  derivs(1,ia) = derivs(1,ia) + xterm
                  derivs(2,ia) = derivs(2,ia) + yterm
                  derivs(3,ia) = derivs(3,ia) + zterm
                  derivs(1,ib) = derivs(1,ib) - xterm
                  derivs(2,ib) = derivs(2,ib) - yterm
                  derivs(3,ib) = derivs(3,ib) - zterm
               end if
            end if
         end do
         do i = 1, n
            moved(i) = update(i)
            update(i) = .false.
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (moved)
      deallocate (update)
c
c     write information on the number of iterations needed
c
      if (niter .eq. maxiter) then
         write (iout,10)
   10    format (/,' SHAKEG  --  Warning, Gradient Constraints',
     &              ' not Satisfied')
         call prterr
         call fatal
      else if (debug) then
         write (iout,20)  niter
   20    format (' SHAKEG  --  Gradient Constraints met at',i6,
     &              ' Iterations')
      end if
c
c     any rigid planar water molecules are handled separately
c
      call settleg (derivs)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2023  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module shapes  --  UnionBall area and volume variables  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     maxedge         maximum number of edges between ball centers
c     maxtetra        maximum number of tetrahedra in the system
c     npoint          total number of balls (points) in the system
c     nvertex         total number of vertices in the system
c     ntetra          total number of tetrahedra in the system
c     nnew            total number of entries on new tetrahedra list
c     ntfree          total number of spaces on free tetrahedra list
c     ntkill          total number of tetrahedra on list to kill
c     nlinkfacet      total number of triangle facets in the system
c     newlist         list with index numbers of the new tetrahedra
c     freespace       list of the tetrahedra currently in free space
c     killspace       list of the existing tetrahedra to be killed
c     vinfo           information value for each of the vertices
c     tedge           number of an edge found in each tetrahedron
c     tinfo           orientation information for each tetrahedron
c     tnindex         index related to tetrahedron orientation
c     tetra           numbers of the four balls in each tetrahedron
c     tneighbor       store the four neighbors of each tetrahedron
c     linkfacet       numbers of two tetrahedra defining each facet
c     linkindex       vertex numbers opposite each facet triangle
c     epsln2          minimal value of determinant over two balls
c     epsln3          minimal value of determinant over three balls
c     epsln4          minimal value of determinant over four balls
c     epsln5          minimal value of determinant over five balls
c     crdball         coordinates in Angstroms of balls as 1-D array
c     radball         radius value for each ball in Angstroms
c     wghtball        weight value assigned for each ball
c
c
      module shapes
      integer maxedge
      integer maxtetra
      integer npoint,nvertex
      integer ntetra,nnew
      integer ntfree,ntkill
      integer nlinkfacet
      integer, allocatable :: newlist(:)
      integer, allocatable :: freespace(:)
      integer, allocatable :: killspace(:)
      integer, allocatable :: vinfo(:)
      integer, allocatable :: tedge(:)
      integer, allocatable :: tinfo(:)
      integer, allocatable :: tnindex(:)
      integer, allocatable :: tetra(:,:)
      integer, allocatable :: tneighbor(:,:)
      integer, allocatable :: linkfacet(:,:)
      integer, allocatable :: linkindex(:,:)
      real*8 epsln2,epsln3
      real*8 epsln4,epsln5
      real*8, allocatable :: crdball(:)
      real*8, allocatable :: radball(:)
      real*8, allocatable :: wghtball(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module shunt  --  polynomial switching function values  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     off    distance at which the potential energy goes to zero
c     off2   square of distance at which the potential goes to zero
c     cut    distance at which switching of the potential begins
c     cut2   square of distance at which the switching begins
c     c0     zeroth order coefficient of multiplicative switch
c     c1     first order coefficient of multiplicative switch
c     c2     second order coefficient of multiplicative switch
c     c3     third order coefficient of multiplicative switch
c     c4     fourth order coefficient of multiplicative switch
c     c5     fifth order coefficient of multiplicative switch
c     f0     zeroth order coefficient of additive switch function
c     f1     first order coefficient of additive switch function
c     f2     second order coefficient of additive switch function
c     f3     third order coefficient of additive switch function
c     f4     fourth order coefficient of additive switch function
c     f5     fifth order coefficient of additive switch function
c     f6     sixth order coefficient of additive switch function
c     f7     seventh order coefficient of additive switch function
c
c
      module shunt
      implicit none
      real*8 off,off2
      real*8 cut,cut2
      real*8 c0,c1,c2
      real*8 c3,c4,c5
      real*8 f0,f1,f2,f3
      real*8 f4,f5,f6,f7
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  function sigmoid  --  general sigmoidal functional form  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "sigmoid" implements a normalized sigmoidal function on the
c     interval [0,1]; the curves connect (0,0) to (1,1) and have
c     a cooperativity controlled by beta, they approach a straight
c     line as beta -> 0 and get more nonlinear as beta increases
c
c
      function sigmoid (beta,x)
      implicit none
      real*8 beta,x
      real*8 sigmoid
      real*8 expmax
      real*8 expmin
      real*8 expterm
c
c
c     compute the value of the normalized sigmoidal function
c
      if (beta .eq. 0.0d0) then
         sigmoid = x
      else
         expmax = 1.0d0 / (exp(-beta) + 1.0d0)
         expmin = 1.0d0 / (exp(beta) + 1.0d0)
         expterm = 1.0d0 / (exp(beta*(2.0d0*x-1.0d0)) + 1.0d0)
         sigmoid = (expmax - expterm) / (expmax - expmin)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2020  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine simplex  --  Nelder-Mead simplex optimization  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "simplex" is a general multidimensional Nelder-Mead simplex
c     optimization routine requiring only repeated evaluations of
c     the objective function
c
c     literature reference:
c
c     R. O'Neill, "Algorithm AS 47: Function Minimization Using a
c     Simplex Procedure", Applied Statistics, 20, 338-345 (1971)
c
c
      subroutine simplex (nvar,iter,ntest,x0,y0,step,toler,fvalue)
      use inform
      use iounit
      use keys
      use minima
      implicit none
      real*8 ccoeff,ecoeff
      real*8 rcoeff,eps
      parameter (ccoeff=0.5d0)
      parameter (ecoeff=2.0d0)
      parameter (rcoeff=1.0d0)
      parameter (eps=0.001d0)
      integer i,j,k,nvar
      integer iter,next
      integer ihi,ilo
      integer ntest,jtest
      real*8 toler,tol
      real*8 fvalue,step
      real*8 x,z,del
      real*8 y0,ylo
      real*8 ystar,y2star
      real*8 x0(*)
      real*8, allocatable :: xmin(:)
      real*8, allocatable :: pbar(:)
      real*8, allocatable :: pstar(:)
      real*8, allocatable :: p2star(:)
      real*8, allocatable :: y(:)
      real*8, allocatable :: p(:,:)
      logical done
      character*20 keyword
      character*240 record
      character*240 string
      external fvalue
c
c
c     set default parameters for the optimization
c
      if (maxiter .eq. 0)  maxiter = 1000000
      if (iprint .lt. 0)  iprint = 1000
      if (iwrite .lt. 0)  iwrite = 1000
c
c     search the keywords for optimization parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:8) .eq. 'MAXITER ') then
            read (string,*,err=10,end=10)  maxiter
         end if
   10    continue
      end do
c
c     initialization of various counters and variables
c
      done = .false.
      iter = 0
      jtest = ntest
      del = 1.0d0
      tol = toler * dble(nvar)
c
c     print header information about the optimization method
c
      if (iprint .gt. 0) then
         write (iout,20)
   20    format (/,' Nelder-Mead Simplex Optimization :')
         write (iout,30)
   30    format (/,' NM Iter     F Value      G RMS      F Move',
     &              '   X Move    Comment')
         flush (iout)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (xmin(nvar))
      allocate (pbar(nvar))
      allocate (pstar(nvar))
      allocate (p2star(nvar))
      allocate (y(nvar+1))
      allocate (p(nvar,nvar+1))
c
c     initialize or restart with the base function value
c
      do while (.not. done)
         do i = 1, nvar
            p(i,nvar+1) = x0(i)
         end do
         y(nvar+1) = fvalue (x0)
         iter = iter + 1
c
c     define the initial simplex as an "nvar+1" polytope
c
         do j = 1, nvar
            x = x0(j)
            x0(j) = x0(j) + step*del
            do i = 1, nvar
               p(i,j) = x0(i)
            end do
            y(j) = fvalue (x0)
            iter = iter + 1
            x0(j) = x
         end do
c
c     find highest and lowest values; highest will be replaced
c
         ilo = nvar + 1
         ylo = y(ilo)
         do i = 1, nvar
            if (y(i) .le. ylo) then
               ilo = i
               ylo = y(ilo)
            end if
         end do
c
c     set "y0" to be the current highest function value
c
         do while (iter .lt. maxiter)
            ihi = nvar + 1
            y0 = y(ihi)
            do i = 1, nvar
               if (y(i) .ge. y0) then
                  ihi = i
                  y0 = y(ihi)
               end if
            end do
c
c     calculate "pbar", the centroid of the simplex vertices
c     excepting the vertex with the highest function value
c
            do i = 1, nvar
               pbar(i) = 0.0d0
               do j = 1, nvar+1
                  pbar(i) = pbar(i) + p(i,j)
               end do
               pbar(i) = (pbar(i)-p(i,ihi)) / dble(nvar)
            end do
c
c     reflection through the centroid of the vertices
c
            do i = 1, nvar
               pstar(i) = pbar(i) + rcoeff*(pbar(i)-p(i,ihi))
            end do
            ystar = fvalue (pstar)
            iter = iter + 1
c
c     successful reflection, so try simplex extension
c
            if (ystar .lt. ylo) then
               do i = 1, nvar
                  p2star(i) = pbar(i) + ecoeff*(pstar(i)-pbar(i))
               end do
               y2star = fvalue (p2star)
               iter = iter + 1
c
c     retain extension or contraction of the simplex
c
               if (ystar .lt. y2star) then
                  do i = 1, nvar
                     p(i,ihi) = pstar(i)
                  end do
                  y(ihi) = ystar
               else
                  do i = 1, nvar
                     p(i,ihi) = p2star(i)
                  end do
                  y(ihi) = y2star
               end if
c
c     no extension of the simplex will be used
c
            else
               k = 0
               do i = 1, nvar+1
                  if (ystar .lt. y(i)) then
                     k = k + 1
                  end if
               end do
               if (1 .lt. k) then
                  do i = 1, nvar
                     p(i,ihi) = pstar(i)
                  end do
                  y(ihi) = ystar
c
c     contraction on the "ihi" side of the centroid
c
               else if (k .eq. 0) then
                  do i = 1, nvar
                     p2star(i) = pbar(i) + ccoeff*(p(i,ihi)-pbar(i))
                  end do
                  y2star = fvalue (p2star)
                  iter = iter + 1
c
c     perform contraction of the whole simplex
c
                  if (y(ihi) .lt. y2star) then
                     do j = 1, nvar+1
                        do i = 1, nvar
                           p(i,j) = 0.5d0 * (p(i,j)+p(i,ilo))
                        end do
                        do i = 1, nvar
                           xmin(i) = p(i,j)
                        end do
                        y(j) = fvalue (xmin)
                        iter = iter + 1
                     end do
                     ilo = nvar + 1
                     ylo = y(ilo)
                     do i = 1, nvar
                        if (y(i) .le. ylo) then
                           ilo = i
                           ylo = y(ilo)
                        end if
                     end do
                     goto 40
c
c     retain the contraction of the simplex
c
                  else
                     do i = 1, nvar
                        p(i,ihi) = p2star(i)
                     end do
                     y(ihi) = y2star
                  end if
c
c     contraction on the reflection side of the centroid
c
               else if (k .eq. 1) then
                  do i = 1, nvar
                     p2star(i) = pbar(i) + ccoeff*(pstar(i)-pbar(i))
                  end do
                  y2star = fvalue (p2star)
                  iter = iter + 1
c
c     check whether to retain reflection of the simplex
c
                  if (y2star .le. ystar) then
                     do i = 1, nvar
                        p(i,ihi) = p2star(i)
                     end do
                     y(ihi) = y2star
                  else
                     do i = 1, nvar
                        p(i,ihi) = pstar(i)
                     end do
                     y(ihi) = ystar
                  end if
               end if
            end if
c
c     check to see if the "ylo" value has improved
c
            if (y(ihi) .lt. ylo) then
               ylo = y(ihi)
               ilo = ihi
            end if
c
c     check to see if the desired minimum has been reached
c
            jtest = jtest -1
            if (jtest .eq. 0) then
               if (iter .le. maxiter) then
                  jtest = ntest
                  x = 0.0d0
                  do i = 1, nvar+1
                     x = x + y(i)
                  end do
                  x = x / dble(nvar+1)
                  z = 0.0d0
                  do i = 1, nvar+1
                     z = z + (y(i)-x)**2
                  end do
                  if (z .le. tol) then
                     goto 50
                  end if
               end if
            end if
   40       continue
         end do
   50    continue
c
c     factorial tests to check if "y0" is a local minimum
c
         do i = 1, nvar
            xmin(i) = p(i,ilo)
         end do
         y0 = y(ilo)
         done = .true.
         if (iter .ge. maxiter) then
            write (iout,60)
   60       format (/,' SIMPLEX  --  Maximum Number of Iterations',
     &                 ' Exceeded')
         else
            do i = 1, nvar
               del = step * eps
               xmin(i) = xmin(i) + del
               z = fvalue (xmin)
               iter = iter + 1
               if (z .lt. y0) then
                  done = .false.
                  goto 70
               end if
               xmin(i) = xmin(i) - del - del
               z = fvalue (xmin)
               iter = iter + 1
               if (z .lt. y0) then
                  done = .false.
                  goto 70
               end if
               xmin(i) = xmin(i) + del
            end do
         end if
   70    continue
c
c     set return to current minimum, restart if warranted
c
         do i = 1, nvar
            x0(i) = xmin(i)
         end do
         del = eps
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xmin)
      deallocate (pbar)
      deallocate (pstar)
      deallocate (p2star)
      deallocate (y)
      deallocate (p)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module sizes  --  parameters to set array dimensions  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "sizes" sets values for array dimensions used throughout
c     the software; these parameters fix the size of the largest
c     systems that can be handled
c
c     parameter:      maximum allowed number of:
c
c     maxatm          atoms in the molecular system
c     maxtyp          force field atom type definitions
c     maxclass        force field atom class definitions
c     maxval          atoms directly bonded to an atom
c     maxref          stored reference molecular systems
c     maxgrp          user-defined groups of atoms
c     maxres          residues in all macromolecules
c     maxbio          biopolymer atom type definitions
c
c
      module sizes
      implicit none
      integer maxatm,maxtyp
      integer maxclass,maxval
      integer maxref,maxgrp
      integer maxres,maxbio
      parameter (maxatm=1000000)
      parameter (maxtyp=5000)
      parameter (maxclass=1000)
      parameter (maxval=8)
      parameter (maxref=30)
      parameter (maxgrp=1000)
      parameter (maxres=10000)
      parameter (maxbio=10000)
      save
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2002 by Michael Schnieders & Jay W. Ponder  ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine sktdyn  --   send the current dynamics info  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "sktdyn" sends the current dynamics info via a socket
c
c
      subroutine sktdyn (istep,dt,epot)
      use atoms
      use moldyn
      use mpole
      use polar
      use potent
      use socket
      implicit none
      integer i,k,istep
      integer flag
      real*8 dt,time,epot
      real*8, allocatable :: vx(:)
      real*8, allocatable :: vy(:)
      real*8, allocatable :: vz(:)
      real*8, allocatable :: ax(:)
      real*8, allocatable :: ay(:)
      real*8, allocatable :: az(:)
      real*8, allocatable :: px(:)
      real*8, allocatable :: py(:)
      real*8, allocatable :: pz(:)
c
c
c     check to see if the server has been created
c
      skttyp = 1
      if (.not. sktstart)  call sktinit ()
      if (.not. use_socket)  return
c
c     save the current step number, time and energy
c
      cstep = istep
      cdt = dt
      cenergy = epot
c
c     check to see if we need to update the system info
c
      flag = 1
      if (.not. sktstop)  call needupdate (flag)
      if (flag .eq. 0)  return
c
c     get the monitor for the update structure
c
      call getmonitor ()
c
c     load the coordinates, time and energy information
c
      call setcoordinates (n,x,y,z)
      time = dble(istep) * dt
      call setmdtime (time)
      call setenergy (epot)
c
c     perform dynamic allocation of some local arrays
c
      allocate (vx(n))
      allocate (vy(n))
      allocate (vz(n))
      allocate (ax(n))
      allocate (ay(n))
      allocate (az(n))
      allocate (px(n))
      allocate (py(n))
      allocate (pz(n))
c
c     load the velocity and acceleration information
c
      do i = 1, n
         vx(i) = v(1,i)
         vy(i) = v(2,i)
         vz(i) = v(3,i)
         ax(i) = a(1,i)
         ay(i) = a(2,i)
         az(i) = a(3,i)
         px(i) = 0.0d0
         py(i) = 0.0d0
         pz(i) = 0.0d0
      end do
      call setvelocity (n,vx,vy,vz)
      call setacceleration (n,ax,ay,az)
      if (use_polar) then
          do i = 1, npole
             k = ipole(i)
             px(k) = uind(1,k)
             py(k) = uind(2,k)
             pz(k) = uind(3,k)
          end do
          call setinduced (n,px,py,pz)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (vx)
      deallocate (vy)
      deallocate (vz)
      deallocate (ax)
      deallocate (ay)
      deallocate (az)
      deallocate (px)
      deallocate (py)
      deallocate (pz)
c
c     release the monitor for the update stucture
c
      call setupdated ()
      call releasemonitor ()
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine sktopt  --  send current optimization info  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "sktopt" sends the current optimization info via a socket
c
c
      subroutine sktopt (ncycle,eopt)
      use atoms
      use deriv
      use mpole
      use polar
      use potent
      use socket
      implicit none
      integer i,k,ncycle
      integer flag
      real*8 eopt
      real*8, allocatable :: gx(:)
      real*8, allocatable :: gy(:)
      real*8, allocatable :: gz(:)
      real*8, allocatable :: px(:)
      real*8, allocatable :: py(:)
      real*8, allocatable :: pz(:)
c
c
c     check to see if the server has been created
c
      skttyp = 2
      if (.not. sktstart)  call sktinit ()
      if (.not. use_socket)  return
c
c     save the current step number and energy
c
      cstep = ncycle
      cenergy = eopt
c
c     check to see if an update is needed
c
      flag = 1
      if (.not. sktstop)  call needupdate (flag)
      if (flag .eq. 0)  return
c
c     get the monitor for the update structure
c
      call getmonitor ()
c
c     load the coordinates and energy information
c
      call setcoordinates (n,x,y,z)
      call setstep (ncycle)
      call setenergy (eopt)
c
c     perform dynamic allocation of some local arrays
c
      allocate (gx(n))
      allocate (gy(n))
      allocate (gz(n))
      allocate (px(n))
      allocate (py(n))
      allocate (pz(n))
c
c     load the gradient and induced dipole information
c
      do i = 1, n
         gx(i) = desum(1,i)
         gy(i) = desum(2,i)
         gz(i) = desum(3,i)
         px(i) = 0.0d0
         py(i) = 0.0d0
         pz(i) = 0.0d0
      end do
      call setgradients (n,gx,gy,gz)
      if (use_polar) then
          do i = 1, npole
             k = ipole(i)
             px(k) = uind(1,k)
             py(k) = uind(2,k)
             pz(k) = uind(3,k)
          end do
          call setinduced (n,px,py,pz)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (gx)
      deallocate (gy)
      deallocate (gz)
      deallocate (px)
      deallocate (py)
      deallocate (pz)
c
c     release the monitor for the system stucture
c
      call setupdated ()
      call releasemonitor ()
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine sktinit  --  initialize socket communication  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "sktinit" sets up socket communication with the graphical
c     user interface by starting a Java virtual machine, initiating
c     a server, and loading an object with system information
c
c
      subroutine sktinit
      use atomid
      use atoms
      use charge
      use couple
      use files
      use fields
      use iounit
      use inform
      use keys
      use polar
      use socket
      implicit none
      integer i
      integer flag
      integer, allocatable :: b1(:)
      integer, allocatable :: b2(:)
      integer, allocatable :: b3(:)
      integer, allocatable :: b4(:)
c
c
c     set initialization flag and test for socket usage
c
      sktstart = .true.
      use_socket = .true.
      call chksocket (flag)
      if (flag .eq. 0) then
         use_socket = .false.
         return
      end if
c
c     create the Java Virtual Machine
c
      call createjvm (flag)
      if (flag .eq. 0) then
         use_socket = .false.
         write (iout,10)
   10    format (/,' SKTINIT  --  Unable to Create the JVM Server',
     &           /,' Check LD_LIBRARY_PATH and CLASSPATH Variables',/)
         return
      end if
c
c     create the Tinker system object
c
      call createsystem (n,nkey,flag)
      if (flag .eq. 0) then
         use_socket = .false.
         write (iout,20)
   20    format (/,' SKTINIT  --  Unable to Create Tinker System',/)        
         return
      end if
c
c     load the keyfile and coordinates information
c
      call setfile (filename)
      call setforcefield (forcefield)
      do i = 1, nkey
         call setkeyword (i,keyline(i))
      end do
      call setcoordinates (n,x,y,z)
c
c     perform dynamic allocation of some local arrays
c
      allocate (b1(n))
      allocate (b2(n))
      allocate (b3(n))
      allocate (b4(n))
c
c     load the atom connectivity information
c
      do i = 1, n
         b1(i) = i12(1,i)
         b2(i) = i12(2,i)
         b3(i) = i12(3,i)
         b4(i) = i12(4,i)
      end do
      call setconnectivity (n,b1,b2,b3,b4)
c
c     perform deallocation of some local arrays
c
      deallocate (b1)
      deallocate (b2)
      deallocate (b3)
      deallocate (b4)
c
c     load atom type information for the parameter set
c
      call setatomtypes (n,type)
      do i = 1, n
         call setname (i,name(i))
         call setstory (i,story(i))
      end do
      call setatomic (n,atomic)
      call setmass (n,mass)
      call setcharge (n,pchg)
c
c     create the Tinker server
c
      call createserver (flag)
      if (flag .eq. 0) then
         use_socket = .false.
         write (iout,30)
   30    format (/,' SKTINIT  --  Unable to Create Tinker Server',/)
         return
      end if
c
c     create the update object
c
      call createupdate (n,skttyp,npolar,flag)
      if (flag .eq. 0) then
         use_socket = .false.
         write (iout,40)
   40    format (/,' SKTINIT  --  Unable to Create Update Object',/)
         return
      end if
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine sktkill  --  shutdown the server and JVM  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "sktkill" closes the server and Java virtual machine
c
c
      subroutine sktkill
      use socket
      implicit none
c
c
c     check to see if there is anything to close
c
      if (.not. use_socket)  return
      sktstop = .true.
c
c     load the final simulation results
c
      if (skttyp .eq. 1)  call sktdyn (cstep,cdt,cenergy)
      if (skttyp .eq. 2)  call sktopt (cstep,cenergy)
c
c     shutdown the Tinker server
c
      call destroyserver ()
c
c     shutdown the Java virtual machine
c
c     call destroyjvm ()
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program sniffer  --  discrete generalized descent search  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "sniffer" performs a global energy minimization using a
c     discrete version of Griewank's global search trajectory
c
c     literature references:
c
c     A. O. Griewank, "Generalized Descent for Global Optimization",
c     Journal of Optimization Theory and Applications, 34, 11-39 (1981)
c
c     R. A. R. Butler and E. E. Slaminka, "An Evaluation of the Sniffer
c     Global Optimization Algorithm Using Standard Test Functions",
c     Journal of Computational Physics, 99, 28-32 (1992)
c
c     J. W. Rogers, Jr. and R. A. Donnelly, "Potential Transformation
c     Methods for Large-Scale Global Optimization", SIAM Journal of
c     Optimization, 5, 871-891 (1995)
c
c
      program sniffer
      use atoms
      use files
      use inform
      use iounit
      use linmin
      use math
      use minima
      use output
      use scales
      use usage
      implicit none
      integer i,j,k,imin
      integer nvar,niter
      integer start,stop
      integer freeunit
      integer istep,maxstep
      real*8 sniffer1,gnorm
      real*8 grms,grdmin
      real*8 f,eps,mu
      real*8 scaler,angle
      real*8 rms,size
      real*8 fmin,gmin
      real*8 dnorm,dot
      real*8 alpha,cosine
      real*8 epsfac,mufac
      real*8 stepfac
      real*8 minimum
      real*8, allocatable :: xx(:)
      real*8, allocatable :: g(:)
      real*8, allocatable :: d(:)
      real*8, allocatable :: derivs(:,:)
      logical exist,done
      character*9 status
      character*240 minfile
      character*240 string
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
      call makeref (1)
c
c     get the number of steps in the initial block
c
      maxstep = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  maxstep
   10 continue
      if (maxstep .le. 0) then
         write (iout,20)
   20    format (/,' Enter Number of Steps in the Initial Set',
     &              ' [100] :  ',$)
         read (input,30)  maxstep
   30    format (i10)
      end if
      if (maxstep .le. 0)  maxstep = 100
c
c     get the target value for the global energy minimum
c
      fctmin = 1000000.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=40,end=40)  fctmin
   40 continue
      if (fctmin .ge. 1000000.0d0) then
         write (iout,50)
   50    format (/,' Enter Target Energy for the Global Minimum',
     &              ' [0.0] :  ',$)
         read (input,60)  fctmin
   60    format (f20.0)
      end if
      if (fctmin .ge. 1000000.0d0)  fctmin = 0.0d0
c
c     get termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=70,end=70)  grdmin
   70 continue
      if (grdmin .le. 0.0d0) then
         write (iout,80)
   80    format (/,' Enter RMS Gradient per Atom Criterion [1.0] :  ',$)
         read (input,90)  grdmin
   90    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 1.0d0
c
c     write out a copy of coordinates for later update
c
      imin = freeunit ()
      minfile = filename(1:leng)//'.xyz'
      call version (minfile,'new')
      open (unit=imin,file=minfile,status='new')
      call prtxyz (imin)
      close (unit=imin)
      outfile = minfile
      coordtype = 'CARTESIAN'
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(scale))  allocate (scale(3*n))
c
c     set scaling parameter for function and derivative values;
c     use square root of median eigenvalue of a typical Hessian
c
      set_scale = .true.
      scaler = 1.0d0
      nvar = 0
      do i = 1, nuse
         do j = 1, 3
            nvar = nvar + 1
            scale(nvar) = scaler
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nvar))
      allocate (g(nvar))
      allocate (d(nvar))
      allocate (derivs(3,n))
c
c     scale the coordinates of each active atom
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         xx(nvar) = x(k) * scale(nvar)
         nvar = nvar + 1
         xx(nvar) = y(k) * scale(nvar)
         nvar = nvar + 1
         xx(nvar) = z(k) * scale(nvar)
      end do
c
c     set initial values for the control parameters
c
      epsfac = 1.1d0
      mufac = 1.7d0
      stepfac = 1.1d0
c
c     set initial values for optimization parameters
c
      iprint = 1
      iwrite = 100
      rms = sqrt(dble(n))
      start = 0
      stop = start + maxstep
      eps = 1.0d0
      mu = 1.0d0
      stpmax = 0.1d0 * rms
      stpmin = 0.001d0
c
c     initialize unit direction vector along negative gradient
c
      f = sniffer1 (xx,g)
      gnorm = 0.0d0
      do i = 1, nvar
         gnorm = gnorm + g(i)**2
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / rms
      do i = 1, nvar
         d(i) = -g(i) / gnorm
      end do
      fmin = f
      gmin = grms
c
c     tests of the successful termination criteria
c
      if (fmin .le. fctmin) then
         status = 'TargetVal'
         done = .true.
      else if (gmin .le. grdmin) then
         status = 'SmallGrad'
         done = .true.
      else
         done = .false.
      end if
c
c     print header information prior to iterations
c
      if (iprint .gt. 0) then
         write (iout,100)
  100    format (/,' Discrete Generalized Descent Global',
     &              ' Optimization :')
      end if
c
c     perform a set of basic sniffer search steps
c
      niter = 0
      do while (.not. done)
         write (iout,110)
  110    format (/,4x,'Iter',11x,'F Value',13x,'G RMS',
     &             8x,'X Move',9x,'Angle',/)
         do istep = start, stop
c
c     get the current energy and gradient values
c
            f = sniffer1 (xx,g)
c
c     if current energy is lowest yet, save the coordinates
c
            if (f .lt. fmin) then
               nvar = 0
               do i = 1, nuse
                  k = iuse(i)
                  nvar = nvar + 1
                  x(k) = xx(nvar) / scale(nvar)
                  nvar = nvar + 1
                  y(k) = xx(nvar) / scale(nvar)
                  nvar = nvar + 1
                  z(k) = xx(nvar) / scale(nvar)
               end do
               call makeref (1)
               imin = freeunit ()
               open (unit=imin,file=minfile,status='old')
               rewind (unit=imin)
               call prtxyz (imin)
               close (unit=imin)
            end if
c
c     get rms gradient and dot product with search direction
c
            gnorm = 0.0d0
            dot = 0.0d0
            do i = 1, nvar
               gnorm = gnorm + g(i)*g(i)
               dot = dot + d(i)*g(i)
            end do
            gnorm = sqrt(gnorm)
            grms = gnorm / (scaler*rms)
c
c     compute the next direction vector and its length
c
            alpha = max(0.0d0,1.0d0+(1.0d0+eps)*dot)
            dnorm = 0.0d0
            do i = 1, nvar
               d(i) = -eps*g(i) + alpha*d(i)
               dnorm = dnorm + d(i)*d(i)
            end do
            dnorm = sqrt(dnorm)
c
c     normalize direction and get angle with negative gradient
c
            dot = 0.0d0
            do i = 1, nvar
               d(i) = d(i) / dnorm
               dot = dot + d(i)*g(i)
            end do
            cosine = -dot / gnorm
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
c
c     move atomic positions along the direction vector
c
            size = min(stpmax,mu*(f-fctmin))
            do i = 1, nvar
               xx(i) = xx(i) + size*d(i)
            end do
c
c     compute the size of the step taken
c
            size = min(stpmax,mu*(f-fctmin))
            size = size / rms
c
c     update the best value and gradient found so far
c
            fmin = min(fmin,f)
            gmin = min(gmin,grms)
c
c     print intermediate results every few iterations
c
            if (iprint .gt. 0) then
               if (done .or. mod(niter,iprint).eq.0) then
                  if (f.lt.1.0d12 .and. f.gt.-1.0d11
     &                .and. grms.lt.1.0d12) then
                     write (iout,120)  istep,f,grms,size,angle
  120                format (i8,2f18.4,2f14.4)
                  else
                     write (iout,130)  istep,f,grms,size,angle
  130                format (i8,2d18.4,2f14.4)
                  end if
               end if
            end if
         end do
c
c     tests of the various termination and error criteria
c
         if (fmin .le. fctmin) then
            status = 'TargetVal'
            done = .true.
         else if (gmin .le. grdmin) then
            status = 'SmallGrad'
            done = .true.
         else if (size .le. stpmin) then
            status = 'SmallMove'
            done = .true.
         end if
c
c     write the final coordinates for this set of steps
c
         niter = niter + 1
         if (cyclesave)  call optsave (niter,fmin,xx)
c
c     update the optimization parameters for the next set
c
         eps = eps * epsfac
         mu = mu / mufac
         maxstep = nint(dble(maxstep)*stepfac)
         start = stop + 1
         stop = start + maxstep
      end do
c
c     write message about satisfaction of termination criteria
c
      if (status .eq. 'SmallMove') then
         write (iout,140)  status
  140    format (/,' SNIFFER  --  Incomplete Convergence due to ',a9)
      else
         write (iout,150)  status
  150    format (/,' SNIFFER  --  Normal Termination due to ',a9)
      end if
c
c     use lowest energy structure as global minimum estimate
c
      call getref (1)
c
c     compute the final function and RMS gradient values
c
      call gradient (minimum,derivs)
      gnorm = 0.0d0
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            gnorm = gnorm + derivs(j,k)**2
         end do
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / rms
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      deallocate (g)
      deallocate (d)
      deallocate (derivs)
c
c     write out the final function and gradient values
c
      if (grms .gt. 0.0001d0) then
         write (iout,160)  minimum,grms,gnorm
  160    format (/,' Final Function Value :',f15.4,
     &           /,' Final RMS Gradient :  ',f15.4,
     &           /,' Final Gradient Norm : ',f15.4)
      else
         write (iout,170)  minimum,grms,gnorm
  170    format (/,' Final Function Value :',f15.4,
     &           /,' Final RMS Gradient :  ',d15.4,
     &           /,' Final Gradient Norm : ',d15.4)
      end if
c
c     write the final coordinates into a file
c
      imin = freeunit ()
      open (unit=imin,file=minfile,status='old')
      rewind (unit=imin)
      call prtxyz (imin)
      close (unit=imin)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function sniffer1  --  energy and gradient for sniffer  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "sniffer1" is a service routine that computes the energy
c     and gradient for the Sniffer global optimization method
c
c
      function sniffer1 (xx,g)
      use atoms
      use scales
      use usage
      implicit none
      integer i,k,nvar
      real*8 sniffer1,e
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         x(k) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         y(k) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         z(k) = xx(nvar) / scale(nvar)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the energy and gradient
c
      call gradient (e,derivs)
      sniffer1 = e
c
c     convert gradient components to optimization parameters
c
      nvar = 0
      do i = 1, nuse
         k = iuse(i)
         nvar = nvar + 1
         g(nvar) = derivs(1,k) / scale(nvar)
         nvar = nvar + 1
         g(nvar) = derivs(2,k) / scale(nvar)
         nvar = nvar + 1
         g(nvar) = derivs(3,k) / scale(nvar)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2002  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module socket  --  socket communication control parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     skttyp      socket information type (1=DYN, 2=OPT)
c     cstep       current dynamics or optimization step number
c     cdt         current dynamics cumulative simulation time
c     cenergy     current potential energy from simulation
c     sktstart    logical flag to indicate socket initialization
c     sktstop     logical flag to indicate socket shutdown
c     use_socket  logical flag governing use of external sockets
c
c
      module socket
      implicit none
      integer skttyp
      integer cstep
      real*8 cdt
      real*8 cenergy
      logical sktstart
      logical sktstop
      logical use_socket
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2020  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module solpot  --  solvation term functional form details  ##
c     ##                                                             ##
c     #################################################################
c
c
c     solvtyp   type of continuum solvation energy model in use
c     borntyp   method to be used for the Born radius computation
c
c
      module solpot
      implicit none
      character*8 solvtyp
      character*8 borntyp
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module solute  --  continuum solvation model parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     maxneck     maximum number of neck correction atom radius bins
c
c     doffset     dielectric offset to continuum solvation atomic radii
c     onipr       probe radius to use with onion Born radius method
c     p1          single-atom scale factor for analytical Still radii
c     p2          1-2 interaction scale factor for analytical Still radii
c     p3          1-3 interaction scale factor for analytical Still radii
c     p4          nonbonded scale factor for analytical Still radii
c     p5          soft cutoff parameter for analytical Still radii
c     descoff     offset for pairwise descreening at small separation
c     rneck       atom radius bins used to store Aij/Bij neck constants
c     aneck       constants to use in calculating neck values
c     bneck       constants to use in calculating neck values
c     rsolv       atomic radius of each atom for continuum solvation
c     rdescr      atomic radius of each atom for descreening
c     asolv       atomic surface area solvation weight parameters
c     rborn       Born radius of each atom for GB/SA solvation
c     drb         solvation derivatives with respect to Born radii
c     drbp        GK polarization derivatives with respect to Born radii
c     drobc       chain rule term for Onufriev-Bashford-Case radii
c     gpol        polarization self-energy values for each atom
c     shct        Hawkins-Cramer-Truhlar radius overlap scale factors 
c     aobc        alpha values for Onufriev-Bashford-Case radii
c     bobc        beta values for Onufriev-Bashford-Case radii
c     gobc        gamma values for Onufriev-Bashford-Case radii
c     vsolv       atomic volume of each atom for use with ACE
c     wace        "omega" values for atom class pairs for use with ACE
c     s2ace       "sigma^2" values for atom class pairs for use with ACE
c     uace        "mu" values for atom class pairs for use with ACE
c     sneck       pairwise neck correction scale factor for each atom
c     bornint     unscaled 1/r^6 corrections for tanh chain rule term
c     useneck     logical flag to use neck interstitial space correction
c     usetanh     logical flag to use tanh interstitial space correction
c     
c
c
      module solute
      implicit none
      integer maxneck
      parameter (maxneck=45)
      real*8 doffset,onipr
      real*8 p1,p2,p3,p4,p5
      real*8 descoff
      real*8 rneck(maxneck)
      real*8 aneck(maxneck,maxneck)
      real*8 bneck(maxneck,maxneck)
      real*8, allocatable :: rsolv(:)
      real*8, allocatable :: rdescr(:)
      real*8, allocatable :: asolv(:)
      real*8, allocatable :: rborn(:)
      real*8, allocatable :: drb(:)
      real*8, allocatable :: drbp(:)
      real*8, allocatable :: drobc(:)
      real*8, allocatable :: gpol(:)
      real*8, allocatable :: shct(:)
      real*8, allocatable :: aobc(:)
      real*8, allocatable :: bobc(:)
      real*8, allocatable :: gobc(:)
      real*8, allocatable :: vsolv(:)
      real*8, allocatable :: wace(:,:)
      real*8, allocatable :: s2ace(:,:)
      real*8, allocatable :: uace(:,:)
      real*8, allocatable :: sneck(:)
      real*8, allocatable :: bornint(:)
      logical useneck
      logical usetanh
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #########################################################
c     ##                                                     ##
c     ##  subroutine sort  --  heapsort of an integer array  ##
c     ##                                                     ##
c     #########################################################
c
c
c     "sort" takes an input list of integers and sorts it
c     into ascending order using the Heapsort algorithm
c
c
      subroutine sort (n,list)
      implicit none
      integer i,j,k,n
      integer index,lists
      integer list(*)
c
c
c     perform the heapsort of the input list
c
      k = n/2 + 1
      index = n
      do while (n .gt. 1)
         if (k .gt. 1) then
            k = k - 1
            lists = list(k)
         else
            lists = list(index)
            list(index) = list(1)
            index = index - 1
            if (index .le. 1) then
               list(1) = lists
               return
            end if
         end if
         i = k
         j = k + k
         do while (j .le. index)
            if (j .lt. index) then
               if (list(j) .lt. list(j+1))  j = j + 1
            end if
            if (lists .lt. list(j)) then
               list(i) = list(j)
               i = j
               j = j + j
            else
               j = index + 1
            end if
         end do
         list(i) = lists
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine sort2  --  heapsort of real array with keys  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "sort2" takes an input list of reals and sorts it
c     into ascending order using the Heapsort algorithm;
c     it also returns a key into the original ordering
c
c
      subroutine sort2 (n,list,key)
      implicit none
      integer i,j,k,n
      integer index,keys
      integer key(*)
      real*8 lists
      real*8 list(*)
c
c
c     initialize index into the original ordering
c
      do i = 1, n
         key(i) = i
      end do
c
c     perform the heapsort of the input list
c
      k = n/2 + 1
      index = n
      do while (n .gt. 1)
         if (k .gt. 1) then
            k = k - 1
            lists = list(k)
            keys = key(k)
         else
            lists = list(index)
            keys = key(index)
            list(index) = list(1)
            key(index) = key(1)
            index = index - 1
            if (index .le. 1) then
               list(1) = lists
               key(1) = keys
               return
            end if
         end if
         i = k
         j = k + k
         do while (j .le. index)
            if (j .lt. index) then
               if (list(j) .lt. list(j+1))  j = j + 1
            end if
            if (lists .lt. list(j)) then
               list(i) = list(j)
               key(i) = key(j)
               i = j
               j = j + j
            else
               j = index + 1
            end if
         end do
         list(i) = lists
         key(i) = keys
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine sort3  --  heapsort of integer array with keys  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "sort3" takes an input list of integers and sorts it
c     into ascending order using the Heapsort algorithm;
c     it also returns a key into the original ordering
c
c
      subroutine sort3 (n,list,key)
      implicit none
      integer i,j,k,n
      integer index
      integer lists
      integer keys
      integer list(*)
      integer key(*)
c
c
c     initialize index into the original ordering
c
      do i = 1, n
         key(i) = i
      end do
c
c     perform the heapsort of the input list
c
      k = n/2 + 1
      index = n
      do while (n .gt. 1)
         if (k .gt. 1) then
            k = k - 1
            lists = list(k)
            keys = key(k)
         else
            lists = list(index)
            keys = key(index)
            list(index) = list(1)
            key(index) = key(1)
            index = index - 1
            if (index .le. 1) then
               list(1) = lists
               key(1) = keys
               return
            end if
         end if
         i = k
         j = k + k
         do while (j .le. index)
            if (j .lt. index) then
               if (list(j) .lt. list(j+1))  j = j + 1
            end if
            if (lists .lt. list(j)) then
               list(i) = list(j)
               key(i) = key(j)
               i = j
               j = j + j
            else
               j = index + 1
            end if
         end do
         list(i) = lists
         key(i) = keys
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine sort4  --  heapsort of integer absolute values  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "sort4" takes an input list of integers and sorts it into
c     ascending absolute value using the Heapsort algorithm
c
c
      subroutine sort4 (n,list)
      implicit none
      integer i,j,k,n
      integer index
      integer lists
      integer list(*)
c
c
c     perform the heapsort of the input list
c
      k = n/2 + 1
      index = n
      do while (n .gt. 1)
         if (k .gt. 1) then
            k = k - 1
            lists = list(k)
         else
            lists = list(index)
            list(index) = list(1)
            index = index - 1
            if (index .le. 1) then
               list(1) = lists
               return
            end if
         end if
         i = k
         j = k + k
         do while (j .le. index)
            if (j .lt. index) then
               if (abs(list(j)) .lt. abs(list(j+1)))  j = j + 1
            end if
            if (abs(lists) .lt. abs(list(j))) then
               list(i) = list(j)
               i = j
               j = j + j
            else
               j = index + 1
            end if
         end do
         list(i) = lists
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine sort5  --  heapsort of integer array modulo m  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "sort5" takes an input list of integers and sorts it
c     into ascending order based on each value modulo "m"
c
c
      subroutine sort5 (n,list,m)
      implicit none
      integer i,j,k,m,n
      integer index,smod
      integer jmod,j1mod
      integer lists
      integer list(*)
c
c
c     perform the heapsort of the input list
c
      k = n/2 + 1
      index = n
      do while (n .gt. 1)
         if (k .gt. 1) then
            k = k - 1
            lists = list(k)
         else
            lists = list(index)
            list(index) = list(1)
            index = index - 1
            if (index .le. 1) then
               list(1) = lists
               return
            end if
         end if
         i = k
         j = k + k
         do while (j .le. index)
            if (j .lt. index) then
               jmod = mod(list(j),m)
               j1mod = mod(list(j+1),m)
               if (jmod .lt. j1mod) then
                  j = j + 1
               else if (jmod.eq.j1mod .and. list(j).lt.list(j+1)) then
                  j = j + 1
               end if
            end if
            smod = mod(lists,m)
            jmod = mod(list(j),m)
            if (smod .lt. jmod) then
               list(i) = list(j)
               i = j
               j = j + j
            else if (smod.eq.jmod .and. lists.lt.list(j)) then
               list(i) = list(j)
               i = j
               j = j + j
            else
               j = index + 1
            end if
         end do
         list(i) = lists
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine sort6  --  heapsort of a text string array  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "sort6" takes an input list of character strings and sorts
c     it into alphabetical order using the Heapsort algorithm
c
c
      subroutine sort6 (n,list)
      implicit none
      integer i,j,k,n
      integer index
      character*256 lists
      character*(*) list(*)
c
c
c     perform the heapsort of the input list
c
      k = n/2 + 1
      index = n
      do while (n .gt. 1)
         if (k .gt. 1) then
            k = k - 1
            lists = list(k)
         else
            lists = list(index)
            list(index) = list(1)
            index = index - 1
            if (index .le. 1) then
               list(1) = lists
               return
            end if
         end if
         i = k
         j = k + k
         do while (j .le. index)
            if (j .lt. index) then
               if (list(j) .lt. list(j+1))  j = j + 1
            end if
            if (lists .lt. list(j)) then
               list(i) = list(j)
               i = j
               j = j + j
            else
               j = index + 1
            end if
         end do
         list(i) = lists
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine sort7  --  heapsort of text strings with keys  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "sort7" takes an input list of character strings and sorts it
c     into alphabetical order using the Heapsort algorithm; it also
c     returns a key into the original ordering
c
c
      subroutine sort7 (n,list,key)
      implicit none
      integer i,j,k,n
      integer index
      integer keys
      integer key(*)
      character*256 lists
      character*(*) list(*)
c
c
c     initialize index into the original ordering
c
      do i = 1, n
         key(i) = i
      end do
c
c     perform the heapsort of the input list
c
      k = n/2 + 1
      index = n
      do while (n .gt. 1)
         if (k .gt. 1) then
            k = k - 1
            lists = list(k)
            keys = key(k)
         else
            lists = list(index)
            keys = key(index)
            list(index) = list(1)
            key(index) = key(1)
            index = index - 1
            if (index .le. 1) then
               list(1) = lists
               key(1) = keys
               return
            end if
         end if
         i = k
         j = k + k
         do while (j .le. index)
            if (j .lt. index) then
               if (list(j) .lt. list(j+1))  j = j + 1
            end if
            if (lists .lt. list(j)) then
               list(i) = list(j)
               key(i) = key(j)
               i = j
               j = j + j
            else
               j = index + 1
            end if
         end do
         list(i) = lists
         key(i) = keys
      end do
      return
      end
c
c
c     #########################################################
c     ##                                                     ##
c     ##  subroutine sort8  --  heapsort to unique integers  ##
c     ##                                                     ##
c     #########################################################
c
c
c     "sort8" takes an input list of integers and sorts it into
c     ascending order using the Heapsort algorithm, duplicate
c     values are removed from the final sorted list
c
c
      subroutine sort8 (n,list)
      implicit none
      integer i,j,k,n
      integer index
      integer lists
      integer list(*)
c
c
c     perform the heapsort of the input list
c
      k = n/2 + 1
      index = n
      do while (n .gt. 1)
         if (k .gt. 1) then
            k = k - 1
            lists = list(k)
         else
            lists = list(index)
            list(index) = list(1)
            index = index - 1
            if (index .le. 1) then
               list(1) = lists
c
c     remove duplicate values from final list
c
               j = 1
               do i = 2, n
                  if (list(i-1) .ne. list(i)) then
                     j = j + 1
                     list(j) = list(i)
                  end if
               end do
               if (j .lt. n)  n = j
               return
            end if
         end if
         i = k
         j = k + k
         do while (j .le. index)
            if (j .lt. index) then
               if (list(j) .lt. list(j+1))  j = j + 1
            end if
            if (lists .lt. list(j)) then
               list(i) = list(j)
               i = j
               j = j + j
            else
               j = index + 1
            end if
         end do
         list(i) = lists
      end do
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine sort9  --  heapsort to unique real values  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "sort9" takes an input list of reals and sorts it into
c     ascending order using the Heapsort algorithm, duplicate
c     values are removed from the final sorted list
c
c
      subroutine sort9 (n,list)
      implicit none
      integer i,j,k,n
      integer index
      real*8 lists
      real*8 list(*)
c
c
c     perform the heapsort of the input list
c
      k = n/2 + 1
      index = n
      do while (n .gt. 1)
         if (k .gt. 1) then
            k = k - 1
            lists = list(k)
         else
            lists = list(index)
            list(index) = list(1)
            index = index - 1
            if (index .le. 1) then
               list(1) = lists
c
c     remove duplicate values from final list
c
               j = 1
               do i = 2, n
                  if (list(i-1) .ne. list(i)) then
                     j = j + 1
                     list(j) = list(i)
                  end if
               end do
               if (j .lt. n)  n = j
               return
            end if
         end if
         i = k
         j = k + k
         do while (j .le. index)
            if (j .lt. index) then
               if (list(j) .lt. list(j+1))  j = j + 1
            end if
            if (lists .lt. list(j)) then
               list(i) = list(j)
               i = j
               j = j + j
            else
               j = index + 1
            end if
         end do
         list(i) = lists
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine sort10  --  heapsort to unique text strings  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "sort10" takes an input list of character strings and sorts
c     it into alphabetical order using the Heapsort algorithm,
c     duplicate values are removed from the final sorted list
c
c
      subroutine sort10 (n,list)
      implicit none
      integer i,j,k,n
      integer index
      character*256 lists
      character*(*) list(*)
c
c
c     perform the heapsort of the input list
c
      k = n/2 + 1
      index = n
      do while (n .gt. 1)
         if (k .gt. 1) then
            k = k - 1
            lists = list(k)
         else
            lists = list(index)
            list(index) = list(1)
            index = index - 1
            if (index .le. 1) then
               list(1) = lists
c
c     remove duplicate values from final list
c
               j = 1
               do i = 2, n
                  if (list(i-1) .ne. list(i)) then
                     j = j + 1
                     list(j) = list(i)
                  end if
               end do
               if (j .lt. n)  n = j
               return
            end if
         end if
         i = k
         j = k + k
         do while (j .le. index)
            if (j .lt. index) then
               if (list(j) .lt. list(j+1))  j = j + 1
            end if
            if (lists .lt. list(j)) then
               list(i) = list(j)
               i = j
               j = j + j
            else
               j = index + 1
            end if
         end do
         list(i) = lists
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  program spacefill  --  surface area and volume of model  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "spacefill" computes the surface area and volume of
c     a structure; the van der Waals, accessible-excluded,
c     and contact-reentrant definitions are available
c
c
      program spacefill
      use atomid
      use atoms
      use files
      use inform
      use iounit
      use kvdws
      use math
      use ptable
      use usage
      implicit none
      integer i,ixyz,next
      integer mode,frame
      integer freeunit
      real*8 area,volume
      real*8 exclude,reentrant
      real*8 random,value
      real*8, allocatable :: radius(:)
      logical exist,query
      character*1 answer
      character*240 xyzfile
      character*240 record
      character*240 string
      external random
c
c
c     set up the structure and values for the computation;
c     atomic radii can be changed via the keyword mechanism
c
      call initial
      call getxyz
      call field
      call active
      call katom
      call kvdw
c
c     initialize random numbers and turn on extra printing
c
      verbose = .false.
      value = random ()
      debug = .true.
c
c     select either vdw, excluded or molecular volume and area
c
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  mode
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' Three Types of Area and Volume can be Computed :',
     &           //,4x,'(1) Van der Waals Area and Volume',
     &           /,4x,'(2) Accessible Area and Excluded Volume',
     &           /,4x,'(3) Contact-Reentrant Area and Volume')
         write (iout,30)
   30    format (/,' Enter the Number of your Choice [1] :  ',$)
         read (input,40)  mode
   40    format (i10)
      end if
      if (mode.ne.2 .and. mode.ne.3)  mode = 1
c
c     set the excluded/accessible and contact/reentrant probes
c
      value = 0.0d0
      exclude = 0.0d0
      reentrant = 0.0d0
      if (mode.eq.2 .or. mode.eq.3) then
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=50,end=50)  value
            query = .false.
         end if
   50    continue
         if (query) then
            write (iout,60)
   60       format (/,' Enter a Value for the Probe Radius',
     &                 ' [1.4 Ang] :  ',$)
            read (input,70)  value
   70       format (f20.0)
         end if
         if (value .eq. 0.0d0)  value = 1.4d0
         if (mode .eq. 2)  exclude = value
         if (mode .eq. 3)  reentrant = value
      end if
c
c     decide whether to include hydrogens in the calculation
c
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,80)
   80    format (/,' Include the Hydrogen Atoms in Computation',
     &              ' [N] :  ',$)
         read (input,90)  record
   90    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .ne. 'Y') then
         do i = 1, n
            if (atomic(i) .eq. 1)  use(i) = .false.
         end do
      end if
c
c     decide whether to provide full output for large systems
c
      if (n .gt. 100) then
         debug = .false.
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,100)
  100       format (/,' Output the Surface Area of Individual Atoms',
     &                 ' [N] :  ',$)
            read (input,110)  record
  110       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  debug = .true.
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (radius(n))
c
c     set atomic radii based on force field or Bondi values
c
      do i = 1, n
         if (use(i)) then
            radius(i) = rad(class(i))
c           radius(i) = rad(class(i)) / twosix
c           radius(i) = vdwrad(atomic(i))
         else
            radius(i) = 0.0d0
         end if
      end do
c
c     reopen the coordinates file and read the first structure
c
      frame = 0
      ixyz = freeunit ()
      xyzfile = filename
      call suffix (xyzfile,'xyz','old')
      open (unit=ixyz,file=xyzfile,status ='old')
      rewind (unit=ixyz)
      call readxyz (ixyz)
c
c     get area and volume for successive coordinate structures
c
      do while (.not. abort)
         frame = frame + 1
         if (frame .gt. 1) then
            write (iout,120)  frame
  120       format (/,' Area and Volume for Archive Structure :',5x,i8)
         end if
c
c     use the Connolly routines to find the area and volume
c
         call connolly (n,x,y,z,radius,exclude,reentrant,area,volume)
c
c     print out the values of the total surface area and volume
c
         if (mode .eq. 1) then
            write (iout,130)
  130       format (/,' Van der Waals Surface Area and Volume :')
         else if (mode .eq. 2) then
            write (iout,140)
  140       format (/,' Accessible Surface Area and Excluded Volume :')
         else if (mode .eq. 3) then
            write (iout,150)
  150       format (/,' Contact-Reentrant Surface Area and Volume :')
         end if
         write (iout,160)  area
  160    format (/,' Total Area :',f20.3,' Square Angstroms')
         write (iout,170)  volume
  170    format (' Total Volume :',f18.3,' Cubic Angstroms')
c
c     attempt to read next structure from the coordinate file
c
         call readxyz (ixyz)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (radius)
c
c     perform any final tasks before program exit
c
      close (unit=ixyz)
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2000  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program spectrum  --  power spectrum from autocorrelation  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "spectrum" computes a power spectrum over a wavelength range
c     from the velocity autocorrelation as a function of time
c
c
      program spectrum
      use files
      use iounit
      use math
      use units
      implicit none
      integer i,k
      integer next,nsamp
      integer ivel,nvel
      integer maxvel
      integer maxfreq
      integer freeunit
      real*8 factor,aver
      real*8 norm,step
      real*8 freq,time
      real*8, allocatable :: vel(:)
      real*8, allocatable :: intense(:)
      logical exist,done
      character*240 velfile
      character*240 record
      character*240 string
c
c
c     perform the standard initialization functions
c
      call initial
c
c     try to get a filename from the command line arguments
c
      call nextarg (velfile,exist)
      if (exist) then
         call basefile (velfile)
         call suffix (velfile,'vel','old')
         inquire (file=velfile,exist=exist)
      end if
c
c     ask for the velocity autocorrelation data filename
c
      do while (.not. exist)
         write (iout,10)
   10    format (/,' Enter Name of Velocity Autocorrelation',
     &              ' File :  ',$)
         read (input,20)  velfile
   20    format (a240)
         call basefile (velfile)
         call suffix (velfile,'vel','old')
         inquire (file=velfile,exist=exist)
      end do
c
c     get the time step between autocorrelation data points
c
      step = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=30,end=30)  step
   30 continue
      if (step .le. 0.0d0) then
         write (iout,40)
   40    format (/,' Enter Time Step for Autocorrelation Data',
     &              ' [1.0 fs] :  ',$)
         read (input,50)  step
   50    format (f20.0)
      end if
      if (step .le. 0.0d0)  step = 1.0d0
      step = 0.001d0 * step
c
c     open the velocity autocorrelation data file
c
      ivel = freeunit ()
      open (unit=ivel,file=velfile,status='old')
      rewind (unit=ivel)
c
c     read through file headers to the start of the data
c
      done = .false.
      do while (.not. done)
         read (ivel,60)  record
   60    format (a240)
         next = 1
         call getword (record,string,next)
         if (string(1:10) .eq. 'Separation') then
            done = .true.
            read (ivel,70)
   70       format ()
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      maxvel = 100000
      maxfreq = 5000
      allocate (vel(0:maxvel))
      allocate (intense(maxfreq))
c
c     read the velocity autocorrelation as a function of time
c
      do i = 1, maxvel
         read (ivel,80,err=90,end=90)  record
   80    format (a240)
         read (record,*)  k,nsamp,aver,norm
         nvel = k
         vel(k) = norm
      end do
   90 continue
c
c     compute the power spectrum via discrete Fourier transform
c
      factor = 2.0d0 * pi * lightspd
      do i = 1, maxfreq
         freq = factor * dble(i)
         intense(i) = 0.0d0
         do k = 0, nvel
            time = step * dble(k)
            intense(i) = intense(i) + vel(k)*cos(freq*time)
         end do
         intense(i) = 1000.0d0 * step * intense(i)
      end do
c
c     print the power spectrum intensity at each wavelength
c
      write (iout,100)
  100 format (/,' Power Spectrum from Velocity Autocorrelation :',
     &        //,4x,'Frequency (cm-1)',10x,'Intensity',/)
      do i = 1, maxfreq
         write (iout,110)  dble(i),intense(i)
  110    format (3x,f12.2,8x,f16.6)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (vel)
      deallocate (intense)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine square  --  nonlinear least squares with bounds  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "square" is a nonlinear least squares routine derived from the
c     IMSL BCLSF and MINPACK LMDER routines; the Jacobian is estimated
c     by finite differences and bounds are specified for the variables
c     to be refined
c
c     literature references:
c
c     "BCLSF: Solve Nonlinear Least Squares Problems Subject to Bounds
c     on the Variables Using a Modified Levenberg-Marquardt Algorithm
c     and a Finite-Difference Jacobian", IMSL Fortran Math Library,
c     Version 2020.0, Rogue Wave Software, 2019
c
c     B. S. Garbow, K. E. Hillstrom and J. J. More, "MINPACK Subroutine
c     LMDER", Argonne National Laboratory, March 1980
c
c     arguments and variables:
c
c     n         number of least squares variables
c     m         number of residual functions
c     xlo       vector with the lower bounds for the variables
c     xhi       vector with the upper bounds for the variables
c     xscale    vector with the diagonal scaling matrix for variables
c     xc        vector with variable values at the approximate solution
c     fc        vector with the residuals at the approximate solution
c     fp        vector containing the updated residuals
c     xp        vector containing the updated point
c     sc        vector containing the last step taken
c     gc        vector with gradient estimate at approximate solution
c     fjac      matrix with estimate of Jacobian at approximate solution
c     iactive   vector showing if variable is at upper or lower bound
c     ipvt      vector with permutation matrix used in QR factorization
c                 of the Jacobian at the approximate solution
c     stpmax    scalar containing maximum allowed step size
c     delta     scalar containing the trust region radius
c
c     required external routines:
c
c     rsdvalue  subroutine to evaluate residual function values
c     lsqwrite  subroutine to write out info about current status
c
c
      subroutine square (n,m,xlo,xhi,xc,fc,gc,fjac,grdmin,
     &                          rsdvalue,lsqwrite)
      use inform
      use iounit
      use keys
      use minima
      implicit none
      integer i,j,k,m,n
      integer icode,next
      integer niter,ncalls
      integer nactive,nbigstp
      integer, allocatable :: iactive(:)
      integer, allocatable :: ipvt(:)
      real*8 eps,epsq,delta
      real*8 fcnorm,fpnorm
      real*8 gcnorm,ganorm
      real*8 grdmin,stpnorm
      real*8 stpmax,stpmin
      real*8 rftol,faketol
      real*8 xtemp,stepsz
      real*8 amu,sum,temp
      real*8 xlo(*)
      real*8 xhi(*)
      real*8 xc(*)
      real*8 fc(*)
      real*8 gc(*)
      real*8, allocatable :: xp(:)
      real*8, allocatable :: xpprev(:)
      real*8, allocatable :: ga(:)
      real*8, allocatable :: gs(:)
      real*8, allocatable :: sc(:)
      real*8, allocatable :: sa(:)
      real*8, allocatable :: xsa(:)
      real*8, allocatable :: xscale(:)
      real*8, allocatable :: rdiag(:)
      real*8, allocatable :: fp(:)
      real*8, allocatable :: fpprev(:)
      real*8, allocatable :: ftemp(:)
      real*8, allocatable :: qtf(:)
      real*8 fjac(m,*)
      logical done,first
      logical gauss,bigstp
      logical pivot
      character*20 keyword
      character*240 record
      character*240 string
      external rsdvalue
      external lsqwrite
c
c
c     initialize various counters for calls and iterations
c
      niter = 0
      ncalls = 0
      nbigstp = 0
c
c     setup the default tolerances and parameter values
c
      eps = 0.00000001d0
      if (maxiter .eq. 0)  maxiter = 100
      if (iprint .lt. 0)  iprint = 1
      if (iwrite .lt. 0)  iwrite = 1
      if (fctmin .eq. 0.0d0)  fctmin = eps
      if (grdmin .eq. 0.0d0)  grdmin = eps**(1.0d0/3.0d0)
      epsq = sqrt(eps)
      delta = 0.0d0
      stpmax = 10000.0d0 * sqrt(dble(n))
      stpmin = eps**(2.0d0/3.0d0)
      rftol = eps**(2.0d0/3.0d0)
      faketol = 100.0d0 * eps
c
c     search each line of the keyword file for options
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:7) .eq. 'FCTMIN ') then
            read (string,*,err=10,end=10)  fctmin
         else if (keyword(1:8) .eq. 'MAXITER ') then
            read (string,*,err=10,end=10)  maxiter
         else if (keyword(1:8) .eq. 'STEPMAX ') then
            read (string,*,err=10,end=10)  stpmax
         else if (keyword(1:8) .eq. 'STEPMIN ') then
            read (string,*,err=10,end=10)  stpmin
         else if (keyword(1:9) .eq. 'PRINTOUT ') then
            read (string,*,err=10,end=10)  iprint
         else if (keyword(1:9) .eq. 'WRITEOUT ') then
            read (string,*,err=10,end=10)  iwrite
         end if
   10    continue
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (iactive(n))
      allocate (ipvt(n))
      allocate (xp(n))
      allocate (xpprev(m))
      allocate (ga(n))
      allocate (gs(n))
      allocate (sc(n))
      allocate (sa(n))
      allocate (xsa(n))
      allocate (xscale(n))
      allocate (rdiag(n))
      allocate (fp(m))
      allocate (fpprev(m))
      allocate (ftemp(m))
      allocate (qtf(m))
c
c     check feasibility of variables and use bounds if needed
c
      nactive = 0
      do j = 1, n
         if (xc(j) .lt. xlo(j)) then
            xc(j) = xlo(j)
            iactive(j) = -1
         else if (xc(j) .gt. xhi(j)) then
            xc(j) = xhi(j)
            iactive(j) = 1
         else
            nactive = nactive + 1
            iactive(j) = 0
         end if
      end do
c
c     evaluate the function at the initial point
c
      ncalls = ncalls + 1
      call rsdvalue (n,m,xc,fc)
      fcnorm = 0.0d0
      do i = 1, m
         fcnorm = fcnorm + fc(i)**2
      end do
      fcnorm = 0.5d0 * fcnorm
c
c     evaluate the Jacobian at the initial point by finite
c     differences; replace loop with user routine if desired
c
      do j = 1, n
         stepsz = epsq * abs(xc(j))
         if (stepsz .lt. epsq)  stepsz = epsq
         if (xc(j) .lt. 0.0d0)  stepsz = -stepsz
         xtemp = xc(j)
         xc(j) = xtemp + stepsz
         ncalls = ncalls + 1
         call rsdvalue (n,m,xc,ftemp)
         xc(j) = xtemp
         do i = 1, m
            fjac(i,j) = (ftemp(i)-fc(i)) / stepsz
         end do
      end do
c
c     compute More's adaptive variable scale factors
c
      do j = 1, n
         temp = 0.0d0
         do i = 1, m
            temp = temp + fjac(i,j)**2
         end do
         xscale(j) = sqrt(temp)
         if (xscale(j) .eq. 0.0d0)  xscale(j) = 1.0d0
      end do
c
c     compute the total gradient vector for all variables
c
      do j = 1, n
         gc(j) = 0.0d0
         do i = 1, m
            gc(j) = gc(j) + fjac(i,j)*fc(i)
         end do
      end do
c
c     compute the norm of the scaled total gradient
c     and the scaled gradient for active variables
c
      gcnorm = 0.0d0
      ganorm = 0.0d0
      do j = 1, n
         gs(j) = gc(j) * max(abs(xc(j)),1.0d0/xscale(j))
         gcnorm = gcnorm + gs(j)**2
         if (iactive(j) .eq. 0) then
            ganorm = ganorm + gs(j)**2
         end if
      end do
      gcnorm = sqrt(gcnorm/dble(n))
      if (nactive .ne. 0)  ganorm = sqrt(ganorm/dble(nactive))
c
c     print out information about initial conditions
c
      if (iprint .gt. 0) then
         write (iout,20)
   20    format (/,' Levenberg-Marquardt Nonlinear Least Squares :')
         write (iout,30)
   30    format (/,' LS Iter     F Value      Total G     Active G',
     &              '    N Active   F Calls',/)
         if (max(fcnorm,gcnorm) .lt. 10000000.0d0) then
            write (iout,40)  niter,fcnorm,gcnorm,ganorm,nactive,ncalls
   40       format (i6,f14.4,2f13.4,2i10)
         else
            write (iout,50)  niter,fcnorm,gcnorm,ganorm,nactive,ncalls
   50       format (i6,d14.4,2d13.4,2i10)
         end if
      end if
c
c     write out the parameters, derivatives and residuals
c
      if (iwrite .ne. 0)  call lsqwrite (niter,m,xc,gs,fc)
c
c     check stopping criteria at the initial point; test the
c     absolute function value and gradient norm for termination
c
      if (fcnorm .le. fctmin)  return
      if (ganorm .le. grdmin)  return
c
c     beginning of the main least squares iteration loop
c
      done = .false.
      do while (.not. done)
         niter = niter + 1
c
c     repack the Jacobian to include only active variables
c
         if (nactive .ne. n) then
            k = 0
            do j = 1, n
               if (iactive(j) .ne. 0) then
                  if (k .eq. 0)  k = j
               else
                  if (k .ne. 0) then
                     do i = 1, m
                        fjac(i,k) = fjac(i,j)
                     end do
                     k = k + 1
                  end if
               end if
            end do
         end if
c
c     repack scale factors and gradient for active variables
c
         k = 0
         do j = 1, n
            if (iactive(j) .eq. 0) then
               k = k + 1
               xsa(k) = xscale(j)
               ga(k) = gc(j)
            end if
         end do
c
c     compute the QR factorization of the Jacobian
c
         pivot = .true.
         call qrfact (nactive,m,fjac,pivot,ipvt,rdiag)
c
c     compute the vector Q(transpose) * residuals
c
         do i = 1, m
            qtf(i) = fc(i)
         end do
         do j = 1, nactive
            if (fjac(j,j) .ne. 0.0d0) then
               sum = 0.0d0
               do i = j, m
                  sum = sum + fjac(i,j)*qtf(i)
               end do
               temp = -sum / fjac(j,j)
               do i = j, m
                  qtf(i) = qtf(i) + fjac(i,j)*temp
               end do
            end if
            fjac(j,j) = rdiag(j)
         end do
c
c     compute the Levenberg-Marquardt step
c
         icode = 6
         first = .true.
         do while (icode .ge. 4)
            call lmstep (nactive,m,ga,fjac,ipvt,xsa,qtf,stpmax,
     &                         delta,amu,first,sa,gauss)
c
c     unpack the step vector to include all variables
c
            k = 0
            do i = 1, n
               if (iactive(i) .ne. 0) then
                  sc(i) = 0.0d0
               else
                  k = k + 1
                  sc(i) = sa(k)
               end if
            end do
c
c     check new point and update the trust region
c
            call trust (n,m,xc,fcnorm,gc,fjac,ipvt,sc,sa,xscale,gauss,
     &                  stpmax,delta,icode,xp,xpprev,fc,fp,fpnorm,
     &                  fpprev,bigstp,ncalls,xlo,xhi,nactive,stpmin,
     &                  rftol,faketol,rsdvalue)
         end do
         if (icode .eq. 1)  done = .true.
c
c     update to the new variables and residuals
c
         do j = 1, n
            xc(j) = xp(j)
         end do
         do i = 1, m
            fc(i) = fp(i)
         end do
         fcnorm = fpnorm
c
c     check for active variables to be made inactive; in a true
c     active set strategy, variables are removed one at a time
c     from the current active set (via goto statements below)
c
         do j = 1, n
            if (iactive(j) .eq. 0) then
               if (abs(xc(j)-xlo(j)) .le. eps) then
                  nactive = nactive - 1
                  iactive(j) = -1
                  goto 60
               else if (abs(xc(j)-xhi(j)) .le. eps) then
                  nactive = nactive - 1
                  iactive(j) = 1
                  goto 60
               end if
            end if
         end do
   60    continue
c
c     evaluate the Jacobian at the new point using finite
c     differences; replace loop with user routine if desired
c
         do j = 1, n
            stepsz = epsq * max(abs(xc(j)),1.0d0/xscale(j))
            if (xc(j) .lt. 0.0d0)  stepsz = -stepsz
            xtemp = xc(j)
            xc(j) = xtemp + stepsz
            ncalls = ncalls + 1
            call rsdvalue (n,m,xc,ftemp)
            xc(j) = xtemp
            do i = 1, m
               fjac(i,j) = (ftemp(i)-fc(i)) / stepsz
            end do
         end do
c
c     compute the LMDER adaptive variable scale factors
c
         do j = 1, n
            temp = 0.0d0
            do i = 1, m
               temp = temp + fjac(i,j)**2
            end do
            xscale(j) = max(xscale(j),sqrt(temp))
         end do
c
c     compute the total gradient vector for all variables
c
         do j = 1, n
            gc(j) = 0.0d0
            do i = 1, m
               gc(j) = gc(j) + fjac(i,j)*fc(i)
            end do
         end do
c
c     compute the norm of the scaled total gradient
c     and the scaled gradient for active variables
c
         gcnorm = 0.0d0
         ganorm = 0.0d0
         do j = 1, n
            gs(j) = gc(j) * max(abs(xc(j)),1.0d0/xscale(j))
            gcnorm = gcnorm + gs(j)**2
            if (iactive(j) .eq. 0) then
               ganorm = ganorm + gs(j)**2
            end if
         end do
         gcnorm = sqrt(gcnorm/dble(n))
         if (nactive .ne. 0)  ganorm = sqrt(ganorm/dble(nactive))
c
c     print out information about current iteration
c
         if (iprint.ne.0 .and. mod(niter,iprint).eq.0) then
            if (max(fcnorm,gcnorm) .lt. 10000000.0d0) then
               write (iout,70)  niter,fcnorm,gcnorm,ganorm,
     &                          nactive,ncalls
   70          format (i6,f14.4,2f13.4,2i10)
            else
               write (iout,80)  niter,fcnorm,gcnorm,ganorm,
     &                          nactive,ncalls
   80          format (i6,d14.4,2d13.4,2i10)
            end if
         end if
c
c     check stopping criteria at the new point; test the absolute
c     function value, gradient norm and step norm for termination
c
         if (fcnorm .le. fctmin)  done = .true.
         if (ganorm .le. grdmin)  done = .true.
         stpnorm = 0.0d0
         do j = 1, n
            temp = max(abs(xc(j)),1.0d0/xscale(j))
            stpnorm = stpnorm + (sc(j)/temp)**2
         end do
         stpnorm = sqrt(stpnorm/dble(n))
         if (stpnorm.gt.eps .and. stpnorm.le.stpmin)  done = .true.
c
c     check for inactive variables to be made active; in a true
c     active set strategy, variables are added one at a time to
c     the current active set (via goto statements below)
c
         if (done) then
            if (nactive .ne. n) then
               do j = 1, n
                  if (iactive(j).eq.-1 .and. gc(j).lt.0.0d0) then
                     nactive = nactive + 1
                     iactive(j) = 0
                     done = .false.
                     goto 90
                  else if (iactive(j).eq.1 .and. gc(j).gt.0.0d0) then
                     nactive = nactive + 1
                     iactive(j) = 0
                     done = .false.
                     goto 90
                  end if
               end do
   90          continue
            end if
         end if
c
c     if still done, then normal termination has been achieved
c
         if (done) then
            write (iout,100)
  100       format (/,' SQUARE  --  Normal Termination of',
     &                 ' Least Squares')
c
c     check for termination due to relative function convergence
c
         else if (icode .eq. 2) then
            done = .true.
            write (iout,110)
  110       format (/,' SQUARE  --  Successful Relative Function',
     &                 ' Convergence')
            if (verbose) then
               write (iout,120)
  120          format (/,' Both the scaled actual and predicted',
     &                    ' reductions in the function',
     &                 /,' are less than or equal to the relative',
     &                    ' convergence tolerance')
            end if
c
c     check for termination due to false convergence
c
         else if (icode .eq. 3) then
            done = .true.
            write (iout,130)
  130       format (/,' SQUARE  --  Possible False Convergence')
            if (verbose) then
               write (iout,140)
  140          format (/,' The iterates appear to be converging to',
     &                    ' a noncritical point due',
     &                 /,' to bad gradient information, discontinuous',
     &                    ' function, or stopping',
     &                 /,' tolerances being too tight')
            end if
c
c     check for several consecutive maximum steps taken
c
         else if (bigstp) then
            nbigstp = nbigstp + 1
            if (nbigstp .eq. 5) then
               done = .true.
               write (iout,150)
  150          format (/,' SQUARE  --  Five Consecutive Maximum',
     &                    ' Length Steps')
               if (verbose) then
                  write (iout,160)
  160             format (/,' Either the function is unbounded below,',
     &                       ' or has a finite',
     &                    /,' asymptote in some direction, or STEPMAX',
     &                       ' is too small')
               end if
            end if
c
c     check the limit on the number of iterations
c
         else if (niter .ge. maxiter) then
            done = .true.
            write (iout,170)
  170       format (/,' SQUARE  --  Incomplete Convergence due',
     &                 ' to IterLimit')
c
c     no reason to quit, so prepare to take another step
c
         else
            nbigstp = 0
         end if
c
c     write out the parameters, derivatives and residuals
c
         if (iwrite.ne.0 .and. mod(niter,iwrite).eq.0) then
            if (.not. done)  call lsqwrite (niter,m,xc,gs,fc)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iactive)
      deallocate (ipvt)
      deallocate (xp)
      deallocate (ga)
      deallocate (gs)
      deallocate (sc)
      deallocate (sa)
      deallocate (xsa)
      deallocate (xscale)
      deallocate (rdiag)
      deallocate (fp)
      deallocate (ftemp)
      deallocate (qtf)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine lmstep  --  computes Levenberg-Marquardt step  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "lmstep" computes a Levenberg-Marquardt step during a nonlinear
c     least squares based on the IMSL U7LSF and MINPACK LMPAR routines
c     and the internal doubling strategy of Dennis and Schnabel
c
c     literature reference:
c
c     J. E. Dennis, Jr. and R. B. Schnabel, "Numerical Methods for
c     Unconstrained Optimization and Nonlinear Equations", SIAM, 1987
c
c     arguments and variables:
c
c     n        number of least squares variables
c     m        number of residual functions
c     ga       vector with the gradient of the residual vector
c     a        array of size n by n which on input contains in the full
c                upper triangle of the matrix r resulting from the QR
c                factorization of the Jacobian; on output the full upper
c                triangle is unaltered, and the strict lower triangle
c                contains the strict lower triangle of the matrix l
c                which is the Cholesky factor of (j**t)*j + amu*xscale
c     ipvt     vector with pivoting information from QR factorization
c     xscale   vector with the diagonal scaling matrix for variables
c     qtf      vector with first n elements of Q(transpose)
c                * (scaled residual)
c     amu      scalar with initial estimate of the Levenberg-Marquardt
c                parameter on input, and the final estimate of the
c                parameter on output
c     first    logical flag set true only if this is the first
c                call to this routine in this iteration
c     sa       vector with the Levenberg-Marquardt step
c     gnstep   vector with the Gauss-Newton step
c     gauss    logical flag set true if the Gauss-Newton step
c                is acceptable, and false otherwise
c     diag     vector with the diagonal elements of the Cholesky
c                factor of (j**t)*j + amu*xscale
c
c
      subroutine lmstep (n,m,ga,a,ipvt,xscale,qtf,stpmax,
     &                      delta,amu,first,sa,gauss)
      implicit none
      integer i,j,k
      integer m,n,nsing
      integer maxtry,ntry
      integer ipvt(*)
      real*8 stpmax,delta
      real*8 amu,alow,alpha
      real*8 amulow,amuhi
      real*8 beta,high,sum
      real*8 deltap,gnleng
      real*8 phi,phip,phipi
      real*8 stplen,sgnorm
      real*8 gamma,eps,temp
      real*8 ga(*)
      real*8 xscale(*)
      real*8 qtf(*)
      real*8 sa(*)
      real*8, allocatable :: gnstep(:)
      real*8, allocatable :: diag(:)
      real*8, allocatable :: work1(:)
      real*8, allocatable :: work2(:)
      real*8 a(m,*)
      logical first,gauss
      logical done
      save deltap,nsing
      save gnleng,sgnorm
      save phi,phip,phipi
c
c
c     initialize the Levenberg-Marquardt step length
c
      do i = 1, n
         sa(i) = 0.0d0
      end do
c
c     set values for floating point magnitude and spacing
c
      gamma = 0.00000001d0
      eps = 0.00000001d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (gnstep(n))
      allocate (diag(n))
      allocate (work1(n))
      allocate (work2(n))
c
c     if initial trust region is not provided, compute the Cauchy
c     step length given by beta = norm2(r*trans(p)*d**(-2)*g)**2
c
      if (delta .eq. 0.0d0) then
         amu = 0.0d0
         do i = 1, n
            work1(i) = ga(i) / xscale(i)
         end do
         alpha = 0.0d0
         do i = 1, n
            alpha = alpha + work1(i)**2
         end do
         beta = 0.0d0
         do i = 1, n
            temp = 0.0d0
            do j = i, n
               k = ipvt(j)
               temp = temp + a(i,j)*ga(k)/xscale(k)**2
            end do
            beta = beta + temp**2
         end do
         if (beta .le. gamma) then
            delta = alpha * sqrt(alpha)
         else
            delta = alpha * sqrt(alpha)/beta
         end if
         delta = min(delta,stpmax)
      end if
c
c     the below is only done the first time through this iteration:
c     (1) compute a Gauss-Newton step; if Jacobian is rank-deficient,
c     obtain a least squares solution, (2) compute the length of the
c     scaled Gauss-Newton step, (3) compute the norm of the scaled
c     gradient used in computing an upper bound for "amu"
c
      if (first) then
         nsing = n
         do j = 1, n
            if (a(j,j).eq.0.0d0 .and. nsing.eq.n)  nsing = j - 1
            if (nsing .lt. n)  work1(j) = 0.0d0
         end do
         work1(nsing) = qtf(nsing) / a(nsing,nsing)
         do j = nsing-1, 1, -1
            sum = 0.0d0
            do i = j+1, nsing
               sum = sum + a(j,i)*work1(i)
            end do
            work1(j) = (qtf(j)-sum) / a(j,j)
         end do
         do j = 1, n
            gnstep(ipvt(j)) = -work1(j)
         end do
c
c     find the length of scaled Gauss-Newton step
c
         do j = 1, n
            work1(j) = xscale(j) * gnstep(j)
         end do
         gnleng = 0.0d0
         do j = 1, n
            gnleng = gnleng + work1(j)**2
         end do
         gnleng = sqrt(gnleng)
c
c     find the length of the scaled gradient
c
         do j = 1, n
            work1(j) = ga(j) / xscale(j)
         end do
         sgnorm = 0.0d0
         do j = 1, n
            sgnorm = sgnorm + work1(j)**2
         end do
         sgnorm = sqrt(sgnorm)
      end if
c
c     set bounds on number of iterations and computed step
c
      maxtry = 100
      high = 1.5d0
      alow = 0.75d0
c
c     check to see if the Gauss-Newton step is acceptable
c
      if (gnleng .le. high*delta) then
         gauss = .true.
         do j = 1, n
            sa(j) = gnstep(j)
         end do
         amu = 0.0d0
         delta = min(delta,gnleng)
c
c     the Gauss-Newton step is rejected, find a nontrivial step;
c     first compute a starting value of "amu" if previous step
c     was not a Gauss-Newton step
c
      else
         gauss = .false.
         if (amu .gt. 0.0d0)
     &      amu = amu - ((phi+deltap)/delta)*(((deltap-delta)+phi)/phip)
         phi = gnleng - delta
c
c     if the Jacobian is not rank deficient, the Newton step
c     provides a lower bound for "amu"; else set bound to zero
c
         if (nsing .eq. n) then
            if (first) then
               first = .false.
               do j = 1, n
                  k = ipvt(j)
                  work1(j) = gnstep(k) * xscale(k)**2
               end do
c
c     obtain trans(r**-1)*(trans(p)*s) by solving the system of
c     equations trans(r)*work1 = work1
c
               work1(n) = work1(n) / a(n,n)
               do j = n-1, 1, -1
                  sum = 0.0d0
                  do i = j+1, n
                     sum = sum + a(j,i)*work1(i)
                  end do
                  work1(j) = (work1(j)-sum) / a(j,j)
               end do
               phipi = 0.0d0
               do j = 1, n
                  phipi = phipi - work1(j)**2
               end do
               phipi = phipi / gnleng
            end if
            amulow = -phi / phipi
         else
            first = .false.
            amulow = 0.0d0
         end if
         amuhi = sgnorm / delta
c
c     iterate until a satisfactory "amu" is generated
c
         ntry = 0
         done = .false.
         do while (.not. done)
            if (amu.lt.amulow .or. amu.gt.amuhi) then
               amu = max(sqrt(amulow*amuhi),0.001d0*amuhi)
            end if
            temp = sqrt(amu)
            do j = 1, n
               work1(j) = temp * xscale(j)
            end do
c
c     solve the damped least squares system using the Levenberg-
c     Marquardt step from the MINPACK LMPAR method
c
            call qrsolve (n,m,a,ipvt,work1,qtf,sa,diag,work2)
            do j = 1, n
               sa(j) = -sa(j)
            end do
            do j = 1, n
               work2(j) = xscale(j) * sa(j)
            end do
            stplen = 0.0d0
            do j = 1, n
               stplen = stplen + work2(j)**2
            end do
            stplen = sqrt(stplen)
            phi = stplen - delta
            do j = 1, n
               k = ipvt(j)
               work1(j) = xscale(k) * work2(k)
            end do
            do j = 1, n
               if (abs(diag(j)) .ge. gamma) then
                  work1(j) = work1(j) / diag(j)
               end if
               if (j .lt. n) then
                  do i = j+1, n
                     work1(i) = work1(i) - work1(j)*a(i,j)
                  end do
               end if
            end do
            phip = 0.0d0
            do j = 1, n
               phip = phip - work1(j)**2
            end do
            phip = phip / stplen
c
c     check for an acceptable step or for too many iterations;
c     otherwise update amulow, amuhi and amu for next iteration
c
            ntry = ntry + 1
            if (stplen.ge.alow*delta .and. stplen.le.high*delta) then
               done = .true.
            else if (amuhi-amulow .le. eps) then
               done = .true.
            else if (ntry .ge. maxtry) then
               done = .true.
            else
               amulow = max(amulow,amu-(phi/phip))
               if (phi .lt. 0.0d0)  amuhi = amu
               amu = amu - (stplen/delta)*(phi/phip)
            end if
         end do
      end if
      deltap = delta
c
c     perform deallocation of some local arrays
c
      deallocate (gnstep)
      deallocate (diag)
      deallocate (work1)
      deallocate (work2)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine trust  --  update of the model trust region  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "trust" updates the model trust region for a nonlinear least
c     squares calculation based on the IMSL B4LSF routine and the
c     NL2SOL method of Dennis and colleagues
c
c     literature reference:
c
c     J. E. Dennis, Jr. and R. B. Schnabel, "Numerical Methods for
c     Unconstrained Optimization and Nonlinear Equations", SIAM, 1987
c
c     arguments and variables:
c
c     n         number of least squares variables
c     m         number of residual functions
c     xc        vector with the current iterate
c     fcnorm    scalar containing the norm of f(xc)
c     gc        vector with the gradient at xc
c     a         real m by n matrix containing the upper triangular
c                 matrix r from the QR factorization of the current
c                 Jacobian in the upper triangle
c     ipvt      vector of length n containing the permutation matrix
c                 from QR factorization of the Jacobian
c     sc        vector containing the Newton step
c     sa        vector containing current step
c     xscale    vector containing the diagonal scaling matrix for x
c     gauss     flag set to true when the Gauss-Newton step is taken
c     stpmax    maximum allowable step size
c     delta     trust region radius with value retained between calls
c     icode     return code values, set upon exit:
c                 0  xp is accepted as the next iterate, and delta
c                      is the trust region for next iteration
c                 1  the algorithm was unable to find a satisfactory
c                      xp sufficiently distinct from xc
c                 2  both the scaled actual and predicted model
c                      reductions are smaller than rftol
c                 3  false convergence is detected
c                 4  fpnorm is too large, so the current iteration
c                      is continued with a new, reduced trust region
c                 5  fpnorm is sufficiently small, but the chance of
c                      taking a longer successful step seems good,
c                      so the current iteration is to be continued
c                      with a new, doubled trust region
c     xp        vector of length n containing the new iterate
c     xpprev    vector with the value of xp at the  previous call
c                 within this iteration
c     fp        vector of length m containing the functions at xp
c     fpnorm    scalar containing the norm of f(xp)
c     fpprev    vector of length m containing f(xpprev)
c     bigstp    flag set to true if maximum step length was taken
c     ncalls    number of function evaluations used
c     xlo       vector of length n containing the lower bounds
c     xhi       vector of length n containing the upper bounds
c     nactive   number of columns in the active Jacobian
c
c     required external routines:
c
c     rsdvalue  subroutine to evaluate residual function values
c
c
      subroutine trust (n,m,xc,fcnorm,gc,a,ipvt,sc,sa,xscale,gauss,
     &                  stpmax,delta,icode,xp,xpprev,fc,fp,fpnorm,
     &                  fpprev,bigstp,ncalls,xlo,xhi,nactive,stpmin,
     &                  rftol,faketol,rsdvalue)
      implicit none
      integer i,j,k
      integer m,n,icode
      integer ncalls,nactive
      integer ipvt(*)
      real*8 fcnorm,stpmax
      real*8 fpnorm,fpnrmp
      real*8 reduce,model
      real*8 rellen,slope,eps
      real*8 stplen,stpmin
      real*8 rftol,faketol
      real*8 alpha,delta,temp
      real*8 xc(*)
      real*8 gc(*)
      real*8 sc(*)
      real*8 sa(*)
      real*8 xp(*)
      real*8 xpprev(*)
      real*8 fc(*)
      real*8 fp(*)
      real*8 fpprev(*)
      real*8 xlo(*)
      real*8 xhi(*)
      real*8 xscale(*)
      real*8 a(m,*)
      logical gauss,bigstp
      logical feas,ltemp
      save fpnrmp
      external rsdvalue
c
c
c     set value of alpha, logical flags and step length
c
      eps = 0.00000001d0
      alpha = 0.0001d0
      bigstp = .false.
      feas = .true.
      stplen = 0.0d0
      do i = 1, n
         stplen = stplen + (xscale(i)*sc(i))**2
      end do
      stplen = sqrt(stplen)
c
c     compute new trial point and new function values
c
      do i = 1, n
         xp(i) = xc(i) + sc(i)
         if (xp(i) .gt. xhi(i)) then
            sc(i) = xhi(i) - xc(i)
            xp(i) = xhi(i)
            feas = .false.
         else if (xp(i) .lt. xlo(i)) then
            sc(i) = xlo(i) - xc(i)
            xp(i) = xlo(i)
            feas = .false.
         end if
      end do
      ncalls = ncalls + 1
      call rsdvalue (n,m,xp,fp)
      fpnorm = 0.0d0
      do i = 1, m
         fpnorm = fpnorm + fp(i)**2
      end do
      fpnorm = 0.5d0 * fpnorm
      reduce = fpnorm - fcnorm
      slope = 0.0d0
      do i = 1, n
         slope = slope + gc(i)*sc(i)
      end do
      if (icode .ne. 5)  fpnrmp = 0.0d0
c
c     internal doubling no good; reset to previous and quit
c
      if (icode.eq.5 .and.
     &     ((fpnorm.ge.fpnrmp).or.(reduce.gt.alpha*slope))) then
         icode = 0
         do i = 1, n
            xp(i) = xpprev(i)
         end do
         do i = 1, m
            fp(i) = fpprev(i)
         end do
         fpnorm = fpnrmp
         delta = 0.5d0 * delta
c
c     fpnorm is too large; the step is unacceptable
c
      else if (reduce .ge. alpha*slope) then
         rellen = 0.0d0
         do i = 1, n
            temp = abs(sc(i))/max(abs(xp(i)),1.0d0/xscale(i))
            rellen = max(rellen,temp)
         end do
c
c     magnitude of (xp-xc) is too small, end the global step
c
         if (rellen .lt. stpmin) then
            icode = 1
            do i = 1, n
               xp(i) = xc(i)
            end do
            do i = 1, m
               fp(i) = fc(i)
            end do
c
c     quadratic interpolation step; reduce delta and continue
c
         else
            icode = 4
            if (abs(reduce-slope) .gt. eps) then
               temp = -0.5d0 * slope * stplen / (reduce-slope)
            else
               temp = -0.5d0 * slope * stplen
            end if
            if (temp .lt. 0.1d0*delta) then
               delta = 0.1d0 * delta
            else if (temp .gt. 0.5d0*delta) then
               delta = 0.5d0 * delta
            else
               delta = temp
            end if
         end if
c
c     fpnorm is sufficiently small; step is acceptable, compute the
c     predicted model reduction as model = g(T)*s + (1/2)*s(T)*h*s
c     with h = p * r**t * r * p**t
c
      else
         model = slope
         do i = 1, nactive
            k = ipvt(i)
            temp = 0.0d0
            do j = i, nactive
               temp = temp + sa(k)*a(i,j)
            end do
            model = model + 0.5d0*temp*temp
         end do
         ltemp = (abs(model-reduce) .le. 0.1d0*abs(reduce))
c
c     if reduce and predicted model agree to within relative error
c     of 0.1 or if negative curvature is indicated, and a longer step
c     is possible and delta has not been decreased this iteration,
c     then double trust region and continue global step
c
         if (icode.ne.4 .and. (ltemp.or.(reduce.le.slope)) .and. feas
     &        .and. .not.gauss .and. (delta.le.0.99d0*stpmax)) then
            icode = 5
            do i = 1, n
               xpprev(i) = xp(i)
            end do
            do i = 1, m
               fpprev(i) = fp(i)
            end do
            fpnrmp = fpnorm
            delta = min(2.0d0*delta,stpmax)
c
c     accept the point; choose new trust region for next iteration
c
         else
            icode = 0
            if (stplen .gt. 0.99d0*stpmax)  bigstp = .true.
            if (reduce .ge. 0.1d0*model) then
               delta = 0.5d0 * delta
            else if (reduce .le. 0.75d0*model) then
               delta = min(2.0d0*delta,stpmax)
            end if
         end if
c
c     check relative function convergence and false convergence
c
         if (reduce .le. 2.0d0*model) then
            if (abs(reduce).le.rftol*abs(fcnorm) .and.
     &          abs(model).le.rftol*abs(fcnorm)) then
               icode = 2
            end if
         else
            rellen = 0.0d0
            do i = 1, n
               temp = abs(sc(i))/max(abs(xp(i)),1.0d0/xscale(i))
               rellen = max(rellen,temp)
            end do
            if (rellen .lt. faketol)  icode = 3
         end if
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module stodyn  --  SD trajectory frictional coefficients  ##
c     ##                                                            ##
c     ################################################################
c
c
c     friction    global frictional coefficient for exposed particle
c     fgamma      atomic frictional coefficients for each atom
c     use_sdarea  logical flag to use surface area friction scaling
c
c
      module stodyn
      implicit none
      real*8 friction
      real*8, allocatable :: fgamma(:)
      logical use_sdarea
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module strbnd  --  stretch-bends in current structure  ##
c     ##                                                         ##
c     #############################################################
c
c
c     nstrbnd   total number of stretch-bend interactions
c     isb       angle and bond numbers used in stretch-bend
c     sbk       force constants for stretch-bend terms
c
c
      module strbnd
      implicit none
      integer nstrbnd
      integer, allocatable :: isb(:,:)
      real*8, allocatable :: sbk(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module strtor  --  stretch-torsions in current structure  ##
c     ##                                                            ##
c     ################################################################
c
c
c     nstrtor   total number of stretch-torsion interactions
c     ist       torsion and bond numbers used in stretch-torsion
c     kst       1-, 2- and 3-fold stretch-torsion force constants
c
c
      module strtor
      implicit none
      integer nstrtor
      integer, allocatable :: ist(:,:)
      real*8, allocatable :: kst(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine suffix  --  test for default file extension  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "suffix" checks a filename for the presence of an extension,
c     and appends an extension and version if none is found
c
c
      subroutine suffix (string,extension,status)
      use ascii
      implicit none
      integer i,k
      integer leng,lext
      integer trimtext
      logical exist
      character*1 letter
      character*3 status
      character*(*) string
      character*(*) extension
c
c
c     get the full length of the current filename
c
      leng = trimtext (string)
      lext = trimtext (extension)
c
c     check for an extension on the current filename
c
      k = leng
      do i = 1, leng
         letter = string(i:i)
         if (letter .eq. '/')  k = leng
c        if (letter .eq. '\')  k = leng
         if (ichar(letter) .eq. backslash)  k = leng
         if (letter .eq. ']')  k = leng
         if (letter .eq. ':')  k = leng
         if (letter .eq. '~')  k = leng
         if (letter .eq. '.')  k = i - 1
      end do
c
c     append an extension or version as appropriate
c
      if (k .eq. leng) then
         exist = .false.
         if (leng .ne. 0) then
            inquire (file=string(1:leng),exist=exist)
         end if
         if (.not. exist) then
            string = string(1:leng)//'.'//extension(1:lext)
            call version (string,status)
         end if
      else if (status .eq. 'new') then
         call version (string,status)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  program superpose  --  optimal coordinate superposition  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "superpose" takes pairs of structures and superimposes them
c     in the optimal least squares sense; it will attempt to match
c     all atom pairs or only those specified by the user
c
c
      program superpose
      use align
      use atomid
      use atoms
      use bound
      use files
      use inform
      use iounit
      use titles
      implicit none
      integer i,ixyz,next
      integer n1,i1,n2,i2
      integer leng1,leng2
      integer ifile1,ifile2
      integer frame1,frame2
      integer nmax,last1
      integer start,stop
      integer option,delta
      integer trimtext,freeunit
      integer range(4)
      integer, allocatable :: atomic1(:)
      integer, allocatable :: atomic2(:)
      real*8 xr,yr,zr
      real*8 dist,cutoff
      real*8 rmsvalue
      real*8, allocatable :: mass1(:)
      real*8, allocatable :: mass2(:)
      real*8, allocatable :: x1(:)
      real*8, allocatable :: y1(:)
      real*8, allocatable :: z1(:)
      real*8, allocatable :: x2(:)
      real*8, allocatable :: y2(:)
      real*8, allocatable :: z2(:)
      logical header,exist
      logical query,skip
      logical dopbc,dowrite
      logical self,same,twin
      character*1 answer
      character*3, allocatable :: name1(:)
      character*3, allocatable :: name2(:)
      character*240 file1,file2
      character*240 xyzfile
      character*240 record
      character*240 string
c
c
c     get atom names and masses for the first structure
c
      call initial
      call getxyz
      call unitcell
      call lattice
      call field
      call katom
      file1 = filename
      leng1 = trimtext (file1)
c
c     perform dynamic allocation of some local arrays
c
      allocate (atomic1(n))
      allocate (mass1(n))
      allocate (x1(n))
      allocate (y1(n))
      allocate (z1(n))
      allocate (name1(n))
c
c     store atom names and masses for the first structure
c
      n1 = n
      do i = 1, n1
         name1(i) = name(i)
         atomic1(i) = atomic(i)
         mass1(i) = mass(i)
      end do
c
c     get atom names and masses for the second structure
c
      call getxyz
      call field
      call katom
      file2 = filename
      leng2 = trimtext (file2)
c
c     perform dynamic allocation of some local arrays
c
      allocate (atomic2(n))
      allocate (mass2(n))
      allocate (x2(n))
      allocate (y2(n))
      allocate (z2(n))
      allocate (name2(n))
c
c     store atom names and masses for the second structure
c
      n2 = n
      do i = 1, n2
         name2(i) = name(i)
         atomic2(i) = atomic(i)
         mass2(i) = mass(i)
      end do
c
c     get atom pairs to be superimposed from command line
c
      option = 0
      start = 0
      stop = 0
      answer = ' '
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         query = .false.
         read (string,*,err=10,end=10)  option
         if (option .eq. 1) then
            call nextarg (string,exist)
            if (exist) then
               answer = string(1:1)
               read (string,*,err=10,end=10)  start
               answer = ' '
               call nextarg (string,exist)
               if (exist) then
                  answer = string(1:1)
                  read (string,*,err=10,end=10)  stop
                  answer = ' '
               end if
            end if
         end if
      end if
   10 continue
c
c     ask the user which pairs of atoms are to be superimposed
c
      if (query) then
         write (iout,20)
   20    format (/,' Two Options are Available :  (1) Fit atoms',
     &              ' "M" through "N" from structure 1',
     &           /,' to the corresponding atoms of structure 2.',
     &              ' Enter "1,M,N" to use this option.',
     &           /,' If "N" is omitted, the fit uses atoms 1',
     &              ' through "M". If both "M" and "N" are',
     &           /,' omitted, the fit uses all atoms; or (2)',
     &              ' Individual entry of atom range pairs',
     &           /,' to be used in the fitting procedure.')
         write (iout,30)
   30    format (/,' Enter an Option (either 1,M,N or 2',
     &              ' [<Enter>=1,0,0]) :  ',$)
         read (input,40)  record
   40    format (a240)
         read (record,*,err=50,end=50)  option,start,stop
   50    continue
         if (option.lt.1 .or. option.gt.2) then
            option = 1
            start = 0
            stop = 0
         end if
      end if
c
c     warning if structures have different numbers of atoms
c
      if (option .eq. 1) then
         if (n1.ne.n2 .and. start.eq.0) then
            write (iout,60)
   60       format (/,' SUPERPOSE  --  The Molecules contain',
     &                 ' Different Numbers of Atoms')
         end if
      end if
c
c     perform dynamic allocation of some global arrays
c
      nmax = max(n1,n2)
      allocate (ifit(2,nmax))
      allocate (wfit(nmax))
c
c     setup automatic superposition with option to omit hydrogens
c
      if (option .eq. 1) then
         if (answer .eq. ' ') then
            call nextarg (answer,exist)
         else
            exist = .true.
         end if
         if (.not. exist) then
            write (iout,70)
   70       format (/,' Include Hydrogen Atoms in the Fitting',
     &                 ' [Y] :  ',$)
            read (input,80)  record
   80       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (start.eq.0 .and. stop.eq.0) then
            start = 1
            stop = min(n1,n2)
         else if (start.ne.0 .and. stop.eq.0) then
            stop = min(n1,n2,start)
            start = 1
         else if (start.ne.0 .and. stop.ne.0) then
            start = max(1,start)
            stop = min(n1,n2,stop)
         end if
         nfit = 0
         do i = start, stop
            skip = .false.
            if (answer .eq. 'N') then
               if (atomic1(i).le.1 .or. atomic2(i).le.1) then
                  skip = .true.
               end if
            end if
            if (.not. skip) then
               nfit = nfit + 1
               ifit(1,nfit) = i
               ifit(2,nfit) = i
            end if
         end do
      end if
c
c     manual input of the pairs of atom ranges to superimpose
c
      if (option .eq. 2) then
         write (iout,90)
   90    format (/,' On successive lines below, enter atom',
     &              ' pairs or pairs of atom ranges to use',
     &           /,' during fitting. Entering "4,7" will fit',
     &              ' atom 4 of structure 1 to atom 7 of',
     &           /,' structure 2, while the entry "4,7,9,12"',
     &              ' will match atoms 4 through 7 from',
     &           /,' structure 1 with atoms 9 through 12 of',
     &              ' structure 2. Hit <RET> to end entry',
     &           /,' of the list of pairs.')
         nfit = 0
         do while (.true.)
            do i = 1, 4
               range(i) = 0
            end do
            write (iout,100)
  100       format (/,' Enter a Pair of Atoms or Ranges :  ',$)
            read (input,110)  record
  110       format (a240)
            read (record,*,err=120,end=120)  (range(i),i=1,4)
  120       continue
            if (range(1) .eq. 0) then
               goto 130
            else if (range(2) .eq. 0) then
               nfit = nfit + 1
               ifit(1,nfit) = range(1)
               ifit(2,nfit) = range(1)
            else if (range(3) .eq. 0) then
               nfit = nfit + 1
               ifit(1,nfit) = range(1)
               ifit(2,nfit) = range(2)
            else
               delta = range(3) - range(1)
               do i = range(1), range(2)
                  nfit = nfit + 1
                  ifit(1,nfit) = i
                  ifit(2,nfit) = i + delta
               end do
            end if
         end do
  130    continue
      end if
c
c     decide on the use of periodic boundary conditions
c
      dopbc = .false.
      if (use_bounds) then
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,140)
  140       format (/,' Apply Periodic Boundary Conditions',
     &                 ' [N] :  ',$)
            read (input,150)  record
  150       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  dopbc = .true.
      end if
c
c     decide on the weighting to use for the coordinates
c
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,160)
  160    format (/,' Use Mass- or Unit-Weighted Coordinates',
     &              ' (M or [U]) :  ',$)
         read (input,170)  record
  170    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'M') then
         do i = 1, nfit
            wfit(i) = 0.5d0 * (mass1(ifit(1,i)) + mass2(ifit(2,i)))
         end do
      else
         do i = 1, nfit
            wfit(i) = 1.0d0
         end do
      end if
c
c     decide whether to write the best fit set of coordinates
c
      dowrite = .false.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,180)
  180    format (/,' Write Best-Fit Coordinates of 2nd Molecule',
     &              ' [N] :  ',$)
         read (input,190)  record
  190    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'Y')  dowrite = .true.
c
c     chose cutoff value for output of atom pair deviations
c
      cutoff = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=200,end=200)  cutoff
  200 continue
      if (cutoff .lt. 0.0d0) then
         cutoff = 0.0d0
         write (iout,210)
  210    format (/,' Cutoff Value for Listing RMS Deviations',
     &              ' [0.0] :  ',$)
         read (input,220,err=230,end=230)  cutoff
  220    format (f20.0)
  230    continue
      end if
c
c     information about structures to be superimposed
c
      write (iout,240)  file1(1:leng1)
  240 format (/,' Structure File 1 :  ',a)
      write (iout,250)  file2(1:leng2)
  250 format (/,' Structure File 2 :  ',a)
c
c     reopen the coordinate files with structures to superimpose
c
      ifile1 = freeunit ()
      call suffix (file1,'xyz','old')
      open (unit=ifile1,file=file1,status ='old')
      rewind (unit=ifile1)
      call suffix (file2,'xyz','old')
      if (file1 .eq. file2) then
         ifile2 = ifile1
         self = .true.
         same = .true.
         do i = 1, nfit
            if (ifit(1,i) .ne. ifit(2,i))   same = .false.
         end do
      else
         ifile2 = freeunit ()
         open (unit=ifile2,file=file2,status ='old')
         rewind (unit=ifile2)
         self = .false.
         same = .false.
      end if
c
c     read initial structure set from the first coordinate file
c
      last1 = 0
      frame1 = 1
      call readxyz (ifile1)
      n1 = n
      do i = 1, n1
         x1(i) = x(i)
         y1(i) = y(i)
         z1(i) = z(i)
      end do
c
c     read initial structure set from the second coordinate file
c
      frame2 = 1
      if (same)  frame2 = 2
      use_bounds = .false.
      call readxyz (ifile2)
      n2 = n
      do i = 1, n2
         x2(i) = x(i)
         y2(i) = y(i)
         z2(i) = z(i)
      end do
      if (abort) then
         abort = .false.
         frame2 = 1
         n2 = n1
         do i = 1, n2
            x2(i) = x1(i)
            y2(i) = y1(i)
            z2(i) = z1(i)
         end do
      end if
c
c     perform the superposition of a structure pair
c
      do while (.not. abort)
         write (iout,260)  frame1,frame2
  260    format (/,' File 1 Frame :',i6,13x,'File 2 Frame :',i6)
         write (iout,270)
  270    format (/,' Summary of Results from Structural',
     &              ' Superposition :')
         if (dopbc) then
            twin = .true.
            do i = 1, nfit
               i1 = ifit(1,i)
               i2 = ifit(2,i)
               if (i1 .ne. i2)  twin = .false.
            end do
            if (twin) then
               do i = 1, n
                  xr = x2(i) - x1(i)
                  yr = y2(i) - y1(i)
                  zr = z2(i) - z1(i)
                  call image (xr,yr,zr)
                  x2(i) = x1(i) + xr
                  y2(i) = y1(i) + yr
                  z2(i) = z1(i) + zr
               end do
            else
               do i = 1, nfit
                  i1 = ifit(1,i)
                  i2 = ifit(2,i)
                  xr = x2(i2) - x1(i1)
                  yr = y2(i2) - y1(i1)
                  zr = z2(i2) - z1(i1)
                  call image (xr,yr,zr)
                  x2(i2) = x1(i1) + xr
                  y2(i2) = y1(i1) + yr
                  z2(i2) = z1(i1) + zr
               end do
            end if
         end if
         verbose = .true.
         call impose (n1,x1,y1,z1,n2,x2,y2,z2,rmsvalue)
         write (iout,280)  rmsvalue,frame1,frame2
  280    format (/,' Root Mean Square Distance :',11x,f15.6,2x,2i7)
c
c     write out the results of the superposition
c
         header = .true.
         do i = 1, nfit
            i1 = ifit(1,i)
            i2 = ifit(2,i)
            xr = x2(i2) - x1(i1)
            yr = y2(i2) - y1(i1)
            zr = z2(i2) - z1(i1)
            dist = sqrt(xr*xr + yr*yr + zr*zr)
            if (dist .ge. cutoff) then
               if (header) then
                  header = .false.
                  write (iout,290)
  290             format (/,'   Atom in the',9x,'Atom in the',12x,
     &                       'Distance',10x,'Weight'
     &                    /,' First Structure',5x,'Second Structure',
     &                       8x,'Separated',10x,'in Fit'/)
               end if
               write (iout,300)  i1,name1(i1),i2,name2(i2),dist,wfit(i)
  300          format (3x,i7,'-',a3,9x,i7,'-',a3,7x,f13.6,4x,f12.4)
            end if
         end do
         if (.not. header) then
            write (iout,310)  rmsvalue
  310       format (/,' Root Mean Square Distance :',11x,f15.6)
         end if
c
c     create output file for superimposed second structure
c
         if (dowrite) then
            do i = 1, n
               x(i) = x2(i)
               y(i) = y2(i)
               z(i) = z2(i)
            end do
            ixyz = freeunit ()
            xyzfile = file2(1:leng)//'.xyz'
            if (frame1 .eq. last1) then
               call version (xyzfile,'old')
               open (unit=ixyz,file=xyzfile,status='old',
     &                  position='append')
            else
               last1 = frame1
               call version (xyzfile,'new')
               open (unit=ixyz,file=xyzfile,status='new')
            end if
            call prtxyz (ixyz)
            close (unit=ixyz)
         end if
c
c     attempt to get next structure pair from coordinate files
c
         frame2 = frame2 + 1
         use_bounds = .false.
         call readxyz (ifile2)
         n2 = n
         do i = 1, n2
            x2(i) = x(i)
            y2(i) = y(i)
            z2(i) = z(i)
         end do
         if (abort) then
            abort = .false.
            if (self) then
               rewind (unit=ifile1)
               do i = 1, frame1
                  call readxyz (ifile1)
               end do
            end if
            frame1 = frame1 + 1
            call readxyz (ifile1)
            n1 = n
            do i = 1, n1
               x1(i) = x(i)
               y1(i) = y(i)
               z1(i) = z(i)
            end do
            if (.not. abort) then
               frame2 = frame1 + 1
               if (.not. same) then
                  frame2 = 1
                  rewind (unit=ifile2)
               end if
               use_bounds = .false.
               call readxyz (ifile2)
               n2 = n
               do i = 1, n2
                  x2(i) = x(i)
                  y2(i) = y(i)
                  z2(i) = z(i)
               end do
            end if
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (atomic1)
      deallocate (mass1)
      deallocate (x1)
      deallocate (y1)
      deallocate (z1)
      deallocate (name1)
      deallocate (atomic2)
      deallocate (mass2)
      deallocate (x2)
      deallocate (y2)
      deallocate (z2)
      deallocate (name2)
c
c     perform any final tasks before program exit
c
      close (unit=ifile1)
      if (.not. self)  close (unit=ifile2)
      call final
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 1990 by Patrice Koehl & Jay William Ponder  ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine surface  --  alpha shapes accessible surface  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "surface" computes the weighted solvent accessible surface
c     area each atom via the inclusion-exclusion method of Herbert
c     Edelsbrunner based on alpha shapes
c
c     note for small or symmetric structures where alpha shapes
c     may fail, the code switches to the Richmond method
c
c     developed to facilitate calling UnionBall from Tinker by
c     Jay W. Ponder, Washington University, October 2023
c
c     literature references:
c
c     P. Mach and P. Koehl, "Geometric Measures of Large Biomolecules:
c     Surface, Volume, and Pockets", Journal of Computational Chemistry,
c     32, 3023-3038 (2011)
c
c     P. Koehl, A. Akopyan and H. Edelsbrunner, "Computing the Volume,
c     Surface Area, Mean, and Gaussian Curvatures of Molecules and Their
c     Derivatives", Journal of Chemical Information and Modeling, 63,
c     973-985 (2023)
c
c     variables and parameters:
c
c     nsphere    number of spheres/balls in the system
c     coords     coordinates of the center of each sphere
c     radii      radius value for each sphere
c     weight     weight value for each sphere
c     probe      radius value of the probe sphere
c     surf       weighted surface area of union of spheres
c     usurf      unweighted surface area of union of spheres
c     asurf      weighted area contribution of each sphere
c
c
      subroutine surface (rad,weight,probe,surf,asurf)
      use atoms
      implicit none
      integer i,nsphere
      integer nsize,nfudge
      integer nredund
      integer, allocatable :: redlist(:)
      real*8 surf,usurf,eps
      real*8 probe,alpha
      real*8 rad(*)
      real*8 weight(*)
      real*8 asurf(*)
      real*8, allocatable :: radii(:)
      real*8, allocatable :: asurfx(:)
      real*8, allocatable :: coords(:,:)
      logical dowiggle
      character*6 symmtyp
c
c
c     check coordinates for linearity, planarity and symmetry
c
      symmtyp = 'NONE'
      call chksymm (symmtyp)
      dowiggle = .false.
      if (n.gt.2 .and. symmtyp.eq.'LINEAR')  dowiggle = .true.
      if (n.gt.3 .and. symmtyp.eq.'PLANAR')  dowiggle = .true.
      if (symmtyp .eq. 'CENTER')  dowiggle = .true.
c
c     use Richmond method for small symmetric structures
c
      if (dowiggle) then
         call richmond (n,x,y,z,rad,weight,probe,surf,asurf)
         return
      end if
c
c     perform dynamic allocation of some local arrays
c
      nfudge = 10
      nsize = n + nfudge
      allocate (radii(nsize))
      allocate (asurfx(nsize))
      allocate (coords(3,nsize))
      allocate (redlist(nsize))
c
c     set the coordinates and sphere radii plus probe`
c
      nsphere = n
      do i = 1, n
         coords(1,i) = x(i)
         coords(2,i) = y(i)
         coords(3,i) = z(i)
         radii(i) = 0.0d0
         if (rad(i) .ne. 0.0d0)  radii(i) = rad(i) + probe
      end do
c
c     random coordinate perturbation to avoid numerical issues
c
      if (dowiggle) then
         eps = 0.001d0
         call wiggle (n,coords,eps)
      end if
c
c     transfer coordinates, complete to minimum of four spheres
c     if needed, set Delaunay and alpha complex arrays
c
      call setunion (nsphere,coords,radii)
c
c     compute the weighted Delaunay triangulation
c
      call regular3 (nredund,redlist)
c
c     compute the alpha complex for fixed value of alpha
c
      alpha = 0.0d0
      call alfcx (alpha,nredund,redlist)
c
c     if fewer than four balls, set artificial spheres as redundant
c
      call readjust_sphere (nsphere,nredund,redlist)
c
c     get accessible surface area via the UnionBall method
c
      call ball_surf (weight,surf,usurf,asurfx)
c
c     copy surface area of each sphere into Tinker array
c
      do i = 1, n
         asurf(i) = asurfx(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (radii)
      deallocate (asurfx)
      deallocate (coords)
      deallocate (redlist)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine surface1  --  alpha shapes surface & derivs  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "surface1" computes the weighted solvent accessible surface
c     area of each atom and the first derivatives of the area with
c     respect to Cartesian coordinates via the inclusion-exclusion
c     method of Herbert Edelsbrunner based on alpha shapes
c
c     note for small or symmetric structures where alpha shapes
c     may fail, the code switches to the Richmond method
c
c     developed to facilitate calling UnionBall from Tinker by
c     Jay W. Ponder, Washington University, October 2023
c
c     literature references:
c
c     P. Mach and P. Koehl, "Geometric Measures of Large Biomolecules:
c     Surface, Volume, and Pockets", Journal of Computational Chemistry,
c     32, 3023-3038 (2011)
c
c     P. Koehl, A. Akopyan and H. Edelsbrunner, "Computing the Volume,
c     Surface Area, Mean, and Gaussian Curvatures of Molecules and Their
c     Derivatives", Journal of Chemical Information and Modeling, 63,
c     973-985 (2023)
c
c     variables and parameters:
c
c     nsphere    number of spheres/balls in the system
c     coords     coordinates of the center of each sphere
c     radii      radius value for each sphere
c     weight     weight value for each sphere
c     probe      radius value of the probe sphere
c     surf       weighted surface area of union of spheres
c     usurf      unweighted surface area of union of spheres
c     asurf      weighted area contribution of each sphere
c     dsurf      derivatives of the weighted surface area over
c                  coordinates of the sphere centers
c
c
      subroutine surface1 (rad,weight,probe,surf,asurf,dsurf)
      use atoms
      implicit none
      integer i,nsphere
      integer nsize,nfudge
      integer nredund
      integer, allocatable :: redlist(:)
      real*8 surf,usurf,eps
      real*8 probe,alpha
      real*8 rad(*)
      real*8 weight(*)
      real*8 asurf(*)
      real*8 dsurf(3,*)
      real*8, allocatable :: radii(:)
      real*8, allocatable :: asurfx(:)
      real*8, allocatable :: coords(:,:)
      real*8, allocatable :: dsurfx(:,:)
      logical dowiggle
      character*6 symmtyp
c
c
c     check coordinates for linearity, planarity and symmetry
c
      symmtyp = 'NONE'
      call chksymm (symmtyp)
      dowiggle = .false.
      if (n.gt.2 .and. symmtyp.eq.'LINEAR')  dowiggle = .true.
      if (n.gt.3 .and. symmtyp.eq.'PLANAR')  dowiggle = .true.
      if (symmtyp .eq. 'CENTER')  dowiggle = .true.
c
c     use Richmond method for small symmetric structures
c
      if (dowiggle) then
         call richmond1 (n,x,y,z,rad,weight,probe,surf,asurf,dsurf)
         return
      end if
c
c     perform dynamic allocation of some local arrays
c
      nfudge = 10
      nsize = n + nfudge
      allocate (radii(nsize))
      allocate (asurfx(nsize))
      allocate (coords(3,nsize))
      allocate (dsurfx(3,nsize))
      allocate (redlist(nsize))
c
c     set the coordinates and sphere radii plus probe`
c
      nsphere = n
      do i = 1, n
         coords(1,i) = x(i)
         coords(2,i) = y(i)
         coords(3,i) = z(i)
         radii(i) = 0.0d0
         if (rad(i) .ne. 0.0d0)  radii(i) = rad(i) + probe
      end do
c
c     random coordinate perturbation to avoid numerical issues
c
      if (dowiggle) then
         eps = 0.001d0
         call wiggle (n,coords,eps)
      end if
c
c     transfer coordinates, complete to minimum of four spheres
c     if needed, set Delaunay and alpha complex arrays
c
      call setunion (nsphere,coords,radii)
c
c     compute the weighted Delaunay triangulation
c
      call regular3 (nredund,redlist)
c
c     compute the alpha complex for fixed value of alpha
c
      alpha = 0.0d0
      call alfcx (alpha,nredund,redlist)
c
c     if fewer than four balls, set artificial spheres as redundant
c
      call readjust_sphere (nsphere,nredund,redlist)
c
c     get accessible surface area via the UnionBall method
c
      call ball_dsurf (weight,surf,usurf,asurfx,dsurfx)
c
c     copy surface area of each sphere into Tinker array
c
      do i = 1, n
         asurf(i) = asurfx(i)
         dsurf(1,i) = dsurfx(1,i)
         dsurf(2,i) = dsurfx(2,i)
         dsurf(3,i) = dsurfx(3,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (radii)
      deallocate (asurfx)
      deallocate (coords)
      deallocate (dsurfx)
      deallocate (redlist)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine surfatom  --  exposed surface area of an atom  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "surfatom" performs an analytical computation of the surface
c     area of a specified atom; a simplified version of "surface"
c
c     literature references:
c
c     T. J. Richmond, "Solvent Accessible Surface Area and
c     Excluded Volume in Proteins", Journal of Molecular Biology,
c     178, 63-89 (1984)
c
c     L. Wesson and D. Eisenberg, "Atomic Solvation Parameters
c     Applied to Molecular Dynamics of Proteins in Solution",
c     Protein Science, 1, 227-235 (1992)
c
c     variables and parameters:
c
c     ir       number of atom for which area is desired
c     area     accessible surface area of the atom
c     radius   radii of each of the individual atoms
c
c
      subroutine surfatom (ir,area,radius)
      use atoms
      use iounit
      use math
      implicit none
      integer maxarc
      parameter (maxarc=1000)
      integer i,j,k,m
      integer ii,ib,jb
      integer io,ir
      integer mi,ni,narc
      integer key(maxarc)
      integer intag(maxarc)
      integer intag1(maxarc)
      integer lt(maxarc)
      integer kent(maxarc)
      integer kout(maxarc)
      real*8 area,arcsum
      real*8 arclen,exang
      real*8 delta,delta2
      real*8 eps,rmove
      real*8 xr,yr,zr
      real*8 rr,rrsq
      real*8 rplus,rminus
      real*8 axx,axy,axz
      real*8 ayx,ayy
      real*8 azx,azy,azz
      real*8 uxj,uyj,uzj
      real*8 tx,ty,tz
      real*8 txb,tyb,td
      real*8 tr2,tr,txr,tyr
      real*8 tk1,tk2
      real*8 thec,the,t,tb
      real*8 txk,tyk,tzk
      real*8 t1,ti,tf,tt
      real*8 txj,tyj,tzj
      real*8 ccsq,cc,xysq
      real*8 bsqk,bk,cosine
      real*8 dsqj,gi,pix2
      real*8 therk,dk,gk
      real*8 risqk,rik
      real*8 radius(*)
      real*8 ri(maxarc),risq(maxarc)
      real*8 bsq(maxarc),bsq1(maxarc)
      real*8 dsq(maxarc),dsq1(maxarc)
      real*8 arci(maxarc),arcf(maxarc)
      real*8 ex(maxarc),gr(maxarc)
      real*8 b(maxarc),b1(maxarc)
      real*8 bg(maxarc),ther(maxarc)
      real*8 xc(maxarc),xc1(maxarc)
      real*8 yc(maxarc),yc1(maxarc)
      real*8 zc(maxarc),zc1(maxarc)
      real*8 ux(maxarc),uy(maxarc)
      real*8 uz(maxarc)
      logical moved,top
      logical omit(maxarc)
c
c
c     zero out the surface area for the sphere of interest
c
      area = 0.0d0
      if (radius(ir) .eq. 0.0d0)  return
c
c     set the overlap significance and connectivity shift
c
      pix2 = 2.0d0 * pi
      delta = 1.0d-8
      delta2 = delta * delta
      eps = 1.0d-8
      moved = .false.
      rmove = 1.0d-8
c
c     store coordinates and radius of the sphere of interest
c
      xr = x(ir)
      yr = y(ir)
      zr = z(ir)
      rr = radius(ir)
      rrsq = rr * rr
c
c     initialize values of some counters and summations
c
   10 continue
      io = 0
      jb = 0
      ib = 0
      arclen = 0.0d0
      exang = 0.0d0
c
c     test each sphere to see if it overlaps the sphere of interest
c
      do i = 1, n
         if (i.eq.ir .or. radius(i).eq.0.0d0)  goto 30
         rplus = rr + radius(i)
         tx = x(i) - xr
         if (abs(tx) .ge. rplus)  goto 30
         ty = y(i) - yr
         if (abs(ty) .ge. rplus)  goto 30
         tz = z(i) - zr
         if (abs(tz) .ge. rplus)  goto 30
c
c     check for sphere overlap by testing distance against radii
c
         xysq = tx*tx + ty*ty
         if (xysq .lt. delta2) then
            tx = delta
            ty = 0.0d0
            xysq = delta2
         end if
         ccsq = xysq + tz*tz
         cc = sqrt(ccsq)
         if (rplus-cc .le. delta)  goto 30
         rminus = rr - radius(i)
c
c     check to see if sphere of interest is completely buried
c
         if (cc-abs(rminus) .le. delta) then
            if (rminus .le. 0.0d0)  goto 170
            goto 30
         end if
c
c     check for too many overlaps with sphere of interest
c
         if (io .ge. maxarc) then
            write (iout,20)
   20       format (/,' SURFATOM  --  Increase the Value of MAXARC')
            call fatal
         end if
c
c     get overlap between current sphere and sphere of interest
c
         io = io + 1
         xc1(io) = tx
         yc1(io) = ty
         zc1(io) = tz
         dsq1(io) = xysq
         bsq1(io) = ccsq
         b1(io) = cc
         gr(io) = (ccsq+rplus*rminus) / (2.0d0*rr*b1(io))
         intag1(io) = i
         omit(io) = .false.
   30    continue
      end do
c
c     case where no other spheres overlap the sphere of interest
c
      if (io .eq. 0) then
         area = 4.0d0 * pi * rrsq
         return
      end if
c
c     case where only one sphere overlaps the sphere of interest
c
      if (io .eq. 1) then
         area = pix2 * (1.0d0 + gr(1))
         area = mod(area,4.0d0*pi) * rrsq
         return
      end if
c
c     case where many spheres intersect the sphere of interest;
c     sort the intersecting spheres by their degree of overlap
c
      call sort2 (io,gr,key)
      do i = 1, io
         k = key(i)
         intag(i) = intag1(k)
         xc(i) = xc1(k)
         yc(i) = yc1(k)
         zc(i) = zc1(k)
         dsq(i) = dsq1(k)
         b(i) = b1(k)
         bsq(i) = bsq1(k)
      end do
c
c     get radius of each overlap circle on surface of the sphere
c
      do i = 1, io
         gi = gr(i) * rr
         bg(i) = b(i) * gi
         risq(i) = rrsq - gi*gi
         ri(i) = sqrt(risq(i))
         ther(i) = 0.5d0*pi - asin(min(1.0d0,max(-1.0d0,gr(i))))
      end do
c
c     find boundary of inaccessible area on sphere of interest
c
      do k = 1, io-1
         if (.not. omit(k)) then
            txk = xc(k)
            tyk = yc(k)
            tzk = zc(k)
            bk = b(k)
            therk = ther(k)
c
c     check to see if J circle is intersecting K circle;
c     get distance between circle centers and sum of radii
c
            do j = k+1, io
               if (omit(j))  goto 60
               cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j))
               cc = acos(min(1.0d0,max(-1.0d0,cc)))
               td = therk + ther(j)
c
c     check to see if circles enclose separate regions
c
               if (cc .ge. td)  goto 60
c
c     check for circle J completely inside circle K
c
               if (cc+ther(j) .lt. therk)  goto 40
c
c     check for circles that are essentially parallel
c
               if (cc .gt. delta)  goto 50
   40          continue
               omit(j) = .true.
               goto 60
c
c     check to see if sphere of interest is completely buried
c
   50          continue
               if (pix2-cc .le. td)  goto 170
   60          continue
            end do
         end if
      end do
c
c     find T value of circle intersections
c
      do k = 1, io
         if (omit(k))  goto 110
         omit(k) = .true.
         narc = 0
         top = .false.
         txk = xc(k)
         tyk = yc(k)
         tzk = zc(k)
         dk = sqrt(dsq(k))
         bsqk = bsq(k)
         bk = b(k)
         gk = gr(k) * rr
         risqk = risq(k)
         rik = ri(k)
         therk = ther(k)
c
c     rotation matrix elements
c
         t1 = tzk / (bk*dk)
         axx = txk * t1
         axy = tyk * t1
         axz = dk / bk
         ayx = tyk / dk
         ayy = txk / dk
         azx = txk / bk
         azy = tyk / bk
         azz = tzk / bk
         do j = 1, io
            if (.not. omit(j)) then
               txj = xc(j)
               tyj = yc(j)
               tzj = zc(j)
c
c     rotate spheres so K vector colinear with z-axis
c
               uxj = txj*axx + tyj*axy - tzj*axz
               uyj = tyj*ayy - txj*ayx
               uzj = txj*azx + tyj*azy + tzj*azz
               cosine = min(1.0d0,max(-1.0d0,uzj/b(j)))
               if (acos(cosine) .lt. therk+ther(j)) then
                  dsqj = uxj*uxj + uyj*uyj
                  tb = uzj*gk - bg(j)
                  txb = uxj * tb
                  tyb = uyj * tb
                  td = rik * dsqj
                  tr2 = risqk*dsqj - tb*tb
                  tr2 = max(eps,tr2)
                  tr = sqrt(tr2)
                  txr = uxj * tr
                  tyr = uyj * tr
c
c     get T values of intersection for K circle
c
                  tb = (txb+tyr) / td
                  tb = min(1.0d0,max(-1.0d0,tb))
                  tk1 = acos(tb)
                  if (tyb-txr .lt. 0.0d0)  tk1 = pix2 - tk1
                  tb = (txb-tyr) / td
                  tb = min(1.0d0,max(-1.0d0,tb))
                  tk2 = acos(tb)
                  if (tyb+txr .lt. 0.0d0)  tk2 = pix2 - tk2
                  thec = (rrsq*uzj-gk*bg(j)) / (rik*ri(j)*b(j))
                  if (abs(thec) .lt. 1.0d0) then
                     the = -acos(thec)
                  else if (thec .ge. 1.0d0) then
                     the = 0.0d0
                  else if (thec .le. -1.0d0) then
                     the = -pi
                  end if
c
c     see if "tk1" is entry or exit point; check t=0 point;
c     "ti" is exit point, "tf" is entry point
c
                  cosine = min(1.0d0,max(-1.0d0,
     &                            (uzj*gk-uxj*rik)/(b(j)*rr)))
                  if ((acos(cosine)-ther(j))*(tk2-tk1) .le. 0.0d0) then
                     ti = tk2
                     tf = tk1
                  else
                     ti = tk2
                     tf = tk1
                  end if
                  narc = narc + 1
                  if (narc .ge. maxarc) then
                     write (iout,70)
   70                format (/,' SURFATOM  --  Increase the Value',
     &                          ' of MAXARC')
                     call fatal
                  end if
                  if (tf .le. ti) then
                     arcf(narc) = tf
                     arci(narc) = 0.0d0
                     tf = pix2
                     lt(narc) = j
                     ex(narc) = the
                     top = .true.
                     narc = narc + 1
                  end if
                  arcf(narc) = tf
                  arci(narc) = ti
                  lt(narc) = j
                  ex(narc) = the
                  ux(j) = uxj
                  uy(j) = uyj
                  uz(j) = uzj
               end if
            end if
         end do
         omit(k) = .false.
c
c     special case; K circle without intersections
c
         if (narc .le. 0)  goto 90
c
c     general case; sum up arclength and set connectivity code
c
         call sort2 (narc,arci,key)
         arcsum = arci(1)
         mi = key(1)
         t = arcf(mi)
         ni = mi
         if (narc .gt. 1) then
            do j = 2, narc
               m = key(j)
               if (t .lt. arci(j)) then
                  arcsum = arcsum + arci(j) - t
                  exang = exang + ex(ni)
                  jb = jb + 1
                  if (jb .ge. maxarc) then
                     write (iout,80)
   80                format (/,' SURFATOM  --  Increase the Value',
     &                          ' of MAXARC')
                     call fatal
                  end if
                  i = lt(ni)
                  kent(jb) = maxarc*i + k
                  i = lt(m)
                  kout(jb) = maxarc*k + i
               end if
               tt = arcf(m)
               if (tt .ge. t) then
                  t = tt
                  ni = m
               end if
            end do
         end if
         arcsum = arcsum + pix2 - t
         if (.not. top) then
            exang = exang + ex(ni)
            jb = jb + 1
            i = lt(ni)
            kent(jb) = maxarc*i + k
            i = lt(mi)
            kout(jb) = maxarc*k + i
         end if
         goto 100
   90    continue
         arcsum = pix2
         ib = ib + 1
  100    continue
         arclen = arclen + gr(k)*arcsum
  110    continue
      end do
      if (arclen .eq. 0.0d0)  goto 170
      if (jb .eq. 0)  goto 150
c
c     find number of independent boundaries and check connectivity
c
      j = 0
      do k = 1, jb
         if (kout(k) .ne. 0) then
            i = k
  120       continue
            m = kout(i)
            kout(i) = 0
            j = j + 1
            do ii = 1, jb
               if (m .eq. kent(ii)) then
                  if (ii .eq. k) then
                     ib = ib + 1
                     if (j .eq. jb)  goto 150
                     goto 130
                  end if
                  i = ii
                  goto 120
               end if
            end do
  130       continue
         end if
      end do
      ib = ib + 1
c
c     attempt to fix connectivity error by moving atom slightly
c
      if (moved) then
         write (iout,140)  ir
  140    format (/,' SURFATOM  --  Connectivity Error at Atom',i6)
      else
         moved = .true.
         xr = xr + rmove
         yr = yr + rmove
         zr = zr + rmove
         goto 10
      end if
c
c     compute the exposed surface area for the sphere of interest
c
  150 continue
      area = ib*pix2 + exang + arclen
      area = mod(area,4.0d0*pi) * rrsq
c
c     attempt to fix negative area by moving atom slightly
c
      if (area .lt. 0.0d0) then
         if (moved) then
            write (iout,160)  ir
  160       format (/,' SURFATOM  --  Negative Area at Atom',i6)
         else
            moved = .true.
            xr = xr + rmove
            yr = yr + rmove
            zr = zr + rmove
            goto 10
         end if
      end if
  170 continue
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine surfatom1  --  surface area and derivs of atom  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "surfatom1" performs an analytical computation of the surface
c     area and first derivatives with respect to Cartesian coordinates
c     of a specified atom
c
c
      subroutine surfatom1 (ir,area,darea,radius)
      use atoms
      use iounit
      use math
      implicit none
      integer maxarc
      parameter (maxarc=1000)
      integer i,j,k,m
      integer ii,ib,jb
      integer io,ir,in
      integer mi,ni,narc
      integer key(maxarc)
      integer intag(maxarc)
      integer intag1(maxarc)
      integer lt(maxarc)
      integer kent(maxarc)
      integer kout(maxarc)
      integer ider(maxarc)
      integer sign_yder(maxarc)
      real*8 area,arcsum
      real*8 arclen,exang
      real*8 delta,delta2
      real*8 wxl,wxlsq
      real*8 p,s,v,rcn
      real*8 eps,rmove
      real*8 xr,yr,zr
      real*8 rr,rin
      real*8 rrx2,rrsq
      real*8 rplus,rminus
      real*8 axx,axy,axz
      real*8 ayx,ayy
      real*8 azx,azy,azz
      real*8 uxj,uyj,uzj
      real*8 tx,ty,tz
      real*8 txb,tyb,td
      real*8 tr2,tr,txr,tyr
      real*8 tk1,tk2
      real*8 thec,the,t,tb
      real*8 txk,tyk,tzk
      real*8 t1,ti,tf,tt
      real*8 txj,tyj,tzj
      real*8 ccsq,cc,xysq
      real*8 bgl,bsqk,bsql
      real*8 bk,cosine
      real*8 gl,uzl,t2
      real*8 dsqj,gi,pix2
      real*8 dax,day,daz
      real*8 deal,decl
      real*8 dtkal,dtkcl
      real*8 dtlal,dtlcl
      real*8 therk,dk,gk
      real*8 risqk,rik,risql
      real*8 faca,facb,facc
      real*8 gaca,gacb
      real*8 radius(*)
      real*8 darea(3,*)
      real*8 ri(maxarc),risq(maxarc)
      real*8 bsq(maxarc),bsq1(maxarc)
      real*8 dsq(maxarc),dsq1(maxarc)
      real*8 arci(maxarc),arcf(maxarc)
      real*8 ex(maxarc),gr(maxarc)
      real*8 b(maxarc),b1(maxarc)
      real*8 bg(maxarc),ther(maxarc)
      real*8 xc(maxarc),xc1(maxarc)
      real*8 yc(maxarc),yc1(maxarc)
      real*8 zc(maxarc),zc1(maxarc)
      real*8 ux(maxarc),uy(maxarc)
      real*8 uz(maxarc)
      logical moved,top
      logical omit(maxarc)
c
c
c     zero out the area and derivatives for sphere of interest
c
      area = 0.0d0
      do i = 1, n
         darea(1,i) = 0.0d0
         darea(2,i) = 0.0d0
         darea(3,i) = 0.0d0
      end do
      if (radius(ir) .eq. 0.0d0)  return
c
c     set the overlap significance and connectivity shift
c
      pix2 = 2.0d0 * pi
      delta = 1.0d-8
      delta2 = delta * delta
      eps = 1.0d-8
      moved = .false.
      rmove = 1.0d-8
      do i = 1, maxarc
         ider(i) = 0
         sign_yder(i) = 0
      end do
c
c     store coordinates and radius of the sphere of interest
c
      xr = x(ir)
      yr = y(ir)
      zr = z(ir)
      rr = radius(ir)
      rrx2 = 2.0d0 * rr
      rrsq = rr * rr
c
c     initialize values of some counters and summations
c
   10 continue
      io = 0
      jb = 0
      ib = 0
      arclen = 0.0d0
      exang = 0.0d0
c
c     test each sphere to see if it overlaps the sphere of interest
c
      do i = 1, n
         if (i.eq.ir .or. radius(i).eq.0.0d0)  goto 30
         rplus = rr + radius(i)
         tx = x(i) - xr
         if (abs(tx) .ge. rplus)  goto 30
         ty = y(i) - yr
         if (abs(ty) .ge. rplus)  goto 30
         tz = z(i) - zr
         if (abs(tz) .ge. rplus)  goto 30
c
c     check for sphere overlap by testing distance against radii
c
         xysq = tx*tx + ty*ty
         if (xysq .lt. delta2) then
            tx = delta
            ty = 0.0d0
            xysq = delta2
         end if
         ccsq = xysq + tz*tz
         cc = sqrt(ccsq)
         if (rplus-cc .le. delta)  goto 30
         rminus = rr - radius(i)
c
c     check to see if sphere of interest is completely buried
c
         if (cc-abs(rminus) .le. delta) then
            if (rminus .le. 0.0d0)  goto 170
            goto 30
         end if
c
c     check for too many overlaps with sphere of interest
c
         if (io .ge. maxarc) then
            write (iout,20)
   20       format (/,' SURFATOM1  --  Increase the Value of MAXARC')
            call fatal
         end if
c
c     get overlap between current sphere and sphere of interest
c
         io = io + 1
         xc1(io) = tx
         yc1(io) = ty
         zc1(io) = tz
         dsq1(io) = xysq
         bsq1(io) = ccsq
         b1(io) = cc
         gr(io) = (ccsq+rplus*rminus) / (2.0d0*rr*b1(io))
         intag1(io) = i
         omit(io) = .false.
   30    continue
      end do
c
c     case where no other spheres overlap the sphere of interest
c
      if (io .eq. 0) then
         area = 4.0d0 * pi * rrsq
         return
      end if
c
c     case where only one sphere overlaps the sphere of interest
c
      if (io .eq. 1) then
         k = 1
         txk = xc1(1)
         tyk = yc1(1)
         tzk = zc1(1)
         bsqk = bsq1(1)
         bk = b1(1)
         intag(1) = intag1(1)
         arcsum = pix2
         ib = ib + 1
         arclen = arclen + gr(k)*arcsum
         if (.not. moved) then
            in = intag(k)
            rin = radius(in)
            t1 = arcsum*rrsq*(bsqk-rrsq+rin*rin) / (rrx2*bsqk*bk)
            darea(1,ir) = darea(1,ir) - txk*t1
            darea(2,ir) = darea(2,ir) - tyk*t1
            darea(3,ir) = darea(3,ir) - tzk*t1
            darea(1,in) = darea(1,in) + txk*t1
            darea(2,in) = darea(2,in) + tyk*t1
            darea(3,in) = darea(3,in) + tzk*t1
         end if
         area = pix2 * (1.0d0 + gr(1))
         area = mod(area,4.0d0*pi) * rrsq
         return
      end if
c
c     case where many spheres intersect the sphere of interest;
c     sort the intersecting spheres by their degree of overlap
c
      call sort2 (io,gr,key)
      do i = 1, io
         k = key(i)
         intag(i) = intag1(k)
         xc(i) = xc1(k)
         yc(i) = yc1(k)
         zc(i) = zc1(k)
         dsq(i) = dsq1(k)
         b(i) = b1(k)
         bsq(i) = bsq1(k)
      end do
c
c     get radius of each overlap circle on surface of the sphere
c
      do i = 1, io
         gi = gr(i) * rr
         bg(i) = b(i) * gi
         risq(i) = rrsq - gi*gi
         ri(i) = sqrt(risq(i))
         ther(i) = 0.5d0*pi - asin(min(1.0d0,max(-1.0d0,gr(i))))
      end do
c
c     find boundary of inaccessible area on sphere of interest
c
      do k = 1, io-1
         if (.not. omit(k)) then
            txk = xc(k)
            tyk = yc(k)
            tzk = zc(k)
            bk = b(k)
            therk = ther(k)
c
c     check to see if J circle is intersecting K circle;
c     get distance between circle centers and sum of radii
c
            do j = k+1, io
               if (omit(j))  goto 60
               cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j))
               cc = acos(min(1.0d0,max(-1.0d0,cc)))
               td = therk + ther(j)
c
c     check to see if circles enclose separate regions
c
               if (cc .ge. td)  goto 60
c
c     check for circle J completely inside circle K
c
               if (cc+ther(j) .lt. therk)  goto 40
c
c     check for circles that are essentially parallel
c
               if (cc .gt. delta)  goto 50
   40          continue
               omit(j) = .true.
               goto 60
c
c     check to see if sphere of interest is completely buried
c
   50          continue
               if (pix2-cc .le. td)  goto 170
   60          continue
            end do
         end if
      end do
c
c     find T value of circle intersections
c
      do k = 1, io
         if (omit(k))  goto 110
         omit(k) = .true.
         narc = 0
         top = .false.
         txk = xc(k)
         tyk = yc(k)
         tzk = zc(k)
         dk = sqrt(dsq(k))
         bsqk = bsq(k)
         bk = b(k)
         gk = gr(k) * rr
         risqk = risq(k)
         rik = ri(k)
         therk = ther(k)
c
c     rotation matrix elements
c
         t1 = tzk / (bk*dk)
         axx = txk * t1
         axy = tyk * t1
         axz = dk / bk
         ayx = tyk / dk
         ayy = txk / dk
         azx = txk / bk
         azy = tyk / bk
         azz = tzk / bk
         do j = 1, io
            if (.not. omit(j)) then
               txj = xc(j)
               tyj = yc(j)
               tzj = zc(j)
c
c     rotate spheres so K vector colinear with z-axis
c
               uxj = txj*axx + tyj*axy - tzj*axz
               uyj = tyj*ayy - txj*ayx
               uzj = txj*azx + tyj*azy + tzj*azz
               cosine = min(1.0d0,max(-1.0d0,uzj/b(j)))
               if (acos(cosine) .lt. therk+ther(j)) then
                  dsqj = uxj*uxj + uyj*uyj
                  tb = uzj*gk - bg(j)
                  txb = uxj * tb
                  tyb = uyj * tb
                  td = rik * dsqj
                  tr2 = risqk*dsqj - tb*tb
                  tr2 = max(eps,tr2)
                  tr = sqrt(tr2)
                  txr = uxj * tr
                  tyr = uyj * tr
c
c     get T values of intersection for K circle
c
                  tb = (txb+tyr) / td
                  tb = min(1.0d0,max(-1.0d0,tb))
                  tk1 = acos(tb)
                  if (tyb-txr .lt. 0.0d0)  tk1 = pix2 - tk1
                  tb = (txb-tyr) / td
                  tb = min(1.0d0,max(-1.0d0,tb))
                  tk2 = acos(tb)
                  if (tyb+txr .lt. 0.0d0)  tk2 = pix2 - tk2
                  thec = (rrsq*uzj-gk*bg(j)) / (rik*ri(j)*b(j))
                  if (abs(thec) .lt. 1.0d0) then
                     the = -acos(thec)
                  else if (thec .ge. 1.0d0) then
                     the = 0.0d0
                  else if (thec .le. -1.0d0) then
                     the = -pi
                  end if
c
c     see if "tk1" is entry or exit point; check t=0 point;
c     "ti" is exit point, "tf" is entry point
c
                  cosine = min(1.0d0,max(-1.0d0,
     &                            (uzj*gk-uxj*rik)/(b(j)*rr)))
                  if ((acos(cosine)-ther(j))*(tk2-tk1) .le. 0.0d0) then
                     ti = tk2
                     tf = tk1
                  else
                     ti = tk2
                     tf = tk1
                  end if
                  narc = narc + 1
                  if (narc .ge. maxarc) then
                     write (iout,70)
   70                format (/,' SURFATOM1  --  Increase the Value',
     &                          ' of MAXARC')
                     call fatal
                  end if
                  if (tf .le. ti) then
                     arcf(narc) = tf
                     arci(narc) = 0.0d0
                     tf = pix2
                     lt(narc) = j
                     ex(narc) = the
                     top = .true.
                     narc = narc + 1
                  end if
                  arcf(narc) = tf
                  arci(narc) = ti
                  lt(narc) = j
                  ex(narc) = the
                  ux(j) = uxj
                  uy(j) = uyj
                  uz(j) = uzj
               end if
            end if
         end do
         omit(k) = .false.
c
c     special case; K circle without intersections
c
         if (narc .le. 0)  goto 90
c
c     general case; sum up arclength and set connectivity code
c
         call sort2 (narc,arci,key)
         arcsum = arci(1)
         mi = key(1)
         t = arcf(mi)
         ni = mi
         if (narc .gt. 1) then
            do j = 2, narc
               m = key(j)
               if (t .lt. arci(j)) then
                  arcsum = arcsum + arci(j) - t
                  exang = exang + ex(ni)
                  jb = jb + 1
                  if (jb .ge. maxarc) then
                     write (iout,80)
   80                format (/,' SURFATOM1  --  Increase the Value',
     &                          ' of MAXARC')
                     call fatal
                  end if
                  i = lt(ni)
                  ider(i) = ider(i) + 1
                  sign_yder(i) = sign_yder(i) + 1
                  kent(jb) = maxarc*i + k
                  i = lt(m)
                  ider(i) = ider(i) + 1
                  sign_yder(i) = sign_yder(i) - 1
                  kout(jb) = maxarc*k + i
               end if
               tt = arcf(m)
               if (tt .ge. t) then
                  t = tt
                  ni = m
               end if
            end do
         end if
         arcsum = arcsum + pix2 - t
         if (.not. top) then
            exang = exang + ex(ni)
            jb = jb + 1
            i = lt(ni)
            ider(i) = ider(i) + 1
            sign_yder(i) = sign_yder(i) + 1
            kent(jb) = maxarc*i + k
            i = lt(mi)
            ider(i) = ider(i) + 1
            sign_yder(i) = sign_yder(i) - 1
            kout(jb) = maxarc*k + i
         end if
c
c     calculate the surface area derivatives
c
         do j = 1, io
            if (ider(j) .ne. 0) then
               rcn = ider(j) * rrsq
               ider(j) = 0
               uzl = uz(j)
               gl = gr(j) * rr
               bgl = bg(j)
               bsql = bsq(j)
               risql = risq(j)
               wxlsq = bsql - uzl**2
               wxl = sqrt(wxlsq)
               p = bgl - gk*uzl
               v = risqk*wxlsq - p**2
               v = max(eps,v)
               v = sqrt(v)
               t1 = rr * (gk*(bgl-bsql)+uzl*(bgl-rrsq))
     &                          / (v*risql*bsql)
               deal = -wxl*t1
               decl = -uzl*t1 - rr/v
               dtkal = (wxlsq-p) / (wxl*v)
               dtkcl = (uzl-gk) / v
               s = gk*b(j) - gl*uzl
               t1 = 2.0d0*gk - uzl
               t2 = rrsq - bgl
               dtlal = -(risql*wxlsq*b(j)*t1
     &                      -s*(wxlsq*t2+risql*bsql))
     &                          / (risql*wxl*bsql*v)
               dtlcl = -(risql*b(j)*(uzl*t1-bgl)-uzl*t2*s)
     &                          / (risql*bsql*v)
               gaca = rcn * (deal-(gk*dtkal-gl*dtlal)/rr) / wxl
               gacb = (gk-uzl*gl/b(j)) * sign_yder(j) * rr / wxlsq
               sign_yder(j) = 0
               if (.not. moved) then
                  faca = ux(j)*gaca - uy(j)*gacb
                  facb = uy(j)*gaca + ux(j)*gacb
                  facc = rcn * (decl-(gk*dtkcl-gl*dtlcl)/rr)
                  dax = axx*faca - ayx*facb + azx*facc
                  day = axy*faca + ayy*facb + azy*facc
                  daz = azz*facc - axz*faca
                  in = intag(j)
                  darea(1,ir) = darea(1,ir) + dax
                  darea(2,ir) = darea(2,ir) + day
                  darea(3,ir) = darea(3,ir) + daz
                  darea(1,in) = darea(1,in) - dax
                  darea(2,in) = darea(2,in) - day
                  darea(3,in) = darea(3,in) - daz
               end if
            end if
         end do
         goto 100
   90    continue
         arcsum = pix2
         ib = ib + 1
  100    continue
         arclen = arclen + gr(k)*arcsum
         if (.not. moved) then
            in = intag(k)
            rin = radius(in)
            t1 = arcsum*rrsq*(bsqk-rrsq+rin*rin) / (rrx2*bsqk*bk)
            darea(1,ir) = darea(1,ir) - txk*t1
            darea(2,ir) = darea(2,ir) - tyk*t1
            darea(3,ir) = darea(3,ir) - tzk*t1
            darea(1,in) = darea(1,in) + txk*t1
            darea(2,in) = darea(2,in) + tyk*t1
            darea(3,in) = darea(3,in) + tzk*t1
         end if
  110    continue
      end do
      if (arclen .eq. 0.0d0)  goto 170
      if (jb .eq. 0)  goto 150
c
c     find number of independent boundaries and check connectivity
c
      j = 0
      do k = 1, jb
         if (kout(k) .ne. 0) then
            i = k
  120       continue
            m = kout(i)
            kout(i) = 0
            j = j + 1
            do ii = 1, jb
               if (m .eq. kent(ii)) then
                  if (ii .eq. k) then
                     ib = ib + 1
                     if (j .eq. jb)  goto 150
                     goto 130
                  end if
                  i = ii
                  goto 120
               end if
            end do
  130       continue
         end if
      end do
      ib = ib + 1
c
c     attempt to fix connectivity error by moving atom slightly
c
      if (moved) then
         write (iout,140)  ir
  140    format (/,' SURFATOM1  --  Connectivity Error at Atom',i6)
      else
         moved = .true.
         xr = xr + rmove
         yr = yr + rmove
         zr = zr + rmove
         goto 10
      end if
c
c     compute the exposed surface area for the sphere of interest
c
  150 continue
      area = ib*pix2 + exang + arclen
      area = mod(area,4.0d0*pi) * rrsq
c
c     attempt to fix negative area by moving atom slightly
c
      if (area .lt. 0.0d0) then
         if (moved) then
            write (iout,160)  ir
  160       format (/,' SURFATOM1  --  Negative Area at Atom',i6)
         else
            moved = .true.
            xr = xr + rmove
            yr = yr + rmove
            zr = zr + rmove
            goto 10
         end if
      end if
  170 continue
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine switch  --  get switching function coefficients  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "switch" sets the coeffcients used by the fifth and seventh
c     order polynomial switching functions for spherical cutoffs
c
c
      subroutine switch (mode)
      use limits
      use nonpol
      use shunt
      implicit none
      real*8 denom,term
      real*8 off3,off4,off5
      real*8 off6,off7
      real*8 cut3,cut4,cut5
      real*8 cut6,cut7
      character*6 mode
c
c
c     get the switching window for the current potential type
c
      if (mode(1:3) .eq. 'VDW') then
         off = vdwcut
         cut = vdwtaper
      else if (mode(1:6) .eq. 'REPULS') then
         off = repcut
         cut = reptaper
      else if (mode(1:4) .eq. 'DISP') then
         off = dispcut
         cut = disptaper
      else if (mode(1:6) .eq. 'CHARGE') then
         off = chgcut
         cut = chgtaper
      else if (mode(1:6) .eq. 'CHGDPL') then
         off = sqrt(chgcut*dplcut)
         cut = sqrt(chgtaper*dpltaper)
      else if (mode(1:6) .eq. 'DIPOLE') then
         off = dplcut
         cut = dpltaper
      else if (mode(1:5) .eq. 'MPOLE') then
         off = mpolecut
         cut = mpoletaper
      else if (mode(1:6) .eq. 'CHGTRN') then
         off = ctrncut
         cut = ctrntaper
      else if (mode(1:5) .eq. 'EWALD') then
         off = ewaldcut
         cut = ewaldcut
      else if (mode(1:6) .eq. 'DEWALD') then
         off = dewaldcut
         cut = dewaldcut
      else if (mode(1:6) .eq. 'USOLVE') then
         off = usolvcut
         cut = usolvcut
      else if (mode(1:3) .eq. 'GKV') then
         off = spoff
         cut = spcut
      else if (mode(1:4) .eq. 'GKSA') then
         off = stcut
         cut = stoff
      else
         off = min(vdwcut,repcut,dispcut,chgcut,
     &                dplcut,mpolecut,ctrncut)
         cut = min(vdwtaper,reptaper,disptaper,chgtaper,
     &                dpltaper,mpoletaper,ctrntaper)
      end if
c
c     test for replicate periodic boundaries at this cutoff
c
      call replica (off)
c
c     set switching coefficients to zero for truncation cutoffs
c
      c0 = 0.0d0
      c1 = 0.0d0
      c2 = 0.0d0
      c3 = 0.0d0
      c4 = 0.0d0
      c5 = 0.0d0
      f0 = 0.0d0
      f1 = 0.0d0
      f2 = 0.0d0
      f3 = 0.0d0
      f4 = 0.0d0
      f5 = 0.0d0
      f6 = 0.0d0
      f7 = 0.0d0
c
c     store the powers of the switching window cutoffs
c
      off2 = off * off
      off3 = off2 * off
      off4 = off2 * off2
      off5 = off2 * off3
      off6 = off3 * off3
      off7 = off3 * off4
      cut2 = cut * cut
      cut3 = cut2 * cut
      cut4 = cut2 * cut2
      cut5 = cut2 * cut3
      cut6 = cut3 * cut3
      cut7 = cut3 * cut4
c
c     get 5th degree multiplicative switching function coefficients
c
      if (cut .lt. off) then
         denom = (off-cut)**5
         c0 = off*off2 * (off2-5.0d0*off*cut+10.0d0*cut2) / denom
         c1 = -30.0d0 * off2*cut2 / denom
         c2 = 30.0d0 * (off2*cut+off*cut2) / denom
         c3 = -10.0d0 * (off2+4.0d0*off*cut+cut2) / denom
         c4 = 15.0d0 * (off+cut) / denom
         c5 = -6.0d0 / denom
      end if
c
c     get 7th degree additive switching function coefficients
c
      if (cut.lt.off .and. mode(1:6).eq.'CHARGE') then
         term = 9.3d0 * cut*off / (off-cut)
         denom = cut7 - 7.0d0*cut6*off + 21.0d0*cut5*off2
     &              - 35.0d0*cut4*off3 + 35.0d0*cut3*off4
     &              - 21.0d0*cut2*off5 + 7.0d0*cut*off6 - off7
         denom = term * denom
         f0 = cut3*off3 * (-39.0d0*cut+64.0d0*off) / denom
         f1 = cut2*off2
     &           * (117.0d0*cut2-100.0d0*cut*off-192.0d0*off2) / denom
         f2 = cut*off * (-117.0d0*cut3-84.0d0*cut2*off
     &                   +534.0d0*cut*off2+192.0d0*off3) / denom
         f3 = (39.0d0*cut4+212.0d0*cut3*off-450.0d0*cut2*off2
     &            -612.0d0*cut*off3-64.0d0*off4) / denom
         f4 = (-92.0d0*cut3+66.0d0*cut2*off
     &            +684.0d0*cut*off2+217.0d0*off3) / denom
         f5 = (42.0d0*cut2-300.0d0*cut*off-267.0d0*off2) / denom
         f6 = (36.0d0*cut+139.0d0*off) / denom
         f7 = -25.0d0 / denom
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module syntrn  --  synchronous transit path definition  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     tpath   value of the path coordinate (0=reactant, 1=product)
c     ppath   path coordinate for extra point in quadratic transit
c     xmin1   reactant coordinates as array of optimization variables
c     xmin2   product coordinates as array of optimization variables
c     xm      extra coordinate set for quadratic synchronous transit
c
c
      module syntrn
      implicit none
      real*8 tpath
      real*8 ppath
      real*8, allocatable :: xmin1(:)
      real*8, allocatable :: xmin2(:)
      real*8, allocatable :: xm(:)
      save
      end
c
c
c     ################################################################
c     ## COPYRIGHT (C) 2013 by Xiao Zhu, Pengyu Ren & Jay W. Ponder ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module tarray  --  store dipole-dipole matrix elements  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     ntpair     number of stored dipole-dipole matrix elements
c     tindex     index into stored dipole-dipole matrix values
c     tdipdip    stored dipole-dipole matrix element values
c
c
      module tarray
      implicit none
      integer ntpair
      integer, allocatable :: tindex(:,:)
      real*8, allocatable :: tdipdip(:,:)
      save
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 2018 by Zhi Wang and Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine induce0b  --  truncated CG dipole solver  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "induce0b" computes and stores the induced dipoles via
c     the truncated conjugate gradient (TCG) method
c
c
      subroutine induce0b
      use poltcg
      implicit none
c
c
c     choose the options for computation of TCG induced dipoles
c
      if (tcgguess) then
         call indtcgb
      else
         call indtcga
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine indtcga  --  TCG zero guess and preconditioner  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "indtcga" computes the induced dipoles and intermediates used
c     in polarization force calculation for the TCG method with dp
c     cross terms set true, initial guess of mu0 set to zero, and
c     using a diagonal preconditioner
c
c
      subroutine indtcga
      use atoms
      use limits
      use mpole
      use polar
      use poltcg
      use potent
      implicit none
      integer i,j,order
      real*8 n0,np0,g0
      real*8 n1,np1,g1,beta1
      real*8 n2,np2,g2,beta2
      real*8 n3,beta3
      real*8 a100,a101,a102
      real*8 a103,b111
      real*8, allocatable :: rsd(:,:,:)
      real*8, allocatable :: r0(:,:,:)
      real*8, allocatable :: p1(:,:,:)
      real*8, allocatable :: p2(:,:,:)
      real*8, allocatable :: p3(:,:,:)
      real*8, allocatable :: tp(:,:,:)
c
c
c     zero out the induced dipoles at each site
c
      do i = 1, n
         do j = 1, 3
            uind(j,i) = 0.0d0
            uinp(j,i) = 0.0d0
         end do
      end do
      if (.not. use_polar)  return
c
c     set up nab based on tcgorder value
c
      order = tcgorder
      call tcg_resource (order)
c
c     perform dynamic allocation for some global arrays
c
      if (.not. allocated(uad))  allocate (uad(3,n,tcgnab))
      if (.not. allocated(uap))  allocate (uap(3,n,tcgnab))
      if (.not. allocated(ubd))  allocate (ubd(3,n,tcgnab))
      if (.not. allocated(ubp))  allocate (ubp(3,n,tcgnab))
      uad = 0.0d0
      uap = 0.0d0
      ubd = 0.0d0
      ubp = 0.0d0
c
c     perform dynamic allocation for some local arrays
c
      allocate (rsd(3,n,2))
      allocate (r0(3,n,2))
      allocate (p1(3,n,2))
      allocate (p2(3,n,2))
      allocate (p3(3,n,2))
      allocate (tp(3,n,2))
c
c     get the electrostaic field due to permanent multipoles
c     because mu0 = 0, r0 = field - T.mu0 = field
c
      if (use_ewald) then
         call dfield0c (r0(:,:,1),r0(:,:,2))
      else if (use_mlist) then
         call dfield0b (r0(:,:,1),r0(:,:,2))
      else
         call dfield0a (r0(:,:,1),r0(:,:,2))
      end if
c
c     udir = alpha.E = alpha.r0
c
      call tcg_alpha22 (r0(:,:,1),r0(:,:,2),udir,udirp)
c
c     compute the following tcg1 intermediates:
c     p0 = alpha*r0 = udir, n0 = r0*a*r0, and np0 = p0*T*p0
c
      call tcg_alphaquad (n0,r0(:,:,1),r0(:,:,2))
      call tcg_t0 (udir,udirp,tp(:,:,1),tp(:,:,2))
      call tcg_dotprod (np0,3*npole,tp(:,:,1),udirp)
      g0 = 0.0d0
      if (np0 .ne. 0.0d0)  g0 = n0 / np0
c
c     set r1 = r0 - gamma0*T*p0, n1 = r1*a*r1, and p1 <- r1, p0
c
      rsd = r0 - g0 * tp
      call tcg_alphaquad (n1,rsd(:,:,1),rsd(:,:,2))
      beta1 = 0.0d0
      if (n0 .ne. 0.0d0)  beta1 = n1 / n0
      p1(:,:,1) = udir
      p1(:,:,2) = udirp
      call tcg_update (p1(:,:,1),rsd(:,:,1),beta1)
      call tcg_update (p1(:,:,2),rsd(:,:,2),beta1)
c
c     set ua(1) = mu1 = g0 * p0, ub(1) <- p0, and xde <- p0, p1
c
      uad(:,:,1) = g0*udir
      uap(:,:,1) = g0*udirp
      ubd(:,:,1) = ubd(:,:,1) + 0.5d0*g0*udir
      ubp(:,:,1) = ubp(:,:,1) + 0.5d0*g0*udirp
      uind = uind + g0*(1.0d0-beta1)*udir + g0*p1(:,:,1)
      uinp = uinp + g0*(1.0d0-beta1)*udirp + g0*p1(:,:,2)
c
c     the tcg1 energy and force are finished
c
      if (order .eq. 1)  goto 10
c
c     np1 = p1*T*p1
c     g1 = n1 / np1
c     r2 = r1 - g1 * T*p1
c     n2 = r2*a*r2
c     beta2 = n2 / n1
c
      call tcg_t0 (p1(:,:,1),p1(:,:,2),tp(:,:,1),tp(:,:,2))
      call tcg_dotprod (np1,3*npole,tp(:,:,1),p1(:,:,2))
      g1 = 0.0d0
      if (np1 .ne. 0.0d0)  g1 = n1 / np1
      rsd = rsd - g1 * tp
      call tcg_alphaquad (n2,rsd(:,:,1),rsd(:,:,2))
      beta2 = 0.0d0
      if (n1 .ne. 0.0d0)  beta2 = n2 / n1
c
c     p2 <- r2, p1
c     np2 = p2*T*p2
c     g2 = n2 / np2
c
      p2 = p1
      call tcg_update (p2(:,:,1),rsd(:,:,1),beta2)
      call tcg_update (p2(:,:,2),rsd(:,:,2),beta2)
      call tcg_t0 (p2(:,:,1),p2(:,:,2),tp(:,:,1),tp(:,:,2))
      call tcg_dotprod (np2,3*npole,tp(:,:,1),p2(:,:,2))
      g2 = 0.0d0
      if (np2 .ne. 0.0d0)  g2 = n2 / np2
c
c     r3 = r2 - g2 * T*p2
c     n3 = r3*a*r3
c     beta3 = n3 / n2
c
      rsd = rsd - g2*tp
      call tcg_alphaquad (n3,rsd(:,:,1),rsd(:,:,2))
      beta3 = 0.0d0
      if (n2 .ne. 0.0d0)  beta3 = n3 / n2
c
c     p3 <- r3, p2
c
      p3 = p2
      call tcg_update (p3(:,:,1),rsd(:,:,1),beta3)
      call tcg_update (p3(:,:,2),rsd(:,:,2),beta3)
c
c     ua(2) = mu2 = g1 * p1
c     ub(1) <- p1, p2
c     ub(2) <- p1
c     xde <- p0, p1
c
      b111 = (1.0d0-beta2) * g1
      a103 = 0.0d0
      if (g2 .ne. 0.0d0)  a103 = g0 * g1 / g2
      a102 = (1.0d0-beta2)*g0 + (1.0d0+beta1)*g1 - (1.0d0+beta3)*a103
      a101 = (beta2**2-1.0d0)*g0 + (1.0d0-beta2-beta1*beta2)*g1
     &          + beta2*a103
      a100 = (1.0d0-beta2) * g0 * beta1
      uad(:,:,2) = g1*p1(:,:,1)
      uap(:,:,2) = g1*p1(:,:,2)
      ubd(:,:,1) = ubd(:,:,1) + b111*p1(:,:,1) + g1*p2(:,:,1)
      ubp(:,:,1) = ubp(:,:,1) + b111*p1(:,:,2) + g1*p2(:,:,2)
      ubd(:,:,2) = ubd(:,:,2) + 0.5d0*g1*p1(:,:,1)
      ubp(:,:,2) = ubp(:,:,2) + 0.5d0*g1*p1(:,:,2)
      uind = uind + a103*p3(:,:,1) + a102*p2(:,:,1) + a101*p1(:,:,1)
     &          + a100*udir
      uinp = uinp + a103*p3(:,:,2) + a102*p2(:,:,2) + a101*p1(:,:,2)
     &          + a100*udirp
c
c     perform deallocation for some local arrays
c
   10 continue
      deallocate (rsd)
      deallocate (r0)
      deallocate (p1)
      deallocate (p2)
      deallocate (p3)
      deallocate (tp)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine indtcgb  --  TCG direct guess and precondition  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "indtcgb" computes the induced dipoles and intermediates used
c     in polarization force calculation for the TCG method with dp
c     cross terms set true, initial guess of mu0=direct, and using
c     a diagonal preconditioner
c
c
      subroutine indtcgb
      use atoms
      use limits
      use mpole
      use polar
      use poltcg
      use potent
      implicit none
      integer i,j,order
      real*8 chi,xi0,xi1
      real*8 n0,np0,g0
      real*8 n1,np1,g1,beta1
      real*8 n2,np2,g2,beta2
      real*8 n3,beta3
      real*8 a100,a101,a102
      real*8 a103,b111
      real*8 c100,c101,c102
      real*8 c200,c201,c202
      real*8 c203,c204
      real*8 d111,d210,d211
      real*8 d212,d213,d222
      real*8, allocatable :: xdr0(:,:,:)
      real*8, allocatable :: rsd(:,:,:)
      real*8, allocatable :: p0(:,:,:)
      real*8, allocatable :: p1(:,:,:)
      real*8, allocatable :: p2(:,:,:)
      real*8, allocatable :: p3(:,:,:)
      real*8, allocatable :: tp(:,:,:)
c
c
c     zero out the induced dipoles at each site
c
      do i = 1, n
         do j = 1, 3
            uind(j,i) = 0.0d0
            uinp(j,i) = 0.0d0
         end do
      end do
      if (.not. use_polar)  return
c
c     set up nab based on tcgorder value
c
      order = tcgorder
      call tcg_resource (order)
c
c     perform dynamic allocation for some global arrays
c
      if (.not. allocated(uad))  allocate (uad(3,n,tcgnab))
      if (.not. allocated(uap))  allocate (uap(3,n,tcgnab))
      if (.not. allocated(ubd))  allocate (ubd(3,n,tcgnab))
      if (.not. allocated(ubp))  allocate (ubp(3,n,tcgnab))
      uad = 0.0d0
      uap = 0.0d0
      ubd = 0.0d0
      ubp = 0.0d0
c
c     perform dynamic allocation for some local arrays
c
      allocate (xdr0(3,n,2))
      allocate (rsd(3,n,2))
      allocate (p0(3,n,2))
      allocate (p1(3,n,2))
      allocate (p2(3,n,2))
      allocate (p3(3,n,2))
      allocate (tp(3,n,2))
      xdr0 = 0.0d0
c
c     chi = omega - 1
c
      chi = tcgpeek - 1.0d0
c
c     get the electrostatic field due to permanent multipoles
c     and mu0 = alpha*E; use tp to store the multipole field
c
      if (use_ewald) then
         call dfield0c (tp(:,:,1),tp(:,:,2))
      else if (use_mlist) then
         call dfield0b (tp(:,:,1),tp(:,:,2))
      else
         call dfield0a (tp(:,:,1),tp(:,:,2))
      end if
      call tcg_alpha22 (tp(:,:,1),tp(:,:,2),udir,udirp)
c
c     compute the following tcg1 intermediates:
c     r0 = -Tu*mu0
c     n0 = r0*a*r0
c     p0 = a*r0
c     xi0
c     np0 = p0*T*p0
c     g0
c
      call tcg_ufield (udir,udirp,rsd(:,:,1),rsd(:,:,2))
      call tcg_alphaquad (n0,rsd(:,:,1),rsd(:,:,2))
      call tcg_alpha22 (rsd(:,:,1),rsd(:,:,2),p0(:,:,1),p0(:,:,2))
      call tcg_dotprod (xi0,3*npole,rsd(:,:,1),udirp)
      xi0 = 0.0d0
      if (n0 .ne. 0.0d0)  xi0 = xi0 / n0
      call tcg_t0 (p0(:,:,1),p0(:,:,2),tp(:,:,1),tp(:,:,2))
      call tcg_dotprod (np0,3*npole,tp(:,:,1),p0(:,:,2))
      g0 = 0.0d0
      if (np0 .ne. 0.0d0)  g0 = n0 / np0
c
c     set r1 = r0 - g0*T*p0, n1 and beta1
c
      rsd = rsd - g0*tp
      call tcg_alphaquad (n1,rsd(:,:,1),rsd(:,:,2))
      beta1 = 0.0d0
      if (n0 .ne. 0.0d0)  beta1 = n1 / n0
c
c     set p1 <- r1, p0
c
      p1 = p0
      call tcg_update (p1(:,:,1),rsd(:,:,1),beta1)
      call tcg_update (p1(:,:,2),rsd(:,:,2),beta1)
c
c     compute "Residual Mutual 1"
c     ua(1) <- mu0
c     ua(2) <- mu1 = g0 * p0
c     ub(2) <- p0
c     xdr0 <- p0, p1
c
      uad(:,:,1) = udir
      uap(:,:,1) = udirp
      ubd(:,:,1) = ubd(:,:,1) + 0.5d0*udir
      ubp(:,:,1) = ubp(:,:,1) + 0.5d0*udirp
      uad(:,:,2) = g0*p0(:,:,1)
      uap(:,:,2) = g0*p0(:,:,2)
      ubd(:,:,2) = ubd(:,:,2) + 0.5d0*g0*p0(:,:,1)
      ubp(:,:,2) = ubp(:,:,2) + 0.5d0*g0*p0(:,:,2)
      xdr0 = xdr0 + g0*(1.0d0-beta1)*p0 + g0*p1
c
c     get the tcg1 energy and force; tp array works as xde array
c
      if (order .eq. 1) then
         c100 = 0.5d0*(1.0d0-g0)
         c101 = (0.5d0 - beta1*(1.0d0-xi0))*g0
         c102 = g0*(1.0d0-xi0)
         d111 = 0.5d0*(1.0d0-xi0)*g0
         xdr0(:,:,1) = xdr0(:,:,1) + chi*(c100*udir
     &                  + c101*p0(:,:,1) + c102*p1(:,:,1))
         xdr0(:,:,2) = xdr0(:,:,2) + chi*(c100*udirp
     &                  + c101*p0(:,:,2) + c102*p1(:,:,2))
         ubd(:,:,1) = ubd(:,:,1) + xdr0(:,:,1)
         ubp(:,:,1) = ubp(:,:,1) + xdr0(:,:,2)
         ubd(:,:,2) = ubd(:,:,2) + chi*(d111*p0(:,:,1)+0.5d0*udir)
         ubp(:,:,2) = ubp(:,:,2) + chi*(d111*p0(:,:,2)+0.5d0*udirp)
         call tcg_ufield (xdr0(:,:,1),xdr0(:,:,2),tp(:,:,1),tp(:,:,2))
         call tcg_alpha12 (tp(:,:,1),tp(:,:,2))
         tp(:,:,1) = tp(:,:,1) + chi*0.5d0*p1(:,:,1)
     &                  + (1.0d0-chi*beta1*0.5d0)*p0(:,:,1) + udir
         tp(:,:,2) = tp(:,:,2) + chi*0.5d0*p1(:,:,2)
     &                  + (1.0d0-chi*beta1*0.5d0)*p0(:,:,2) + udirp
         goto 10
      end if
c
c     compute the tcg2 intermediates: xi1, np1 and g1
c
      call tcg_dotprod (xi1,3*npole,rsd(:,:,1),udirp)
      if (n1 .ne. 0.0d0)  xi1 = xi1 / n1
      xi1 = xi1 + xi0
      call tcg_t0 (p1(:,:,1),p1(:,:,2),tp(:,:,1),tp(:,:,2))
      call tcg_dotprod (np1,3*npole,tp(:,:,1),p1(:,:,2))
      g1 = 0.0d0
      if (np1 .ne. 0.0d0)  g1 = n1 / np1
c
c     r2 = r1 - g1*T*p1
c     n2, beta2
c     p2 <- r2, p1
c     np2, g2
c
      rsd = rsd - g1*tp
      call tcg_alphaquad (n2,rsd(:,:,1),rsd(:,:,2))
      beta2 = 0.0d0
      if (n1 .ne. 0.0d0)  beta2 = n2 / n1
      p2 = p1
      call tcg_update (p2(:,:,1),rsd(:,:,1),beta2)
      call tcg_update (p2(:,:,2),rsd(:,:,2),beta2)
      call tcg_t0 (p2(:,:,1),p2(:,:,2),tp(:,:,1),tp(:,:,2))
      call tcg_dotprod (np2,3*npole,tp(:,:,1),p2(:,:,2))
      g2 = 0.0d0
      if (np2 .ne. 0.0d0)  g2 = n2 / np2
c
c     r3 = r2 - g2*T*p2
c     n3, beta3
c     p3 <- r3, p2
c
      rsd = rsd - g2*tp
      call tcg_alphaquad (n3,rsd(:,:,1),rsd(:,:,2))
      beta3 = 0.0d0
      if (n2 .ne. 0.0d0)  beta3 = n3 / n2
      p3 = p2
      call tcg_update (p3(:,:,1),rsd(:,:,1),beta3)
      call tcg_update (p3(:,:,2),rsd(:,:,2),beta3)
c
c     compute "Residual Mutual 2"
c     ub(2) <- p1, p2
c     ua(3) <- mu2 = g1 * p1
c     ub(3) <- p1
c     xdr0 <- p0, p1, p2, p3
c
      b111 = (1.0d0-beta2) * g1
      a103 = 0.0d0
      if (g2 .ne. 0.0d0)  a103 = g0 * g1 / g2
      a102 = (1.0d0-beta2)*g0 + (1.0d0+beta1)*g1 - (1.0d0+beta3)*a103
      a101 = (beta2**2-1.0d0)*g0 + (1.0d0-beta2-beta1*beta2)*g1
     &          + beta2*a103
      a100 = (1.0d0-beta2) * g0 * beta1
      ubd(:,:,2) = ubd(:,:,2)+ b111*p1(:,:,1) + g1*p2(:,:,1)
      ubp(:,:,2) = ubp(:,:,2)+ b111*p1(:,:,2) + g1*p2(:,:,2)
      uad(:,:,3) = g1*p1(:,:,1)
      uap(:,:,3) = g1*p1(:,:,2)
      ubd(:,:,3) = ubd(:,:,3) + 0.5d0*g1*p1(:,:,1)
      ubp(:,:,3) = ubp(:,:,3) + 0.5d0*g1*p1(:,:,2)
      xdr0 = xdr0 + a100*p0 + a101*p1 + a102*p2 + a103*p3
c
c     get the tcg2 energy and force; tp array works as xde array
c
      if (order .eq. 2) then
         c200 = 0.5d0*((1.0d0-g0)*(1.0d0-g1)-beta1*g1)
         c201 = 0.5d0*(1.0d0-g1)*g0 + (xi0-xi1)*g1*beta1**2
     &             + (xi1-1.0d0)*beta1*beta2*g0
     &             + (xi0+g0-xi0*g0)*beta1*g1
         c202 = 0.0d0
         c203 = 0.0d0
         c204 = 0.0d0
         if (g2 .ne. 0.0d0) then
            c202 = 0.5d0*g1 + (1.0d0-xi1)*beta2*g0*g1/g2
     &                + (1.0d0-xi1)*(beta2*g0-(1.0d0+beta1)*g1)*beta2
     &                + (xi0*g0-xi0-g0)*g1
     &                + (beta2*g0-beta1*g1)*(xi0-xi1)
            c203 = (xi1-1.0d0)*(1.0d0+beta3)*g0*g1/g2
     &                + (g1+beta1*g1-beta2*g0)*(1.0d0-xi1)
     &                + (1.0d0-xi0)*g0
            c204 = (1.0d0-xi1) * g0 * g1 / g2
         end if
         d210 = 0.5d0 * (1.0d0-g1)
         d211 = 0.5d0 * (1.0d0-xi0)*(1.0d0-g1)*g0
         d212 = ((1.0d0-xi0)-(1.0d0-xi1)*beta2) * g1
         d213 = (1.0d0-xi1) * g1
         d222 = 0.5d0 * d213
         xdr0(:,:,1) = xdr0(:,:,1) + chi*(c204*p3(:,:,1)
     &                    + c203*p2(:,:,1) + c202*p1(:,:,1)
     &                    + c201*p0(:,:,1) + c200*udir)
         xdr0(:,:,2) = xdr0(:,:,2) + chi*(c204*p3(:,:,2)
     &                    + c203*p2(:,:,2) + c202*p1(:,:,2)
     &                    + c201*p0(:,:,2) + c200*udirp)
         ubd(:,:,1) = ubd(:,:,1) + xdr0(:,:,1)
         ubp(:,:,1) = ubp(:,:,1) + xdr0(:,:,2)
         ubd(:,:,2) = ubd(:,:,2) + chi*(d213*p2(:,:,1) + d212*p1(:,:,1)
     &                   + d211*p0(:,:,1) + d210*udir)
         ubp(:,:,2) = ubp(:,:,2) + chi*(d213*p2(:,:,2) + d212*p1(:,:,2)
     &                   + d211*p0(:,:,2) + d210*udirp)
         ubd(:,:,3) = ubd(:,:,3) + chi*(d222*p1(:,:,1) + 0.5d0*udir)
         ubp(:,:,3) = ubp(:,:,3) + chi*(d222*p1(:,:,2) + 0.5d0*udirp)
         call tcg_ufield (xdr0(:,:,1),xdr0(:,:,2),tp(:,:,1),tp(:,:,2))
         call tcg_alpha12 (tp(:,:,1),tp(:,:,2))
         tp(:,:,1) = tp(:,:,1) + p0(:,:,1) + udir
     &                  + chi*0.5d0*(p2(:,:,1)-beta2*p1(:,:,1))
         tp(:,:,2) = tp(:,:,2) + p0(:,:,2) + udirp
     &                  + chi*0.5d0*(p2(:,:,2)-beta2*p1(:,:,2))
         goto 10
      end if
c
c     store induced dipoles from elements of the xde arrays
c
   10 continue
      uind = tp(:,:,1)
      uinp = tp(:,:,2)
c
c     perform deallocation for some local arrays
c
      deallocate (xdr0)
      deallocate (rsd)
      deallocate (p0)
      deallocate (p1)
      deallocate (p2)
      deallocate (p3)
      deallocate (tp)
      return
      end
c
c
c     ################################
c     ##                            ##
c     ##  subroutine tcg_alphaquad  ##
c     ##                            ##
c     ################################
c
c
c     "tcg_alphaquad" computes the quadratic form, <a*alpha*b>,
c     where alpha is the diagonal atomic polarizability matrix
c
c
      subroutine tcg_alphaquad (sum,a,b)
      use mpole
      use polar
      implicit none
      integer i,j,k
      real*8 sum
      real*8 a(3,*)
      real*8 b(3,*)
c
c
      sum = 0.0d0
!$OMP PARALLEL default(shared) private(i,j,k)
!$OMP DO reduction(+:sum)
      do i = 1, npole
         k = ipole(i)
         do j = 1, 3
            sum = sum + a(j,k)*b(j,k)*polarity(k)
         end do
      end do
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ###############################
c     ##                           ##
c     ##  subroutine tcg_resource  ##
c     ##                           ##
c     ###############################
c
c
c     "tcg_resource" sets the number of mutual induced dipole
c     pairs based on the passed argument
c
c
      subroutine tcg_resource (order)
      use iounit
      use poltcg
      implicit none
      integer order
c
c
      if (order.lt.1 .or. order.gt.2) then
         write (iout,10)
   10    format (/,' TCG_RESOURCE -- Argument ORDER Is Out of Range')
         call fatal
      end if
      tcgnab = order
      if (tcgguess)  tcgnab = tcgnab + 1
      return
      end
c
c
c     ##############################
c     ##                          ##
c     ##  subroutine tcg_alpha12  ##
c     ##                          ##
c     ##############################
c
c
c     "tcg_alpha12" computes source1 = alpha*source1 and
c     source2 = alpha*source2
c
c
      subroutine tcg_alpha12 (source1,source2)
      use mpole
      use polar
      implicit none
      integer i,j,k
      real*8 source1(3,*)
      real*8 source2(3,*)
c
c
!$OMP PARALLEL default(shared) private(i,j,k)
!$OMP DO
      do i = 1, npole
         k = ipole(i)
         do j = 1, 3
            source1(j,k) = polarity(k) * source1(j,k)
            source2(j,k) = polarity(k) * source2(j,k)
         end do
      end do
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##############################
c     ##                          ##
c     ##  subroutine tcg_alpha22  ##
c     ##                          ##
c     ##############################
c
c
c     "tcg_alpha22" computes result1 = alpha*source1 and
c     result2 = alpha*source2
c
c
      subroutine tcg_alpha22 (source1,source2,result1,result2)
      use mpole
      use polar
      implicit none
      integer i,j,k
      real*8 source1(3,*)
      real*8 source2(3,*)
      real*8 result1(3,*)
      real*8 result2(3,*)
c
c
!$OMP PARALLEL default(shared) private(i,j,k)
!$OMP DO
      do i = 1, npole
         k = ipole(i)
         do j = 1, 3
            result1(j,k) = polarity(k) * source1(j,k)
            result2(j,k) = polarity(k) * source2(j,k)
         end do
      end do
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##############################
c     ##                          ##
c     ##  subroutine tcg_dotprod  ##
c     ##                          ##
c     ##############################
c
c
c     "tcg_dotprod" computes the dot product of two vectors
c     of length n elements
c
c
      subroutine tcg_dotprod (sum,n,a,b)
      implicit none
      integer i,n
      real*8 sum
      real*8 a(*)
      real*8 b(*)
c
c
c     find value of the scalar dot product
c
      sum = 0.0d0
!$OMP PARALLEL default(shared) private(i)
!$OMP DO reduction(+:sum)
      do i = 1, n
         sum = sum + a(i)*b(i)
      end do
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #############################
c     ##                         ##
c     ##  subroutine tcg_ufield  ##
c     ##                         ##
c     #############################
c
c
c     "tcg_ufield" applies -Tu to ind/p and returns v3d/p
c
c
      subroutine tcg_ufield (ind,inp,v3d,v3p)
      use limits
      use mpole
      use polar
      implicit none
      real*8 ind(3,*)
      real*8 inp(3,*)
      real*8 v3d(3,*)
      real*8 v3p(3,*)
c
c
c     swap TCG components with induced dipoles
c
      call tcgswap (uind,uinp,ind,inp)
c
c     compute mutual field
c
      if (use_ewald) then
         call ufield0c (v3d,v3p)
      else if (use_mlist) then
         call ufield0b (v3d,v3p)
      else
         call ufield0a (v3d,v3p)
      end if
c
c     swap TCG components with induced dipoles
c
      call tcgswap (uind,uinp,ind,inp)
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine tcg_t0  ##
c     ##                     ##
c     #########################
c
c
c     "tcg_t0" applies T matrix to ind/p, and returns v3d/p
c     T = 1/alpha + Tu
c
c
      subroutine tcg_t0 (ind,inp,v3d,v3p)
      use limits
      use mpole
      use polar
      implicit none
      integer i,j,k
      real*8 polk,polmin
      real*8 ind(3,*)
      real*8 inp(3,*)
      real*8 v3d(3,*)
      real*8 v3p(3,*)
c
c
c     apply -Tu to ind/p
c
      call tcg_ufield (ind,inp,v3d,v3p)
c
c     compute the 1/alpha contribution
c
      polmin = 0.00000001d0
!$OMP PARALLEL default(shared) private(i,j,k,polk)
!$OMP DO
      do i = 1, npole
         k = ipole(i)
         if (douind(k)) then
            polk = max(polmin,polarity(k))
            do j = 1, 3
               v3d(j,k) = ind(j,k)/polk - v3d(j,k)
               v3p(j,k) = inp(j,k)/polk - v3p(j,k)
            end do
         end if
      end do
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine tcgswap  --  swap induced dipoles for TCG use  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "tcgswap" switches two sets of induced dipole quantities for
c     use with the TCG induced dipole solver
c
c
      subroutine tcgswap (uind1,uinp1,uind2,uinp2)
      use mpole
      implicit none
      integer i,j,k
      real*8 dterm,pterm
      real*8 uind1(3,*)
      real*8 uinp1(3,*)
      real*8 uind2(3,*)
      real*8 uinp2(3,*)
c
c
c     swap sets of induced dipoles for use with the TCG method
c
!$OMP PARALLEL default(shared) private(i,j,k,dterm,pterm)
!$OMP DO
      do i = 1, npole
         k = ipole(i)
         do j = 1, 3
            dterm = uind1(j,k)
            pterm = uinp1(j,k)
            uind1(j,k) = uind2(j,k)
            uinp1(j,k) = uinp2(j,k)
            uind2(j,k) = dterm
            uinp2(j,k) = pterm
         end do
      end do
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine tcg_update  --  get an updated TCG p-vector  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "tcg_update" computes pvec = alpha*rvec + beta*pvec;
c     if the preconditioner is not used, then alpha = identity
c
c
      subroutine tcg_update (pvec,rvec,beta)
      use mpole
      use polar
      use poltcg
      implicit none
      integer i,j,k
      real*8 beta,alpha
      real*8 pvec(3,*)
      real*8 rvec(3,*)
c
c
c     computes an updated pvec from prior intermediates
c
!$OMP PARALLEL default(shared) private(i,j,k,alpha)
!$OMP DO
      do i = 1, npole
         k = ipole(i)
         alpha = polarity(k)
         do j = 1, 3
            pvec(j,k) = alpha*rvec(j,k) + beta*pvec(j,k)
         end do
      end do
!$OMP END DO
!$OMP END PARALLEL
      return
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 2003 by Alan Grossfield & Jay W. Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine temper  --  thermostat applied at full-step  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "temper" computes the instantaneous temperature and applies a
c     thermostat via Berendsen scaling, Bussi stochastic velocity
c     rescaling, Andersen stochastic collisions or Nose-Hoover chains
c
c     literature references:
c
c     H. J. C. Berendsen, J. P. M. Postma, W. F. van Gunsteren,
c     A. DiNola and J. R. Hauk, "Molecular Dynamics with Coupling
c     to an External Bath", Journal of Chemical Physics, 81,
c     3684-3690 (1984)
c
c     G. Bussi and M. Parrinello, "Stochastic Thermostats: Comparison
c     of Local and Global Schemes", Computer Physics Communications,
c     179, 26-29 (2008)
c
c     H. C. Andersen, "Molecular Dynamics Simulations at Constant
c     Pressure and/or Temperature", Journal of Chemical Physics,
c     72, 2384-2393 (1980)
c
c     G. J. Martyna, M. L. Klein and M. Tuckerman, "Nose-Hoover
c     Chains: The Canonical Ensembele via Continuous Dynamics",
c     Journal of Chemical Physics, 97, 2635-2643 (1992)
c
c
      subroutine temper (dt,eksum,ekin,temp)
      use atomid
      use atoms
      use bath
      use group
      use mdstuf
      use molcul
      use moldyn
      use rgddyn
      use units
      use usage
      implicit none
      integer i,j,k,m
      integer nc,ns
      real*8 dt,dtc,dts
      real*8 dt2,dt4,dt8
      real*8 eksum,ekt
      real*8 scale,speed
      real*8 c,d,r,s,si
      real*8 random,normal
      real*8 kt,rate,trial
      real*8 temp,expterm
      real*8 w(3)
      real*8 ekin(3,3)
      external random,normal
c
c
c     get the kinetic energy and instantaneous temperature
c
      call kinetic (eksum,ekin,temp)
      if (.not. isothermal)  return
c
c     couple to external temperature bath via Berendsen scaling
c
      if (thermostat .eq. 'BERENDSEN') then
         scale = 1.0d0
         if (temp .ne. 0.0d0)
     &      scale = sqrt(1.0d0 + (dt/tautemp)*(kelvin/temp-1.0d0))
         if (integrate .eq. 'RIGIDBODY') then
            do i = 1, ngrp
               do j = 1, 3
                  vcm(j,i) = scale * vcm(j,i)
                  wcm(j,i) = scale * wcm(j,i)
               end do
            end do
         else
            do i = 1, nuse
               k = iuse(i)
               do j = 1, 3
                  v(j,k) = scale * v(j,k)
               end do
            end do
         end if
c
c     couple to external temperature bath via Bussi scaling
c
      else if (thermostat .eq. 'BUSSI') then
         if (temp .eq. 0.0d0)  temp = 0.1d0
         c = exp(-dt/tautemp)
         d = (1.0d0-c) * (kelvin/temp) / dble(nfree)
         r = normal ()
         s = 0.0d0
         do i = 1, nfree-1
            si = normal ()
            s = s + si*si
         end do
         scale = c + (s+r*r)*d + 2.0d0*r*sqrt(c*d)
         scale = sqrt(scale)
         if (r+sqrt(c/d) .lt. 0.0d0)  scale = -scale
         if (integrate .eq. 'RIGIDBODY') then
            do i = 1, ngrp
               do j = 1, 3
                  vcm(j,i) = scale * vcm(j,i)
                  wcm(j,i) = scale * wcm(j,i)
               end do
            end do
         else
            do i = 1, nuse
               k = iuse(i)
               do j = 1, 3
                  v(j,k) = scale * v(j,k)
               end do
            end do
         end if
c
c     select random velocities via Andersen stochastic collisions
c
      else if (thermostat .eq. 'ANDERSEN') then
         kt = boltzmann * kelvin
         rate = 1000.0d0 * dt * collide
         if (integrate .eq. 'RIGIDBODY') then
            rate = rate / dble(ngrp)**(2.0d0/3.0d0)
            do i = 1, ngrp
               trial = random ()
               if (trial .lt. rate) then
                  speed = sqrt(kt/grpmass(i))
                  do j = 1, 3
                     vcm(j,i) = speed * normal ()
                  end do
               end if
            end do
         else if (barostat.eq.'MONTECARLO' .and.
     &            volscale.eq.'MOLECULAR') then
            rate = rate / dble(nmol)**(2.0d0/3.0d0)
            do i = 1, nmol
               trial = random ()
               if (trial .lt. rate) then
                  do j = imol(1,i), imol(2,i)
                     k = kmol(j)
                     speed = sqrt(kt/mass(k))
                     do m = 1, 3
                        v(m,k) = speed * normal ()
                     end do
                  end do
               end if
            end do
         else
            rate = rate / dble(nuse)**(2.0d0/3.0d0)
            do i = 1, nuse
               k = iuse(i)
               trial = random ()
               if (trial .lt. rate) then
                  speed = sqrt(kt/mass(k))
                  do j = 1, 3
                     v(j,k) = speed * normal ()
                  end do
               end if
            end do
         end if
c
c     make full-step velocity correction for Nose-Hoover system
c
      else if (thermostat .eq. 'NOSE-HOOVER') then
         ekt = gasconst * kelvin
         nc = 5
         ns = 3
         dtc = dt / dble(nc)
         w(1) = 1.0d0 / (2.0d0-2.0d0**(1.0d0/3.0d0))
         w(2) = 1.0d0 - 2.0d0*w(1)
         w(3) = w(1)
         scale = 1.0d0
         do i = 1, nc
            do j = 1, ns
               dts = w(j) * dtc
               dt2 = 0.5d0 * dts
               dt4 = 0.25d0 * dts
               dt8 = 0.125d0 * dts
               gnh(4) = (qnh(3)*vnh(3)*vnh(3)-ekt) / qnh(4)
               vnh(4) = vnh(4) + gnh(4)*dt4
               gnh(3) = (qnh(2)*vnh(2)*vnh(2)-ekt) / qnh(3)
               expterm = exp(-vnh(4)*dt8)
               vnh(3) = expterm * (vnh(3)*expterm+gnh(3)*dt4)
               gnh(2) = (qnh(1)*vnh(1)*vnh(1)-ekt) / qnh(2)
               expterm = exp(-vnh(3)*dt8)
               vnh(2) = expterm * (vnh(2)*expterm+gnh(2)*dt4)
               gnh(1) = (2.0d0*eksum-dble(nfree)*ekt) / qnh(1)
               expterm = exp(-vnh(2)*dt8)
               vnh(1) = expterm * (vnh(1)*expterm+gnh(1)*dt4)
               expterm = exp(-vnh(1)*dt2)
               scale = scale * expterm
               eksum = eksum * expterm * expterm
               gnh(1) = (2.0d0*eksum-dble(nfree)*ekt) / qnh(1)
               expterm = exp(-vnh(2)*dt8)
               vnh(1) = expterm * (vnh(1)*expterm+gnh(1)*dt4)
               gnh(2) = (qnh(1)*vnh(1)*vnh(1)-ekt) / qnh(2)
               expterm = exp(-vnh(3)*dt8)
               vnh(2) = expterm * (vnh(2)*expterm+gnh(2)*dt4)
               gnh(3) = (qnh(2)*vnh(2)*vnh(2)-ekt) / qnh(3)
               expterm = exp(-vnh(4)*dt8)
               vnh(3) = expterm * (vnh(3)*expterm+gnh(3)*dt4)
               gnh(4) = (qnh(3)*vnh(3)*vnh(3)-ekt) / qnh(4)
               vnh(4) = vnh(4) + gnh(4)*dt4
            end do
         end do
         if (integrate .eq. 'RIGIDBODY') then
            do i = 1, ngrp
               do j = 1, 3
                  vcm(j,i) = scale * vcm(j,i)
                  wcm(j,i) = scale * wcm(j,i)
               end do
            end do
         else
            do i = 1, nuse
               k = iuse(i)
               do j = 1, 3
                  v(j,k) = scale * v(j,k)
               end do
            end do
         end if
      end if
c
c     recompute kinetic energy and instantaneous temperature
c
      call kinetic (eksum,ekin,temp)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine temper2  --  thermostat applied at half-step  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "temper2" applies a velocity correction at the half time step
c     as needed for the Nose-Hoover chain thermostat; also uses the
c     Berendsen thermostat for any iEL induced dipole variables
c
c     literature references:
c
c     D. Frenkel and B. Smit, "Understanding Molecular Simulation,
c     2nd Edition", Academic Press, San Diego, CA, 2002; see Appendix
c     E.2 for implementation details
c
c     G. J. Martyna, M. E. Tuckerman, D. J. Tobias and M. L. Klein,
c     "Explicit Reversible Integrators for Extended Systems Dynamics",
c     Molecular Physics, 87, 1117-1157 (1996)
c
c
      subroutine temper2 (dt,temp)
      use atoms
      use bath
      use group
      use ielscf
      use mdstuf
      use moldyn
      use rgddyn
      use units
      use usage
      implicit none
      integer i,j,k
      integer nc,ns
      real*8 dt,dtc,dts
      real*8 dt2,dt4,dt8
      real*8 eksum,ekt
      real*8 scale,temp
      real*8 expterm
      real*8 scalep
      real*8 temp_aux
      real*8 temp_auxp
      real*8 w(3)
      real*8 ekin(3,3)
c
c
c     get the kinetic energy and instantaneous temperature
c
      call kinetic (eksum,ekin,temp)
c
c     make half-step velocity correction for Nose-Hoover system
c
      if (isothermal .and. thermostat.eq.'NOSE-HOOVER') then
         ekt = gasconst * kelvin
         nc = 5
         ns = 3
         dtc = dt / dble(nc)
         w(1) = 1.0d0 / (2.0d0-2.0d0**(1.0d0/3.0d0))
         w(2) = 1.0d0 - 2.0d0*w(1)
         w(3) = w(1)
         scale = 1.0d0
         do i = 1, nc
            do j = 1, ns
               dts = w(j) * dtc
               dt2 = 0.5d0 * dts
               dt4 = 0.25d0 * dts
               dt8 = 0.125d0 * dts
               gnh(4) = (qnh(3)*vnh(3)*vnh(3)-ekt) / qnh(4)
               vnh(4) = vnh(4) + gnh(4)*dt4
               gnh(3) = (qnh(2)*vnh(2)*vnh(2)-ekt) / qnh(3)
               expterm = exp(-vnh(4)*dt8)
               vnh(3) = expterm * (vnh(3)*expterm+gnh(3)*dt4)
               gnh(2) = (qnh(1)*vnh(1)*vnh(1)-ekt) / qnh(2)
               expterm = exp(-vnh(3)*dt8)
               vnh(2) = expterm * (vnh(2)*expterm+gnh(2)*dt4)
               gnh(1) = (2.0d0*eksum-dble(nfree)*ekt) / qnh(1)
               expterm = exp(-vnh(2)*dt8)
               vnh(1) = expterm * (vnh(1)*expterm+gnh(1)*dt4)
               expterm = exp(-vnh(1)*dt2)
               scale = scale * expterm
               eksum = eksum * expterm * expterm
               gnh(1) = (2.0d0*eksum-dble(nfree)*ekt) / qnh(1)
               expterm = exp(-vnh(2)*dt8)
               vnh(1) = expterm * (vnh(1)*expterm+gnh(1)*dt4)
               gnh(2) = (qnh(1)*vnh(1)*vnh(1)-ekt) / qnh(2)
               expterm = exp(-vnh(3)*dt8)
               vnh(2) = expterm * (vnh(2)*expterm+gnh(2)*dt4)
               gnh(3) = (qnh(2)*vnh(2)*vnh(2)-ekt) / qnh(3)
               expterm = exp(-vnh(4)*dt8)
               vnh(3) = expterm * (vnh(3)*expterm+gnh(3)*dt4)
               gnh(4) = (qnh(3)*vnh(3)*vnh(3)-ekt) / qnh(4)
               vnh(4) = vnh(4) + gnh(4)*dt4
            end do
         end do
         if (integrate .eq. 'RIGIDBODY') then
            do i = 1, ngrp
               do j = 1, 3
                  vcm(j,i) = scale * vcm(j,i)
                  wcm(j,i) = scale * wcm(j,i)
               end do
            end do
         else
            do i = 1, nuse
               k = iuse(i)
               do j = 1, 3
                  v(j,k) = scale * v(j,k)
               end do
            end do
         end if
         call kinetic (eksum,ekin,temp)
      end if
c
c     use Berendsen scaling for iEL auxiliary dipole velocities
c
      if (use_ielscf) then
         call kinaux (temp_aux,temp_auxp)
         scale = 1.0d0
         scalep = 1.0d0
         if (temp_aux .ne. 0.0d0) then
            scale = sqrt(1.0d0+(dt/tautemp_aux)
     &                             *(kelvin_aux/temp_aux-1.0d0))
         end if
         if (temp_auxp .ne. 0.0d0) then
            scalep = sqrt(1.0d0+(dt/tautemp_aux)
     &                              *(kelvin_aux/temp_auxp-1.0d0))
         end if
         do i = 1, nuse
            k = iuse(i)
            do j = 1, 3
               vaux(j,k) = scale * vaux(j,k)
               vpaux(j,k) = scalep * vpaux(j,k)
            end do
         end do
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program testgrad  --  derivative test; Cartesian version  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "testgrad" computes and compares the analytical and numerical
c     gradient vectors of the potential energy function with respect
c     to Cartesian coordinates
c
c
      program testgrad
      use atoms
      use deriv
      use energi
      use files
      use inform
      use inter
      use iounit
      use solpot
      use usage
      implicit none
      integer i,j,ixyz
      integer next,frame
      integer freeunit
      real*8 eval,energy
      real*8 f,f0,eps,eps0,old
      real*8 eb0,ea0,eba0,eub0
      real*8 eaa0,eopb0,eopd0,eid0
      real*8 eit0,et0,ept0,ebt0
      real*8 eat0,ett0,ev0,er0
      real*8 edsp0,ec0,ecd0,ed0
      real*8 em0,ep0,ect0,erxf0
      real*8 es0,elf0,eg0,ex0
      real*8 totnorm,ntotnorm,rms,nrms
      real*8, allocatable :: denorm(:)
      real*8, allocatable :: ndenorm(:)
      real*8, allocatable :: ndesum(:,:)
      real*8, allocatable :: ndeb(:,:)
      real*8, allocatable :: ndea(:,:)
      real*8, allocatable :: ndeba(:,:)
      real*8, allocatable :: ndeub(:,:)
      real*8, allocatable :: ndeaa(:,:)
      real*8, allocatable :: ndeopb(:,:)
      real*8, allocatable :: ndeopd(:,:)
      real*8, allocatable :: ndeid(:,:)
      real*8, allocatable :: ndeit(:,:)
      real*8, allocatable :: ndet(:,:)
      real*8, allocatable :: ndept(:,:)
      real*8, allocatable :: ndebt(:,:)
      real*8, allocatable :: ndeat(:,:)
      real*8, allocatable :: ndett(:,:)
      real*8, allocatable :: ndev(:,:)
      real*8, allocatable :: nder(:,:)
      real*8, allocatable :: ndedsp(:,:)
      real*8, allocatable :: ndec(:,:)
      real*8, allocatable :: ndecd(:,:)
      real*8, allocatable :: nded(:,:)
      real*8, allocatable :: ndem(:,:)
      real*8, allocatable :: ndep(:,:)
      real*8, allocatable :: ndect(:,:)
      real*8, allocatable :: nderxf(:,:)
      real*8, allocatable :: ndes(:,:)
      real*8, allocatable :: ndelf(:,:)
      real*8, allocatable :: ndeg(:,:)
      real*8, allocatable :: ndex(:,:)
      real*8, allocatable :: derivs(:,:)
      logical exist,query
      logical doanalyt,donumer,dofull
      character*1 answer
      character*1 axis(3)
      character*240 xyzfile
      character*240 record
      character*240 string
      data axis  / 'X','Y','Z' /
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     decide whether to do an analytical gradient calculation
c
      doanalyt = .true.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,10)
   10    format (/,' Compute the Analytical Gradient Vector [Y] :  ',$)
         read (input,20)  record
   20    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'N')  doanalyt = .false.
c
c     decide whether to do a numerical gradient calculation
c
      donumer = .true.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,30)
   30    format (/,' Compute the Numerical Gradient Vector [Y] :   ',$)
         read (input,40)  record
   40    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'N')  donumer = .false.
c
c     get the stepsize for numerical gradient calculation
c
      if (donumer) then
         eps = -1.0d0
         eps0 = 0.00001d0
         if (solvtyp.eq.'GK' .or. solvtyp.eq.'PB')  eps0 = 0.001d0
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=50,end=50)  eps
            query = .false.
         end if
   50    continue
         if (query) then
            write (iout,60)  eps0
   60       format (/,' Enter Finite Difference Stepsize [',d8.1,
     &                 ' Ang] :  ',$)
            read (input,70,err=50)  eps
   70       format (f20.0)
         end if
         if (eps .le. 0.0d0)  eps = eps0
      end if
c
c     decide whether to output results by gradient component
c
      dofull = .true.
      if (n .gt. 100) then
         dofull = .false.
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,80)
   80       format (/,' Output Breakdown by Gradient Component',
     &                 ' [N] :  ',$)
            read (input,90)  record
   90       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  dofull = .true.
      end if
c
c     reopen the coordinates file and read the first structure
c
      frame = 0
      ixyz = freeunit ()
      xyzfile = filename
      call suffix (xyzfile,'xyz','old')
      open (unit=ixyz,file=xyzfile,status ='old')
      rewind (unit=ixyz)
      call readxyz (ixyz)
c
c     perform dynamic allocation of some local arrays
c
      if (doanalyt) then
         allocate (denorm(n))
         allocate (derivs(3,n))
      end if
      if (donumer) then
         allocate (ndenorm(n))
         allocate (ndesum(3,n))
         allocate (ndeb(3,n))
         allocate (ndea(3,n))
         allocate (ndeba(3,n))
         allocate (ndeub(3,n))
         allocate (ndeaa(3,n))
         allocate (ndeopb(3,n))
         allocate (ndeopd(3,n))
         allocate (ndeid(3,n))
         allocate (ndeit(3,n))
         allocate (ndet(3,n))
         allocate (ndept(3,n))
         allocate (ndebt(3,n))
         allocate (ndeat(3,n))
         allocate (ndett(3,n))
         allocate (ndev(3,n))
         allocate (nder(3,n))
         allocate (ndedsp(3,n))
         allocate (ndec(3,n))
         allocate (ndecd(3,n))
         allocate (nded(3,n))
         allocate (ndem(3,n))
         allocate (ndep(3,n))
         allocate (ndect(3,n))
         allocate (nderxf(3,n))
         allocate (ndes(3,n))
         allocate (ndelf(3,n))
         allocate (ndeg(3,n))
         allocate (ndex(3,n))
      end if
c
c     perform analysis for each successive coordinate structure
c
      do while (.not. abort)
         frame = frame + 1
         if (frame .gt. 1) then
            write (iout,100)  frame
  100       format (/,' Analysis for Archive Structure :',8x,i8)
         end if
c
c     compute the energy and analytical gradient components
c
         if (doanalyt) then
            call gradient (eval,derivs)
         end if
c
c     print the total potential energy of the system
c
         if (doanalyt) then
            if (digits .ge. 8) then
               write (iout,110)  esum
  110          format (/,' Total Potential Energy :',8x,f20.8,
     &                    ' Kcal/mole')
            else if (digits .ge. 6) then
               write (iout,120)  esum
  120          format (/,' Total Potential Energy :',8x,f18.6,
     &                    ' Kcal/mole')
            else
               write (iout,130)  esum
  130          format (/,' Total Potential Energy :',8x,f16.4,
     &                    ' Kcal/mole')
            end if
c
c     print the energy breakdown over individual components
c
            write (iout,140)
  140       format (/,' Potential Energy Breakdown by Individual',
     &              ' Components :')
            if (digits .ge. 8) then
               write (iout,150)
  150          format (/,'  Energy',7x,'EB',14x,'EA',14x,'EBA',
     &                    13x,'EUB',
     &                 /,'  Terms',8x,'EAA',13x,'EOPB',12x,'EOPD',
     &                    12x,'EID',
     &                 /,15x,'EIT',13x,'ET',14x,'EPT',13x,'EBT',
     &                 /,15x,'EAT',13x,'ETT',13x,'EV',14x,'ER',
     &                 /,15x,'EDSP',12x,'EC',14x,'ECD',13x,'ED',
     &                 /,15x,'EM',14x,'EP',14x,'ECT',13x,'ERXF',
     &                 /,15x,'ES',14x,'ELF',13x,'EG',14x,'EX')
               write (iout,160)  eb,ea,eba,eub,eaa,eopb,eopd,eid,eit,et,
     &                           ept,ebt,eat,ett,ev,er,edsp,ec,ecd,ed,
     &                           em,ep,ect,erxf,es,elf,eg,ex
  160          format (/,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8,
     &                 /,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8)
            else if (digits .ge. 6) then
               write (iout,170)
  170          format (/,'  Energy',6x,'EB',12x,'EA',12x,'EBA',
     &                    11x,'EUB',11x,'EAA',
     &                 /,'  Terms',7x,'EOPB',10x,'EOPD',10x,'EID',
     &                    11x,'EIT',11x,'ET',
     &                 /,14x,'EPT',11x,'EBT',11x,'EAT',11x,'ETT',
     &                    11x,'EV',
     &                 /,14x,'ER',12x,'EDSP',10x,'EC',12x,'ECD',
     &                    11x,'ED',
     &                 /,14x,'EM',12x,'EP',12x,'ECT',11x,'ERXF',
     &                    10x,'ES',
     &                 /,14x,'ELF',11x,'EG',12x,'EX')
               write (iout,180)  eb,ea,eba,eub,eaa,eopb,eopd,eid,eit,et,
     &                           ept,ebt,eat,ett,ev,er,edsp,ec,ecd,ed,
     &                           em,ep,ect,erxf,es,elf,eg,ex
  180          format (/,6x,5f14.6,/,6x,5f14.6,/,6x,5f14.6,/,6x,5f14.6,
     &                 /,6x,5f14.6,/,6x,3f14.6)
            else
               write (iout,190)
  190          format (/,'  Energy',6x,'EB',10x,'EA',10x,'EBA',
     &                    9x,'EUB',9x,'EAA',9x,'EOPB',
     &                 /,'  Terms',7x,'EOPD',8x,'EID',9x,'EIT',
     &                    9x,'ET',10x,'EPT',9x,'EBT',
     &                 /,14x,'EAT',9x,'ETT',9x,'EV',10x,'ER',
     &                    10x,'EDSP',8x,'EC',
     &                 /,14x,'ECD',9x,'ED',10x,'EM',10x,'EP',
     &                    10x,'ECT',9x,'ERXF',
     &                 /,14x,'ES',10x,'ELF',9x,'EG',10x,'EX')
               write (iout,200)  eb,ea,eba,eub,eaa,eopb,eopd,eid,eit,et,
     &                           ept,ebt,eat,ett,ev,er,edsp,ec,ecd,ed,
     &                           em,ep,ect,erxf,es,elf,eg,ex
  200          format (/,6x,6f12.4,/,6x,6f12.4,/,6x,6f12.4,/,6x,6f12.4,
     &                    /,6x,4f12.4)
            end if
         end if
c
c     print a header for the gradients of individual potentials
c
         if (dofull) then
            write (iout,210)
  210       format (/,' Cartesian Gradient Breakdown by Individual',
     &                 ' Components :')
            if (digits .ge. 8) then
               write (iout,220)
  220          format (/,2x,'Atom',9x,'d EB',12x,'d EA',12x,'d EBA',
     &                 11x,'d EUB',
     &              /,2x,'Axis',9x,'d EAA',11x,'d EOPB',10x,'d EOPD',
     &                 10x,'d EID',
     &              /,2x,'Type',9x,'d EIT',11x,'d ET',12x,'d EPT',
     &                 11x,'d EBT',
     &              /,15x,'d EAT',11x,'d ETT',11x,'d EV',12x,'d ER',
     &              /,15x,'d EDSP',10x,'d EC',12x,'d ECD',11x,'d ED',
     &              /,15x,'d EM',12x,'d EP',12x,'d ECT',11x,'d ERXF',
     &              /,15x,'d ES',12x,'d ELF',11x,'d EG',12x,'d EX')
            else if (digits .ge. 6) then
               write (iout,230)
  230          format (/,2x,'Atom',8x,'d EB',10x,'d EA',10x,'d EBA',
     &                 9x,'d EUB',9x,'d EAA',
     &              /,2x,'Axis',8x,'d EOPB',8x,'d EOPD',8x,'d EID',
     &                 9x,'d EIT',9x,'d ET',
     &              /,2x,'Type',8x,'d EPT',9x,'d EBT',9x,'d EAT',
     &                 9x,'d ETT',9x,'d EV',
     &              /,14x,'d ER',10x,'d EDSP',8x,'d EC',10x,'d ECD',
     &                 9x,'d ED',
     &              /,14x,'d EM',10x,'d EP',10x,'d ECT',9x,'d ERXF',
     &                 8x,'d ES',
     &              /,14x,'d ELF',9x,'d EG',10x,'d EX')
            else
               write (iout,240)
  240          format (/,2x,'Atom',6x,'d EB',8x,'d EA',8x,'d EBA',
     &                 7x,'d EUB',7x,'d EAA',7x,'d EOPB',
     &              /,2x,'Axis',6x,'d EOPD',6x,'d EID',7x,'d EIT',
     &                 7x,'d ET',8x,'d EPT',7x,'d EBT',
     &              /,2x,'Type',6x,'d EAT',7x,'d ETT',7x,'d EV',
     &                 8x,'d ER',8x,'d EDSP',6x,'d EC',
     &              /,12x,'d ECD',7x,'d ED',8x,'d EM',8x,'d EP',
     &                 8x,'d ECT',7x,'d ERXF',
     &              /,12x,'d ES',8x,'d ELF',7x,'d EG',8x,'d EX')
            end if
         end if
c
c     get the Cartesian component two-sided numerical gradients
c
         do i = 1, n
            if (donumer .and. use(i)) then
               do j = 1, 3
                  if (j .eq. 1) then
                     old = x(i)
                     x(i) = x(i) - 0.5d0*eps
                  else if (j .eq. 2) then
                     old = y(i)
                     y(i) = y(i) - 0.5d0*eps
                  else if (j .eq. 3) then
                     old = z(i)
                     z(i) = z(i) - 0.5d0*eps
                  end if
                  f0 = energy ()
                  eb0 = eb
                  ea0 = ea
                  eba0 = eba
                  eub0 = eub
                  eaa0 = eaa
                  eopb0 = eopb
                  eopd0 = eopd
                  eid0 = eid
                  eit0 = eit
                  et0 = et
                  ept0 = ept
                  ebt0 = ebt
                  eat0 = eat
                  ett0 = ett
                  ev0 = ev
                  er0 = er
                  edsp0 = edsp
                  ec0 = ec
                  ecd0 = ecd
                  ed0 = ed
                  em0 = em
                  ep0 = ep
                  ect0 = ect
                  erxf0 = erxf
                  es0 = es
                  elf0 = elf
                  eg0 = eg
                  ex0 = ex
                  if (j .eq. 1) then
                     x(i) = x(i) + eps
                  else if (j .eq. 2) then
                     y(i) = y(i) + eps
                  else if (j .eq. 3) then
                     z(i) = z(i) + eps
                  end if
                  f = energy ()
                  if (j .eq. 1) then
                     x(i) = old
                  else if (j .eq. 2) then
                     y(i) = old
                  else if (j .eq. 3) then
                     z(i) = old
                  end if
                  ndesum(j,i) = (f - f0) / eps
                  ndeb(j,i) = (eb - eb0) / eps
                  ndea(j,i) = (ea - ea0) / eps
                  ndeba(j,i) = (eba - eba0) / eps
                  ndeub(j,i) = (eub - eub0) / eps
                  ndeaa(j,i) = (eaa - eaa0) / eps
                  ndeopb(j,i) = (eopb - eopb0) / eps
                  ndeopd(j,i) = (eopd - eopd0) / eps
                  ndeid(j,i) = (eid - eid0) / eps
                  ndeit(j,i) = (eit - eit0) / eps
                  ndet(j,i) = (et - et0) / eps
                  ndept(j,i) = (ept - ept0) / eps
                  ndebt(j,i) = (ebt - ebt0) / eps
                  ndeat(j,i) = (eat - eat0) / eps
                  ndett(j,i) = (ett - ett0) / eps
                  ndev(j,i) = (ev - ev0) / eps
                  nder(j,i) = (er - er0) / eps
                  ndedsp(j,i) = (edsp - edsp0) / eps
                  ndec(j,i) = (ec - ec0) / eps
                  ndecd(j,i) = (ecd - ecd0) / eps
                  nded(j,i) = (ed - ed0) / eps
                  ndem(j,i) = (em - em0) / eps
                  ndep(j,i) = (ep - ep0) / eps
                  ndect(j,i) = (ect - ect0) / eps
                  nderxf(j,i) = (erxf - erxf0) / eps
                  ndes(j,i) = (es - es0) / eps
                  ndelf(j,i) = (elf - elf0) / eps
                  ndeg(j,i) = (eg - eg0) / eps
                  ndex(j,i) = (ex - ex0) / eps
               end do
            end if
c
c     print analytical gradients of each energy term for each atom
c
            if (dofull .and. use(i)) then
               do j = 1, 3
                  if (doanalyt) then
                     if (digits .ge. 8) then
                        write (iout,250)  i,deb(j,i),dea(j,i),deba(j,i),
     &                                    deub(j,i),axis(j),deaa(j,i),
     &                                    deopb(j,i),deopd(j,i),
     &                                    deid(j,i),deit(j,i),det(j,i),
     &                                    dept(j,i),debt(j,i),deat(j,i),
     &                                    dett(j,i),dev(j,i),der(j,i),
     &                                    dedsp(j,i),dec(j,i),decd(j,i),
     &                                    ded(j,i),dem(j,i),dep(j,i),
     &                                    dect(j,i),derxf(j,i),
     &                                    des(j,i),delf(j,i),deg(j,i),
     &                                    dex(j,i)
  250                   format (/,i6,4f16.8,/,5x,a1,4f16.8,
     &                          /,' Anlyt',4f16.8,/,6x,4f16.8,
     &                          /,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8)
                     else if (digits .ge. 6) then
                        write (iout,260)  i,deb(j,i),dea(j,i),deba(j,i),
     &                                    deub(j,i),deaa(j,i),axis(j),
     &                                    deopb(j,i),deopd(j,i),
     &                                    deid(j,i),deit(j,i),det(j,i),
     &                                    dept(j,i),debt(j,i),deat(j,i),
     &                                    dett(j,i),dev(j,i),der(j,i),
     &                                    dedsp(j,i),dec(j,i),decd(j,i),
     &                                    ded(j,i),dem(j,i),dep(j,i),
     &                                    dect(j,i),derxf(j,i),
     &                                    des(j,i),delf(j,i),deg(j,i),
     &                                    dex(j,i)
  260                   format (/,i6,5f14.6,/,5x,a1,5f14.6,
     &                          /,' Anlyt',5f14.6,/,6x,5f14.6,
     &                          /,6x,5f14.6,/,6x,3f14.6)
                     else
                        write (iout,270)  i,deb(j,i),dea(j,i),deba(j,i),
     &                                    deub(j,i),deaa(j,i),
     &                                    deopb(j,i),axis(j),deopd(j,i),
     &                                    deid(j,i),deit(j,i),det(j,i),
     &                                    dept(j,i),debt(j,i),deat(j,i),
     &                                    dett(j,i),dev(j,i),der(j,i),
     &                                    dedsp(j,i),dec(j,i),decd(j,i),
     &                                    ded(j,i),dem(j,i),dep(j,i),
     &                                    dect(j,i),derxf(j,i),
     &                                    des(j,i),delf(j,i),deg(j,i),
     &                                    dex(j,i)
  270                   format (/,i6,6f12.4,/,5x,a1,6f12.4,
     &                          /,' Anlyt',6f12.4,/,6x,6f12.4,
     &                          /,6x,4f12.4)
                     end if
                  end if
c
c     print numerical gradients of each energy term for each atom
c
                  if (donumer) then
                     if (digits .ge. 8) then
                        write (iout,280)  i,ndeb(j,i),ndea(j,i),
     &                                    ndeba(j,i),ndeub(j,i),
     &                                    axis(j),ndeaa(j,i),
     &                                    ndeopb(j,i),ndeopd(j,i),
     &                                    ndeid(j,i),ndeit(j,i),
     &                                    ndet(j,i),ndept(j,i),
     &                                    ndebt(j,i),ndeat(j,i),
     &                                    ndett(j,i),ndev(j,i),
     &                                    nder(j,i),ndedsp(j,i),
     &                                    ndec(j,i),ndecd(j,i),
     &                                    nded(j,i),ndem(j,i),
     &                                    ndep(j,i),ndect(j,i),
     &                                    nderxf(j,i),ndes(j,i),
     &                                    ndelf(j,i),ndeg(j,i),
     &                                    ndex(j,i)
  280                   format (/,i6,4f16.8,/,5x,a1,4f16.8,
     &                          /,' Numer',4f16.8,/,6x,4f16.8,
     &                          /,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8)
                     else if (digits .ge. 6) then
                        write (iout,290)  i,ndeb(j,i),ndea(j,i),
     &                                    ndeba(j,i),ndeub(j,i),
     &                                    ndeaa(j,i),axis(j),
     &                                    ndeopb(j,i),ndeopd(j,i),
     &                                    ndeid(j,i),ndeit(j,i),
     &                                    ndet(j,i),ndept(j,i),
     &                                    ndebt(j,i),ndeat(j,i),
     &                                    ndett(j,i),ndev(j,i),
     &                                    nder(j,i),ndedsp(j,i),
     &                                    ndec(j,i),ndecd(j,i),
     &                                    nded(j,i),ndem(j,i),
     &                                    ndep(j,i),ndect(j,i),
     &                                    nderxf(j,i),ndes(j,i),
     &                                    ndelf(j,i),ndeg(j,i),
     &                                    ndex(j,i)
  290                   format (/,i6,5f14.6,/,5x,a1,5f14.6,
     &                          /,' Numer',5f14.6,/,6x,5f14.6,
     &                          /,6x,5f14.6,/,6x,3f14.6)
                     else
                        write (iout,300)  i,ndeb(j,i),ndea(j,i),
     &                                    ndeba(j,i),ndeub(j,i),
     &                                    ndeaa(j,i),ndeopb(j,i),
     &                                    axis(j),ndeopd(j,i),
     &                                    ndeid(j,i),ndeit(j,i),
     &                                    ndet(j,i),ndept(j,i),
     &                                    ndebt(j,i),ndeat(j,i),
     &                                    ndett(j,i),ndev(j,i),
     &                                    nder(j,i),ndedsp(j,i),
     &                                    ndec(j,i),ndecd(j,i),
     &                                    nded(j,i),ndem(j,i),
     &                                    ndep(j,i),ndect(j,i),
     &                                    nderxf(j,i),ndes(j,i),
     &                                    ndelf(j,i),ndeg(j,i),
     &                                    ndex(j,i)
  300                   format (/,i6,6f12.4,/,5x,a1,6f12.4,
     &                          /,' Numer',6f12.4,/,6x,6f12.4,
     &                          /,6x,4f12.4)
                     end if
                  end if
               end do
            end if
         end do
c
c     print the total gradient components for each atom
c
         if (doanalyt .or. donumer) then
            write (iout,310)
  310       format (/,' Cartesian Gradient Breakdown over Individual',
     &                 ' Atoms :')
            if (digits .ge. 8) then
               write (iout,320)
  320          format (/,2x,'Type',4x,'Atom',10x,'dE/dX',11x,'dE/dY',
     &                    11x,'dE/dZ',11x,'Norm',/)
            else if (digits .ge. 6) then
               write (iout,330)
  330          format (/,2x,'Type',6x,'Atom',11x,'dE/dX',9x,'dE/dY',
     &                    9x,'dE/dZ',11x,'Norm',/)
            else
               write (iout,340)
  340          format (/,2x,'Type',6x,'Atom',14x,'dE/dX',7x,'dE/dY',
     &                    7x,'dE/dZ',10x,'Norm',/)
            end if
         end if
         totnorm = 0.0d0
         ntotnorm = 0.0d0
         do i = 1, n
            if (doanalyt .and. use(i)) then
               denorm(i) = desum(1,i)**2 + desum(2,i)**2
     &                        + desum(3,i)**2
               totnorm = totnorm + denorm(i)
               denorm(i) = sqrt(denorm(i))
               if (digits .ge. 8) then
                  write (iout,350)  i,(desum(j,i),j=1,3),denorm(i)
  350             format (' Anlyt',i8,1x,3f16.8,f16.8)
               else if (digits .ge. 6) then
                  write (iout,360)  i,(desum(j,i),j=1,3),denorm(i)
  360             format (' Anlyt',2x,i8,3x,3f14.6,2x,f14.6)
               else
                  write (iout,370)  i,(desum(j,i),j=1,3),denorm(i)
  370             format (' Anlyt',2x,i8,7x,3f12.4,2x,f12.4)
               end if
            end if
            if (donumer .and. use(i)) then
               ndenorm(i) = ndesum(1,i)**2 + ndesum(2,i)**2
     &                         + ndesum(3,i)**2
               ntotnorm = ntotnorm + ndenorm(i)
               ndenorm(i) = sqrt(ndenorm(i))
               if (digits .ge. 8) then
                  write (iout,380)  i,(ndesum(j,i),j=1,3),ndenorm(i)
  380             format (' Numer',i8,1x,3f16.8,f16.8)
               else if (digits .ge. 6) then
                  write (iout,390)  i,(ndesum(j,i),j=1,3),ndenorm(i)
  390             format (' Numer',2x,i8,3x,3f14.6,2x,f14.6)
               else
                  write (iout,400)  i,(ndesum(j,i),j=1,3),ndenorm(i)
  400             format (' Numer',2x,i8,7x,3f12.4,2x,f12.4)
               end if
            end if
         end do
c
c     print the total norm for the analytical gradient
c
         if (doanalyt .or. donumer) then
            write (iout,410)
  410       format (/,' Total Gradient Norm and RMS Gradient',
     &                 ' per Atom :',/)
         end if
         if (doanalyt) then
            totnorm = sqrt(totnorm)
            if (digits .ge. 8) then
               write (iout,420)  totnorm
  420          format (' Anlyt',6x,'Total Gradient Norm Value',
     &                    6x,f20.8)
            else if (digits .ge. 6) then
               write (iout,430)  totnorm
  430          format (' Anlyt',6x,'Total Gradient Norm Value',
     &                    6x,f18.6)
            else
               write (iout,440)  totnorm
  440          format (' Anlyt',6x,'Total Gradient Norm Value',
     &                    6x,f16.4)
            end if
         end if
c
c     print the total norm for the numerical gradient
c
         if (donumer) then
            ntotnorm = sqrt(ntotnorm)
            if (digits .ge. 8) then
               write (iout,450)  ntotnorm
  450          format (' Numer',6x,'Total Gradient Norm Value',
     &                    6x,f20.8)
            else if (digits .ge. 6) then
               write (iout,460)  ntotnorm
  460          format (' Numer',6x,'Total Gradient Norm Value',
     &                    6x,f18.6)
            else
               write (iout,470)  ntotnorm
  470          format (' Numer',6x,'Total Gradient Norm Value',
     &                    6x,f16.4)
            end if
         end if
c
c     print the rms per atom norm for the analytical gradient
c
         if (doanalyt .or. donumer) then
            write (iout,480)
  480       format ()
         end if
         if (doanalyt) then
            rms = totnorm / sqrt(dble(nuse))
            if (digits .ge. 8) then
               write (iout,490)  rms
  490          format (' Anlyt',6x,'RMS Gradient over All Atoms',
     &                    4x,f20.8)
            else if (digits .ge. 6) then
               write (iout,500)  rms
  500          format (' Anlyt',6x,'RMS Gradient over All Atoms',
     &                    4x,f18.6)
            else
               write (iout,510)  rms
  510          format (' Anlyt',6x,'RMS Gradient over All Atoms',
     &                    4x,f16.4)
            end if
         end if
c
c     print the rms per atom norm for the numerical gradient
c
         if (donumer) then
            nrms = ntotnorm / sqrt(dble(nuse))
            if (digits .ge. 8) then
               write (iout,520)  nrms
  520          format (' Numer',6x,'RMS Gradient over All Atoms',
     &                    4x,f20.8)
            else if (digits .ge. 6) then
               write (iout,530)  nrms
  530          format (' Numer',6x,'RMS Gradient over All Atoms',
     &                    4x,f18.6)
            else
               write (iout,540)  nrms
  540          format (' Numer',6x,'RMS Gradient over All Atoms',
     &                    4x,f16.4)
            end if
         end if
c
c     attempt to read next structure from the coordinate file
c
         call readxyz (ixyz)
      end do
c
c     perform deallocation of some local arrays
c
      if (doanalyt) then
         deallocate (denorm)
         deallocate (derivs)
      end if
      if (donumer) then
         deallocate (ndenorm)
         deallocate (ndesum)
         deallocate (ndeb)
         deallocate (ndea)
         deallocate (ndeba)
         deallocate (ndeub)
         deallocate (ndeaa)
         deallocate (ndeopb)
         deallocate (ndeopd)
         deallocate (ndeid)
         deallocate (ndeit)
         deallocate (ndet)
         deallocate (ndept)
         deallocate (ndebt)
         deallocate (ndeat)
         deallocate (ndett)
         deallocate (ndev)
         deallocate (nder)
         deallocate (ndedsp)
         deallocate (ndec)
         deallocate (ndecd)
         deallocate (nded)
         deallocate (ndem)
         deallocate (ndep)
         deallocate (ndect)
         deallocate (nderxf)
         deallocate (ndes)
         deallocate (ndelf)
         deallocate (ndeg)
         deallocate (ndex)
      end if
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program testhess  --  Hessian matrix test; cart. version  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "testhess" computes and compares the analytical and numerical
c     Hessian matrices of the potential energy function with respect
c     to Cartesian coordinates
c
c
      program testhess
      use atoms
      use files
      use hescut
      use inform
      use iounit
      use usage
      implicit none
      integer i,j,k,m
      integer ii,jj
      integer ixyz,ihes
      integer index,maxnum
      integer next,frame
      integer freeunit
      integer, allocatable :: hindex(:)
      integer, allocatable :: hinit(:,:)
      integer, allocatable :: hstop(:,:)
      real*8 energy,e,old,eps,eps0
      real*8 diff,delta,sum
      real*8, allocatable :: h(:)
      real*8, allocatable :: g(:,:)
      real*8, allocatable :: g0(:,:)
      real*8, allocatable :: hdiag(:,:)
      real*8, allocatable :: nhess(:,:,:,:)
      logical doanalyt,donumer
      logical dograd,dofull
      logical exist,query
      logical identical
      character*1 answer
      character*1 axis(3)
      character*240 xyzfile
      character*240 hessfile
      character*240 record
      character*240 string
      external energy
      data axis  / 'X','Y','Z' /
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     set difference threshhold via the energy precision
c
      delta = 0.0001d0
      if (digits .ge. 6)  delta = 0.000001d0
      if (digits .ge. 8)  delta = 0.00000001d0
c
c     decide whether to do an analytical Hessian calculation
c
      doanalyt = .true.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,10)
   10    format (/,' Compute Analytical Hessian Matrix [Y] :  ',$)
         read (input,20)  record
   20    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'N')  doanalyt = .false.
c
c     decide whether to do a numerical Hessian calculation
c
      donumer = .false.
      maxnum = 300
      if (n .le. maxnum) then
         donumer = .true.
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,30)
   30       format (/,' Compute Numerical Hessian Matrix [Y] :   ',$)
            read (input,40)  record
   40       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'N')  donumer = .false.
      end if
c
c     get numerical Hessian from either gradient or energy
c
      dograd = .true.
      if (donumer) then
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,50)
   50       format (/,' Numerical Hessian from Gradient',
     &                 ' or Energy [G] :  ',$)
            read (input,60)  record
   60       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'E')  dograd = .false.
c
c     get the stepsize for numerical Hessian calculation
c
         eps = -1.0d0
         eps0 = 0.001d0
         if (dograd)  eps0 = 0.00001d0
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=70,end=70)  eps
            query = .false.
         end if
   70    continue
         if (query) then
            write (iout,80)  eps0
   80       format (/,' Enter Finite Difference Stepsize [',d8.1,
     &                 ' Ang] :  ',$)
            read (input,90,err=70)  eps
   90       format (f20.0)
         end if
         if (eps .le. 0.0d0)  eps = eps0
      end if
c
c     decide whether to output results by Hessian component
c
      dofull = .false.
      if (n.le.20 .and. donumer) then
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,100)
  100       format (/,' List Individual Hessian Components [N] :   ',$)
            read (input,110)  record
  110       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  dofull = .true.
      end if
c
c     reopen the coordinates file and read the first structure
c
      frame = 0
      ixyz = freeunit ()
      xyzfile = filename
      call suffix (xyzfile,'xyz','old')
      open (unit=ixyz,file=xyzfile,status ='old')
      rewind (unit=ixyz)
      call readxyz (ixyz)
c
c     perform dynamic allocation of some local arrays
c
      allocate (hindex(3*n*(3*n-1)/2))
      allocate (hinit(3,n))
      allocate (hstop(3,n))
      allocate (h(3*n*(3*n-1)/2))
      allocate (g(3,n))
      allocate (g0(3,n))
      allocate (hdiag(3,n))
      if (n .le. maxnum)  allocate (nhess(3,n,3,n))
c
c     perform analysis for each successive coordinate structure
c
      do while (.not. abort)
         frame = frame + 1
         if (frame .gt. 1) then
            write (iout,120)  frame
  120       format (/,' Analysis for Archive Structure :',8x,i8)
         end if
c
c     get the analytical Hessian matrix elements
c
         identical = .true.
         if (doanalyt) then
            if (verbose) then
               write (iout,130)
  130          format ()
            end if
            hesscut = 0.0d0
            call hessian (h,hinit,hstop,hindex,hdiag)
         end if
c
c     get the two-sided numerical Hessian matrix elements
c
         do i = 1, n
            if (donumer .and. use(i)) then
               old = x(i)
               x(i) = x(i) - 0.5d0*eps
               if (dograd) then
                  call gradient (e,g)
               else
                  call numgrad (energy,g,eps)
               end if
               do k = 1, n
                  do j = 1, 3
                     g0(j,k) = g(j,k)
                  end do
               end do
               x(i) = x(i) + eps
               if (dograd) then
                  call gradient (e,g)
               else
                  call numgrad (energy,g,eps)
               end if
               x(i) = old
               do k = 1, n
                  do j = 1, 3
                     nhess(j,k,1,i) = (g(j,k)-g0(j,k)) / eps
                  end do
               end do
               old = y(i)
               y(i) = y(i) - 0.5d0*eps
               if (dograd) then
                  call gradient (e,g)
               else
                  call numgrad (energy,g,eps)
               end if
               do k = 1, n
                  do j = 1, 3
                     g0(j,k) = g(j,k)
                  end do
               end do
               y(i) = y(i) + eps
               if (dograd) then
                  call gradient (e,g)
               else
                  call numgrad (energy,g,eps)
               end if
               y(i) = old
               do k = 1, n
                  do j = 1, 3
                     nhess(j,k,2,i) = (g(j,k)-g0(j,k)) / eps
                  end do
               end do
               old = z(i)
               z(i) = z(i) - 0.5d0*eps
               if (dograd) then
                  call gradient (e,g)
               else
                  call numgrad (energy,g,eps)
               end if
               do k = 1, n
                  do j = 1, 3
                     g0(j,k) = g(j,k)
                  end do
               end do
               z(i) = z(i) + eps
               if (dograd) then
                  call gradient (e,g)
               else
                  call numgrad (energy,g,eps)
               end if
               z(i) = old
               do k = 1, n
                  do j = 1, 3
                     nhess(j,k,3,i) = (g(j,k)-g0(j,k)) / eps
                  end do
               end do
            end if
c
c     compare the analytical and numerical diagonal elements
c
            if (doanalyt .and. donumer) then
               do j = 1, 3
                  diff = abs(hdiag(j,i)-nhess(j,i,j,i))
                  if (diff .gt. delta) then
                     if (identical) then
                        identical = .false.
                        write (iout,140)
  140                   format (/,' Comparison of Analytical and',
     &                             ' Numerical Hessian Elements :',
     &                          //,3x,'1st Atom',4x,'2nd Atom',
     &                             9x,'Analytical',8x,'Numerical',
     &                             7x,'Difference',/)
                     end if
                     if (digits .ge. 8) then
                        write (iout,150)  i,axis(j),i,axis(j),
     &                                    hdiag(j,i),nhess(j,i,j,i),
     &                                    hdiag(j,i)-nhess(j,i,j,i)
  150                   format (1x,i6,' (',a1,') ',1x,i6,' (',
     &                             a1,') ',1x,3f17.8)
                     else if (digits .ge. 6) then
                        write (iout,160)  i,axis(j),i,axis(j),
     &                                    hdiag(j,i),nhess(j,i,j,i),
     &                                    hdiag(j,i)-nhess(j,i,j,i)
  160                   format (1x,i6,' (',a1,') ',1x,i6,' (',
     &                             a1,') ',1x,3f17.6)
                     else
                        write (iout,170)  i,axis(j),i,axis(j),
     &                                    hdiag(j,i),nhess(j,i,j,i),
     &                                    hdiag(j,i)-nhess(j,i,j,i)
  170                   format (1x,i6,' (',a1,') ',1x,i6,' (',
     &                             a1,') ',1x,3f17.4)
                     end if
                  end if
c
c     compare the analytical and numerical off-diagonal elements
c
                  do k = hinit(j,i), hstop(j,i)
                     index = hindex(k)
                     jj = mod(index,3)
                     if (jj .eq. 0)  jj = 3
                     ii = (index+2) / 3
                     diff = abs(h(k)-nhess(jj,ii,j,i))
                     if (diff .gt. delta) then
                        if (identical) then
                           identical = .false.
                           write (iout,180)
  180                      format (/,' Comparison of Analytical and',
     &                                ' Numerical Hessian Elements :',
     &                             //,3x,'1st Atom',4x,'2nd Atom',
     &                                9x,'Analytical',8x,'Numerical',
     &                                7x,'Difference',/)
                        end if
                        if (digits .ge. 8) then
                           write (iout,190)  i,axis(j),ii,axis(jj),
     &                                       h(k),nhess(jj,ii,j,i),
     &                                       h(k)-nhess(jj,ii,j,i)
  190                      format (1x,i6,' (',a1,') ',1x,i6,' (',
     &                                a1,') ',1x,3f17.8)
                        else if (digits .ge. 6) then
                           write (iout,200)  i,axis(j),ii,axis(jj),
     &                                       h(k),nhess(jj,ii,j,i),
     &                                       h(k)-nhess(jj,ii,j,i)
  200                      format (1x,i6,' (',a1,') ',1x,i6,' (',
     &                                a1,') ',1x,3f17.6)
                        else
                           write (iout,210)  i,axis(j),ii,axis(jj),
     &                                       h(k),nhess(jj,ii,j,i),
     &                                       h(k)-nhess(jj,ii,j,i)
  210                      format (1x,i6,' (',a1,') ',1x,i6,' (',
     &                                a1,') ',1x,3f17.4)
                        end if
                     end if
                  end do
               end do
            end if
         end do
c
c     success if the analytical and numerical elements are the same
c
         if (doanalyt .and. donumer) then
            if (identical) then
               write (iout,220)
  220          format (/,' Analytical and Numerical Hessian Elements',
     &                    ' are Identical')
            end if
         end if
c
c     write out the diagonal Hessian elements for each atom
c
         if (doanalyt) then
            if (digits .ge. 8) then
               write (iout,230)
  230          format (/,' Diagonal Hessian Elements for Each Atom :',
     &                    //,6x,'Atom',21x,'X',19x,'Y',19x,'Z',/)
            else if (digits .ge. 6) then
               write (iout,240)
  240          format (/,' Diagonal Hessian Elements for Each Atom :',
     &                    //,6x,'Atom',19x,'X',17x,'Y',17x,'Z',/)
            else
               write (iout,250)
  250          format (/,' Diagonal Hessian Elements for Each Atom :',
     &                    //,6x,'Atom',17x,'X',15x,'Y',15x,'Z',/)
            end if
            do i = 1, n
               if (digits .ge. 8) then
                  write (iout,260)  i,(hdiag(j,i),j=1,3)
  260             format (i10,5x,3f20.8)
               else if (digits .ge. 6) then
                  write (iout,270)  i,(hdiag(j,i),j=1,3)
  270             format (i10,5x,3f18.6)
               else
                  write (iout,280)  i,(hdiag(j,i),j=1,3)
  280             format (i10,5x,3f16.4)
               end if
            end do
         end if
c
c     write out the Hessian trace as sum of diagonal elements
c
         if (doanalyt) then
            sum = 0.0d0
            do i = 1, n
               do j = 1, 3
                  sum = sum + hdiag(j,i)
               end do
            end do
            if (digits .ge. 8) then
               write (iout,290)  sum
  290          format (/,' Sum of Diagonal Hessian Elements :',8x,f20.8)
            else if (digits .ge. 6) then
               write (iout,300)  sum
  300          format (/,' Sum of Diagonal Hessian Elements :',8x,f18.6)
            else
               write (iout,310)  sum
  310          format (/,' Sum of Diagonal Hessian Elements :',8x,f16.4)
            end if
         end if
c
c     write out the full matrix of numerical Hessian elements
c
         if (dofull .and. donumer) then
            do i = 1, n
               do k = 1, n
                  write (iout,320)  i,k
  320             format (/,' 3x3 Hessian Block for Atoms :',3x,2i8,/)
                  do j = 1, 3
                     if (digits .ge. 8) then
                        write (iout,330)  (nhess(m,i,j,k),m=1,3)
  330                   format (' Numer',5x,3f20.8)
                     else if (digits .ge. 6) then
                        write (iout,340)  (nhess(m,i,j,k),m=1,3)
  340                   format (' Numer',5x,3f18.6)
                     else
                        write (iout,350)  (nhess(m,i,j,k),m=1,3)
  350                   format (' Numer',5x,3f16.4)
                     end if
                  end do
               end do
            end do
         end if
c
c     write out the full matrix of analytical Hessian elements
c
         if (doanalyt .and. .not.donumer) then
            ihes = freeunit ()
            hessfile = filename(1:leng)//'.hes'
            call version (hessfile,'new')
            open (unit=ihes,file=hessfile,status='new')
            write (iout,360)  hessfile
  360       format (/,' Hessian Matrix written to File :  ',a40)
            write (ihes,370)
  370       format (/,' Diagonal Hessian Elements  (3 per Atom)',/)
            if (digits .ge. 8) then
               write (ihes,380)  ((hdiag(j,i),j=1,3),i=1,n)
  380          format (4f16.8)
            else if (digits .ge. 6) then
               write (ihes,390)  ((hdiag(j,i),j=1,3),i=1,n)
  390          format (5f14.6)
            else
               write (ihes,400)  ((hdiag(j,i),j=1,3),i=1,n)
  400          format (6f12.4)
            end if
            do i = 1, n
               do j = 1, 3
                  if (hinit(j,i) .le. hstop(j,i)) then
                     write (ihes,410)  i,axis(j)
  410                format (/,' Off-diagonal Hessian Elements for Atom'
     &,                         i6,1x,a1,/)
                     if (digits .ge. 8) then
                        write (ihes,420)  (h(k),k=hinit(j,i),hstop(j,i))
  420                   format (4f16.8)
                     else if (digits .ge. 6) then
                        write (ihes,430)  (h(k),k=hinit(j,i),hstop(j,i))
  430                   format (5f14.6)
                     else
                        write (ihes,440)  (h(k),k=hinit(j,i),hstop(j,i))
  440                   format (6f12.4)
                     end if
                  end if
               end do
            end do
            close (unit=ihes)
         end if
c
c     attempt to read next structure from the coordinate file
c
         call readxyz (ixyz)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (hindex)
      deallocate (hinit)
      deallocate (hstop)
      deallocate (h)
      deallocate (g)
      deallocate (g0)
      deallocate (hdiag)
      if (allocated(nhess))  deallocate (nhess)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program testpair  --  time various neighbor pair schemes  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "testpair" performs a set of timing tests to compare the
c     evaluation of potential energy and energy/gradient using
c     different methods for finding pairwise neighbors
c
c
      program testpair
      use atoms
      use deriv
      use energi
      use inform
      use iounit
      use light
      use neigh
      use potent
      use vdwpot
      implicit none
      integer i,j,k,m
      integer kgy,kgz
      integer start,stop
      integer ncalls,lmax
      integer npair,nterm
      real*8 xi,yi,zi
      real*8 xr,yr,zr,r2
      real*8 wall,cpu,delta
      real*8 vrms,erms
      real*8 off,off2
      real*8 eloop,elight,elist
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      real*8, allocatable :: gloop(:,:)
      real*8, allocatable :: glight(:,:)
      real*8, allocatable :: glist(:,:)
      logical exist,query
      logical header,match
      logical unique,repeat
      character*1 axis(3)
      character*6 mode
      character*240 string
      data axis  / 'X','Y','Z' /
c
c
c     read the molecular system and setup molecular mechanics
c
      call initial
      call getxyz
      call mechanic
c
c     set difference threshhold via the energy precision
c
      delta = 1.0d-4
      if (digits .ge. 6)  delta = 1.0d-6
      if (digits .ge. 8)  delta = 1.0d-8
c
c     get the number of calculation cycles to be performed
c
      ncalls = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  ncalls
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' Enter Desired Number of Repetitions [1] :  ',$)
         read (input,30,err=10)  ncalls
   30    format (i10)
      end if
      if (ncalls .eq. 0)  ncalls = 1
c
c     initialize number of pairs and generic cutoff distance
c
      npair = 0
      nterm = 0
      if (use_vdw)  nterm = nterm + 1
      if (use_repel)  nterm = nterm + 1
      if (use_disp)  nterm = nterm + 1
      if (use_charge)  nterm = nterm + 1
      if (use_chgdpl)  nterm = nterm + 1
      if (use_dipole)  nterm = nterm + 1
      if (use_mpole)  nterm = nterm + 1
      if (use_polar)  nterm = nterm + 1
      if (use_chgtrn)  nterm = nterm + 1
      nterm = nterm * ncalls
      off = 5.0d0
      off2 = off * off
c
c     perform dynamic allocation of some local arrays
c
      lmax = 8 * n
      allocate (xsort(lmax))
      allocate (ysort(lmax))
      allocate (zsort(lmax))
      allocate (gloop(3,n))
      allocate (glight(3,n))
      allocate (glist(3,n))
c
c     get the timing for setup of double nested loop
c
      mode = 'LOOP'
      call setpair (mode)
      call settime
      do m = 1, nterm
         do i = 1, n-1
            xi = x(i)
            yi = y(i)
            zi = z(i)
            do j = i+1, n
               xr = x(j) - xi
               yr = y(j) - yi
               zr = z(j) - zi
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .lt. off2)  npair = npair + 1
            end do
         end do
      end do
      call gettime (wall,cpu)
      write (iout,40)  ncalls
   40 format (/,' Total Wall Clock and CPU Time in Seconds for',
     &           i6,' Evaluations :')
      write (iout,50)
   50 format (/,' Computation Overhead',8x,'Wall',8x,'CPU')
      write (iout,60)  wall,cpu
   60 format (/,' Double Nested Loop',3x,2f11.3)
c
c     get the timing for setup of method of lights
c
      mode = 'LIGHTS'
      call setpair (mode)
      call settime
      unique = .true.
      do m = 1, nterm
         do i = 1, n
            xsort(i) = x(i)
            ysort(i) = y(i)
            zsort(i) = z(i)
         end do
         call lights (off,n,xsort,ysort,zsort,unique)
         do i = 1, n
            xi = xsort(rgx(i))
            yi = ysort(rgy(i))
            zi = zsort(rgz(i))
            if (kbx(i) .le. kex(i)) then
               repeat = .false.
               start = kbx(i) + 1
               stop = kex(i)
            else
               repeat = .true.
               start = 1
               stop = kex(i)
            end if
   70       continue
            do j = start, stop
               k = locx(j)
               kgy = rgy(k)
               if (kby(i) .le. key(i)) then
                  if (kgy.lt.kby(i) .or. kgy.gt.key(i))  goto 80
               else
                  if (kgy.lt.kby(i) .and. kgy.gt.key(i))  goto 80
               end if
               kgz = rgz(k)
               if (kbz(i) .le. kez(i)) then
                  if (kgz.lt.kbz(i) .or. kgz.gt.kez(i))  goto 80
               else
                  if (kgz.lt.kbz(i) .and. kgz.gt.kez(i))  goto 80
               end if
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               call image (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .lt. off2)  npair = npair + 1
   80          continue
            end do
            if (repeat) then
               repeat = .false.
               start = kbx(i) + 1
               stop = nlight
               goto 70
            end if
         end do
      end do
      call gettime (wall,cpu)
      write (iout,90)  wall,cpu
   90 format (' Method of Lights',5x,2f11.3)
      if (npair .lt. 0)  call fatal
c
c     get the timing for setup of pair neighbor list
c
      mode = 'LIST'
      call setpair (mode)
      call settime
      do m = 1, ncalls
         dovlst = .true.
         dodlst = .true.
         doclst = .true.
         domlst = .true.
         doulst = .true.
         call nblist
      end do
      call gettime (wall,cpu)
      write (iout,100)  wall,cpu
  100 format (' Pair Neighbor List',3x,2f11.3)
c
c     perform dynamic allocation of some global arrays
c
      allocate (dev(3,n))
      allocate (der(3,n))
      allocate (dedsp(3,n))
      allocate (dec(3,n))
      allocate (decd(3,n))
      allocate (ded(3,n))
      allocate (dem(3,n))
      allocate (dep(3,n))
      allocate (dect(3,n))
c
c     zero out each of the energy and gradient components
c
      ev = 0.0d0
      er = 0.0d0
      edsp = 0.0d0
      ec = 0.0d0
      ecd = 0.0d0
      ed = 0.0d0
      em = 0.0d0
      ep = 0.0d0
      ect = 0.0d0
      do i = 1, n
         do j = 1, 3
            dev(j,i) = 0.0d0
            der(j,i) = 0.0d0
            dedsp(j,i) = 0.0d0
            dec(j,i) = 0.0d0
            decd(j,i) = 0.0d0
            ded(j,i) = 0.0d0
            dem(j,i) = 0.0d0
            dep(j,i) = 0.0d0
            dect(j,i) = 0.0d0
         end do
      end do
c
c     get the timing for energy terms via double nested loop
c
      mode = 'LOOP'
      call setpair (mode)
      call settime
      do k = 1, ncalls
         if (use_vdw) then
            if (vdwtyp .eq. 'LENNARD-JONES')  call elj
            if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck
            if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb
            if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal
            if (vdwtyp .eq. 'GAUSSIAN')  call egauss
         end if
         if (use_repel)  call erepel
         if (use_disp)  call edisp
         if (use_charge)  call echarge
         if (use_chgdpl)  call echgdpl
         if (use_dipole)  call edipole
         if (use_mpole)  call empole
         if (use_polar)  call epolar
         if (use_chgtrn)  call echgtrn
      end do
      call gettime (wall,cpu)
      write (iout,110)
  110 format (/,' Potential Energy Only',7x,'Wall',8x,'CPU',
     &           13x,'Evdw',11x,'Eelect')
      eloop = ev + er + edsp + ec + ecd + ed + em + ep + ect
      if (digits .ge. 8) then
         write (iout,120)  wall,cpu,ev+er+edsp,eloop-ev-er-edsp
  120    format (/,' Double Nested Loop',3x,2f11.3,2f17.8)
      else if (digits .ge. 6) then
         write (iout,130)  wall,cpu,ev+er+edsp,eloop-ev-er-edsp
  130    format (/,' Double Nested Loop',3x,2f11.3,2f17.6)
      else
         write (iout,140)  wall,cpu,ev+er+edsp,eloop-ev-er-edsp
  140    format (/,' Double Nested Loop',3x,2f11.3,2f17.4)
      end if
c
c     get the timing for energy terms via method of lights
c
      mode = 'LIGHTS'
      call setpair (mode)
      call settime
      do k = 1, ncalls
         if (use_vdw) then
            if (vdwtyp .eq. 'LENNARD-JONES')  call elj
            if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck
            if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb
            if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal
            if (vdwtyp .eq. 'GAUSSIAN')  call egauss
         end if
         if (use_repel)  call erepel
         if (use_disp)  call edisp
         if (use_charge)  call echarge
         if (use_chgdpl)  call echgdpl
         if (use_dipole)  call edipole
         if (use_mpole)  call empole
         if (use_polar)  call epolar
         if (use_chgtrn)  call echgtrn
      end do
      call gettime (wall,cpu)
      elight = ev + er + edsp + ec + ecd + ed + em + ep + ect
      if (digits .ge. 8) then
         write (iout,150)  wall,cpu,ev+er+edsp,elight-ev-er-edsp
  150    format (' Method of Lights',5x,2f11.3,2f17.8)
      else if (digits .ge. 6) then
         write (iout,160)  wall,cpu,ev+er+edsp,elight-ev-er-edsp
  160    format (' Method of Lights',5x,2f11.3,2f17.6)
      else
         write (iout,170)  wall,cpu,ev+er+edsp,elight-ev-er-edsp
  170    format (' Method of Lights',5x,2f11.3,2f17.4)
      end if
c
c     get the timing for energy terms via pair neighbor list
c
      mode = 'LIST'
      call setpair (mode)
      call settime
      do k = 1, ncalls
         if (use_vdw) then
            if (vdwtyp .eq. 'LENNARD-JONES')  call elj
            if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck
            if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb
            if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal
            if (vdwtyp .eq. 'GAUSSIAN')  call egauss
         end if
         if (use_repel)  call erepel
         if (use_disp)  call edisp
         if (use_charge)  call echarge
         if (use_chgdpl)  call echgdpl
         if (use_dipole)  call edipole
         if (use_mpole)  call empole
         if (use_polar)  call epolar
         if (use_chgtrn)  call echgtrn
      end do
      call gettime (wall,cpu)
      elist = ev + er + edsp + ec + ecd + ed + em + ep + ect
      if (digits .ge. 8) then
         write (iout,180)  wall,cpu,ev+er+edsp,elist-ev-er-edsp
  180    format (' Pair Neighbor List',3x,2f11.3,2f17.8)
      else if (digits .ge. 6) then
         write (iout,190)  wall,cpu,ev+er+edsp,elist-ev-er-edsp
  190    format (' Pair Neighbor List',3x,2f11.3,2f17.6)
      else
         write (iout,200)  wall,cpu,ev+er+edsp,elist-ev-er-edsp
  200    format (' Pair Neighbor List',3x,2f11.3,2f17.4)
      end if
c
c     compare the nonbond energies from the various methods
c
      match = .true.
      if (abs(elight-eloop).gt.delta .or. abs(elist-eloop).gt.delta)
     &   match = .false.
      if (match) then
         write (iout,210)
  210    format (/,' Energies Computed via all Neighbor Methods',
     &              ' are Identical')
      end if
c
c     get the timing for gradient via double nested loop
c
      mode = 'LOOP'
      call setpair (mode)
      call settime
      do k = 1, ncalls
         if (use_vdw) then
            if (vdwtyp .eq. 'LENNARD-JONES')  call elj1
            if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck1
            if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb1
            if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal1
            if (vdwtyp .eq. 'GAUSSIAN')  call egauss1
         end if
         if (use_repel)  call erepel1
         if (use_disp)  call edisp1
         if (use_charge)  call echarge1
         if (use_chgdpl)  call echgdpl1
         if (use_dipole)  call edipole1
         if (use_mpole)  call empole1
         if (use_polar)  call epolar1
         if (use_chgtrn)  call echgtrn1
      end do
      call gettime (wall,cpu)
c
c     store the double loop gradient and get rms values
c
      vrms = 0.0d0
      erms = 0.0d0
      do i = 1, n
         do j = 1, 3
            gloop(j,i) = dev(j,i) + der(j,i) + dedsp(j,i)
     &                      + dec(j,i) + decd(j,i) + ded(j,i)
     &                      + dem(j,i) + dep(j,i) + dect(j,i)
            vrms = vrms + dev(j,i)**2 + der(j,i)**2 + dedsp(j,i)**2
            erms = erms + dec(j,i)**2 + decd(j,i)**2 + ded(j,i)**2
     &                + dem(j,i)**2 + dep(j,i)**2 + dect(j,i)**2
         end do
      end do
      vrms = sqrt(vrms/dble(n))
      erms = sqrt(erms/dble(n))
      write (iout,220)
  220 format (/,' Energy and Gradient',9x,'Wall',8x,'CPU',
     &           13x,'Dvdw',11x,'Delect')
      if (digits .ge. 8) then
         write (iout,230)  wall,cpu,vrms,erms
  230    format (/,' Double Nested Loop',3x,2f11.3,2f17.8)
      else if (digits .ge. 6) then
         write (iout,240)  wall,cpu,vrms,erms
  240    format (/,' Double Nested Loop',3x,2f11.3,2f17.6)
      else
         write (iout,250)  wall,cpu,vrms,erms
  250    format (/,' Double Nested Loop',3x,2f11.3,2f17.4)
      end if
c
c     get the timing for gradient via method of lights
c
      mode = 'LIGHTS'
      call setpair (mode)
      call settime
      do k = 1, ncalls
         if (use_vdw) then
            if (vdwtyp .eq. 'LENNARD-JONES')  call elj1
            if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck1
            if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb1
            if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal1
            if (vdwtyp .eq. 'GAUSSIAN')  call egauss1
         end if
         if (use_repel)  call erepel1
         if (use_disp)  call edisp1
         if (use_charge)  call echarge1
         if (use_chgdpl)  call echgdpl1
         if (use_dipole)  call edipole1
         if (use_mpole)  call empole1
         if (use_polar)  call epolar1
         if (use_chgtrn)  call echgtrn1
      end do
      call gettime (wall,cpu)
c
c     store the method of lights gradient and get rms values
c
      vrms = 0.0d0
      erms = 0.0d0
      do i = 1, n
         do j = 1, 3
            glight(j,i) = dev(j,i) + der(j,i) + dedsp(j,i)
     &                       + dec(j,i) + decd(j,i) + ded(j,i)
     &                       + dem(j,i) + dep(j,i) + dect(j,i)
            vrms = vrms + dev(j,i)**2 + der(j,i)**2 + dedsp(j,i)**2
            erms = erms + dec(j,i)**2 + decd(j,i)**2 + ded(j,i)**2
     &                + dem(j,i)**2 + dep(j,i)**2 + dect(j,i)**2
         end do
      end do
      vrms = sqrt(vrms/dble(n))
      erms = sqrt(erms/dble(n))
      if (digits .ge. 8) then
         write (iout,260)  wall,cpu,vrms,erms
  260    format (' Method of Lights',5x,2f11.3,2f17.8)
      else if (digits .ge. 6) then
         write (iout,270)  wall,cpu,vrms,erms
  270    format (' Method of Lights',5x,2f11.3,2f17.6)
      else
         write (iout,280)  wall,cpu,vrms,erms
  280    format (' Method of Lights',5x,2f11.3,2f17.4)
      end if
c
c     get the timing for gradient via pair neighbor list
c
      mode = 'LIST'
      call setpair (mode)
      call settime
      do k = 1, ncalls
         if (use_vdw) then
            if (vdwtyp .eq. 'LENNARD-JONES')  call elj1
            if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck1
            if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb1
            if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal1
            if (vdwtyp .eq. 'GAUSSIAN')  call egauss1
         end if
         if (use_repel)  call erepel1
         if (use_disp)  call edisp1
         if (use_charge)  call echarge1
         if (use_chgdpl)  call echgdpl1
         if (use_dipole)  call edipole1
         if (use_mpole)  call empole1
         if (use_polar)  call epolar1
         if (use_chgtrn)  call echgtrn1
      end do
      call gettime (wall,cpu)
c
c     get the pair neighbor list gradient rms values
c
      vrms = 0.0d0
      erms = 0.0d0
      do i = 1, n
         do j = 1, 3
            glist(j,i) = dev(j,i) + der(j,i) + dedsp(j,i)
     &                      + dec(j,i) + decd(j,i) + ded(j,i)
     &                      + dem(j,i) + dep(j,i) + dect(j,i)
            vrms = vrms + dev(j,i)**2 + der(j,i)**2 + dedsp(j,i)**2
            erms = erms + dec(j,i)**2 + decd(j,i)**2 + ded(j,i)**2
     &                + dem(j,i)**2 + dep(j,i)**2 + dect(j,i)**2
         end do
      end do
      vrms = sqrt(vrms/dble(n))
      erms = sqrt(erms/dble(n))
      if (digits .ge. 8) then
         write (iout,290)  wall,cpu,vrms,erms
  290    format (' Pair Neighbor List',3x,2f11.3,2f17.8)
      else if (digits .ge. 6) then
         write (iout,300)  wall,cpu,vrms,erms
  300    format (' Pair Neighbor List',3x,2f11.3,2f17.6)
      else
         write (iout,310)  wall,cpu,vrms,erms
  310    format (' Pair Neighbor List',3x,2f11.3,2f17.4)
      end if
c
c     compare the nonbond gradients from the various methods
c
      match = .true.
      header = .true.
      do i = 1, n
         do j = 1, 3
            if (abs(glight(j,i)-gloop(j,i)).gt.delta .or.
     &          abs(glist(j,i)-gloop(j,i)).gt.delta) then
               if (header) then
                  match = .false.
                  header = .false.
                  write (iout,320)
  320             format (/,' Comparison of Nonbond Gradients from',
     &                       ' Different Methods :',
     &                    //,11x,'Component',14x,'Loop',12x,'Lights',
     &                       14x,'List',/)
               end if
               if (digits .ge. 8) then
                  write (iout,330)  i,axis(j),gloop(j,i),glight(j,i),
     &                              glist(j,i)
  330             format (10x,i6,' (',a1,')',3f18.8)
               else if (digits .ge. 6) then
                  write (iout,340)  i,axis(j),gloop(j,i),glight(j,i),
     &                              glist(j,i)
  340             format (10x,i6,' (',a1,')',3f18.6)
               else
                  write (iout,350)  i,axis(j),gloop(j,i),glight(j,i),
     &                              glist(j,i)
  350             format (10x,i6,' (',a1,')',3f18.4)
               end if
            end if
         end do
      end do
      if (match) then
         write (iout,360)
  360    format (/,' Gradients Computed via all Methods are Identical')
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      deallocate (gloop)
      deallocate (glight)
      deallocate (glist)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  program setpair  --  list setup and cutoffs for testpair  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "setpair" is a service routine that assigns flags, sets cutoffs
c     and allocates arrays used by different pairwise neighbor methods
c
c
      subroutine setpair (mode)
      use atoms
      use limits
      use neigh
      use polpot
      use tarray
      implicit none
      character*6 mode
c
c
c     set control flags to handle use of neighbor lists
c
      if (mode .eq. 'LIST') then
         use_list = .true.
         use_vlist = .true.
         use_dlist = .true.
         use_clist = .true.
         use_mlist = .true.
         use_ulist = .true.
         dovlst = .true.
         dodlst = .true.
         doclst = .true.
         domlst = .true.
         doulst = .true.
      else
         use_list = .false.
         use_vlist = .false.
         use_dlist = .false.
         use_clist = .false.
         use_mlist = .false.
         use_ulist = .false.
         dovlst = .false.
         dodlst = .false.
         doclst = .false.
         domlst = .false.
         doulst = .false.
      end if
c
c     fix the dipole preconditioner cutoff at 4.5 Angstroms
c
      if (mode .eq. 'LOOP') then
         use_lights = .false.
         usolvcut = 4.5
      else if (mode .eq. 'LIGHTS') then
         use_lights = .true.
         usolvcut = 4.5
      else if (mode .eq. 'LIST') then
         use_lights = .false.
         usolvcut = 4.5 - pbuffer
         ubuf2 = (usolvcut+pbuffer)**2
         ubufx = (usolvcut+2.0d0*pbuffer)**2
      end if
c
c     allocate the arrays needed by the pair neighbor lists
c
      if (mode .eq. 'LIST') then
         if (.not.allocated(nvlst))  allocate (nvlst(n))
         if (.not.allocated(vlst))  allocate (vlst(maxvlst,n))
         if (.not.allocated(xvold))  allocate (xvold(n))
         if (.not.allocated(yvold))  allocate (yvold(n))
         if (.not.allocated(zvold))  allocate (zvold(n))
         if (.not.allocated(nelst))  allocate (nelst(n))
         if (.not.allocated(elst))  allocate (elst(maxelst,n))
         if (.not.allocated(xeold))  allocate (xeold(n))
         if (.not.allocated(yeold))  allocate (yeold(n))
         if (.not.allocated(zeold))  allocate (zeold(n))
         if (.not.allocated(nulst))  allocate (nulst(n))
         if (.not.allocated(ulst))  allocate (ulst(maxulst,n))
         if (.not.allocated(xuold))  allocate (xuold(n))
         if (.not.allocated(yuold))  allocate (yuold(n))
         if (.not.allocated(zuold))  allocate (zuold(n))
         if (poltyp .eq. 'MUTUAL') then
            if (.not.allocated(tindex))  allocate (tindex(2,n*maxelst))
            if (.not.allocated(tdipdip))
     &         allocate (tdipdip(6,n*maxelst))
         end if
      end if
c
c     generate the pair neighbor lists if they are in use
c
      if (mode .eq. 'LIST')  call nblist
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2012  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program testpol  --  check convergence of induced dipoles  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "testpol" compares the induced dipoles from direct polarization,
c     mutual SCF iterations, perturbation theory extrapolation (OPT),
c     and truncated conjugate gradient (TCG) solvers
c
c
      program testpol
      use atoms
      use bound
      use inform
      use iounit
      use limits
      use minima
      use mpole
      use polar
      use polopt
      use polpot
      use poltcg
      use potent
      use rigid
      use units
      use usage
      implicit none
      integer i,j,k,m
      integer next,kpcg
      integer nvar,size
      integer itercut
      integer saveopt
      integer savetcg
      integer iter,ntest
      real*8 sum,epscut
      real*8 ux,uy,uz,u2
      real*8 rdirect,rpcg
      real*8 rxpt,rtcg
      real*8 step,delta
      real*8 optfit
      real*8, allocatable :: var(:)
      real*8, allocatable :: rms(:)
      real*8, allocatable :: drms(:)
      real*8, allocatable :: tdirect(:)
      real*8, allocatable :: tpcg(:)
      real*8, allocatable :: txpt(:)
      real*8, allocatable :: ttcg(:)
      real*8, allocatable :: ddirect(:,:)
      real*8, allocatable :: dpcg(:,:)
      real*8, allocatable :: dxpt(:,:)
      real*8, allocatable :: dtcg(:,:)
      real*8, allocatable :: udirect(:,:)
      real*8, allocatable :: upcg(:,:)
      real*8, allocatable :: uxpt(:,:)
      real*8, allocatable :: utcg(:,:)
      real*8, allocatable :: ustore(:,:,:)
      logical exist,done
      logical dofull
      logical dofitopt
      character*1 answer
      character*1 digit
      character*6 savetyp
      character*240 record
      external optfit
c
c
c     get the coordinates and required force field parameters
c
      call initial
      call getxyz
      call mechanic
      if (use_solv)  call born
c
c     check to make sure mutual polarization is being used
c
      if (.not. use_polar) then
         write (iout,10)
   10    format (/,' TESTPOL  --  Induced Dipole Polarization Model',
     &              ' Not in Use')
         call fatal
      end if
c
c     decide whether to output results by gradient component
c
      dofull = .true.
      if (n .gt. 100) then
         dofull = .false.
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,20)
   20       format (/,' Output Induced Dipole Components by Atom',
     &                 ' [N] :  ',$)
            read (input,30)  record
   30       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  dofull = .true.
      end if
c
c     decide whether to output results by gradient component
c
      dofitopt = .false.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,40)
   40    format (/,' Optimize OPT Coefficients for Current System',
     &              ' [N] :  ',$)
         read (input,50)  record
   50    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'Y')  dofitopt = .true.
c
c     maintain any periodic boundary conditions
c
      if (use_bounds .and. .not.use_rigid)  call bounds
c
c     store the original polarization type for the system
c
      if (optorder .eq. 0)  optorder = 4
      if (tcgorder .eq. 0)  tcgorder = 2
      if (poltyp .eq. 'OPT') then
         size = 1
         call numeral (optorder,digit,size)
         poltyp = 'OPT'//digit//'  '
      else if (poltyp .eq. 'TCG') then
         size = 1
         call numeral (tcgorder,digit,size)
         poltyp = 'TCG'//digit//'  '
      end if
      saveopt = optorder
      savetcg = tcgorder
      savetyp = poltyp
c
c     generate neighbor lists for iterative SCF solver
c
      poltyp = 'MUTUAL'
      call cutoffs
      if (use_list)  call nblist
c
c     set tolerances and rotate multipoles to global frame
c
      maxiter = 100
      itercut = politer
      epscut = poleps
      poleps = 0.0000000001d0
      debug = .false.
      call chkpole
      call rotpole ('MPOLE')
c
c     perform dynamic allocation of some local arrays
c
      allocate (rms(0:maxiter))
      allocate (drms(maxiter))
      allocate (tdirect(n))
      allocate (tpcg(n))
      allocate (txpt(n))
      allocate (ttcg(n))
      allocate (ddirect(3,n))
      allocate (dpcg(3,n))
      allocate (dxpt(3,n))
      allocate (dtcg(3,n))
      allocate (udirect(3,n))
      allocate (upcg(3,n))
      allocate (uxpt(3,n))
      allocate (utcg(3,n))
      allocate (ustore(3,n,0:maxiter))
c
c     perform dynamic allocation of some global arrays
c
      allocate (uexact(3,n))
      if (use_solv) then
         if (allocated(uopts))  deallocate (uopts)
         if (allocated(uoptps))  deallocate (uoptps)
         allocate (uopts(0:optorder,3,n))
         allocate (uoptps(0:optorder,3,n))
      end if
c
c     find PCG induced dipoles for increasing iteration counts
c
      poltyp = 'MUTUAL'
      done = .false.
      do k = 1, maxiter
         politer = k
         call induce
         do i = 1, n
            do j = 1, 3
               if (use_solv) then
                  ustore(j,i,k) = debye * uinds(j,i)
               else
                  ustore(j,i,k) = debye * uind(j,i)
               end if
            end do
         end do
         sum = 0.0d0
         do i = 1, n
            do j = 1, 3
               sum = sum + (ustore(j,i,k)-ustore(j,i,k-1))**2
            end do
         end do
         drms(k) = sqrt(sum/dble(npolar))
         if (.not. done) then
            if (k.eq.itercut .or. drms(k).lt.epscut) then
               done = .true.
               kpcg = k
               do i = 1, n
                  do j = 1, 3
                     upcg(j,i) = ustore(j,i,k)
                  end do
               end do
            end if
         end if
         if (drms(k) .lt. 0.5d0*poleps)  goto 60
      end do
   60 continue
      maxiter = politer
      do i = 1, n
         do j = 1, 3
            uexact(j,i) = ustore(j,i,maxiter)
         end do
      end do
c
c     print the fully converged SCF induced dipole moments
c
      if (dofull) then
         write (iout,70)
   70    format (/,' Exact SCF Induced Dipole Moments :',
     &           //,4x,'Atom',14x,'X',13x,'Y',13x,'Z',12x,'Norm',/)
         do i = 1, n
            if (use(i) .and. douind(i)) then
               ux = uexact(1,i)
               uy = uexact(2,i)
               uz = uexact(3,i)
               u2 = sqrt(ux*ux+uy*uy+uz*uz)
               write (iout,80)  i,ux,uy,uz,u2
   80          format (i8,4x,4f14.6)
            end if
         end do
      end if
c
c     print the iterative PCG induced dipole moments
c
      if (dofull) then
         write (iout,90)  kpcg
   90    format (/,' Iterative PCG Induced Dipole Moments :',
     &              4x,'(',i3,' Iterations)',
     &           //,4x,'Atom',15x,'X',13x,'Y',13x,'Z',12x,'Norm',/)
         do i = 1, n
            if (use(i) .and. douind(i)) then
               ux = upcg(1,i)
               uy = upcg(2,i)
               uz = upcg(3,i)
               u2 = sqrt(ux*ux+uy*uy+uz*uz)
               write (iout,100)  i,ux,uy,uz,u2
  100          format (i8,4x,4f14.6)
            end if
         end do
      end if
c
c     get induced dipoles for direct polarization only
c
      poltyp = 'DIRECT'
      call induce
      do i = 1, n
         do j = 1, 3
            if (use_solv) then
               udirect(j,i) = debye * uinds(j,i)
            else
               udirect(j,i) = debye * uind(j,i)
            end if
            ustore(j,i,0) = udirect(j,i)
         end do
      end do
c
c     print the direct polarization induced dipole moments
c
      if (dofull) then
         write (iout,110)
  110    format (/,' Direct Induced Dipole Moments :',
     &           //,4x,'Atom',15x,'X',13x,'Y',13x,'Z',12x,'Norm',/)
         do i = 1, n
            if (use(i) .and. douind(i)) then
               ux = udirect(1,i)
               uy = udirect(2,i)
               uz = udirect(3,i)
               u2 = sqrt(ux*ux+uy*uy+uz*uz)
               write (iout,120)  i,ux,uy,uz,u2
  120          format (i8,4x,4f14.6)
            end if
         end do
      end if
c
c     get induced dipoles from OPT extrapolation method
c
      poltyp = savetyp
      if (poltyp(1:3) .ne. 'OPT')  poltyp = 'OPT   '
      call kpolar
      call induce
      do i = 1, n
         do j = 1, 3
            if (use_solv) then
               uxpt(j,i) = debye * uinds(j,i)
            else
               uxpt(j,i) = debye * uind(j,i)
            end if
         end do
      end do
c
c     print the OPT extrapolation induced dipole moments
c
      if (dofull) then
         write (iout,130)  optorder
  130    format (/,' Analytical OPT',i1,' Induced Dipole Moments :',
     &           //,4x,'Atom',15x,'X',13x,'Y',13x,'Z',12x,'Norm',/)
         do i = 1, n
            if (use(i) .and. douind(i)) then
               ux = uxpt(1,i)
               uy = uxpt(2,i)
               uz = uxpt(3,i)
               u2 = sqrt(ux*ux+uy*uy+uz*uz)
               write (iout,140)  i,ux,uy,uz,u2
  140          format (i8,4x,4f14.6)
            end if
         end do
      end if
c
c     get induced dipoles from TCG analytical dipole method
c
      poltyp = savetyp
      if (poltyp(1:3) .ne. 'TCG')  poltyp = 'TCG   '
      call kpolar
      call induce
      do i = 1, n
         do j = 1, 3
            utcg(j,i) = debye * uind(j,i)
         end do
      end do
c
c     print the TCG analytical induced dipole moments
c
      if (dofull .and. .not.use_solv) then
         write (iout,150)  tcgorder
  150    format (/,' Analytical TCG',i1,' Induced Dipole Moments :',
     &           //,4x,'Atom',15x,'X',13x,'Y',13x,'Z',12x,'Norm',/)
         do i = 1, n
            if (use(i) .and. douind(i)) then
               ux = utcg(1,i)
               uy = utcg(2,i)
               uz = utcg(3,i)
               u2 = sqrt(ux*ux+uy*uy+uz*uz)
               write (iout,160)  i,ux,uy,uz,u2
  160          format (i8,4x,4f14.6)
            end if
         end do
      end if
c
c     find differences between approximate and exact dipoles
c
      rdirect = 0.0d0
      rpcg = 0.0d0
      rxpt = 0.0d0
      rtcg = 0.0d0
      m = 0
      do i = 1, n
         if (use(i) .and. douind(i)) then
            m = m + 1
            do j = 1, 3
               ddirect(j,i) = udirect(j,i) - uexact(j,i)
               dpcg(j,i) = upcg(j,i) - uexact(j,i)
               dxpt(j,i) = uxpt(j,i) - uexact(j,i)
               dtcg(j,i) = utcg(j,i) - uexact(j,i)
            end do
            tdirect(i) = sqrt(ddirect(1,i)**2+ddirect(2,i)**2
     &                              +ddirect(3,i)**2)
            tpcg(i) = sqrt(dpcg(1,i)**2+dpcg(2,i)**2+dpcg(3,i)**2)
            txpt(i) = sqrt(dxpt(1,i)**2+dxpt(2,i)**2+dxpt(3,i)**2)
            ttcg(i) = sqrt(dtcg(1,i)**2+dtcg(2,i)**2+dtcg(3,i)**2)
            rdirect = rdirect + tdirect(i)**2
            rpcg = rpcg + tpcg(i)**2
            rxpt = rxpt + txpt(i)**2
            rtcg = rtcg + ttcg(i)**2
         end if
      end do
      rdirect = sqrt(rdirect/dble(m))
      rpcg = sqrt(rpcg/dble(m))
      rxpt = sqrt(rxpt/dble(m))
      rtcg = sqrt(rtcg/dble(m))
c
c     print the RMS between approximate and exact dipoles
c
      if (use_solv) then
         write (iout,170)  saveopt
  170    format (/,' Approximate vs. Exact Induced Dipoles :',
     &           //,4x,'Atom',14x,'Direct',12x,'PCG',12x,'OPT',i1)
      else
         write (iout,180)  saveopt,savetcg
  180    format (/,' Approximate vs. Exact Induced Dipoles :',
     &           //,4x,'Atom',14x,'Direct',12x,'PCG',12x,'OPT',i1,
     &              12x,'TCG',i1)
      end if
      if (dofull) then
         write (iout,190)
  190    format ()
         if (use_solv) then
            do i = 1, n
               if (use(i) .and. douind(i)) then
                  write (iout,200)  i,tdirect(i),tpcg(i),txpt(i)
  200             format (i8,6x,3f16.10)
               end if
            end do
         else
            do i = 1, n
               if (use(i) .and. douind(i)) then
                  write (iout,210)  i,tdirect(i),tpcg(i),txpt(i),ttcg(i)
  210             format (i8,6x,4f16.10)
               end if
            end do
         end if
      end if
      if (use_solv) then
         write (iout,220)  rdirect,rpcg,rxpt
  220    format (/,5x,'RMS',6x,3f16.10)
      else
         write (iout,230)  rdirect,rpcg,rxpt,rtcg
  230    format (/,5x,'RMS',6x,4f16.10)
      end if
c
c     find the RMS of each iteration from the exact dipoles
c
      do k = 0, maxiter
         sum = 0.0d0
         m = 0
         do i = 1, n
            if (use(i) .and. douind(i)) then
               m = m + 1
               do j = 1, 3
                  sum = sum + (ustore(j,i,k)-uexact(j,i))**2
               end do
            end if
         end do
         rms(k) = sqrt(sum/dble(m))
      end do
c
c     print the RMS between iterations and versus exact dipoles
c
      write (iout,240)
  240 format (/,' Iterative PCG Induced Dipole Convergence :',
     &        //,4x,'Iter',12x,'RMS Change',11x,'RMS vs Exact')
      write (iout,250)  0,rms(0)
  250 format (/,i8,15x,'----',6x,f20.10)
      do k = 1, maxiter
         write (iout,260)  k,drms(k),rms(k)
  260    format (i8,2x,f20.10,3x,f20.10)
         if (rms(k) .lt. 0.5d0*poleps)  goto 270
      end do
  270 continue
c
c     refine the extrapolated OPT coefficients via optimization
c
      if (dofitopt) then
         poltyp = savetyp
         if (poltyp(1:3) .ne. 'OPT')  poltyp = 'OPT   '
         call kpolar
         write (iout,280)  optorder
  280    format (/,' Analytical OPT',i1,' Coefficient Refinement :',
     &           //,4x,'Iter',7x,'C0',5x,'C1',5x,'C2',5x,'C3',
     &              5x,'C4',5x,'C5',5x,'C6',5x,'RMS vs Exact',/)
c
c     perform dynamic allocation of some local arrays
c
         nvar = 0
         do i = 0, optorder
            if (copt(i) .ne. 0.0d0)  nvar = nvar + 1
         end do
         allocate (var(nvar))
c
c     count number of variables and define the initial simplex
c
         nvar = 0
         do i = 0, optorder
            if (copt(i) .ne. 0.0d0) then
               nvar = nvar + 1
               var(nvar) = copt(i)
            end if
         end do
c
c     optimize OPT coefficients, then print refined values
c
         iter = 0
         maxiter = 3000
         iprint = 0
         ntest = 200
         step = 0.03d0
         delta = 0.0001d0
         rxpt = 1000.0d0
         call simplex (nvar,iter,ntest,var,rxpt,step,delta,optfit)
         nvar = 0
         do i = 0, optorder
            if (copt(i) .ne. 0.0d0) then
               nvar = nvar + 1
               copt(i) = var(nvar)
            end if
         end do
         write (iout,290)  iter,(copt(i),i=0,6),rxpt
  290    format (i8,3x,7f7.3,f16.10)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (rms)
      deallocate (drms)
      deallocate (tdirect)
      deallocate (tpcg)
      deallocate (txpt)
      deallocate (ttcg)
      deallocate (ddirect)
      deallocate (dpcg)
      deallocate (dxpt)
      deallocate (dtcg)
      deallocate (udirect)
      deallocate (upcg)
      deallocate (uxpt)
      deallocate (utcg)
      deallocate (ustore)
      if (dofitopt)  deallocate (var)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function optfit  --  OPT dipole coefficient refinement  ##
c     ##                                                          ##
c     ##############################################################
c
c
      function optfit (var)
      use atoms
      use iounit
      use polar
      use polopt
      use polpot
      use potent
      use units
      use usage
      implicit none
      integer i,j,k
      integer nvar,iter
      real*8 optfit
      real*8 rxpt
      real*8 var(*)
      real*8, allocatable :: uxpt(:,:)
      logical first
      save first,iter
      data first  / .true. /
c
c
c     count the number of times the function has been called
c
      if (first) then
         first = .false.
         iter = -1
      end if
      iter = iter + 1
c
c     copy optimization variables into extrapolation coefficients
c
      nvar = 0
      do i = 0, maxopt
         if (copt(i) .ne. 0.0d0) then
            nvar = nvar + 1
            copt(i) = var(nvar)
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (uxpt(3,n))
c
c     compute RMS error between OPT and exact SCF dipoles
c
      poltyp = 'OPT'
      call induce
      rxpt = 0.0d0
      k = 0
      do i = 1, n
         if (use(i) .and. douind(i)) then
            k = k + 1
            do j = 1, 3
               if (use_solv) then
                  uxpt(j,i) = debye * uinds(j,i)
               else
                  uxpt(j,i) = debye * uind(j,i)
               end if
               rxpt = rxpt + (uxpt(j,i)-uexact(j,i))**2
c              rxpt = rxpt + (uxpt(j,i)-uexact(j,i))**6
            end do
         end if
      end do
      rxpt = sqrt(rxpt/dble(k))
      if (mod(iter,100) .eq. 0) then
         write (iout,10)  iter,(copt(i),i=0,6),rxpt
   10    format (i8,3x,7f7.3,f16.10)
      end if
c
c     set the return value equal to the RMS error
c
      optfit = rxpt
c
c     perform deallocation of some local arrays
c
      deallocate (uxpt)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  program testrot  --  derivative test; torsional version  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "testrot" computes and compares the analytical and numerical
c     gradient vectors of the potential energy function with respect
c     to rotatable torsional angles
c
c
      program testrot
      use domega
      use energi
      use inform
      use iounit
      use math
      use omega
      use zcoord
      implicit none
      integer i
      real*8 e,e0,etot,energy
      real*8 delta,delta0,eps
      real*8 eb0,ea0,eba0,eub0
      real*8 eaa0,eopb0,eopd0
      real*8 eid0,eit0,et0,ept0
      real*8 ebt0,eat0,ett0,ev0
      real*8 er0,edsp0,ec0,ecd0
      real*8 ed0,em0,ep0,ect0
      real*8 erxf0,es0,elf0
      real*8 eg0,ex0
      real*8, allocatable :: derivs(:)
      real*8, allocatable :: nderiv(:)
      logical exist,query
      character*240 string
c
c
c     set up the molecular mechanics calculation
c
      call initial
      call getint
      call mechanic
      call initrot
c
c     get the stepsize for numerical gradient calculation
c
      delta = -1.0d0
      delta0 = 1.0d-3
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  delta
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)  delta0
   20    format (/,' Enter Finite Difference Stepsize [',d8.1,
     &              ' Deg] :  ',$)
         read (input,30,err=10)  delta
   30    format (f20.0)
      end if
      if (delta .le. 0.0d0)  delta = delta0
      eps = -delta / radian
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(nomega))
c
c     make the call to get analytical torsional derivatives
c
      call gradrot (etot,derivs)
c
c     print the total potential energy of the system
c
      if (digits .ge. 8) then
         write (iout,40)  etot
   40    format (/,' Total Potential Energy :',8x,f20.8,' Kcal/mole')
      else if (digits .ge. 6) then
         write (iout,50)  etot
   50    format (/,' Total Potential Energy :',8x,f18.6,' Kcal/mole')
      else
         write (iout,60)  etot
   60    format (/,' Total Potential Energy :',8x,f16.4,' Kcal/mole')
      end if
c
c     print the energy breakdown over individual components
c
      write (iout,70)
   70 format (/,' Potential Energy Breakdown by Individual',
     &           ' Components :')
      if (digits .ge. 8) then
         write (iout,80)
   80    format (/,'  Energy',7x,'EB',14x,'EA',14x,'EBA',13x,'EUB',
     &           /,'  Terms',8x,'EAA',13x,'EOPB',12x,'EOPD',12x,'EID',
     &           /,15x,'EIT',13x,'ET',14x,'EPT',13x,'EBT',
     &           /,15x,'EAT',13x,'ETT',13x,'EV',14x,'ER',
     &           /,15x,'EDSP',12x,'EC',14x,'ECD',13x,'ED',
     &           /,15x,'EM',14x,'EP',14x,'ECT',13x,'ERXF',
     &           /,15x,'ES',14x,'ELF',13x,'EG',14x,'EX')
         write (iout,90)  eb,ea,eba,eub,eaa,eopb,eopd,eid,eit,
     &                    et,ept,ebt,eat,ett,ev,er,edsp,ec,ecd,
     &                    ed,em,ep,ect,erxf,es,elf,eg,ex
   90    format (/,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8,
     &              /,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8)
      else if (digits .ge. 6) then
         write (iout,100)
  100    format (/,'  Energy',6x,'EB',12x,'EA',12x,'EBA',11x,'EUB',
     &              11x,'EAA',
     &           /,'  Terms',7x,'EOPB',10x,'EOPD',10x,'EID',
     &              11x,'EIT',11x,'ET',
     &           /,14x,'EPT',11x,'EBT',11x,'EAT',11x,'ETT',11x,'EV',
     &           /,14x,'ER',12x,'EDSP',10x,'EC',12x,'ECD',11x,'ED',
     &           /,14x,'EM',12x,'EP',12x,'ECT',11x,'ERXF',10x,'ES',
     &           /,14x,'ELF',11x,'EG',12x,'EX')
         write (iout,110)  eb,ea,eba,eub,eaa,eopb,eopd,eid,eit,
     &                     et,ept,ebt,eat,ett,ev,er,edsp,ec,ecd,
     &                     ed,em,ep,ect,erxf,es,elf,eg,ex
  110    format (/,6x,5f14.6,/,6x,5f14.6,/,6x,5f14.6,/,6x,5f14.6,
     &              /,6x,5f14.6,/,6x,3f14.6)
      else
         write (iout,120)
  120    format (/,'  Energy',6x,'EB',10x,'EA',10x,'EBA',9x,'EUB',
     &              9x,'EAA',9x,'EOPB',
     &           /,'  Terms',7x,'EOPD',8x,'EID',9x,'EIT',9x,'ET',
     &              10x,'EPT',9x,'EBT',
     &           /,14x,'EAT',9x,'ETT',9x,'EV',10x,'ER',10x,'EDSP',
     &              8x,'EC',
     &           /,14x,'ECD',9x,'ED',10x,'EM',10x,'EP',10x,'ECT',
     &              9x,'ERXF',
     &           /,14x,'ES',10x,'ELF',9x,'EG',10x,'EX')
         write (iout,130)  eb,ea,eba,eub,eaa,eopb,eopd,eid,eit,
     &                     et,ept,ebt,eat,ett,ev,er,edsp,ec,ecd,
     &                     ed,em,ep,ect,erxf,es,elf,eg,ex
  130    format (/,6x,6f12.4,/,6x,6f12.4,/,6x,6f12.4,/,6x,6f12.4,
     &               /,6x,4f12.4)
      end if
c
c     print a header for the gradients of individual potentials
c
      write (iout,140)
  140 format (/,' Torsional Gradient Breakdown by Individual',
     &              ' Components :')
      if (digits .ge. 8) then
         write (iout,150)
  150    format (/,2x,'Atom',9x,'d EB',12x,'d EA',12x,'d EBA',
     &              11x,'d EUB',
     &           /,2x,'Axis',9x,'d EAA',11x,'d EOPB',10x,'d EOPD',
     &              10x,'d EID',
     &           /,2x,'Type',9x,'d EIT',11x,'d ET',12x,'d EPT',
     &              11x,'d EBT',
     &           /,15x,'d EAT',10x,'d ETT',10x,'d EV',12x,'d ER',
     &           /,15x,'d EDSP',10x,'d EC',12x,'d ECD',11x,'d ED',
     &           /,15x,'d EM',12x,'d EP',12x,'d ECT',11x,'d ERXF',
     &           /,15x,'d ES',12x,'d ELF',11x,'d EG',12x,'d EX')
      else if (digits .ge. 6) then
         write (iout,160)
  160    format (/,2x,'Atom',8x,'d EB',10x,'d EA',10x,'d EBA',
     &              9x,'d EUB',9x,'d EAA',
     &           /,2x,'Axis',8x,'d EOPB',8x,'d EOPD',8x,'d EID',
     &              9x,'d EIT',9x,'d ET',
     &           /,2x,'Type',8x,'d EPT',9x,'d EBT',9x,'d EAT',
     &              9x,'d ETT',9x,'d EV',
     &           /,14x,'d ER',10x,'d EDSP',8x,'d EC',10x,'d ECD',
     &              9x,'d ED',
     &           /,14x,'d EM',10x,'d EP',10x,'d ECT',9x,'d ERXF',
     &              8x,'d ES',
     &           /,14x,'d ELF',9x,'d EG',10x,'d EX')
      else
         write (iout,170)
  170    format (/,2x,'Atom',6x,'d EB',8x,'d EA',8x,'d EBA',
     &              7x,'d EUB',7x,'d EAA',7x,'d EOPB',
     &           /,2x,'Axis',6x,'d EOPD',6x,'d EID',7x,'d EIT',
     &              7x,'d ET',8x,'d EPT',7x,'d EBT',
     &           /,2x,'Type',6x,'d EAT',7x,'d ETT',7x,'d EV',
     &              8x,'d ER',8x,'d EDSP',6x,'d EC',
     &           /,12x,'d ECD',7x,'d ED',8x,'d EM',8x,'d EP',
     &              8x,'d ECT',7x,'d ERXF',
     &           /,12x,'d ES',8x,'d ELF',7x,'d EG',8x,'d EX')
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (nderiv(nomega))
c
c     get numerical derivatives for each of the rotatable torsions
c
      do i = 1, nomega
         ztors(zline(i)) = ztors(zline(i)) + delta/2.0d0
         call makexyz
         e0 = energy ()
         eb0 = eb
         ea0 = ea
         eba0 = eba
         eub0 = eub
         eaa0 = eaa
         eopb0 = eopb
         eopd0 = eopd
         eid0 = eid
         eit0 = eit
         et0 = et
         ept0 = ept
         ebt0 = ebt
         eat0 = eat
         ett0 = ett
         ev0 = ev
         er0 = er
         edsp0 = edsp
         ec0 = ec
         ecd0 = ecd
         ed0 = ed
         em0 = em
         ep0 = ep
         ect0 = ect
         erxf0 = erxf
         es0 = es
         elf0 = elf
         eg0 = eg
         ex0 = ex
         ztors(zline(i)) = ztors(zline(i)) - delta
         call makexyz
         e = energy ()
         ztors(zline(i)) = ztors(zline(i)) + delta/2.0d0
         nderiv(i) = (e-e0) / eps
c
c     print analytical gradients of each energy term for each atom
c
         if (digits .ge. 8) then
            write (iout,180)  iomega(2,i),teb(i),tea(i),teba(i),teub(i),
     &                        iomega(1,i),teaa(i),teopb(i),teopd(i),
     &                        teid(i),teit(i),tet(i),tept(i),tebt(i),
     &                        teat(i),tett(i),tev(i),ter(i),tedsp(i),
     &                        tec(i),tecd(i),ted(i),tem(i),tep(i),
     &                        tect(i),terxf(i),tes(i),telf(i),teg(i),
     &                        tex(i)
  180       format (/,i6,4f16.8,/,i6,4f16.8,/,' Anlyt',4f16.8,
     &                 /,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8,
     &                 /,6x,4f16.8)
         else if (digits .ge. 6) then
            write (iout,190)  iomega(2,i),teb(i),tea(i),teba(i),teub(i),
     &                        teaa(i),iomega(1,i),teopb(i),teopd(i),
     &                        teid(i),teit(i),tet(i),tept(i),tebt(i),
     &                        teat(i),tett(i),tev(i),ter(i),tedsp(i),
     &                        tec(i),tecd(i),ted(i),tem(i),tep(i),
     &                        tect(i),terxf(i),tes(i),telf(i),teg(i),
     &                        tex(i)
  190       format (/,i6,5f14.6,/,i6,5f14.6,/,' Anlyt',5f14.6,
     &                 /,6x,5f14.6,/,6x,5f14.6,/,6x,3f14.6)
         else
            write (iout,200)  iomega(2,i),teb(i),tea(i),teba(i),teub(i),
     &                        teaa(i),teopb(i),iomega(1,i),teopd(i),
     &                        teid(i),teit(i),tet(i),tept(i),tebt(i),
     &                        teat(i),tett(i),tev(i),ter(i),tedsp(i),
     &                        tec(i),tecd(i),ted(i),tem(i),tep(i),
     &                        tect(i),terxf(i),tes(i),telf(i),teg(i),
     &                        tex(i)
  200       format (/,i6,6f12.4,/,i6,6f12.4,/,' Anlyt',6f12.4,
     &                 /,6x,6f12.4,/,6x,4f12.4)
         end if
c
c     print numerical gradients of each energy term for each atom
c
         if (digits .ge. 8) then
            write (iout,210)  iomega(2,i),(eb-eb0)/eps,(ea-ea0)/eps,
     &                        (eba-eba0)/eps,(eub-eub0)/eps,
     &                        iomega(1,i),(eaa-eaa0)/eps,
     &                        (eopb-eopb0)/eps,(eopd-eopd0)/eps,
     &                        (eid-eid0)/eps,(eit-eit0)/eps,
     &                        (et-et0)/eps,(ept-ept0)/eps,
     &                        (ebt-ebt0)/eps,(eat-eat0)/eps,
     &                        (ett-ett0)/eps,(ev-ev0)/eps,(er-er0)/eps,
     &                        (edsp-edsp0)/eps,(ec-ec0)/eps,
     &                        (ecd-ecd0)/eps,(ed-ed0)/eps,(em-em0)/eps,
     &                        (ep-ep0)/eps,(ect-ect0)/eps,
     &                        (erxf-erxf0)/eps,(es-es0)/eps,
     &                        (elf-elf0)/eps,(eg-eg0)/eps,(ex-ex0)/eps
  210       format (/,i6,4f16.8,/,i6,4f16.8,/,' Numer',4f16.8,
     &                 /,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8,
     &                 /,6x,4f14.8)
         else if (digits .ge. 6) then
            write (iout,220)  iomega(2,i),(eb-eb0)/eps,(ea-ea0)/eps,
     &                        (eba-eba0)/eps,(eub-eub0)/eps,
     &                        (eaa-eaa0)/eps,iomega(1,i),
     &                        (eopb-eopb0)/eps,(eopd-eopd0)/eps,
     &                        (eid-eid0)/eps,(eit-eit0)/eps,
     &                        (et-et0)/eps,(ept-ept0)/eps,
     &                        (ebt-ebt0)/eps,(eat-eat0)/eps,
     &                        (ett-ett0)/eps,(ev-ev0)/eps,(er-er0)/eps,
     &                        (edsp-edsp0)/eps,(ec-ec0)/eps,
     &                        (ecd-ecd0)/eps,(ed-ed0)/eps,(em-em0)/eps,
     &                        (ep-ep0)/eps,(ect-ect0)/eps,
     &                        (erxf-erxf0)/eps,(es-es0)/eps,
     &                        (elf-elf0)/eps,(eg-eg0)/eps,(ex-ex0)/eps
  220       format (/,i6,5f14.6,/,i6,5f14.6,/,' Numer',5f14.6,
     &                 /,6x,5f14.6,/,6x,5f14.6,/,6x,3f14.6)
         else
            write (iout,230)  iomega(2,i),(eb-eb0)/eps,(ea-ea0)/eps,
     &                        (eba-eba0)/eps,(eub-eub0)/eps,
     &                        (eaa-eaa0)/eps,(eopb-eopb0)/eps,
     &                        iomega(1,i),(eopd-eopd0)/eps,
     &                        (eid-eid0)/eps,(eit-eit0)/eps,
     &                        (et-et0)/eps,(ept-ept0)/eps,
     &                        (ebt-ebt0)/eps,(eat-eat0)/eps,
     &                        (ett-ett0)/eps,(ev-ev0)/eps,(er-er0)/eps,
     &                        (edsp-edsp0)/eps,(ec-ec0)/eps,
     &                        (ecd-ecd0)/eps,(ed-ed0)/eps,(em-em0)/eps,
     &                        (ep-ep0)/eps,(ect-ect0)/eps,
     &                        (erxf-erxf0)/eps,(es-es0)/eps,
     &                        (elf-elf0)/eps,(eg-eg0)/eps,(ex-ex0)/eps
  230       format (/,i6,6f12.4,/,i6,6f12.4,/,' Numer',6f12.4,
     &                 /,6x,6f12.4,/,6x,4f12.4)
         end if
      end do
c
c     print a header for the analytical vs. numerical comparison
c
      write (iout,240)
  240 format (/,' Total Torsional Gradient Norm over Rotatable',
     &           ' Bonds :')
      if (digits .ge. 8) then
         write (iout,250)
  250    format (/,5x,'Torsion',19x,'Anlyt Deriv',9x,'Numer Deriv',/)
      else if (digits .ge. 6) then
         write (iout,260)
  260    format (/,5x,'Torsion',18x,'Anlyt Deriv',7x,'Numer Deriv',/)
      else
         write (iout,270)
  270    format (/,5x,'Torsion',17x,'Anlyt Deriv',5x,'Numer Deriv',/)
      end if
c
c     print comparison of analytical and numerical derivatives
c
      if (digits .ge. 8) then
         do i = 1, nomega
            write (iout,280)  iomega(2,i),iomega(1,i),derivs(i),
     &                        nderiv(i)
  280       format (1x,i5,'-',i5,10x,2f20.8)
         end do
      else if (digits .ge. 6) then
         do i = 1, nomega
            write (iout,290)  iomega(2,i),iomega(1,i),derivs(i),
     &                        nderiv(i)
  290       format (1x,i5,'-',i5,10x,2f18.6)
         end do
      else
         do i = 1, nomega
            write (iout,300)  iomega(2,i),iomega(1,i),derivs(i),
     &                        nderiv(i)
  300       format (1x,i5,'-',i5,10x,2f16.4)
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      deallocate (nderiv)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2023  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine testsurf  --  find & compare area and volume  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "testsurf" finds the accessible surface area, excluded volume
c     and their derivatives for a molecular system via the methods of
c     Tim Richmond, Michael Connolly, Craig Kundrot and Patrice Koehl
c
c
      program testsurf
      use atomid
      use atoms
      use files
      use iounit
      use kvdws
      use nonpol
      use ptable
      use vdwpot
      implicit none
      integer i,icrd
      integer nsize,nfudge
      integer freeunit
      real*8 surf,vol
      real*8 probe,rmax
      real*8 reentrant
      real*8 wall,cpu
      real*8, allocatable :: rsolv(:)
      real*8, allocatable :: weight(:)
      real*8, allocatable :: asurf(:)
      real*8, allocatable :: avol(:)
      real*8, allocatable :: dsurf(:,:)
      real*8, allocatable :: dvol(:,:)
      logical exist,query
      logical docrd
      logical doderiv,dovol
      character*240 crdfile
      character*240 string
c
c
c     set up the structure and values for the computation;
c     solute radii can be changed via the keyword mechanism
c
      call initial
      call getxyz
      call active
      call field
      call katom
      call kvdw
c
c     get probe radius for accessible area/excluded volume
c
      probe = 0.0d0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  probe
         query = .false.
      end if
   10 continue
      if (query) then
         probe = -1.0d0
         write (iout,20)
   20    format (/,' Enter a Value for the Probe Radius',
     &              ' [1.4 Ang] :  ',$)
         read (input,30)  string
   30    format (a240)
         read (string,*,err=40,end=40)  probe
         goto 50
   40    continue
         probe = 1.4d0
   50    continue
      end if
c
c     print out the total number of atoms
c
      write (iout,60)
   60 format (/,' Alternative Surface Area & Volume Methods')
      write (iout,70)  n,probe
   70 format (/,' Number of Atoms :',15x,i8,
     &        /,' Probe Size :',16x,f12.4)
c
c     perform dynamic allocation of some local arrays
c
      nfudge = 10
      nsize = n + nfudge
      allocate (rsolv(nsize))
      allocate (weight(nsize))
      allocate (asurf(nsize))
      allocate (avol(nsize))
      allocate (dsurf(3,nsize))
      allocate (dvol(3,nsize))
c
c     if all radii are zero then switch to generic vdw radii
c
      rmax = 0.0d0
      do i = 1, n
         rmax = rad(i)
         if (rmax .gt. 0.0d0)  goto 80
      end do
   80 continue
      if (rmax .eq. 0.0d0) then
         write (iout,90)
   90    format (/,' Atomic Radii not Set, Using Generic VDW Values')
         do i = 1, n
            rad(i) = vdwrad(atomic(i))
         end do
      end if
c
c     set radii to use for surface area and volume calculation
c
      do i = 1, n
         if (vdwindex .eq. 'CLASS') then
            rsolv(i) = rad(class(i))
         else
            rsolv(i) = rad(type(i))
         end if
         weight(i) = 1.0d0
      end do
c
c     initialize variables for Richmond and Connolly routines
c
      surf = 0.0d0
      vol = 0.0d0
      reentrant = 0.0d0
      do i = 1, n
         asurf(i) = 0.0d0
         dsurf(1,i) = 0.0d0
         dsurf(2,i) = 0.0d0
         dsurf(3,i) = 0.0d0
      end do
c
c     compute accessible surface area via Richmond method
c
      surf = 0.0d0
      write (iout,100)
  100 format (/,' Timothy Richmond Accessible Surface Area Method :')
      call settime
      call richmond (n,x,y,z,rsolv,weight,probe,surf,asurf)
      call gettime (wall,cpu)
      write (iout,110)  cpu,wall
  110 format (/,' CPU and Wall Times :',8x,2f12.4) 
      write (iout,120)  surf
  120 format (/,' Total Surface Area :',8x,f12.4)
c
c     compute accessible surface and derivatives via Richmond
c
      surf = 0.0d0
      write (iout,130)
  130 format (/,' Timothy Richmond Surface Area Derivative Method :')
      call settime
      call richmond1 (n,x,y,z,rsolv,weight,probe,surf,asurf,dsurf)
      call gettime (wall,cpu)
      write (iout,140)  cpu,wall
  140 format (/,' CPU and Wall Times :',8x,2f12.4)
      write (iout,150)  surf
  150 format (/,' Total Surface Area :',8x,f12.4)
      write (iout,160)
  160 format (/,' Surface Area Derivatives :  (First Ten Atoms)',
     &        //,5x,'Atom',11x,'dAx',7x,'dAy',7x,'dAz',/)
      do i = 1, min(10,n)
         write (iout,170)  i,dsurf(1,i),dsurf(2,i),dsurf(3,i)
  170    format (i8,6x,3f10.4)
      end do
c
c     compute surface area and excluded volume via Connolly
c
      surf = 0.0d0
      vol = 0.0d0
      write (iout,180)
  180 format (/,' Michael Connolly Molecular Area-Volume Method :')
      call settime
      call connolly (n,x,y,z,rsolv,probe,reentrant,surf,vol)
      call gettime (wall,cpu)
      write (iout,190)  cpu,wall
  190 format (/,' CPU and Wall Times :',8x,2f12.4)
      write (iout,200)  surf
  200 format (/,' Total Surface Area :',8x,f12.4)
      write (iout,210)  vol
  210 format (/,' Total Excluded Volume :',5x,f12.4)
c
c     compute excluded volume derivatives via Kundrot method
c
      do i = 1, n
         dvol(1,i) = 0.0d0
         dvol(2,i) = 0.0d0
         dvol(3,i) = 0.0d0
      end do
      write (iout,220)
  220 format (/,' Craig Kundrot Excluded Volume Derivative Method :')
      call settime
      call kundrot1 (n,x,y,z,rsolv,probe,dvol)
      call gettime (wall,cpu)
      write (iout,230)  cpu,wall
  230 format (/,' CPU and Wall Times :',8x,2f12.4)
      write (iout,240)
  240 format (/,' Excluded Volume Derivatives :  (First Ten Atoms)',
     &        //,5x,'Atom',11x,'dVx',7x,'dVy',7x,'dVz',/)
      do i = 1, min(10,n)
         write (iout,250)  i,dvol(1,i),dvol(2,i),dvol(3,i)
  250    format (i8,6x,3f10.4)
      end do

c
c     initialize variables for Koehl UnionBall routines
c
      doderiv = .true.
      dovol = .true.
      surf = 0.0d0
      vol = 0.0d0
      do i = 1, n
         asurf(i) = 0.0d0
         avol(i) = 0.0d0
         dsurf(1,i) = 0.0d0
         dsurf(2,i) = 0.0d0
         dsurf(3,i) = 0.0d0
         dvol(1,i) = 0.0d0
         dvol(2,i) = 0.0d0
         dvol(3,i) = 0.0d0
      end do
c
c     print out structure in UnionBall coordinate format
c
      docrd = .false.
      if (docrd) then
         icrd = freeunit ()
         crdfile = filename(1:leng)//'.crd'
         call version (crdfile,'new')
         open (unit=icrd,file=crdfile,status='new')
         write (icrd,260)  n
  260    format (i8,/)
         do i = 1, n
            write (icrd,270)  i,x(i),y(i),z(i),rsolv(i)
  270       format (i8,3f14.6,f12.4)
         end do
         close (unit=icrd)
      end if
c
c     compute area, volume and derivatives via UnionBall
c
      write (iout,280)
  280 format (/,' Patrice Koehl UnionBall Alpha Shape Method :')
      call settime
      call unionball (n,x,y,z,rsolv,weight,probe,doderiv,dovol,
     &                   surf,vol,asurf,avol,dsurf,dvol)
      call gettime (wall,cpu)
      write (iout,290)  cpu,wall
  290 format (/,' CPU and Wall Times :',8x,2f12.4)
      write (iout,300)  surf
  300 format (/,' Total Surface Area :',8x,f12.4)
      write (iout,310)  vol
  310 format (/,' Total Excluded Volume :',5x,f12.4)
      write (iout,320)
  320 format (/,' Surface Area & Volume Derivatives :',
     &           '  (First Ten Atoms)',
     &        //,5x,'Atom',11x,'dAx',7x,'dAy',7x,'dAz',
     &           7x,'dVx',7x,'dVy',7x,'dVz',/)
      do i = 1, min(10,n)
         write (iout,330)  i,dsurf(1,i),dsurf(2,i),dsurf(3,i),
     &                     dvol(1,i),dvol(2,i),dvol(3,i)
  330    format (i8,6x,6f10.4)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (rsolv)
      deallocate (weight)
      deallocate (asurf)
      deallocate (avol)
      deallocate (dsurf)
      deallocate (dvol)
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2018  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program testvir  --  check analytical & numerical virial  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "testvir" computes the analytical internal virial and compares
c     it to a numerical virial derived from the finite difference
c     derivative of the energy with respect to lattice vectors
c
c
      program testvir
      use atoms
      use inform
      use iounit
      use virial
      implicit none
      integer i
      real*8 energy
      real*8, allocatable :: derivs(:,:)
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     set option control flags based desired analysis types
c
      debug = .false.
      allocate (derivs(3,n))
      call gradient (energy,derivs)
      deallocate (derivs)
c
c     print the components of the analytical internal virial
c
      write (iout,10)  (vir(1,i),vir(2,i),vir(3,i),i=1,3)
   10 format (/,' Analytical Virial Tensor :',9x,3f13.3,
     &           /,36x,3f13.3,/,36x,3f13.3)
c
c     get the numerical dE/dV value and a pressure estimate
c
      call ptest
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ptest  --  find pressure via finite differences  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ptest" determines the numerical virial tensor, and compares
c     analytical to numerical values for dE/dV and isotropic pressure
c
c     original version written by John D. Chodera, University of
c     California, Berkeley, December 2010
c
c     modified for off-diagonal numerical virial by Jay W. Ponder,
c     Saint Louis, August 2018
c
c
      subroutine ptest
      use atoms
      use bath
      use bound
      use boxes
      use iounit
      use math
      use units
      use virial
      implicit none
      integer i,j,k
      real*8 energy,epos,eneg
      real*8 eps,temp,lorig
      real*8 dedv_vir,dedv_num
      real*8 pres_vir,pres_num
      real*8 dedl(3,3)
      real*8 virn(3,3)
      real*8, allocatable :: xf(:)
      real*8, allocatable :: yf(:)
      real*8, allocatable :: zf(:)
c
c
c     set relative volume change for finite-differences
c
      if (.not. use_bounds)  return
      eps = 0.00003d0
c
c     set prism lattice type to the general triclinic case
c
      if (.not. nonprism) then
         orthogonal = .false.
         monoclinic = .false.
         triclinic = .true.
      end if
c
c     print out the lattice vectors as matrix rows
c
      write (iout,10)  (lvec(1,i),lvec(2,i),lvec(3,i),i=1,3)
   10 format (/,' Lattice Vectors (Lvec) :',11x,3f13.3,
     &           /,36x,3f13.3,/,36x,3f13.3)
c
c     perform dynamic allocation of some local arrays
c
      allocate (xf(n))
      allocate (yf(n))
      allocate (zf(n))
c
c     store the original fractional coordinate values
c
      do i = 1, n
         xf(i) = x(i)*recip(1,1) + y(i)*recip(2,1) + z(i)*recip(3,1)
         yf(i) = x(i)*recip(1,2) + y(i)*recip(2,2) + z(i)*recip(3,2)
         zf(i) = x(i)*recip(1,3) + y(i)*recip(2,3) + z(i)*recip(3,3)
      end do
c
c     get energy derivatives with respect to lattice vectors
c
      do i = 1, 3
         do j = i, 3
            dedl(j,i) = 0.0d0
         end do
      end do
      do i = 1, 3
         do j = i, 3
            lorig = lvec(j,i)
            lvec(j,i) = lorig - eps
            call cellang (xf,yf,zf)
            eneg = energy ()
            lvec(j,i) = lorig + eps
            call cellang (xf,yf,zf)
            epos = energy ()
            lvec(j,i) = lorig
            call cellang (xf,yf,zf)
            dedl(j,i) = 0.5d0 * (epos-eneg) / eps
         end do
      end do
c
c     print out the partial derivatives of the energy
c
      write (iout,20)  (dedl(1,i),dedl(2,i),dedl(3,i),i=1,3)
   20 format (/,' dE/dLvec Derivatives :',13x,3f13.3,
     &           /,36x,3f13.3,/,36x,3f13.3)
c
c     perform deallocation of some local arrays
c
      deallocate (xf)
      deallocate (yf)
      deallocate (zf)
c
c     compute and print numerical virial tensor components
c
      do i = 1, 3
         do j = 1, i
            virn(j,i) = 0.0d0
            do k = 1, 3
               virn(j,i) = virn(j,i) + dedl(k,j)*lvec(k,i)
            end do
            virn(i,j) = virn(j,i)
         end do
      end do
      if (dodecadron) then
         write (iout,30)  (virn(1,1)+virn(2,2)+virn(3,3))/3.0d0
   30    format (/,' Numerical Mean Diagonal :',10x,f13.3)
      else if (octahedron) then
         write (iout,40)  virn(1,1),virn(2,2),virn(3,3)
   40    format (/,' Numerical Virial Diagonal :',8x,3f13.3)
      else
         write (iout,50)  (virn(1,i),virn(2,i),virn(3,i),i=1,3)
   50    format (/,' Numerical Virial Tensor :',10x,3f13.3,
     &              /,36x,3f13.3,/,36x,3f13.3)
      end if
c
c     find the analytical and numerical values of dE/dV
c
      dedv_vir = (vir(1,1)+vir(2,2)+vir(3,3)) / (3.0d0*volbox)
      dedv_num = (virn(1,1)+virn(2,2)+virn(3,3)) / (3.0d0*volbox)
c
c     get analytical and numerical isotropic pressure values
c
      temp = kelvin
      if (temp .eq. 0.0d0)  temp = 298.0d0
      pres_vir = prescon * (dble(n)*gasconst*temp/volbox-dedv_vir)
      pres_num = prescon * (dble(n)*gasconst*temp/volbox-dedv_num)
      write (iout,60)  nint(temp),pres_vir
   60 format (/,' Pressure (Analytical,',i4,' K) :',5x,f13.3,
     &           ' Atmospheres')
      write (iout,70)  nint(temp),pres_num
   70 format (' Pressure (Numerical,',i4,' K) :',6x,f13.3,
     &           ' Atmospheres')
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine cellang  --  lattice vectors to cell parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "cellang" computes atomic coordinates and unit cell parameters
c     from fractional coordinates and lattice vectors
c
c
      subroutine cellang (xf,yf,zf)
      use atoms
      use boxes
      use math
      implicit none
      integer i
      real*8 amag,bmag,cmag
      real*8 abdot,acdot,bcdot
      real*8 xf(*),yf(*),zf(*)
c
c
c     update coordinates via fractionals and lattice vectors
c
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
c
c     compute unit cell lengths and angles from lattice vectors
c
      amag = sqrt(lvec(1,1)**2+lvec(1,2)**2+lvec(1,3)**2)
      bmag = sqrt(lvec(2,1)**2+lvec(2,2)**2+lvec(2,3)**2)
      cmag = sqrt(lvec(3,1)**2+lvec(3,2)**2+lvec(3,3)**2)
      abdot = lvec(1,1)*lvec(2,1) + lvec(1,2)*lvec(2,2)
     &           + lvec(1,3)*lvec(2,3)
      acdot = lvec(1,1)*lvec(3,1) + lvec(1,2)*lvec(3,2)
     &           + lvec(1,3)*lvec(3,3)
      bcdot = lvec(2,1)*lvec(3,1) + lvec(2,2)*lvec(3,2)
     &           + lvec(2,3)*lvec(3,3)
      xbox = amag
      ybox = bmag
      zbox = cmag
      alpha = radian * acos(bcdot/(bmag*cmag))
      beta = radian * acos(acdot/(amag*cmag))
      gamma = radian * acos(abdot/(amag*bmag))
c
c     reset lattice parameters, box dimensions and volume
c
      call lattice
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2025  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module tettor  --  tetratorsions in the current structure  ##
c     ##                                                             ##
c     #################################################################
c
c
c     ntettor  total number of tetratorsions in the system
c     itettor  numbers of the atoms in each tetratorsion
c
c
      module tettor
      implicit none
      integer ntettor
      integer, allocatable :: itettor(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2025  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine tettors  --  locate and store tetratorsions  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "tettors" finds the total number of tetratorsions as tuples
c     of adjacent torsional angles, and the numbers of the seven
c     atoms defining each tetratorsion
c
c
      subroutine tettors
      use atoms
      use bitor
      use couple
      use tettor
      implicit none
      integer i,j,k
      integer ia,ib,ic,id
      integer ie,ig,ih
c
c
c     initial count of the total number of tetratorsions
c
      ntettor = 0
      do i = 1, nbitor
         ib = ibitor(1,i)
         ic = ibitor(2,i)
         id = ibitor(3,i)
         ie = ibitor(4,i)
         ig = ibitor(5,i)
         do j = 1, n12(ib)
            ia = i12(j,ib)
            if (ia.ne.ic .and. ia.ne.id .and.
     &          ia.ne.ie .and. ia.ne.ig) then
               do k = 1, n12(ig)
                  ih = i12(k,ig)
                  if (ih.ne.ie .and. ih.ne.id .and. ih.ne.ic
     &                .and. ih.ne.ib .and. ih.ne.ia) then
                     ntettor = ntettor + 1
                  end if
               end do
            end if
         end do
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(itettor))  deallocate (itettor)
      allocate (itettor(7,ntettor))
c
c     store the list of atoms involved in each tetratorsion
c
      ntettor = 0
      do i = 1, nbitor
         ib = ibitor(1,i)
         ic = ibitor(2,i)
         id = ibitor(3,i)
         ie = ibitor(4,i)
         ig = ibitor(5,i)
         do j = 1, n12(ib)
            ia = i12(j,ib)
            if (ia.ne.ic .and. ia.ne.id .and.
     &          ia.ne.ie .and. ia.ne.ig) then
               do k = 1, n12(ig)
                  ih = i12(k,ig)
                  if (ih.ne.ie .and. ih.ne.id .and. ih.ne.ic
     &                .and. ih.ne.ib .and. ih.ne.ia) then
                     ntettor = ntettor + 1
                     itettor(1,ntettor) = ia
                     itettor(2,ntettor) = ib
                     itettor(3,ntettor) = ic
                     itettor(4,ntettor) = id
                     itettor(5,ntettor) = ie
                     itettor(6,ntettor) = ig
                     itettor(7,ntettor) = ih
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  program timer  --  timer for Cartesian energy functions  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "timer" measures the CPU time required for file reading and
c     parameter assignment, potential energy computation, energy
c     and gradient computation, and Hessian matrix evaluation
c
c
      program timer
      use atoms
      use hescut
      use inform
      use iounit
      use limits
      use polpot
      implicit none
      integer i,ncalls,next
      integer, allocatable :: hindex(:)
      integer, allocatable :: hinit(:,:)
      integer, allocatable :: hstop(:,:)
      real*8 value,energy
      real*8 wall,cpu
      real*8, allocatable :: h(:)
      real*8, allocatable :: hdiag(:,:)
      real*8, allocatable :: derivs(:,:)
      logical exist,query
      logical dohessian
      character*1 answer
      character*240 record
      character*240 string
c
c
c     read in the molecular system to be timed
c
      call initial
      call getxyz
c
c     get the number of calculation cycles to perform
c
      ncalls = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  ncalls
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' Enter Desired Number of Repetitions [1] :  ',$)
         read (input,30)  ncalls
   30    format (i10)
      end if
      if (ncalls .eq. 0)  ncalls = 1
c
c     decide whether to include timing of Hessian evaluations
c
      dohessian = .false.
      if (n .le. 10000) then
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,40)
   40       format (/,' Include Timing for Hessian Evaluations',
     &                 ' [N] :  ',$)
            read (input,50)  record
   50       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  dohessian = .true.
      end if
c
c     perform dynamic allocation of some local arrays
c
      if (dohessian) then
         allocate (hindex((3*n*(3*n-1))/2))
         allocate (hinit(3,n))
         allocate (hstop(3,n))
         allocate (h((3*n*(3*n-1))/2))
         allocate (hdiag(3,n))
      end if
      allocate (derivs(3,n))
c
c     get the timing for setup of the calculation
c
      call settime
      call mechanic
      if (use_list)  call nblist
      call gettime (wall,cpu)
      write (iout,60)  ncalls
   60 format (/,' Total Wall Clock and CPU Time in Seconds for',
     &           i6,' Evaluations :')
      write (iout,70)  wall,cpu
   70 format (/,' Computation Set-up :',f15.3,' Sec (Wall)',
     &           f15.3,' Sec (CPU)')
c
c     set a large Hessian cutoff and turn off extra printing
c
      hesscut = 1.0d0
      verbose = .false.
      polprt = .false.
c
c     run the potential energy only timing experiment
c
      call settime
      do i = 1, ncalls
         value = energy ()
      end do
      call gettime (wall,cpu)
      write (iout,80)  wall,cpu
   80 format (/,' Potential Energy :  ',f15.3,' Sec (Wall)',
     &           f15.3,' Sec (CPU)')
c
c     run the energy and gradient timing experiment
c
      call settime
      do i = 1, ncalls
         call gradient (value,derivs)
      end do
      call gettime (wall,cpu)
      write (iout,90)  wall,cpu
   90 format (/,' Energy & Gradient : ',f15.3,' Sec (Wall)',
     &           f15.3,' Sec (CPU)')
c
c     run the Hessian matrix only timing experiment
c
      if (dohessian) then
         call settime
         do i = 1, ncalls
            call hessian (h,hinit,hstop,hindex,hdiag)
         end do
         call gettime (wall,cpu)
         write (iout,100)  wall,cpu
  100    format (/,' Hessian Matrix :    ',f15.3,' Sec (Wall)',
     &              f15.3,' Sec (CPU)')
      end if
c
c     repeat the potential energy only timing experiment
c
      call settime
      do i = 1, ncalls
         value = energy ()
      end do
      call gettime (wall,cpu)
      write (iout,110)  wall,cpu
  110 format (/,' Potential Energy :  ',f15.3,' Sec (Wall)',
     &           f15.3,' Sec (CPU)')
c
c     repeat the energy and gradient timing experiment
c
      call settime
      do i = 1, ncalls
         call gradient (value,derivs)
      end do
      call gettime (wall,cpu)
      write (iout,120)  wall,cpu
  120 format (/,' Energy & Gradient : ',f15.3,' Sec (Wall)',
     &           f15.3,' Sec (CPU)')
c
c     repeat the Hessian matrix only timing experiment
c
      if (dohessian) then
         call settime
         do i = 1, ncalls
            call hessian (h,hinit,hstop,hindex,hdiag)
         end do
         call gettime (wall,cpu)
         write (iout,130)  wall,cpu
  130    format (/,' Hessian Matrix :    ',f15.3,' Sec (Wall)',
     &              f15.3,' Sec (CPU)')
      end if
c
c     perform deallocation of some local arrays
c
      if (dohessian) then
         deallocate (hindex)
         deallocate (hinit)
         deallocate (hstop)
         deallocate (h)
         deallocate (hdiag)
      end if
      deallocate (derivs)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  program timerot  --  timer for torsional energy terms  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "timerot" measures the CPU time required for file reading
c     and parameter assignment, potential energy computation,
c     energy and gradient over torsions, and torsional angle
c     Hessian matrix evaluation
c
c
      program timerot
      use hescut
      use inform
      use iounit
      use limits
      use omega
      use polpot
      implicit none
      integer i,ncalls,next
      real*8 energy,value
      real*8 wall,cpu
      real*8, allocatable :: derivs(:)
      real*8, allocatable :: hrot(:,:)
      logical exist,query
      logical dohessian
      character*1 answer
      character*240 record
      character*240 string
c
c
c     read in the molecular system to be timed
c
      call initial
      call getint
c
c     get the timing for setup of the calculation
c
      call settime
      call mechanic
      call initrot
      if (use_list)  call nblist
      call gettime (wall,cpu)
c
c     get the number of calculation cycles to perform
c
      ncalls = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  ncalls
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' Enter Desired Number of Repetitions [1] :  ',$)
         read (input,30)  ncalls
   30    format (i10)
      end if
      if (ncalls .eq. 0)  ncalls = 1
c
c     decide whether to include timing of Hessian evaluations
c
      dohessian = .false.
      if (nomega .le. 1000) then
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,40)
   40       format (/,' Include Timing for Hessian Evaluations',
     &                 ' [N] :  ',$)
            read (input,50)  record
   50       format (a240)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  dohessian = .true.
      end if
c
c     print the time required for the computation setup
c
      write (iout,60)  ncalls
   60 format (/,' Total Wall Clock and CPU Time in Seconds for',
     &           i6,' Evaluations :')
      write (iout,70)  wall,cpu
   70 format (/,' Computation Set-up :',f15.3,' Sec (Wall)',
     &           f15.3,' Sec (CPU)')
c
c     set a large Hessian cutoff and turn off extra printing
c
      hesscut = 1.0d0
      verbose = .false.
      polprt = .false.
c
c     run the potential energy only timing experiment
c
      call settime
      do i = 1, ncalls
         value = energy ()
      end do
      call gettime (wall,cpu)
      write (iout,80)  wall,cpu
   80 format (/,' Potential Energy :  ',f15.3,' Sec (Wall)',
     &           f15.3,' Sec (CPU)')
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(nomega))
      allocate (hrot(nomega,nomega))
c
c     run the energy and gradient timing experiment
c
      call settime
      do i = 1, ncalls
         call gradrot (value,derivs)
      end do
      call gettime (wall,cpu)
      write (iout,90)  wall,cpu
   90 format (/,' Energy & Gradient : ',f15.3,' Sec (Wall)',
     &           f15.3,' Sec (CPU)')
c
c     run the Hessian matrix only timing experiment
c
      if (dohessian) then
         call settime
         do i = 1, ncalls
            call hessrot ('FULL',hrot)
         end do
         call gettime (wall,cpu)
         write (iout,100)  wall,cpu
  100    format (/,' Hessian Matrix :    ',f15.3,' Sec (Wall)',
     &              f15.3,' Sec (CPU)')
      end if
c
c     repeat the potential energy only timing experiment
c
      call settime
      do i = 1, ncalls
         value = energy ()
      end do
      call gettime (wall,cpu)
      write (iout,110)  wall,cpu
  110 format (/,' Potential Energy :  ',f15.3,' Sec (Wall)',
     &           f15.3,' Sec (CPU)')
c
c     repeat the energy and gradient timing experiment
c
      call settime
      do i = 1, ncalls
         call gradrot (value,derivs)
      end do
      call gettime (wall,cpu)
      write (iout,120)  wall,cpu
  120 format (/,' Energy & Gradient : ',f15.3,' Sec (Wall)',
     &           f15.3,' Sec (CPU)')
c
c     repeat the Hessian matrix only timing experiment
c
      if (dohessian) then
         call settime
         do i = 1, ncalls
            call hessrot ('FULL',hrot)
         end do
         call gettime (wall,cpu)
         write (iout,130)  wall,cpu
  130    format (/,' Hessian Matrix :    ',f15.3,' Sec (Wall)',
     &              f15.3,' Sec (CPU)')
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      deallocate (hrot)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module titles  --  title for current molecular system  ##
c     ##                                                         ##
c     #############################################################
c
c
c     ltitle   length in characters of the nonblank title string
c     title    title used to describe the current structure
c
c
      module titles
      implicit none
      integer ltitle
      character*240 title
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine tncg  --  truncated Newton optimization method  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "tncg" implements a truncated Newton optimization algorithm
c     in which a preconditioned linear conjugate gradient method is
c     used to approximately solve Newton's equations; special features
c     include use of an explicit sparse Hessian or finite-difference
c     gradient-Hessian products within the PCG iteration; the exact
c     Newton search directions can be used optionally; by default the
c     algorithm checks for negative curvature to prevent convergence
c     to a stationary point having negative eigenvalues; if a saddle
c     point is desired this test can be removed by disabling "negtest"
c
c     literature references:
c
c     J. W. Ponder and F. M Richards, "An Efficient Newton-like
c     Method for Molecular Mechanics Energy Minimization of
c     Large Molecules", Journal of Computational Chemistry,
c     8, 1016-1024 (1987)
c
c     R. S. Dembo and T. Steihaug, "Truncated-Newton Algorithms
c     for Large-Scale Unconstrained Optimization", Mathematical
c     Programming, 26, 190-212 (1983)
c
c     D. S. Kershaw, "The Incomplete Cholesky-Conjugate Gradient
c     Method for the Iterative Solution of Systems of Linear Equations",
c     Journal of Computational Physics, 26, 43-65 (1978)
c
c     variables and parameters:
c
c     mode       determines optimization method; choice of
c                  Newton's method, truncated Newton, or
c                  truncated Newton with finite differencing
c     method     determines which type of preconditioning will
c                  be used on the Newton equations; choice
c                  of none, diagonal, 3x3 block diagonal,
c                  SSOR or incomplete Cholesky preconditioning
c     nvar       number of parameters in the objective function
c     minimum    upon return contains the best value of the
c                  function found during the optimization
c     f          contains current best value of function
c     x0         contains starting point upon input, upon
c                  return contains the best point found
c     g          contains gradient of current best point
c     h          contains the Hessian matrix values in an
c                  indexed linear array
c     h_mode     controls amount of Hessian matrix computed;
c                  either the full matrix, diagonal or none
c     h_init     points to the first Hessian matrix element
c                  associated with each parameter
c     h_stop     points to the last Hessian matrix element
c                  associated with each parameter
c     h_index    contains second parameter involved in each
c                  element of the Hessian array
c     h_diag     contains diagonal of the Hessian matrix
c     p          search direction resulting from pcg iteration
c     f_move     function decrease over last tncg iteration
c     f_old      function value at end of last iteration
c     x_move     rms movement per atom over last tn iteration
c     x_old      parameters value at end of last tn iteration
c     g_norm     Euclidian norm of the gradient vector
c     g_rms      root mean square gradient value
c     fg_call    cumulative number of function/gradient calls
c     grdmin     termination criterion based on RMS gradient
c     iprint     print iteration results every iprint iterations
c     iwrite     call user-supplied output every iwrite iterations
c     newhess    number of iterations between the computation
c                  of new Hessian matrix values
c     negtest    determines whether test for negative curvature
c                  is performed during the PCG iterations
c     maxiter    maximum number of tncg iterations to attempt
c
c     parameters used in the line search:
c
c     cappa      accuarcy of line search control  (0 < cappa < 1)
c     stpmin     minimum allowed line search step size
c     stpmax     maximum allowed line search step size
c     angmax     maximum angle between search and -grad directions
c     intmax     maximum number of interpolations in line search
c
c     required external routines:
c
c     fgvalue    function to evaluate function and gradient values
c     hmatrix    subroutine which evaluates Hessian diagonal
c                  and large off-diagonal matrix elements
c     optsave    subroutine to write out info about current status
c
c
      subroutine tncg (mode,method,nvar,x0,minimum,grdmin,
     &                       fgvalue,hmatrix,optsave)
      use atoms
      use hescut
      use inform
      use iounit
      use keys
      use linmin
      use math
      use minima
      use output
      use piorbs
      use potent
      implicit none
      integer i,fg_call
      integer nvar,nmax
      integer iter_tn,iter_cg
      integer next,newhess
      integer nerr,maxerr
      integer, allocatable :: h_init(:)
      integer, allocatable :: h_stop(:)
      integer, allocatable :: h_index(:)
      real*8 f,fgvalue,grdmin
      real*8 minimum,angle,rms
      real*8 x_move,f_move,f_old
      real*8 g_norm,g_rms
      real*8 x0(*)
      real*8, allocatable :: x_old(:)
      real*8, allocatable :: g(:)
      real*8, allocatable :: p(:)
      real*8, allocatable :: h_diag(:)
      real*8, allocatable :: h(:)
      logical done,negtest
      logical automode,automatic
      character*4 h_mode
      character*6 mode,method
      character*9 status
      character*9 info_solve
      character*9 info_search
      character*20 keyword
      character*240 record
      character*240 string
      save h_index,h
      external fgvalue
      external hmatrix
      external optsave
c
c
c     check number of variables and get type of optimization
c
      rms = sqrt(dble(nvar))
      if (coordtype .eq. 'CARTESIAN') then
         rms = rms / sqrt(3.0d0)
      else if (coordtype .eq. 'RIGIDBODY') then
         rms = rms / sqrt(6.0d0)
      end if
c
c     set default parameters for the optimization
c
      if (fctmin .eq. 0.0d0)  fctmin = -100000000.0d0
      if (iwrite .lt. 0)  iwrite = 1
      if (iprint .lt. 0)  iprint = 1
      if (maxiter .eq. 0)  maxiter = 1000
      if (nextiter .eq. 0)  nextiter = 1
      newhess = 1
      maxerr = 3
      done = .false.
      status = '         '
      negtest = .true.
      automode = .false.
      automatic = .false.
      if (mode .eq. 'AUTO')  automode = .true.
      if (method .eq. 'AUTO')  automatic = .true.
c
c     set default parameters for the line search
c
      if (stpmax .eq. 0.0d0)  stpmax = 5.0d0
      stpmin = 1.0d-16
      cappa = 0.1d0
      slpmax = 10000.0d0
      angmax = 180.0d0
      intmax = 8
c
c     search each line of the keyword file for options
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:7) .eq. 'FCTMIN ') then
            read (string,*,err=10,end=10)  fctmin
         else if (keyword(1:8) .eq. 'MAXITER ') then
            read (string,*,err=10,end=10)  maxiter
         else if (keyword(1:9) .eq. 'NEXTITER ') then
            read (string,*,err=10,end=10)  nextiter
         else if (keyword(1:8) .eq. 'NEWHESS ') then
            read (string,*,err=10,end=10)  newhess
         else if (keyword(1:12) .eq. 'SADDLEPOINT ') then
            negtest = .false.
         else if (keyword(1:8) .eq. 'STEPMIN ') then
            read (string,*,err=10,end=10)  stpmin
         else if (keyword(1:8) .eq. 'STEPMAX ') then
            read (string,*,err=10,end=10)  stpmax
         else if (keyword(1:6) .eq. 'CAPPA ') then
            read (string,*,err=10,end=10)  cappa
         else if (keyword(1:9) .eq. 'SLOPEMAX ') then
            read (string,*,err=10,end=10)  slpmax
         else if (keyword(1:7) .eq. 'ANGMAX ') then
            read (string,*,err=10,end=10)  angmax
         else if (keyword(1:7) .eq. 'INTMAX ') then
            read (string,*,err=10,end=10)  intmax
         end if
   10    continue
      end do
c
c     initialize the function call and iteration counters
c
      fg_call = 0
      nerr = 0
      iter_tn = nextiter - 1
      maxiter = iter_tn + maxiter
c
c     print header information about the method used
c
      if (iprint .gt. 0) then
         if (mode .eq. 'NEWTON') then
            write (iout,20)
   20       format (/,' Full-Newton Conjugate-Gradient',
     &                 ' Optimization :')
         else if (mode .eq. 'TNCG') then
            write (iout,30)
   30       format (/,' Truncated-Newton Conjugate-Gradient',
     &                 ' Optimization :')
         else if (mode .eq. 'DTNCG') then
            write (iout,40)
   40       format (/,' Finite-Difference Truncated-Newton',
     &                 ' Conjugate-Gradient Optimization :')
         else if (mode .eq. 'AUTO') then
            write (iout,50)
   50       format (/,' Variable-Mode Truncated-Newton',
     &                 ' Conjugate-Gradient Optimization :')
         end if
         write (iout,60)  mode,method,grdmin
   60    format (/,' Algorithm : ',a6,5x,'Preconditioning : ',a6,5x,
     &              ' RMS Grad :',d9.2)
         write (iout,70)
   70    format (/,' TN Iter     F Value      G RMS      F Move',
     &              '   X Move   CG Iter  Solve   FG Call')
         flush (iout)
      end if
c
c     perform dynamic allocation of some local arrays
c
      nmax = 3 * n
      allocate (h_init(nmax))
      allocate (h_stop(nmax))
      allocate (x_old(nmax))
      allocate (g(nmax))
      allocate (p(nmax))
      allocate (h_diag(nmax))
      allocate (h_index((nmax*(nmax-1))/2))
      allocate (h((nmax*(nmax-1))/2))
c
c     evaluate the function and get the initial gradient
c
      iter_cg = 0
      fg_call = fg_call + 1
      f = fgvalue (x0,g)
      f_old = f
      g_norm = 0.0d0
      do i = 1, nvar
         x_old(i) = x0(i)
         g_norm = g_norm + g(i)**2
      end do
      g_norm = sqrt(g_norm)
      f_move = 0.5d0 * stpmax * g_norm
      g_rms = g_norm / rms
c
c     print initial information prior to first iteration
c
      if (iprint .gt. 0) then
         if (f.lt.1.0d8 .and. f.gt.-1.0d7 .and. g_rms.lt.1.0d5) then
            write (iout,80)  iter_tn,f,g_rms,fg_call
   80       format (/,i6,f14.4,f11.4,41x,i7)
         else
            write (iout,90)  iter_tn,f,g_rms,fg_call
   90       format (/,i6,d14.4,d11.4,41x,i7)
         end if
         flush (iout)
      end if
c
c     write initial intermediate prior to first iteration
c
      if (iwrite .gt. 0)  call optsave (iter_tn,f,x0)
c
c     check for termination criteria met by initial point
c
      if (g_rms .le. grdmin) then
         done = .true.
         minimum = f
         if (iprint .gt. 0) then
            write (iout,100)
  100       format (/,' TNCG  --  Normal Termination due to SmallGrad')
         end if
      else if (f .le. fctmin) then
         done = .true.
         minimum = f
         if (iprint .gt. 0) then
            write (iout,110)
  110       format (/,' TNCG  --  Normal Termination due to SmallFct')
         end if
      else if (iter_tn .ge. maxiter) then
         done = .true.
         minimum = f
         if (iprint .gt. 0) then
            write (iout,120)
  120       format (/,' TNCG  --  Incomplete Convergence',
     &                 ' due to IterLimit')
         end if
      end if
c
c     beginning of the outer truncated Newton iteration
c
      do while (.not. done)
         iter_tn = iter_tn + 1
c
c     if pisystem is present, update the molecular orbitals
c
         if (use_orbit) then
            reorbit = 1
            call picalc
            fg_call = fg_call + 1
            f = fgvalue (x0,g)
            reorbit = 0
         end if
c
c     choose the optimization mode based on the gradient value
c
         if (automode) then
            if (g_rms .ge. 3.0d0) then
               mode = 'TNCG'
            else
               mode = 'DTNCG'
            end if
         end if
c
c     decide on an optimal preconditioning based on the gradient
c
         if (automatic) then
            if (nvar .lt. 10) then
               method = 'DIAG'
               hesscut = 0.0d0
            else if (g_rms .ge. 10.0d0) then
               method = 'DIAG'
               hesscut = 1.0d0
            else if (g_rms .ge. 1.0d0) then
               method = 'ICCG'
               hesscut = 0.001d0 * nvar
               if (hesscut .gt. 1.0d0)  hesscut = 1.0d0
            else
               method = 'ICCG'
               hesscut = 0.001d0 * nvar
               if (hesscut .gt. 0.1d0)  hesscut = 0.1d0
            end if
         end if
c
c     compute needed portions of the Hessian matrix
c
         h_mode = 'FULL'
         if (mod(iter_tn-1,newhess) .ne. 0)  h_mode = 'NONE'
         if (mode.eq.'DTNCG' .and. method.eq.'NONE')  h_mode = 'NONE'
         if (mode.eq.'DTNCG' .and. method.eq.'DIAG')  h_mode = 'DIAG'
         call hmatrix (h_mode,x0,h,h_init,h_stop,h_index,h_diag)
c
c     find the next approximate Newton search direction
c
         call tnsolve (mode,method,negtest,nvar,p,x0,g,h,
     &                 h_init,h_stop,h_index,h_diag,iter_tn,
     &                 iter_cg,fg_call,fgvalue,info_solve)
c
c     perform a line search in the chosen direction
c
         info_search = '         '
         call search (nvar,f,g,x0,p,f_move,angle,fg_call,
     &                fgvalue,info_search)
         if (info_search .ne. ' Success ') then
            info_solve = info_search
         end if
c
c     update variables to reflect this iteration
c
         f_move = f_old - f
         f_old = f
         x_move = 0.0d0
         g_norm = 0.0d0
         do i = 1, nvar
            x_move = x_move + (x0(i)-x_old(i))**2
            x_old(i) = x0(i)
            g_norm = g_norm + g(i)**2
         end do
         x_move = sqrt(x_move)
         x_move = x_move / rms
         if (coordtype .eq. 'INTERNAL') then
            x_move = x_move * radian
         end if
         g_norm = sqrt(g_norm)
         g_rms = g_norm / rms
c
c     quit if the maximum number of iterations is exceeded
c
         if (iter_tn .ge. maxiter) then
            done = .true.
            status = 'IterLimit'
         end if
c
c     quit if the function value did not change
c
         if (f_move .eq. 0.0d0) then
            done = .true.
            status = 'NoMotion '
         end if
c
c     quit if either of the normal termination tests are met
c
         if (g_rms .le. grdmin) then
            done = .true.
            status = 'SmallGrad'
         else if (f .le. fctmin) then
            done = .true.
            status = 'SmallFct '
         end if
c
c     quit if the line search encounters successive problems
c
         if (info_search.eq.'BadIntpln' .or.
     &       info_search.eq.'IntplnErr') then
            nerr = nerr + 1
            if (nerr .ge. maxerr) then
               done = .true.
               status = info_search
            end if
         else
            nerr = 0
         end if
c
c     print intermediate results for the current iteration
c
         if (iprint .gt. 0) then
            if (done .or. mod(iter_tn,iprint).eq.0) then
               if (f.lt.1.0d8 .and. f.gt.-1.0d7 .and.
     &             g_rms.lt.1.0d5 .and. f_move.lt.1.0d6 .and.
     &             f_move.gt.-1.0d5) then
                  write (iout,130)  iter_tn,f,g_rms,f_move,x_move,
     &                              iter_cg,info_solve,fg_call
  130             format (i6,f14.4,f11.4,f12.4,f9.4,i8,3x,a9,i7)
               else
                  write (iout,140)  iter_tn,f,g_rms,f_move,x_move,
     &                              iter_cg,info_solve,fg_call
  140             format (i6,d14.4,d11.4,d12.4,f9.4,i8,3x,a9,i7)
               end if
               flush (iout)
            end if
         end if
c
c     write intermediate results for the current iteration
c
         if (iwrite .gt. 0) then
            if (done .or. mod(iter_tn,iwrite).eq.0) then
               call optsave (iter_tn,f,x0)
            end if
         end if
c
c     print the reason for terminating the optimization
c
         if (done) then
            minimum = f
            if (iprint .gt. 0) then
               if (g_rms.le.grdmin .or. f.le.fctmin) then
                  write (iout,150)  status
  150             format (/,' TNCG  --  Normal Termination due to ',a9)
               else
                  write (iout,160)  status
  160             format (/,' TNCG  --  Incomplete Convergence',
     &                       ' due to ',a9)
               end if
               flush (iout)
            end if
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (h_init)
      deallocate (h_stop)
      deallocate (x_old)
      deallocate (g)
      deallocate (p)
      deallocate (h_diag)
      deallocate (h_index)
      deallocate (h)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine tnsolve  --  approx linear equation solution  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "tnsolve" uses a linear conjugate gradient method to find
c     an approximate solution to the set of linear equations
c     represented in matrix form by Hp = -g (Newton's equations)
c
c     status codes upon return:
c
c     TruncNewt    convergence to (truncated) Newton criterion
c     NegCurve     termination upon detecting negative curvature
c     OverLimit    maximum number of CG iterations exceeded
c
c
      subroutine tnsolve (mode,method,negtest,nvar,p,x0,g,h,
     &                    h_init,h_stop,h_index,h_diag,cycle,
     &                    iter_cg,fg_call,fgvalue,status)
      use output
      implicit none
      integer i,j,k,nvar,cycle
      integer iter,iter_cg
      integer fg_call,maxiter
      integer h_init(*)
      integer h_stop(*)
      integer h_index(*)
      real*8 alpha,beta,delta
      real*8 sigma,f_sigma
      real*8 fgvalue,eps
      real*8 g_norm,g_rms
      real*8 hj,gg,dq,rr,dd
      real*8 rs,rs_new,r_norm
      real*8 converge
      real*8 x0(*)
      real*8 g(*)
      real*8 p(*)
      real*8 h_diag(*)
      real*8 h(*)
      real*8, allocatable :: m(:)
      real*8, allocatable :: r(:)
      real*8, allocatable :: s(:)
      real*8, allocatable :: d(:)
      real*8, allocatable :: q(:)
      real*8, allocatable :: x_sigma(:)
      real*8, allocatable :: g_sigma(:)
      logical negtest
      character*6 mode,method
      character*9 status
      external fgvalue
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (m(nvar))
      allocate (r(nvar))
      allocate (s(nvar))
      allocate (d(nvar))
      allocate (q(nvar))
      allocate (x_sigma(nvar))
      allocate (g_sigma(nvar))
c
c     transformation using exact Hessian diagonal
c
      if (mode.ne.'DTNCG' .and. method.ne.'NONE') then
         do i = 1, nvar
            m(i) = 1.0d0 / sqrt(abs(h_diag(i)))
         end do
         do i = 1, nvar
            g(i) = g(i) * m(i)
            h_diag(i) = h_diag(i) * m(i) * m(i)
            do j = h_init(i), h_stop(i)
               k = h_index(j)
               h(j) = h(j) * m(i) * m(k)
            end do
         end do
      end if
c
c     setup prior to linear conjugate gradient iterations
c
      iter = 0
      gg = 0.0d0
      do i = 1, nvar
         p(i) = 0.0d0
         r(i) = -g(i)
         gg = gg + g(i)*g(i)
      end do
      g_norm = sqrt(gg)
      call precond (method,iter,nvar,s,r,h,h_init,
     &                  h_stop,h_index,h_diag)
      rs = 0.0d0
      do i = 1, nvar
         d(i) = s(i)
         rs = rs + r(i)*s(i)
      end do
      if (mode .eq. 'NEWTON') then
         eps = 1.0d-10
         maxiter = nvar
      else if (mode.eq.'TNCG' .or. mode.eq.'DTNCG') then
         delta = 1.0d0
         eps = delta / dble(cycle)
         g_rms = g_norm / sqrt(dble(nvar))
         eps = min(eps,g_rms)
         converge = 1.0d0
         eps = eps**converge
         maxiter = nint(10.0d0*sqrt(dble(nvar)))
      end if
      iter = 1
c
c     evaluate or estimate the matrix-vector product
c
      do while (.true.)
         if (mode.eq.'TNCG' .or. mode.eq.'NEWTON') then
            do i = 1, nvar
               q(i) = 0.0d0
            end do
            do i = 1, nvar
               q(i) = q(i) + h_diag(i)*d(i)
               do j = h_init(i), h_stop(i)
                  k = h_index(j)
                  hj = h(j)
                  q(i) = q(i) + hj*d(k)
                  q(k) = q(k) + hj*d(i)
               end do
            end do
         else if (mode .eq. 'DTNCG') then
            dd = 0.0d0
            do i = 1, nvar
               dd = dd + d(i)*d(i)
            end do
            sigma = 1.0d-7 / sqrt(dd)
            if (coordtype .eq. 'INTERNAL') then
               sigma = 1.0d-4 / sqrt(dd)
            end if
            do i = 1, nvar
               x_sigma(i) = x0(i) + sigma*d(i)
            end do
            fg_call = fg_call + 1
            f_sigma = fgvalue (x_sigma,g_sigma)
            do i = 1, nvar
               q(i) = (g_sigma(i)-g(i)) / sigma
            end do
         end if
c
c     check for a direction of negative curvature
c
         dq = 0.0d0
         do i = 1, nvar
            dq = dq + d(i)*q(i)
         end do
         if (negtest) then
            if (dq .le. 0.0d0) then
               if (iter .eq. 1) then
                  do i = 1, nvar
                     p(i) = d(i)
                  end do
               end if
               status = ' NegCurve'
               goto 10
            end if
         end if
c
c     test the truncated Newton termination criterion
c
         alpha = rs / dq
         rr = 0.0d0
         do i = 1, nvar
            p(i) = p(i) + alpha*d(i)
            r(i) = r(i) - alpha*q(i)
            rr = rr + r(i)*r(i)
         end do
         r_norm = sqrt(rr)
         if (r_norm/g_norm .le. eps) then
            status = 'TruncNewt'
            goto 10
         end if
c
c     solve the preconditioning equations
c
         call precond (method,iter,nvar,s,r,h,h_init,
     &                     h_stop,h_index,h_diag)
c
c     update the truncated Newton direction
c
         rs_new = 0.0d0
         do i = 1, nvar
            rs_new = rs_new + r(i)*s(i)
         end do
         beta = rs_new / rs
         rs = rs_new
         do i = 1, nvar
            d(i) = s(i) + beta*d(i)
         end do
c
c     check for overlimit, then begin next iteration
c
         if (iter .ge. maxiter) then
            status = 'OverLimit'
            goto 10
         end if
         iter = iter + 1
      end do
c
c     retransform and increment total iterations, then terminate
c
   10 continue
      if (mode.ne.'DTNCG' .and. method.ne.'NONE') then
         do i = 1, nvar
            p(i) = p(i) * m(i)
            g(i) = g(i) / m(i)
         end do
      end if
      iter_cg = iter_cg + iter
c
c     perform deallocation of some local arrays
c
      deallocate (m)
      deallocate (r)
      deallocate (s)
      deallocate (d)
      deallocate (q)
      deallocate (x_sigma)
      deallocate (g_sigma)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine precond  --  precondition linear CG method  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "precond" solves a simplified version of the Newton equations
c     Ms = r, and uses the result to precondition linear conjugate
c     gradient iterations on the full Newton equations in "tnsolve"
c
c     literature reference:
c
c     T. A. Manteuffel, "An Incomplete Factorization Technique
c     for Positive Definite Linear Systems", Mathematics of
c     Computation, 34, 473-497 (1980); the present routine is
c     based upon the SICCG(0) method described in this paper
c
c     types of preconditioning methods:
c
c     none     use no preconditioning at all
c     diag     exact Hessian diagonal preconditioning
c     block    3x3 block diagonal preconditioning
c     ssor     symmetric successive over-relaxation
c     iccg     shifted incomplete Cholesky factorization
c
c
      subroutine precond (method,iter,nvar,s,r,h,h_init,
     &                       h_stop,h_index,h_diag)
      use inform
      use iounit
      implicit none
      integer i,j,k,ii,kk
      integer iii,kkk,iter
      integer nvar,nblock
      integer ix,iy,iz,icount
      integer h_init(*)
      integer h_stop(*)
      integer h_index(*)
      integer, allocatable :: c_init(:)
      integer, allocatable :: c_stop(:)
      integer, allocatable :: c_index(:)
      integer, allocatable :: c_value(:)
      real*8 f_i,f_k
      real*8 omega,factor
      real*8 maxalpha,alpha
      real*8 a(6),b(3)
      real*8 h_diag(*)
      real*8 h(*)
      real*8 s(*)
      real*8 r(*)
      real*8, allocatable :: diag(:)
      real*8, allocatable :: f_diag(:)
      real*8, allocatable :: f(:)
      logical stable
      character*6 method
      save f,f_diag,stable
c
c
c     perform dynamic allocation of some local arrays
c
      if (method .eq. 'SSOR')  allocate (diag(nvar))
      if (method .eq. 'ICCG') then
         if (iter .eq. 0) then
            allocate (c_init(nvar))
            allocate (c_stop(nvar))
            allocate (c_index((nvar*(nvar-1))/2))
            allocate (c_value((nvar*(nvar-1))/2))
         end if
         if (.not. allocated(f_diag))  allocate (f_diag(nvar))
         if (.not. allocated(f))  allocate (f((nvar*(nvar-1))/2))
      end if
c
c     use no preconditioning, using M = identity matrix
c
      if (method .eq. 'NONE') then
         do i = 1, nvar
            s(i) = r(i)
         end do
      end if
c
c     diagonal preconditioning, using M = abs(Hessian diagonal)
c
      if (method .eq. 'DIAG') then
         do i = 1, nvar
            s(i) = r(i) / abs(h_diag(i))
         end do
      end if
c
c     block diagonal preconditioning with exact atom blocks
c     (using M = 3x3 blocks from diagonal of full Hessian)
c
      if (method .eq. 'BLOCK') then
         nblock = 3
         do i = 1, nvar/3
            iz = 3 * i
            iy = iz - 1
            ix = iz - 2
            a(1) = h_diag(ix)
            if (h_index(h_init(ix)) .eq. iy) then
               a(2) = h(h_init(ix))
            else
               a(2) = 0.0d0
            end if
            if (h_index(h_init(ix)+1) .eq. iz) then
               a(3) = h(h_init(ix)+1)
            else
               a(3) = 0.0d0
            end if
            a(4) = h_diag(iy)
            if (h_index(h_init(iy)) .eq. iz) then
               a(5) = h(h_init(iy))
            else
               a(5) = 0.0d0
            end if
            a(6) = h_diag(iz)
            b(1) = r(ix)
            b(2) = r(iy)
            b(3) = r(iz)
            call cholesky (nblock,a,b)
            s(ix) = b(1)
            s(iy) = b(2)
            s(iz) = b(3)
         end do
      end if
c
c     symmetric successive over-relaxation (SSOR) preconditioning
c     (using M = (D/w+U)T * (D/w)-1 * (D/w+U) with 0 < w < 2)
c
      if (method .eq. 'SSOR') then
         omega = 1.0d0
         factor = 2.0d0 - omega
         do i = 1, nvar
            s(i) = r(i) * factor
            diag(i) = h_diag(i) / omega
         end do
         do i = 1, nvar
            s(i) = s(i) / diag(i)
            do j = h_init(i), h_stop(i)
               k = h_index(j)
               s(k) = s(k) - h(j)*s(i)
            end do
         end do
         do i = nvar, 1, -1
            s(i) = s(i) * diag(i)
            do j = h_init(i), h_stop(i)
               k = h_index(j)
               s(i) = s(i) - h(j)*s(k)
            end do
            s(i) = s(i) / diag(i)
         end do
      end if
c
c     factorization phase of incomplete cholesky preconditioning
c
      if (method.eq.'ICCG' .and. iter.eq.0) then
         call column (nvar,h_init,h_stop,h_index,
     &                c_init,c_stop,c_index,c_value)
         stable = .true.
         icount = 0
         maxalpha = 2.1d0
         alpha = -0.001d0
   10    continue
         if (alpha .le. 0.0d0) then
            alpha = alpha + 0.001d0
         else
            alpha = 2.0d0 * alpha
         end if
         if (alpha .gt. maxalpha) then
            stable = .false.
            if (verbose) then
               write (iout,20)
   20          format (' PRECOND  --  Incomplete Cholesky is',
     &                    ' Unstable, using Diagonal Method')
            end if
         else
            factor = 1.0d0 + alpha
            do i = 1, nvar
               f_diag(i) = factor * h_diag(i)
               do j = c_init(i), c_stop(i)
                  k = c_index(j)
                  f_i = f(c_value(j))
                  f_diag(i) = f_diag(i) - f_i*f_i*f_diag(k)
                  icount = icount + 1
               end do
               if (f_diag(i) .le. 0.0d0)  goto 10
               if (f_diag(i) .lt. 1.0d-7)  f_diag(i) = 1.0d-7
               f_diag(i) = 1.0d0 / f_diag(i)
               do j = h_init(i), h_stop(i)
                  k = h_index(j)
                  f(j) = h(j)
                  ii = c_init(i)
                  kk = c_init(k)
                  do while (ii.le.c_stop(i) .and. kk.le.c_stop(k))
                     iii = c_index(ii)
                     kkk = c_index(kk)
                     if (iii .lt. kkk) then
                        ii = ii + 1
                     else if (kkk .lt. iii) then
                        kk = kk + 1
                     else
                        f_i = f(c_value(ii))
                        f_k = f(c_value(kk))
                        f(j) = f(j) - f_i*f_k*f_diag(iii)
                        ii = ii + 1
                        kk = kk + 1
                        icount = icount + 1
                     end if
                  end do
               end do
            end do
            if (verbose) then
               write (iout,30)  icount,alpha
   30          format (' PRECOND  --  Incomplete Cholesky',i12,
     &                    ' Operations',f8.3,' Alpha Value')
            end if
         end if
      end if
c
c     solution phase of incomplete cholesky preconditioning
c
      if (method .eq. 'ICCG') then
         if (stable) then
            do i = 1, nvar
               s(i) = r(i)
            end do
            do i = 1, nvar
               s(i) = s(i) * f_diag(i)
               do j = h_init(i), h_stop(i)
                  k = h_index(j)
                  s(k) = s(k) - f(j)*s(i)
               end do
            end do
            do i = nvar, 1, -1
               s(i) = s(i) / f_diag(i)
               do j = h_init(i), h_stop(i)
                  k = h_index(j)
                  s(i) = s(i) - f(j)*s(k)
               end do
               s(i) = s(i) * f_diag(i)
            end do
         else
            do i = 1, nvar
               s(i) = r(i) / abs(h_diag(i))
            end do
         end if
      end if
c
c     perform deallocation of some local arrays
c
      if (method .eq. 'SSOR')  deallocate (diag)
      if (method .eq. 'ICCG') then
         if (iter .eq. 0) then
            deallocate (c_init)
            deallocate (c_stop)
            deallocate (c_index)
            deallocate (c_value)
         end if
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine torphase  --  torsional amplitude and phase  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "torphase" sets the n-fold amplitude and phase values
c     for each torsion via sorting of the input parameters
c
c
      subroutine torphase (ft,vt,st)
      implicit none
      integer i,k
      integer ft(*)
      real*8 ampli(6)
      real*8 phase(6)
      real*8 vt(*),st(*)
c
c
c     copy the input fold, amplitude and phase angles
c
      do i = 1, 6
         ampli(i) = vt(i)
         phase(i) = st(i)
         vt(i) = 0.0d0
         st(i) = 0.0d0
      end do
c
c     shift the phase angles into the standard range
c
      do i = 1, 6
         do while (phase(i) .lt. -180.0d0)
            phase(i) = phase(i) + 360.0d0
         end do
         do while (phase(i) .gt. 180.0d0)
            phase(i) = phase(i) - 360.0d0
         end do
      end do
c
c     convert input torsional parameters to storage format
c
      do i = 1, 6
         k = ft(i)
         if (k.ge.1 .and. k.le.6) then
            vt(k) = ampli(i)
            st(k) = phase(i)
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  module torpot  --  torsional functional form details  ##
c     ##                                                        ##
c     ############################################################
c
c
c     idihunit  convert improper dihedral energy to kcal/mole
c     itorunit  convert improper torsion amplitudes to kcal/mole
c     torsunit  convert torsional parameter amplitudes to kcal/mole
c     ptorunit  convert pi-system torsion energy to kcal/mole
c     storunit  convert stretch-torsion energy to kcal/mole
c     atorunit  convert angle-torsion energy to kcal/mole
c     ttorunit  convert torsion-torsion energy to kcal/mole
c
c
      module torpot
      implicit none
      real*8 idihunit
      real*8 itorunit
      real*8 torsunit
      real*8 ptorunit
      real*8 storunit
      real*8 atorunit
      real*8 ttorunit
      save
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 2007 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine torque  --  convert single site torque to force  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "torque" takes the torque values on a single site defined by
c     a local coordinate frame and converts to Cartesian forces on
c     the original site and sites specifying the local frame, also
c     gives the x,y,z-force components needed for virial computation
c
c     force distribution for the 3-fold local frame by Chao Lu,
c     Ponder Lab, Washington University, July 2016
c
c     literature reference:
c
c     P. L. Popelier and A. J. Stone, "Formulae for the First and
c     Second Derivatives of Anisotropic Potentials with Respect to
c     Geometrical Parameters", Molecular Physics, 82, 411-425 (1994)
c
c     C. Segui, L. G. Pedersen and T. A. Darden, "Towards an Accurate
c     Representation of Electrostatics in Classical Force Fields:
c     Efficient Implementation of Multipolar Interactions in
c     Biomolecular Simulations", Journal of Chemical Physics, 120,
c     73-87 (2004)
c
c
      subroutine torque (i,trq,frcx,frcy,frcz,de)
      use atoms
      use deriv
      use mpole
      implicit none
      integer i,j
      integer ia,ib,ic,id
      real*8 du,dv,dw,dot
      real*8 usiz,vsiz,wsiz
      real*8 psiz,rsiz,ssiz
      real*8 t1siz,t2siz
      real*8 uvsiz,uwsiz,vwsiz
      real*8 ursiz,ussiz
      real*8 vssiz,wssiz
      real*8 delsiz,dphiddel
      real*8 uvcos,uwcos,urcos
      real*8 vwcos,vscos,wscos
      real*8 upcos,vpcos,wpcos
      real*8 rwcos,rucos,rvcos
      real*8 ut1cos,ut2cos
      real*8 uvsin,uwsin,ursin
      real*8 vwsin,vssin,wssin
      real*8 rwsin,rusin,rvsin
      real*8 ut1sin,ut2sin
      real*8 dphidu,dphidv,dphidw
      real*8 dphidr,dphids
      real*8 trq(3),frcx(3)
      real*8 frcy(3),frcz(3)
      real*8 u(3),v(3),w(3)
      real*8 p(3),r(3),s(3)
      real*8 t1(3),t2(3)
      real*8 uv(3),uw(3),vw(3)
      real*8 ur(3),us(3)
      real*8 vs(3),ws(3)
      real*8 del(3),eps(3)
      real*8 de(3,*)
      character*8 axetyp
c
c
c     zero out force components on local frame-defining atoms
c
      do j = 1, 3
         frcz(j) = 0.0d0
         frcx(j) = 0.0d0
         frcy(j) = 0.0d0
      end do
c
c     get the local frame type and the frame-defining atoms
c
      axetyp = polaxe(i)
      if (axetyp .eq. 'None')  return
      ia = zaxis(i)
      ib = i
      ic = xaxis(i)
      id = abs(yaxis(i))
c
c     construct the three rotation axes for the local frame
c
      u(1) = x(ia) - x(ib)
      u(2) = y(ia) - y(ib)
      u(3) = z(ia) - z(ib)
      usiz = sqrt(u(1)*u(1) + u(2)*u(2) + u(3)*u(3))
      if (axetyp .ne. 'Z-Only') then
         v(1) = x(ic) - x(ib)
         v(2) = y(ic) - y(ib)
         v(3) = z(ic) - z(ib)
         vsiz = sqrt(v(1)*v(1) + v(2)*v(2) + v(3)*v(3))
      else
         v(1) = 1.0d0
         v(2) = 0.0d0
         v(3) = 0.0d0
         vsiz = 1.0d0
         dot = u(1) / usiz
         if (abs(dot) .gt. 0.866d0) then
            v(1) = 0.0d0
            v(2) = 1.0d0
         end if
      end if
      if (axetyp.eq.'Z-Bisect' .or. axetyp.eq.'3-Fold') then
         w(1) = x(id) - x(ib)
         w(2) = y(id) - y(ib)
         w(3) = z(id) - z(ib)
      else
         w(1) = u(2)*v(3) - u(3)*v(2)
         w(2) = u(3)*v(1) - u(1)*v(3)
         w(3) = u(1)*v(2) - u(2)*v(1)
      end if
      wsiz = sqrt(w(1)*w(1) + w(2)*w(2) + w(3)*w(3))
      do j = 1, 3
         u(j) = u(j) / usiz
         v(j) = v(j) / vsiz
         w(j) = w(j) / wsiz
      end do
c
c     build some additional axes for the Z-Bisect local frame
c
      if (axetyp .eq. 'Z-Bisect') then
         r(1) = v(1) + w(1)
         r(2) = v(2) + w(2)
         r(3) = v(3) + w(3)
         rsiz = sqrt(r(1)*r(1) + r(2)*r(2) + r(3)*r(3))
         s(1) = u(2)*r(3) - u(3)*r(2)
         s(2) = u(3)*r(1) - u(1)*r(3)
         s(3) = u(1)*r(2) - u(2)*r(1)
         ssiz = sqrt(s(1)*s(1) + s(2)*s(2) + s(3)*s(3))
         do j = 1, 3
            r(j) = r(j) / rsiz
            s(j) = s(j) / ssiz
         end do
      end if
c
c     negative of dot product of torque with unit vectors gives
c     result of infinitesimal rotation around these vectors
c
      dphidu = -trq(1)*u(1) - trq(2)*u(2) - trq(3)*u(3)
      dphidv = -trq(1)*v(1) - trq(2)*v(2) - trq(3)*v(3)
      dphidw = -trq(1)*w(1) - trq(2)*w(2) - trq(3)*w(3)
      if (axetyp .eq. 'Z-Bisect') then
         dphidr = -trq(1)*r(1) - trq(2)*r(2) - trq(3)*r(3)
         dphids = -trq(1)*s(1) - trq(2)*s(2) - trq(3)*s(3)
      end if
c
c     find the perpendicular and angle for each pair of axes
c
      uv(1) = v(2)*u(3) - v(3)*u(2)
      uv(2) = v(3)*u(1) - v(1)*u(3)
      uv(3) = v(1)*u(2) - v(2)*u(1)
      uvsiz = sqrt(uv(1)*uv(1) + uv(2)*uv(2) + uv(3)*uv(3))
      uw(1) = w(2)*u(3) - w(3)*u(2)
      uw(2) = w(3)*u(1) - w(1)*u(3)
      uw(3) = w(1)*u(2) - w(2)*u(1)
      uwsiz = sqrt(uw(1)*uw(1) + uw(2)*uw(2) + uw(3)*uw(3))
      vw(1) = w(2)*v(3) - w(3)*v(2)
      vw(2) = w(3)*v(1) - w(1)*v(3)
      vw(3) = w(1)*v(2) - w(2)*v(1)
      vwsiz = sqrt(vw(1)*vw(1) + vw(2)*vw(2) + vw(3)*vw(3))
      do j = 1, 3
         uv(j) = uv(j) / uvsiz
         uw(j) = uw(j) / uwsiz
         vw(j) = vw(j) / vwsiz
      end do
      if (axetyp .eq. 'Z-Bisect') then
         ur(1) = r(2)*u(3) - r(3)*u(2)
         ur(2) = r(3)*u(1) - r(1)*u(3)
         ur(3) = r(1)*u(2) - r(2)*u(1)
         ursiz = sqrt(ur(1)*ur(1) + ur(2)*ur(2) + ur(3)*ur(3))
         us(1) = s(2)*u(3) - s(3)*u(2)
         us(2) = s(3)*u(1) - s(1)*u(3)
         us(3) = s(1)*u(2) - s(2)*u(1)
         ussiz = sqrt(us(1)*us(1) + us(2)*us(2) + us(3)*us(3))
         vs(1) = s(2)*v(3) - s(3)*v(2)
         vs(2) = s(3)*v(1) - s(1)*v(3)
         vs(3) = s(1)*v(2) - s(2)*v(1)
         vssiz = sqrt(vs(1)*vs(1) + vs(2)*vs(2) + vs(3)*vs(3))
         ws(1) = s(2)*w(3) - s(3)*w(2)
         ws(2) = s(3)*w(1) - s(1)*w(3)
         ws(3) = s(1)*w(2) - s(2)*w(1)
         wssiz = sqrt(ws(1)*ws(1) + ws(2)*ws(2) + ws(3)*ws(3))
         do j = 1, 3
            ur(j) = ur(j) / ursiz
            us(j) = us(j) / ussiz
            vs(j) = vs(j) / vssiz
            ws(j) = ws(j) / wssiz
         end do
      end if
c
c     find sine and cosine of angles between the rotation axes
c
      uvcos = u(1)*v(1) + u(2)*v(2) + u(3)*v(3)
      uvsin = sqrt(1.0d0 - uvcos*uvcos)
      uwcos = u(1)*w(1) + u(2)*w(2) + u(3)*w(3)
      uwsin = sqrt(1.0d0 - uwcos*uwcos)
      vwcos = v(1)*w(1) + v(2)*w(2) + v(3)*w(3)
      vwsin = sqrt(1.0d0 - vwcos*vwcos)
      if (axetyp .eq. 'Z-Bisect') then
         urcos = u(1)*r(1) + u(2)*r(2) + u(3)*r(3)
         ursin = sqrt(1.0d0 - urcos*urcos)
         vscos = v(1)*s(1) + v(2)*s(2) + v(3)*s(3)
         vssin = sqrt(1.0d0 - vscos*vscos)
         wscos = w(1)*s(1) + w(2)*s(2) + w(3)*s(3)
         wssin = sqrt(1.0d0 - wscos*wscos)
      end if
c
c     get projection of v and w onto the ru-plane for Z-Bisect
c
      if (axetyp .eq. 'Z-Bisect') then
         do j = 1, 3
            t1(j) = v(j) - s(j)*vscos
            t2(j) = w(j) - s(j)*wscos
         end do
         t1siz = sqrt(t1(1)*t1(1)+t1(2)*t1(2)+t1(3)*t1(3))
         t2siz = sqrt(t2(1)*t2(1)+t2(2)*t2(2)+t2(3)*t2(3))
         do j = 1, 3
            t1(j) = t1(j) / t1siz
            t2(j) = t2(j) / t2siz
         end do
         ut1cos = u(1)*t1(1) + u(2)*t1(2) + u(3)*t1(3)
         ut1sin = sqrt(1.0d0 - ut1cos*ut1cos)
         ut2cos = u(1)*t2(1) + u(2)*t2(2) + u(3)*t2(3)
         ut2sin = sqrt(1.0d0 - ut2cos*ut2cos)
      end if
c
c     force distribution for Z-Only local coordinate frame
c
      if (axetyp .eq. 'Z-Only') then
         do j = 1, 3
            du = uv(j)*dphidv/(usiz*uvsin) + uw(j)*dphidw/usiz
            de(j,ia) = de(j,ia) + du
            de(j,ib) = de(j,ib) - du
            frcz(j) = frcz(j) + du
         end do
c
c     force distribution for Z-then-X local coordinate frame
c
      else if (axetyp .eq. 'Z-then-X') then
         do j = 1, 3
            du = uv(j)*dphidv/(usiz*uvsin) + uw(j)*dphidw/usiz
            dv = -uv(j)*dphidu/(vsiz*uvsin)
            de(j,ia) = de(j,ia) + du
            de(j,ic) = de(j,ic) + dv
            de(j,ib) = de(j,ib) - du - dv
            frcz(j) = frcz(j) + du
            frcx(j) = frcx(j) + dv
         end do
c
c     force distribution for Bisector local coordinate frame
c
      else if (axetyp .eq. 'Bisector') then
         do j = 1, 3
            du = uv(j)*dphidv/(usiz*uvsin) + 0.5d0*uw(j)*dphidw/usiz
            dv = -uv(j)*dphidu/(vsiz*uvsin) + 0.5d0*vw(j)*dphidw/vsiz
            de(j,ia) = de(j,ia) + du
            de(j,ic) = de(j,ic) + dv
            de(j,ib) = de(j,ib) - du - dv
            frcz(j) = frcz(j) + du
            frcx(j) = frcx(j) + dv
         end do
c
c     force distribution for Z-Bisect local coordinate frame
c
      else if (axetyp .eq. 'Z-Bisect') then
         do j = 1, 3
            du = ur(j)*dphidr/(usiz*ursin) + us(j)*dphids/usiz
            dv = (vssin*s(j)-vscos*t1(j))*dphidu
     &              / (vsiz*(ut1sin+ut2sin))
            dw = (wssin*s(j)-wscos*t2(j))*dphidu
     &              / (wsiz*(ut1sin+ut2sin))
            de(j,ia) = de(j,ia) + du
            de(j,ic) = de(j,ic) + dv
            de(j,id) = de(j,id) + dw
            de(j,ib) = de(j,ib) - du - dv - dw
            frcz(j) = frcz(j) + du
            frcx(j) = frcx(j) + dv
            frcy(j) = frcy(j) + dw
         end do
c
c     force distribution for 3-Fold local coordinate frame
c
      else if (axetyp .eq. '3-Fold') then
         p(1) = u(1) + v(1) + w(1)
         p(2) = u(2) + v(2) + w(2)
         p(3) = u(3) + v(3) + w(3)
         psiz = sqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3)) 
         do j = 1, 3 
            p(j) = p(j) / psiz
         end do
         wpcos = w(1)*p(1) + w(2)*p(2) + w(3)*p(3)
         upcos = u(1)*p(1) + u(2)*p(2) + u(3)*p(3)
         vpcos = v(1)*p(1) + v(2)*p(2) + v(3)*p(3)
         r(1) = u(1) + v(1)
         r(2) = u(2) + v(2)
         r(3) = u(3) + v(3)
         rsiz = sqrt(r(1)*r(1)+r(2)*r(2)+r(3)*r(3))
         do j = 1, 3
            r(j) = r(j) / rsiz
         end do
         rwcos = r(1)*w(1) + r(2)*w(2) + r(3)*w(3)
         rwsin = sqrt(1.0d0 - rwcos*rwcos)
         dphidr = -trq(1)*r(1) - trq(2)*r(2) - trq(3)*r(3)
         del(1) = r(2)*w(3) - r(3)*w(2)
         del(2) = r(3)*w(1) - r(1)*w(3) 
         del(3) = r(1)*w(2) - r(2)*w(1)
         delsiz = sqrt(del(1)*del(1)+del(2)*del(2)+del(3)*del(3))    
         do j = 1, 3
            del(j) = del(j) / delsiz
         end do
         dphiddel = -trq(1)*del(1) - trq(2)*del(2) - trq(3)*del(3)
         eps(1) = del(2)*w(3) - del(3)*w(2)
         eps(2) = del(3)*w(1) - del(1)*w(3)
         eps(3) = del(1)*w(2) - del(2)*w(1)
         do j = 1, 3
            dw = del(j)*dphidr/(wsiz*rwsin)
     &              + eps(j)*dphiddel*wpcos/(wsiz*psiz) 
            de(j,id) = de(j,id) + dw
            de(j,ib) = de(j,ib) - dw
            frcy(j) = frcy(j) + dw
         end do
         r(1) = v(1) + w(1)
         r(2) = v(2) + w(2)
         r(3) = v(3) + w(3)
         rsiz = sqrt(r(1)*r(1)+r(2)*r(2)+r(3)*r(3))
         do j = 1, 3
            r(j) = r(j) / rsiz
         end do
         rucos = r(1)*u(1) + r(2)*u(2) + r(3)*u(3)
         rusin = sqrt(1.0d0 - rucos*rucos) 
         dphidr = -trq(1)*r(1) - trq(2)*r(2) - trq(3)*r(3)
         del(1) = r(2)*u(3) - r(3)*u(2)
         del(2) = r(3)*u(1) - r(1)*u(3)
         del(3) = r(1)*u(2) - r(2)*u(1)
         delsiz = sqrt(del(1)*del(1)+del(2)*del(2)+del(3)*del(3))
         do j = 1, 3
            del(j) = del(j) / delsiz
         end do
         dphiddel = -trq(1)*del(1) - trq(2)*del(2) - trq(3)*del(3)
         eps(1) = del(2)*u(3) - del(3)*u(2)
         eps(2) = del(3)*u(1) - del(1)*u(3)
         eps(3) = del(1)*u(2) - del(2)*u(1)
         do j = 1, 3
            du = del(j)*dphidr/(usiz*rusin)
     &              + eps(j)*dphiddel*upcos/(usiz*psiz)
            de(j,ia) = de(j,ia) + du
            de(j,ib) = de(j,ib) - du
            frcz(j) = frcz(j) + du
         end do
         r(1) = u(1) + w(1)
         r(2) = u(2) + w(2)
         r(3) = u(3) + w(3)
         rsiz = sqrt(r(1)*r(1)+r(2)*r(2)+r(3)*r(3))
         do j = 1, 3
            r(j) = r(j) / rsiz
         end do
         rvcos = r(1)*v(1) + r(2)*v(2) + r(3)*v(3) 
         rvsin = sqrt(1.0d0 - rvcos*rvcos)
         dphidr = -trq(1)*r(1) - trq(2)*r(2) - trq(3)*r(3)
         del(1) = r(2)*v(3) - r(3)*v(2)
         del(2) = r(3)*v(1) - r(1)*v(3)
         del(3) = r(1)*v(2) - r(2)*v(1)
         delsiz = sqrt(del(1)*del(1)+del(2)*del(2)+del(3)*del(3))
         do j = 1, 3
            del(j) = del(j) / delsiz
         end do
         dphiddel = -trq(1)*del(1) - trq(2)*del(2) - trq(3)*del(3)
         eps(1) = del(2)*v(3) - del(3)*v(2)
         eps(2) = del(3)*v(1) - del(1)*v(3)
         eps(3) = del(1)*v(2) - del(2)*v(1)
         do j = 1, 3
            dv = del(j)*dphidr/(vsiz*rvsin)
     &              + eps(j)*dphiddel*vpcos/(vsiz*psiz)
            de(j,ic) = de(j,ic) + dv
            de(j,ib) = de(j,ib) - dv
            frcx(j) = frcx(j) + dv
         end do
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module tors  --  torsional angles in current structure  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     ntors   total number of torsional angles in the system
c     itors   numbers of the atoms in each torsional angle
c     tors1   1-fold amplitude and phase for each torsional angle
c     tors2   2-fold amplitude and phase for each torsional angle
c     tors3   3-fold amplitude and phase for each torsional angle
c     tors4   4-fold amplitude and phase for each torsional angle
c     tors5   5-fold amplitude and phase for each torsional angle
c     tors6   6-fold amplitude and phase for each torsional angle
c
c
      module tors
      implicit none
      integer ntors
      integer, allocatable :: itors(:,:)
      real*8, allocatable :: tors1(:,:)
      real*8, allocatable :: tors2(:,:)
      real*8, allocatable :: tors3(:,:)
      real*8, allocatable :: tors4(:,:)
      real*8, allocatable :: tors5(:,:)
      real*8, allocatable :: tors6(:,:)
      save
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 2010 by Chuanjie Wu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program torsfit  --  fit torsional force field parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "torsfit" refines torsional force field parameters based on
c     a quantum mechanical potential surface and analytical gradient
c
c
      program torsfit
      use files
      use inform
      use iounit
      use keys
      implicit none
      integer i,length
      integer torbnd(10)
      logical exist,query
      character*240 record
      character*240 string
      character*240 xyzfile
c
c
c     get the Cartesian coordinates and connectivity info
c
      call initial
      call getxyz
      xyzfile = filename
      length = leng
c
c     find keyword options and setup force field parameters
c
      call getkey
      call mechanic
c
c     choose the first torsion based on the center bond atoms
c
      do i = 1, 10
         torbnd(i) = 0
      end do
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  torbnd(1),torbnd(2)
         query = .false.
      end if
   10 continue
      if (query) then
         do while (torbnd(1).eq.0 .or. torbnd(2).eq.0)
            write (iout,20)
   20       format (/,' Enter Central Atoms of First Torsion : ',$)
            read (input,*,err=30,end=30)  torbnd(1),torbnd(2)
   30       continue
         end do
      end if
c
c     choose the second torsion based on the center bond atoms
c
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=40,end=40)  torbnd(3),torbnd(4)
         query = .false.
      end if
   40 continue
      if (query) then
         write(iout,50)
   50    format (/,' Enter Central Atoms for 2nd Torsion',
     &              ' [Optional, <Enter>=None] : ',$)
         read (input,60,err=70,end=70)  record
   60    format (a240)
         read (record,*,err=70,end=70)  torbnd(3),torbnd(4)
   70    continue
      end if
c
c     fit the torsional parameters based on potential surface
c
      call fittors (torbnd)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine fittors  --  torsional parameter refinement  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "fittors" refines torsion parameters based on a quantum
c     mechanical optimized energy surface
c
c
      subroutine fittors (torbnd)
      use atoms
      use atomid
      use files
      use inform
      use iounit
      use keys
      use ktorsn
      use math
      use output
      use potent
      use qmstuf
      use restrn
      use scales
      use tors
      use usage
      implicit none
      integer maxfit,maxconf
      parameter (maxfit=12)
      parameter (maxconf=500)
      integer i,j,k,ii,jj,kk
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer itmpa,itmpb,otfix
      integer ntorfit,ntorcrs
      integer nconf,size
      integer oldleng,oldnkey
      integer istep,maxstep
      integer nvxx,ivxx
      integer ikey,nvar
      integer freeunit
      integer trimtext
      integer torbnd(*)
      integer ctorid(maxfit)
      integer ftorid(maxfit)
      integer tflg(maxfit)
      integer torcrs(4,maxfit)
      integer cflg(9*maxfit)
      integer refconf(maxconf)
      real*8 tmpa,tmpb,tv,vcon
      real*8 eqmmin,emmmin
      real*8 rms,zrms,avedl
      real*8 minimum,grdmin
      real*8 energy,torfit1
      real*8 geometry
      real*8 vxx(6*maxfit)
      real*8 vxxl(6*maxfit)
      real*8 eqm(maxconf)
      real*8 emm(maxconf)
      real*8 erqm(maxconf)
      real*8 ermm(maxconf)
      real*8 delte(maxconf)
      real*8 fwt(maxconf)
      real*8 torf(maxconf)
      real*8, allocatable :: xx(:)
      real*8 tord(6*maxfit,6*maxfit)
      real*8 mata(6*maxfit,6*maxfit)
      real*8 ftv(maxconf,maxfit)
      real*8 rftv(maxconf,maxfit)
      real*8 coeff(maxconf,6*maxfit)
      real*8 ctv(maxconf,9*maxfit)
      logical done
      logical vflg(6,maxfit)
      logical confvisited(maxconf)
      character*4 pa,pb,pc,pd
      character*16 kft(maxfit)
      character*16 kct(9*maxfit)
      character*240 record
      character*240 keyfile
      character*240 oldfilename
      character*240, allocatable :: oldkeyline(:)
      external torfit1
      external optsave
c
c
c     set initial values
c
      ntorfit = 0
      ntorcrs = 0
      otfix = ntfix
      istep = 0
      tv = 0.0d0
      vcon = 0.5d0
      do i = 1, maxfit
         ftorid(i) = 0
         tflg(i) = 0
         do j = 1, 6
            vflg(j,i) = .false.
         end do
      end do
      do i = 1, 6*maxfit
         vxx(i) = 0.0d0
         vxxl(i) = 0.1d0
         avedl = 0.0d0
         do j = 1, 6*maxfit
            tord(i,j) = 0.0d0
         end do
      end do
      do i = 1, 9*maxfit
         cflg(i) = 0
      end do
      do i = 1, maxconf
         fwt(i) = 1.0d0
         torf(i) = 0.0d0
         confvisited(i) = .false.
      end do
      do i = 1, maxconf
         do j = 1, 6*maxfit
            coeff(i,j) = 0.0d0
         end do
         refconf = 0
      end do
      grdmin = 0.01
      if (torbnd(1) .gt. torbnd(2)) then
         itmpa = torbnd(1)
         torbnd(1) = torbnd(2)
         torbnd(2) = itmpa
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (oldkeyline(nkey))
c
c     store the information from the keyfile
c
      oldfilename = filename
      oldleng = leng
      oldnkey = nkey
      do i = 1, nkey
         oldkeyline(i) = keyline(i)
      end do
c
c     check all the torsions cross the two center bond atoms
c
      write (iout,10)
   10 format (/,' Torsions Crossing the Central Bond :',/)
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         itmpa = ib
         itmpb = ic
         if (itmpa .gt. itmpb) then
            j = itmpa
            itmpa = itmpb
            itmpb = j
         end if
         if ((torbnd(1).eq.itmpa .and. torbnd(2).eq.itmpb) .or.
     &       (torbnd(3).eq.itmpa .and. torbnd(4).eq.itmpb)) then
            ntorcrs = ntorcrs + 1
            torcrs(1,ntorcrs) = ia
            torcrs(2,ntorcrs) = ib
            torcrs(3,ntorcrs) = ic
            torcrs(4,ntorcrs) = id
            ctorid(ntorcrs) = i
            write (iout,20)  ntorcrs,ia,name(ia),ib,name(ib),
     &                       ic,name(ic),id,name(id)
   20       format (' Torsion',i5,' :',3x,4(i6,'-',a3))
         end if
      end do
c
c     choose the specific torsions for fitting
c
      write (iout,30)
   30 format (/,' Choose Torsions for Fitting from Above List :  ',$)
      read (input,40,err=50,end=50)  record
   40 format (a240)
   50 continue
      read (record,*,err=60,end=60)  (ftorid(i),i=1,ntorcrs)
   60 continue
c
c     count the torsions to be fitted
c
      do i = 1, ntorcrs
         if (ftorid(i) .gt. 0)  ntorfit = ntorfit + 1
      end do
c
c     get the number of conformations for fitting
c
      write (iout,70)
   70 format (/,' Enter Total Number of Conformations :  ',$)
      read (input,*,err=80,end=80)  nconf
   80 continue
c
c     read the QM coordinates and conformations energies
c
      do i = 1, nconf
         call readgau
         write (iout,90)  i
   90    format (/ ,' Finished Reading Conformation',i4)
         do j = 1, n
            x(j) = gx(j)
            y(j) = gy(j)
            z(j) = gz(j)
         end do
         call makeref (i)
         eqm(i) = egau
      end do
c
c     calculate the relative QM conformational energies
c
      eqmmin = eqm(1)
      do i = 2, nconf
         if (eqm(i) .lt. eqmmin)  eqmmin = eqm(i)
      end do
      write (iout,100)
  100 format ()
      do i = 1, nconf
         erqm(i) = eqm(i) - eqmmin
         write (iout,110)  i,erqm(i)
  110    format (' Relative Conformational Energy (QM)',i8,f12.4,
     &              ' Kcal/mole')
      end do
c
c     get fitting torsion type (atom classes)
c
      do i = 1, ntorfit
         j = ftorid(i)
         k = ctorid(j)
         ia = itors(1,k)
         ib = itors(2,k)
         ic = itors(3,k)
         id = itors(4,k)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         if (itb .le. itc) then
            kft(i) = pa//pb//pc//pd
         else
            kft(i) = pd//pc//pb//pa
         end if
      end do
c
c     get all the cross torsion types
c
      do i = 1, ntorcrs
         k = ctorid(i)
         ia = itors(1,k)
         ib = itors(2,k)
         ic = itors(3,k)
         id = itors(4,k)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         if (itb .le. itc) then
            kct(i) = pa//pb//pc//pd
         else
            kct(i) = pd//pc//pb//pa
         end if
      end do
c
c     initialize the torsion and geometry restrain parameters
c
      write (iout,120)
  120 format (/,' Initial Torsional Parameters:',/)
      nvxx = 0
      do i = 1, ntorfit
         j = ftorid(i)
         k = ctorid(j)
         done = .false.
         tflg(i) = 0
         ia = itors(1,k)
         ib = itors(2,k)
         ic = itors(3,k)
         id = itors(4,k)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         write (iout,130)  ita,itb,itc,itd,tors1(1,k),tors2(1,k),
     &                     tors3(1,k),tors4(1,k),tors5(1,k),tors6(1,k)
  130    format (' torsion ',4i4,6f8.3)
         do ii = 1, i-1
            jj = ftorid(ii)
            kk = ctorid(jj)
            if (kft(i) .eq. kft(ii)) then
               done = .true.
               tflg(i) = ii
               goto 150
            end if
         end do
         do ii = 1, ntorcrs
            if (kct(ii).eq.kft(i) .and. ii.ne.j)  cflg(ii) = j
         end do
         if (abs(tors1(1,k)) .gt. 0.0d0) then
            nvxx = nvxx +1
            vxx(nvxx) = tors1(1,k)
            vflg(1,i) = .true.
         end if
         tors1(1,k) = 0.0d0
         tors1(2,k) = 0.0d0
         if (abs(tors2(1,k)) .gt. 0.0d0) then
            nvxx = nvxx +1
            vxx(nvxx) = tors2(1,k)
            vflg(2,i) = .true.
         end if
         tors2(1,k) = 0.0d0
         tors2(2,k) = 180.0d0
         if (abs(tors3(1,k)) .gt. 0.0d0) then
            nvxx = nvxx +1
            vxx(nvxx) = tors3(1,k)
            vflg(3,i) = .true.
         end if
         tors3(1,k) = 0.0d0
         tors3(2,k) = 0.0d0
         if (abs(tors4(1,k)) .gt. 0.0d0) then
            nvxx = nvxx +1
            vxx(nvxx) = tors4(1,k)
            vflg(4,i) = .true.
         end if
         tors4(1,k) = 0.0d0
         tors4(2,k) = 180.0d0
         if (abs(tors5(1,k)) .gt. 0.0d0) then
            nvxx = nvxx +1
            vxx(nvxx) = tors5(1,k)
            vflg(5,i) = .true.
         end if
         tors5(1,k) = 0.0d0
         tors5(2,k) = 0.0d0
         if (abs(tors6(1,k)) .gt. 0.0d0) then
            nvxx = nvxx +1
            vxx(nvxx) = tors6(1,k)
            vflg(6,i) = .true.
         end if
         tors6(1,k) = 0.0d0
         tors6(2,k) = 180.0d0
         ntfix = ntfix+1
         itfix(1,ntfix) = ia
         itfix(2,ntfix) = ib
         itfix(3,ntfix) = ic
         itfix(4,ntfix) = id
         tfix(1,ntfix) = 5.0d0
         write (iout,140)  ia,ib,ic,id
  140    format (' Fixed Torsion',3x,4i6)
  150    continue
      end do
c
c     print torsion flags (check duplicated torsion types)
c
      do i = 1, ntorfit
         write (iout,160)  i,tflg(i)
  160    format (/,' Fitting Torsion Number',i5,5x,'Flag',i5)
         do j = 1, 6
            write (iout,170)  i,j,vflg(j,i)
  170       format (' Variable',2i4,5x,'Variable Flag',l5)
         end do
      end do
c
c     print torsion flags for all the torsions across the bond
c
      write (iout,180)
  180 format (/,' All the Torsions Across the Bond :')
      do i = 1, ntorcrs
         k = ctorid(i)
         if (cflg(i) .gt. 0) then
            tors1(1,k) = 0.0d0
            tors2(1,k) = 0.0d0
            tors3(1,k) = 0.0d0
            tors4(1,k) = 0.0d0
            tors5(1,k) = 0.0d0
            tors6(1,k) = 0.0d0
         end if
         write (iout,190)  i,cflg(i)
  190    format (' Fitting Torsion Number',i5,5x,'Flag',i5)
      end do
c
c     add one constant variable
c
      nvxx = nvxx + 1
      vxx(nvxx) = vcon
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(scale))  allocate (scale(3*n))
c
c     get initial energy difference
c
      do i = 1, nconf
         call getref (i)
         kk = 0
         do j = 1, ntorfit
            k = ftorid(j)
            ia = torcrs(1,k)
            ib = torcrs(2,k)
            ic = torcrs(3,k)
            id = torcrs(4,k)
            ftv(i,j) = geometry (ia,ib,ic,id)
            write (iout,200)  i,j,ftv(i,j)
  200       format (' Fitting Torsion Value',2i5,f12.4)
            if (tflg(j) .eq. 0) then
               kk = kk+1
               tfix(2,otfix+kk) = ftv(i,j)
               tfix(3,otfix+kk) = tfix(2,otfix+kk)
            end if
         end do
         do k = 1, ntorcrs
            ia = torcrs(1,k)
            ib = torcrs(2,k)
            ic = torcrs(3,k)
            id = torcrs(4,k)
            ctv(i,k) = geometry (ia,ib,ic,id)
         end do
c
c     perform dynamic allocation of some local arrays
c
         allocate (xx(3*nuse))
c
c     scale the coordinates of each active atom
c
         nvar = 0
         do j = 1, n
            if (use(j)) then
               nvar = nvar + 1
               scale(nvar) = 12.0d0
               xx(nvar) = x(j) * scale(nvar)
               nvar = nvar + 1
               scale(nvar) = 12.0d0
               xx(nvar) = y(j) * scale(nvar)
               nvar = nvar + 1
               scale(nvar) = 12.0d0
               xx(nvar) = z(j) * scale(nvar)
            end if
         end do
c
c     make the call to the optimization routine
c
         write (iout,210)  i
  210    format (/,' Minimizing Structure',i6)
         coordtype = 'CARTESIAN'
         use_geom = .true.
         grdmin = 0.01d0
         iwrite = 0
         iprint = 0
         call lbfgs (nvar,xx,minimum,grdmin,torfit1,optsave)
c
c     unscale the final coordinates for active atoms
c
         nvar = 0
         do j = 1, n
            if (use(j)) then
               nvar = nvar + 1
               x(j) = xx(nvar) / scale(nvar)
               nvar = nvar + 1
               y(j) = xx(nvar) / scale(nvar)
               nvar = nvar + 1
               z(j) = xx(nvar) / scale(nvar)
            end if
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (xx)
c
c     set the energy value for the current minimum
c
         emm(i) = energy ()
      end do
c
c     calculate relative value for each torsional angle
c
      do i = 1, nconf
         do j = 1, ntorfit
            rftv(i,j) = ftv(i,j) - ftv(i,1)
         end do
      end do
c
c     calculate the relative MM energies
c
      emmmin = emm(1)
      do i = 2, nconf
         if (emm(i) .lt. emmmin)  emmmin = emm(i)
      end do
c
c     calculate the energy difference and RMS
c
      rms = 0.0d0
      zrms = 0.0d0
      write (iout,220)
  220 format ()
      do i = 1, nconf
         ermm (i) = emm(i) - emmmin
         delte (i) = erqm (i) - ermm(i)
         rms = rms + delte(i)*delte(i)
         write (iout,230)  i,ermm(i)
  230    format (' Relative Conformational Energy (MM)',i8,f12.4,
     &              ' Kcal/mole')
      end do
      rms = sqrt(rms/dble(nconf))
      zrms = rms
      write (iout,240)  rms
  240 format (/,' Energy RMS Difference :',8x,f12.4)
c
c     calculate the weights
c
c     do i = 1, nconf
c        do j = 1, nconf
c           if (.not. confvisited(j)) then
c              tmpa = ftv(j,1)
c              itmpa = j
c              confvisited(j) = .true.
c              goto 241
c           end if
c        end do
c 241    continue
c        do j = 1, nconf
c           if (ftv(j,1).lt.tmpa .and. .not.confvisited(j)) then
c              confvisited(itmpa) = .false.
c              itmpa = j
c              tmpa = ftv(j,1)
c           end if
c        end do
c        refconf(itmpa) = i
c        confvisited(itmpa) = .true.
c        write (iout,242)  itmpa,refconf(itmpa)
c 242    format (i8,' <===> ',i8)
c     end do
      if (nconf .gt. 1 .and. torbnd(3) .eq. 0) then
         if ((ftv(nconf,1)+180.0d0) .lt. 1.0d0
     &           .and. ftv(nconf-1,1) .gt. 0.0d0)
     &       ftv(nconf,1) = 180.0d0
         tmpa = erqm(2) - erqm(1)
         tmpb = (ftv(2,1)-ftv(1,1)) / radian
         fwt(1) = 1.0d0 / sqrt(1.0d0+(tmpa/tmpb)**2)
         if (nconf .gt. 2) then
            do i = 2, nconf-1
               tmpa = erqm(i+1) - erqm(i-1)
               tmpb = (ftv(i+1,1) - ftv(i-1,1))/radian
               fwt(i) = 1.0d0 / sqrt(1.0d0+(tmpa/tmpb)**2)
            end do
         end if
         tmpa = erqm(nconf) - erqm(nconf-1)
         tmpb = (ftv(nconf,1) - ftv(nconf-1,1))/radian
         fwt(nconf) = 1.0d0 / sqrt(1.0d0+(tmpa/tmpb)**2)
      end if
      write (iout,250)
  250 format ()
      do i = 1, nconf
         write (iout,260)  i,fwt(i)
  260    format (' Conformation',i5,5x,'Weight',f8.4)
      end do
c
c     set initial values for torsions to be fitted
c
      ivxx = 0
      do i = 1, ntorfit
         j = ftorid(i)
         k = ctorid(j)
         do ii = 1, 6
            if (vflg(ii,i) .and. tflg(i).eq.0) then
               ivxx = ivxx + 1
               if (ii .eq. 1) then
                  tors1(1,k) = vxx(ivxx)
               else if (ii .eq. 2) then
                  tors2(1,k) = vxx(ivxx)
               else if (ii .eq. 3) then
                  tors3(1,k) = vxx(ivxx)
               else if (ii .eq. 4) then
                  tors4(1,k) = vxx(ivxx)
               else if (ii .eq. 5) then
                  tors5(1,k) = vxx(ivxx)
               else if (ii .eq. 6) then
                  tors6(1,k) = vxx(ivxx)
               end if
               do jj = 1, ntorfit
                  kk = ctorid(ftorid(jj))
                  if (tflg(jj) .eq. i) then
                     if (ii .eq. 1) then
                        tors1(1,kk) = vxx(ivxx)
                     else if (ii .eq. 2) then
                        tors2(1,kk) = vxx(ivxx)
                     else if (ii .eq. 3) then
                        tors3(1,kk) = vxx(ivxx)
                     else if (ii .eq. 4) then
                        tors4(1,kk) = vxx(ivxx)
                     else if (ii .eq. 5) then
                        tors5(1,kk) = vxx(ivxx)
                     else if (ii .eq. 6) then
                        tors6(1,kk) = vxx(ivxx)
                     end if
                  end if
               end do
            end if
         end do
         ivxx = ivxx + 1
         vcon = vxx(ivxx)
      end do
c
c     fitting the torsion parameters
c
      write (iout,270)
  270 format ()
      maxstep = 1
      avedl = 0.5d0
      do while (avedl.gt.0.1d0 .and. istep.lt.maxstep)
         do i = 1, nconf
            ivxx = 0
            torf(i) = 0.0d0
            do j = 1, ntorfit
               jj = ftorid(j)
               kk = ctorid(jj)
               ia = itors(1,kk)
               ib = itors(2,kk)
               ic = itors(3,kk)
               id = itors(4,kk)
               ita = class(ia)
               itb = class(ib)
               itc = class(ic)
               itd = class(id)
               tv = ftv(i,j) / radian
               tmpa = tors1(1,kk)*(1+cos(tv))
     &                    + tors2(1,kk)*(1-cos(2*tv))
     &                    + tors3(1,kk)*(1+cos(3*tv))
     &                    + tors4(1,kk)*(1-cos(4*tv))
     &                    + tors5(1,kk)*(1+cos(5*tv))
     &                    + tors6(1,kk)*(1-cos(6*tv))
               torf(i) = torf(i) + 0.5*tmpa
               do ii = 1, 6
                  if (vflg(ii,j) .and. tflg(j).eq.0) then
                     ivxx = ivxx +1
                     coeff(i,ivxx) = 0.5*(1+(-1)**(ii+1)
     &                                  *cos(dble(ii)*tv))
                     do k = 1, ntorcrs
                        if (cflg(k).gt.0 .and. cflg(k).eq.jj) then
                           coeff(i,ivxx) = coeff(i,ivxx)
     &                                     +0.5*(1+(-1)**(ii+1)
     &                               *cos(dble(ii)*ctv(i,k)/radian))
                        end if
                     end do
                     write (iout,280)  i,ivxx,coeff(i,ivxx)
  280                format (' Derivative :',5x,2i4,f8.4)
                  end if
               end do
            end do
            torf(i) = torf(i) + vcon - delte(i)
            ivxx = ivxx + 1
            coeff(i,ivxx) = 1.0d0
            write (iout,290)  i,torf(i)
  290       format (' Energy Difference :',i8,f12.4)
         end do
c
c     set matrix elements for matrix A
c
         do i = 1, nvxx
            do j = 1, nvxx
               tord(i,j) = 0.0d0
               do k = 1, nconf
                  tord(i,j) = tord(i,j) + coeff(k,i)*coeff(k,j)*fwt(k)
               end do
            end do
         end do
c
c     print the matrix A elements
c
         write (iout,300)  nvxx
  300    format (/,' Total Variable Number ',i8)
         write (iout,310)
  310    format (/,' Matrix A Elements :')
         do i = 1, nvxx
            do j = 1, nvxx
               mata(i,j) = tord(i,j)
            end do
            write (iout,320)  (mata(i,j),j=1,nvxx)
  320       format (1x,5f12.4)
         end do
c
c     multiply vector: Yi * Coeff * Weight
c
         do i = 1, nvxx
            torf(i) = 0.0d0
            do j = 1, nconf
               torf(i) = torf(i) + delte(j)*fwt(j)*coeff(j,i)
            end do
         end do
         do i = 1, nvxx
            mata(i,nvxx+1) = torf(i)
         end do
c
c     solve the linear equations via Gauss-Jordan elimination
c
         call gaussjordan (nvxx,mata)
c
c     get new torsion force constants
c
         do i = 1, nvxx
            vxx(i) = mata(i,nvxx+1)
         end do
         ivxx = 0
         do i = 1, ntorfit
            j = ftorid(i)
            k = ctorid(j)
            do ii = 1, 6
               if (vflg(ii,i) .and. tflg(i).eq.0) then
                  ivxx = ivxx + 1
                  if (ii .eq. 1) then
                     tors1(1,k) = vxx(ivxx)
                  else if (ii .eq. 2) then
                     tors2(1,k) = vxx(ivxx)
                  else if (ii .eq. 3) then
                     tors3(1,k) = vxx(ivxx)
                  else if (ii .eq. 4) then
                     tors4(1,k) = vxx(ivxx)
                  else if (ii .eq. 5) then
                     tors5(1,k) = vxx(ivxx)
                  else if (ii .eq. 6) then
                     tors6(1,k) = vxx(ivxx)
                  end if
                  do jj = 1, ntorcrs
                     kk = ctorid(jj)
                     if (cflg(j).gt.0 .and. cflg(jj).eq.j) then
                        if (ii .eq. 1) then
                           tors1(1,kk) = vxx(ivxx)
                        else if (ii .eq. 2) then
                           tors2(1,kk) = vxx(ivxx)
                        else if (ii .eq. 3) then
                           tors3(1,kk) = vxx(ivxx)
                        else if (ii .eq. 4) then
                           tors4(1,kk) = vxx(ivxx)
                        else if (ii .eq. 5) then
                           tors5(1,kk) = vxx(ivxx)
                        else if (ii .eq. 6) then
                           tors6(1,kk) = vxx(ivxx)
                        end if
                     end if
                  end do
               end if
            end do
            ivxx = ivxx + 1
            vcon = vxx(ivxx)
         end do
         istep = istep + 1
      end do
c
c     validate the fitted results
c
      write (iout,330)
  330 format ()
      do i = 1, nconf
         call getref (i)
         kk = 0
         do j = 1, ntorfit
            k = ftorid(j)
            ia = torcrs(1,k)
            ib = torcrs(2,k)
            ic = torcrs(3,k)
            id = torcrs(4,k)
            ftv(i,j) = geometry (ia,ib,ic,id)
            if (tflg(j) .eq. 0) then
               kk = kk + 1
               tfix(2,otfix+kk) = ftv(i,j)
               tfix(3,otfix+kk) = tfix(2,otfix+kk)
            end if
         end do
c
c     perform dynamic allocation of some local arrays
c
         allocate (xx(3*nuse))
c
c     scale the coordinates of each active atom
c
         nvar = 0
         do j = 1, n
            if (use(j)) then
               nvar = nvar + 1
               xx(nvar) = x(j) * scale(nvar)
               nvar = nvar + 1
               xx(nvar) = y(j) * scale(nvar)
               nvar = nvar + 1
               xx(nvar) = z(j) * scale(nvar)
            end if
         end do
c
c     make the call to the optimization routine
c
         write (iout,340)  i
  340    format (' Minimizing Structure',i5,2x,'with New Parameters')
         coordtype = 'CARTESIAN'
         call lbfgs (nvar,xx,minimum,grdmin,torfit1,optsave)
c
c     unscale the final coordinates for active atoms
c
         nvar = 0
         do j = 1, n
            if (use(j)) then
               nvar = nvar + 1
               x(j) = xx(nvar) / scale(nvar)
               nvar = nvar + 1
               y(j) = xx(nvar) / scale(nvar)
               nvar = nvar + 1
               z(j) = xx(nvar) / scale(nvar)
            end if
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (xx)
c
c     set the energy value for the current minimum
c
         emm(i) = energy ()
      end do
c
c     calculate the relative MM energies
c
      emmmin = emm(1)
      do i = 2, nconf
         if (emm(i) .lt. emmmin)  emmmin = emm(i)
      end do
c
c     calculate the energy difference and RMS
c
      rms = 0.0d0
      write (iout,350)
  350 format ()
      do i = 1, nconf
         ermm (i) = emm(i) - emmmin
         delte (i) = erqm (i) - ermm(i)
         rms = rms + delte(i)*delte(i)
         write (iout,360)  i,ermm(i)
  360    format (' Relative Conformational Energy (MM)',i8,f12.4,
     &              ' Kcal/mole')
      end do
      rms = sqrt(rms/dble(nconf))
      write (iout,370)  rms
  370 format (/,' Energy RMS With Fitting Parmeters :',8x,f12.4)
      if (rms .gt. zrms ) then
         write (iout,380)  zrms
  380    format (/,' Annihilating the Torsions is Preferable',
     &           /,' Final RMS :',f12.6,' Kcal/mole',/)
      end if
c
c     output keyfile information with the fitted parameters
c
      filename = oldfilename
      leng = oldleng
      nkey = oldnkey
      do i = 1, nkey
         keyline(i) = oldkeyline(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (oldkeyline)
c
c     output some definitions and parameters to a keyfile
c
      ikey = freeunit ()
      keyfile = filename(1:leng)//'.key'
      call version (keyfile,'new')
      open (unit=ikey,file=keyfile,status='new')
c
c     copy the contents of any previously existing keyfile
c
      do i = 1, nkey
         record = keyline(i)
         size = trimtext (record)
         write (ikey,390)  record(1:size)
  390    format (a)
      end do
c
c     list the valence parameters
c
      write (ikey,400)
  400 format (/,'#',/,'# Results of Valence Parameter Fitting',
     &        /,'#',/)
      write (iout,410)
  410 format (/,' Optimized Torsional Parameters:',/)
      do i = 1, ntorfit
         if (tflg(i) .eq. 0) then
            j = ftorid(i)
            k = ctorid(j)
            ia = itors(1,k)
            ib = itors(2,k)
            ic = itors(3,k)
            id = itors(4,k)
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            itd = class(id)
            if (rms .gt. zrms) then
               tors1(1,k) = 0.0d0
               tors2(1,k) = 0.0d0
               tors3(1,k) = 0.0d0
            end if
            write (iout,420)  ita,itb,itc,itd,tors1(1,k),
     &                        tors2(1,k),tors3(1,k)
  420       format (' torsion ',4i4,f8.3,' 0.0 1 ',f8.3,
     &                 ' 180.0 2 ',f8.3,' 0.0 3')
            write (ikey,430)  ita,itb,itc,itd,tors1(1,k),
     &                        tors2(1,k),tors3(1,k)
  430       format (' torsion ',4i4,f8.3,' 0.0 1 ',f8.3,
     &                 ' 180.0 2 ',f8.3,' 0.0 3')
         end if
      end do
      close (unit=ikey)
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine gaussjordan  --  Gauss-Jordan elimination  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "gaussjordan" solves a system of linear equations by using
c     the method of Gaussian elimination with partial pivoting
c
c
      subroutine gaussjordan (n,a)
      use iounit
      implicit none
      integer maxfit
      parameter (maxfit=12)
      integer i,j,k,l,n
      real*8 t,av
      real*8 a(6*maxfit,*)
c
c
c     perform the Gauss-Jordan elimination procedure
c
      do k = 1, n-1
         av = 0.0d0
         do i = k, n
            if (abs(a(i,k)) .gt. abs(av)) then
               av = a(i,k)
               l = i
            end if
         end do
         if (abs(av) .lt. 1.0d-8) then
            write (iout,10)
   10       format (/,' GAUSSJORDAN  --  Singular Coefficient Matrix')
            call fatal
         end if
         if (l .ne. k) then
            do j = k, n+1
               t = a(k,j)
               a(k,j) = a(l,j)
               a(l,j) = t
            end do
         end if
         av = 1.0d0 / av
         do j = k+1, n+1
            a(k,j) = a(k,j) * av
            do i = k+1, n
               a(i,j) = a(i,j) - a(i,k)*a(k,j)
            end do
         end do
      end do
      a(n,n+1) = a(n,n+1) / a(n,n)
      do k = 1, n-1
         i = n - k
         av = 0.0d0
         do j = i+1, n
            av = av + a(i,j)*a(j,n+1)
         end do
         a(i,n+1) = a(i,n+1) - av
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function torfit1  --  energy and gradient for minimize  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "torfit1" is a service routine that computes the energy and
c     gradient for a low storage BFGS optimization in Cartesian
c     coordinate space
c
c
      function torfit1 (xx,g)
      use atoms
      use scales
      use usage
      implicit none
      integer i,nvar
      real*8 torfit1,e
      real*8 energy,eps
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
      logical analytic
      external energy
c
c
c     use either analytical or numerical gradients
c
      analytic = .true.
      eps = 0.00001d0
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            x(i) = xx(nvar) / scale(nvar)
            nvar = nvar + 1
            y(i) = xx(nvar) / scale(nvar)
            nvar = nvar + 1
            z(i) = xx(nvar) / scale(nvar)
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the energy and gradient
c
      if (analytic) then
         call gradient (e,derivs)
      else
         e = energy ()
         call numgrad (energy,derivs,eps)
      end if
      torfit1 = e
c
c     convert gradient components to optimization parameters
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            g(nvar) = derivs(1,i) / scale(nvar)
            nvar = nvar + 1
            g(nvar) = derivs(2,i) / scale(nvar)
            nvar = nvar + 1
            g(nvar) = derivs(3,i) / scale(nvar)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine torsions  --  locate and store torsions  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "torsions" finds the total number of torsional angles and
c     the numbers of the four atoms defining each torsional angle
c
c
      subroutine torsions
      use atoms
      use bndstr
      use couple
      use tors
      implicit none
      integer i,j,k
      integer ia,ib,ic,id
c
c
c     initial count of the total number of torsions
c
      ntors = 0
      do i = 1, nbond
         ib = ibnd(1,i)
         ic = ibnd(2,i)
         do j = 1, n12(ib)
            ia = i12(j,ib)
            if (ia .ne. ic) then
               do k = 1, n12(ic)
                  id = i12(k,ic)
                  if (id.ne.ib .and. id.ne.ia) then
                     ntors = ntors + 1
                  end if
               end do
            end if
         end do
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(itors))  deallocate (itors)
      allocate (itors(4,ntors))
c
c     store the list of atoms involved in each torsion
c
      ntors = 0
      do i = 1, nbond
         ib = ibnd(1,i)
         ic = ibnd(2,i)
         do j = 1, n12(ib)
            ia = i12(j,ib)
            if (ia .ne. ic) then
               do k = 1, n12(ic)
                  id = i12(k,ic)
                  if (id.ne.ib .and. id.ne.ia) then
                     ntors = ntors + 1
                     itors(1,ntors) = ia
                     itors(2,ntors) = ib
                     itors(3,ntors) = ic
                     itors(4,ntors) = id
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2003  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module tortor  --  torsion-torsions in current structure  ##
c     ##                                                            ##
c     ################################################################
c
c
c     ntortor   total number of torsion-torsion interactions
c     itt       atoms and parameter indices for torsion-torsion
c
c
      module tortor
      implicit none
      integer ntortor
      integer, allocatable :: itt(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module tree  --  potential smoothing search tree levels  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     maxpss   maximum number of potential smoothing levels
c
c     nlevel   number of levels of potential smoothing used
c     etree    energy reference value at the top of the tree
c     ilevel   smoothing deformation value at each tree level
c
c
      module tree
      implicit none
      integer maxpss
      parameter (maxpss=500)
      integer nlevel
      real*8 etree
      real*8 ilevel(0:maxpss)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  function trimtext  --  find last non-blank character  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "trimtext" finds and returns the location of the last
c     non-blank character before the first null character in
c     an input text string; the function returns zero if no
c     such character is found
c
c
      function trimtext (string)
      implicit none
      integer i,size,last
      integer len,trimtext
      character*1 char
      character*1 null
      character*(*) string
c
c
c     move forward through the string, one character
c     at a time, looking for first null character
c
      trimtext = 0
      size = len(string)
      null = char(0)
      last = size
      do i = 1, size
         if (string(i:i) .eq. null) then
            last = i - 1
            goto 10
         end if
      end do
   10 continue
c
c     move backward through the string, one character
c     at a time, looking for first non-blank character
c
      do i = last, 1, -1
         if (string(i:i) .gt. ' ') then
            trimtext = i
            goto 20
         end if
      end do
   20 continue
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine trimhead  --  remove spaces before first text  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "trimhead" removes blank spaces before the first non-blank
c     character in a text string by shifting the string to the left
c
c
      subroutine trimhead (string)
      implicit none
      integer i,j,k
      character*240 string
      character*240 temp
c
c
c     loop over characters, removing blank beginning spaces
c
      do i = 1, 240
         temp(i:i) = ' '
      end do
      j = 0
      k = 0
      do i = 1, 240
         if (string(i:i) .ne. ' ')  j = 1
         if (j .eq. 1) then
            k = k + 1
            temp(k:k) = string(i:i)
         end if
      end do
      do i = 1, 240
         string(i:i) = temp(i:i)
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine justify  --  convert string to right justified  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "justify" converts a text string to right justified format
c     with leading blank spaces
c
c
      subroutine justify (string)
      implicit none
      integer i,k,len
      integer size,last
      character*1 char
      character*1 null
      character*1 letter
      character*(*) string
c
c
c     move backward through the string, one character
c     at a time, looking for first non-blank character
c
      size = len(string)
      null = char(0)
      last = 0
      do i = size, 1, -1
         letter = string(i:i)
         if (letter.ne.' ' .and. letter.ne.null) then
            last = i
            goto 10
         end if
      end do
   10 continue
c
c     move string to the right and pad with leading blanks
c
      do i = last, 1, -1
         k = i + size - last
         string(k:k) = string(i:i)
      end do
      do i = 1, size-last
         string(i:i) = ' '
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine upcase  --  convert string to all upper case  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "upcase" converts a text string to all upper case letters
c
c
      subroutine upcase (string)
      implicit none
      integer i,size,len
      integer code,ichar
      character*1 char
      character*1 letter
      character*(*) string
c
c
c     convert lower case to upper case one letter at a time
c
      size = len(string)
      do i = 1, size
         letter = string(i:i)
         code = ichar(letter)
         if (letter.ge.'a' .and. letter.le.'z')
     &      string(i:i) = char(code-32)
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine lowcase  --  convert string to all lower case  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "lowcase" converts a text string to all lower case letters
c
c
      subroutine lowcase (string)
      implicit none
      integer i,size
      integer code,ichar
      character*1 char
      character*1 letter
      character*(*) string
c
c
c     convert upper case to lower case one letter at a time
c
      size = len(string)
      do i = 1, size
         letter = string(i:i)
         code = ichar(letter)
         if (letter.ge.'A' .and. letter.le.'Z')
     &      string(i:i) = char(code+32)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2025  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module tritor  --  tritorsions in the current structure  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     ntritor  total number of tritorsions in the system
c     itritor  numbers of the atoms in each tritorsion
c
c
      module tritor
      implicit none
      integer ntritor
      integer, allocatable :: itritor(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2025  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine tritors  --  locate and store tritorsions  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "tritors" finds the total number of tritorsions as triples
c     of adjacent torsional angles, and the numbers of the six
c     atoms defining each tritorsion
c
c
      subroutine tritors
      use atoms
      use couple
      use tors
      use tritor
      implicit none
      integer i,j,k
      integer ia,ib,ic
      integer id,ie,ig
c
c
c     initial count of the total number of tritorsions
c
      ntritor = 0
      do i = 1, ntors
         ib = itors(1,i)
         ic = itors(2,i)
         id = itors(3,i)
         ie = itors(4,i)
         do j = 1, n12(ib)
            ia = i12(j,ib)
            if (ia.ne.ic .and. ia.ne.id .and. ia.ne.ie) then
               do k = 1, n12(ie)
                  ig = i12(k,ie)
                  if (ig.ne.id .and. ig.ne.ic .and.
     &                ig.ne.ib .and. ig.ne.ia) then
                     ntritor = ntritor + 1
                  end if
               end do
            end if
         end do
      end do
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(itritor))  deallocate (itritor)
      allocate (itritor(6,ntritor))
c
c     store the list of atoms involved in each tritorsion
c
      ntritor = 0
      do i = 1, ntors
         ib = itors(1,i)
         ic = itors(2,i)
         id = itors(3,i)
         ie = itors(4,i)
         do j = 1, n12(ib)
            ia = i12(j,ib)
            if (ia.ne.ic .and. ia.ne.id .and. ia.ne.ie) then
               do k = 1, n12(ie)
                  ig = i12(k,ie)
                  if (ig.ne.id .and. ig.ne.ic .and.
     &                ig.ne.ib .and. ig.ne.ia) then
                     ntritor = ntritor + 1
                     itritor(1,ntritor) = ia
                     itritor(2,ntritor) = ib
                     itritor(3,ntritor) = ic
                     itritor(4,ntritor) = id
                     itritor(5,ntritor) = ie
                     itritor(6,ntritor) = ig
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ###############################################################
c     ##        COPYRIGHT (C)  2002-2009  by  Patrice Koehl        ##
c     ##  COPYRIGHT (C) 2023 by Moses K. J. Chung & Jay W. Ponder  ##
c     ##                    All Rights Reserved                    ##
c     ###############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine unionball  --  alpha shapes surface & volume  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "unionball" computes the surface area and volume of a union of
c     spheres via the analytical inclusion-exclusion method of Herbert
c     Edelsbrunner based on alpha shapes, also finds derivatives of
c     surface area and volume with respect to Cartesian coordinates
c
c     original UnionBall code developed and provided by Patrice Koehl,
c     Computer Science, University of California, Davis
c
c     modified to facilitate calling of UnionBall from Tinker by
c     Moses K. J. Chung and Jay W. Ponder, Washington University,
c     October 2023 to May 2024
c
c     literature references:
c
c     P. Mach and P. Koehl, "Geometric Measures of Large Biomolecules:
c     Surface, Volume, and Pockets", Journal of Computational Chemistry,
c     32, 3023-3038 (2011)
c
c     P. Koehl, A. Akopyan and H. Edelsbrunner, "Computing the Volume,
c     Surface Area, Mean, and Gaussian Curvatures of Molecules and Their
c     Derivatives", Journal of Chemical Information and Modeling, 63,
c     973-985 (2023)
c 
c     variables and parameters:
c
c     n         total number of spheres in the current system
c     x         current x-coordinate for each sphere in the system
c     y         current y-coordinate for each sphere in the system
c     z         current z-coordinate for each sphere in the system
c     rad       radius value in Angstroms for each sphere
c     weight    weight value for each sphere in the system
c     probe     radius value in Angstroms of the probe sphere
c     doderiv   logical flag to find derivatives over coordinates
c     dovol     logical flag to compute the excluded volume
c     surf      weighted surface area of union of spheres
c     vol       weighted volume of the union of spheres
c     asurf     weighted contribution of each sphere to the area
c     avol      weighted contribution of each ball to the volume
c     dsurf     derivatives of weighted surface area over coordinates
c     dvol      derivatives of weighted volume over coordinates
c     usurf     unweighted surface area of union of spheres
c     uvol      unweighted volume of the union of spheres
c
c     
      subroutine unionball (n,x,y,z,rad,weight,probe,doderiv,dovol,
     &                         surf,vol,asurf,avol,dsurf,dvol)
      use iounit
      implicit none
      integer i,n,nsphere
      integer nsize,nfudge
      integer nredund
      integer, allocatable :: redlist(:)                                 
      real*8 surf,usurf
      real*8 vol,uvol
      real*8 probe,alpha,eps
      real*8 x(*)
      real*8 y(*)
      real*8 z(*)
      real*8 rad(*)
      real*8 weight(*)
      real*8 asurf(*)
      real*8 avol(*)
      real*8 dsurf(3,*)
      real*8 dvol(3,*)
      real*8, allocatable :: radii(:)
      real*8, allocatable :: asurfx(:)
      real*8, allocatable :: avolx(:)
      real*8, allocatable :: coords(:,:)
      real*8, allocatable :: dsurfx(:,:)
      real*8, allocatable :: dvolx(:,:)
      logical doderiv,dovol
      logical dowiggle
      character*6 symmtyp
c
c
c     perform dynamic allocation of some local arrays
c
      nfudge = 10
      nsize = n + nfudge
      allocate (radii(nsize))
      allocate (asurfx(nsize))
      allocate (avolx(nsize))
      allocate (coords(3,nsize))
      allocate (dsurfx(3,nsize))
      allocate (dvolx(3,nsize))
      allocate (redlist(nsize))
c
c     increment the sphere radii by the radius of the probe
c
      nsphere = n
      do i = 1, n
         coords(1,i) = x(i)
         coords(2,i) = y(i)
         coords(3,i) = z(i)
         radii(i) = 0.0d0
         if (rad(i) .ne. 0.0d0)  radii(i) = rad(i) + probe
      end do
c
c     check coordinates for linearity, planarity and symmetry
c
      symmtyp = 'NONE'
      call chksymm (symmtyp)
      dowiggle = .false.
      if (n.gt.2 .and. symmtyp.eq.'LINEAR')  dowiggle = .true.
      if (n.gt.3 .and. symmtyp.eq.'PLANAR')  dowiggle = .true.
      if (symmtyp .eq. 'CENTER')  dowiggle = .true.
c
c     random coordinate perturbation to avoid numerical issues
c
      if (dowiggle) then
         write (iout,10)  symmtyp
   10    format (/,' UNIONBALL  --  Warning, ',a6,' Symmetry;'
     &              ' Wiggling Coordinates')
         eps = 0.001d0
         call wiggle (n,coords,eps)
      else if (symmtyp .ne. 'NONE') then
         write (iout,20)  symmtyp
   20    format (/,' UNIONBALL  --  Warning, ',a6,' Symmetry'
     &              ' Detected for the System')
      end if
c
c     transfer coordinates, complete to minimum of four spheres
c     if needed, set Delaunay and alpha complex arrays
c
      call setunion (nsphere,coords,radii)
c
c     compute the weighted Delaunay triangulation
c
      call regular3 (nredund,redlist)
c
c     compute the alpha complex for fixed value of alpha
c
      alpha = 0.0d0
      call alfcx (alpha,nredund,redlist)
c
c     if fewer than four balls, set artificial spheres as redundant
c
      call readjust_sphere (nsphere,nredund,redlist)
c
c     get surface area and volume, then copy to Tinker arrays
c
      if (doderiv) then
         if (dovol) then
            call ball_dvol (weight,surf,vol,usurf,uvol,asurfx,avolx,
     &                         dsurfx,dvolx)
            do i = 1, n
               asurf(i) = asurfx(i)
               avol(i) = avolx(i)
               dsurf(1,i) = dsurfx(1,i)
               dsurf(2,i) = dsurfx(2,i)
               dsurf(3,i) = dsurfx(3,i)
               dvol(1,i) = dvolx(1,i)
               dvol(2,i) = dvolx(2,i)
               dvol(3,i) = dvolx(3,i)
            end do
         else
            call ball_dsurf (weight,surf,usurf,asurfx,dsurfx)
            do i = 1, n
               asurf(i) = asurfx(i)
               dsurf(1,i) = dsurfx(1,i)
               dsurf(2,i) = dsurfx(2,i)
               dsurf(3,i) = dsurfx(3,i)
            end do
         end if
      else
         if (dovol) then
            call ball_vol (weight,surf,vol,usurf,uvol,asurfx,avolx)
            do i = 1, n
               asurf(i) = asurfx(i)
               avol(i) = avolx(i)
            end do
         else
            call ball_surf (weight,surf,usurf,asurfx)
            do i = 1, n
               asurf(i) = asurfx(i)
            end do
         end if
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (radii)
      deallocate (asurfx)
      deallocate (avolx)
      deallocate (coords)
      deallocate (dsurfx)
      deallocate (dvolx)
      deallocate (redlist)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine setunion  --  get UnionBall coordinates & radii  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "setunion" gets the coordinates and radii of the balls, and
c     stores these into data structures used in UnionBall
c
c     variables and parameters:
c
c     nsphere   number of points (spheres) to be triangulated
c     coords    Cartesian coordinates of all spheres
c     radii     radius of each sphere, used to set weights for
c                 regular triangulation related to radius squared
c
c
      subroutine setunion (nsphere,coords,radii)
      use shapes
      implicit none
      integer ndigit
      integer nsize,nfudge
      integer nsphere
      integer new_points
      integer i,j,k,ip,jp
      integer, allocatable :: ranlist(:)
      real*8 crdmax,epsd
      real*8 x,xval,sum
      real*8 y,z,w,xi,yi,zi,wi,r
      real*8 brad(3),bcoord(9)
      real*8 coords(*)
      real*8 radii(*)
      real*8, allocatable :: ranval(:)
      save
c
c
c     define array sizes used for memory allocation
c
      nfudge = 10
      nsize = nsphere + nfudge
      maxtetra = 10 * nsize
c
c     set number of digits for truncation of real numbers
c
      ndigit = 8
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(vinfo)) then
         if (size(vinfo) .lt. nsize) then
            deallocate (vinfo)
            deallocate (crdball)
            deallocate (radball)
            deallocate (wghtball)
         end if
      end if
      if (allocated(tinfo)) then
         if (size(tinfo) .lt. ntetra) then
            deallocate (tetra)
            deallocate (tneighbor)
            deallocate (tinfo)
            deallocate (tnindex)
         end if
      end if
      if (.not. allocated(vinfo))  allocate (vinfo(nsize))
      if (.not. allocated(crdball))  allocate (crdball(3*nsize))
      if (.not. allocated(radball))  allocate (radball(nsize))
      if (.not. allocated(wghtball))  allocate (wghtball(nsize))
      if (.not. allocated(tetra))  allocate (tetra(4,maxtetra))
      if (.not. allocated(tneighbor))  allocate (tneighbor(4,maxtetra))
      if (.not. allocated(tinfo))  allocate (tinfo(maxtetra))
      if (.not. allocated(tnindex))  allocate (tnindex(maxtetra))
c
c     perform dynamic allocation of some local arrays
c
      allocate (ranlist(nsize))
      allocate (ranval(3*nsize))
c
c     truncate input coordinates to desired precision
c
      npoint = nsphere
      crdmax = 0.0d0
      do i = 1, npoint
         vinfo(i) = 0
         vinfo(i) = ibset(vinfo(i),0)
         x = radii(i)
         call truncate_real (x,xval,ndigit)
         radball(i) = xval
         do j = 1, 3
            k = 3*(i-1) + j
            x = coords(k)
            call truncate_real (x,xval,ndigit)
            crdball(k) = xval
            if (abs(crdball(k)) .gt. crdmax)  crdmax = abs(crdball(k))
         end do
      end do
      crdmax = max(100.0d0,crdmax)
c
c     machine precision is smallest value different from zero;
c     note "epsd" may become zero if compiled with optimization
c
      sum = 10.0d0
      epsd = 1.0d0
      do while (sum .gt. 1.0d0)
         epsd = epsd / 2.0d0
         sum = 1.0d0 + epsd
      end do
      epsd = 2.0d0 * epsd
c
c     use typical value from compilation without optimization
c
      epsd = 0.222045d-15
c
c     set tolerance values based upon the machine precision
c
      epsln2 = epsd * crdmax * crdmax
      epsln3 = epsln2 * crdmax
      epsln4 = epsln3 * crdmax
      epsln5 = epsln4 * crdmax
      epsln2 = 1.0d-1
      epsln3 = 1.0d-1
      epsln4 = 1.0d-1
      epsln5 = 1.0d-1
c
c     precompute the weight value for each of the points
c
      do i = 1, npoint
         x = crdball(3*(i-1)+1)
         y = crdball(3*(i-1)+2)
         z = crdball(3*(i-1)+3)
         r = radball(i)
         call build_weight (x,y,z,r,w)
         wghtball(i) = w
      end do
c
c     check for trivial redundancy with same point twice
c
      do i = 1, 3*npoint
         ranval(i) = crdball(i)
      end do
      call hpsort_three (ranval,ranlist,npoint)
      jp = ranlist(1)
      x = crdball(3*jp-2)
      y = crdball(3*jp-1)
      z = crdball(3*jp)
      w = radball(jp)
      do i = 2, npoint
         ip = ranlist(i)
         xi = crdball(3*ip-2)
         yi = crdball(3*ip-1)
         zi = crdball(3*ip)
         wi = radball(ip)
         if ((xi-x)**2+(yi-y)**2+(zi-z)**2 .le. 100.0d0*epsd) then
            if (wi .le. w) then
               vinfo(ip) = ibclr(vinfo(ip),0)
            else
               vinfo(jp) = ibclr(vinfo(jp),0)
               jp = ip
               w = wi
            end if
         else
            x = xi
            y = yi
            z = zi
            w = wi
            jp = ip
         end if
      end do
      if (npoint .lt. 4) then
         new_points = 4 - npoint;
         call addbogus (bcoord, brad)
         do i = 1, new_points
            npoint = npoint + 1
            x = bcoord(3*(i-1)+1);
            y = bcoord(3*(i-1)+2);
            z = bcoord(3*(i-1)+3);
            r = brad(i);
            call build_weight (x,y,z,r,w)
            crdball(3*(npoint-1)+1) = x
            crdball(3*(npoint-1)+2) = y
            crdball(3*(npoint-1)+3) = z
            radball(npoint) = r
            wghtball(npoint) = w
            vinfo(npoint) = 0
            vinfo(npoint) = ibset(vinfo(npoint),0)
         end do
      end if
c
c     initialization for the four added infinite points
c
      do i = 3*npoint, 1, -1
         crdball(i+12) = crdball(i)
      end do
      do i = npoint, 1, -1
         radball(i+4) = radball(i)
         wghtball(i+4) = wghtball(i)
         vinfo(i+4) = vinfo(i)
      end do
      nvertex = npoint + 4
      do i = 1, 12
         crdball(i) = 0.0d0
      end do
      do i = 1, 4
         radball(i) = 0.0d0
         wghtball(i) = 0.0d0
         vinfo(i) = 0
         vinfo(i) = ibset(vinfo(i),0)
      end do
c
c     initialize tetrahedra for Delaunay calculation
c
      ntetra = 1
      tetra(1,ntetra) = 1
      tetra(2,ntetra) = 2
      tetra(3,ntetra) = 3
      tetra(4,ntetra) = 4
      tneighbor(1,ntetra) = 0
      tneighbor(2,ntetra) = 0
      tneighbor(3,ntetra) = 0
      tneighbor(4,ntetra) = 0
      tinfo(ntetra) = 0
      tinfo(ntetra) = ibset(tinfo(ntetra),1)
c
c     orientation is right most bit, bit=0 means -1, bit=1 means 1;
c     the orientation of the first tetrahedron is -1
c
      tinfo(ntetra) = ibclr(tinfo(ntetra),0)
c
c     perform deallocation of some local arrays
c
      deallocate (ranlist)
      deallocate (ranval)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine regular3  --  triangulation of a set of points  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "regular3" computes the regular triangulation of a set of N
c     weighted points in 3D using the incremental flipping algorithm
c     of Herbert Edelsbrunner
c
c     literature reference:
c
c     H. Edelsbrunner and N. R. Shah, "Incremental Topological
c     Flipping Works for Regular Triangulations", Algorithmica,
c     15, 223-241 (1996)
c
c     algorithm summary:
c
c     (1) initialize the procedure with a big tetrahedron, all four
c     vertices of this tetrahedron are set at "infinite", (2) all N
c     points are added one by one, (3) for each point localize the
c     tetrahedron in the current regular triangulation that contains
c     this point, (4) test if the point is redundant, and is so then
c     remove it, (5) if the point is not redundant, insert it in the
c     tetrahedron via a "1-4" flip, (6) collect all "link facets",
c     (i.e., all triangles in tetrahedron containing the new point,
c     that face this new point) that are not regular, (7) for each
c     non-regular link facet, check if it is "flippable", (8) if yes,
c     perform a "2-3", "3-2" or "1-4" flip, add new link facets in
c     the list if needed, (9) when link facet list is empty, move to
c     next point, (10) remove "infinite" tetrahedra, which are those
c     with one vertex at "infinite", and (11) collect the remaining
c     tetrahedra, and define convex hull
c
c
      subroutine regular3 (nredund,redlist)
      use shapes
      implicit none
      integer i,ival
      integer iredund
      integer nredund
      integer iflag,iseed
      integer tetra_loc
      integer tetra_last
      integer maxfree,maxkill
      integer maxlink,maxnew
      integer npeel_try
      integer redlist(*)
      save
c
c
c     perform dynamic allocation of some global arrays
c
      maxnew = 20000
      maxfree = 20000
      maxkill = 20000
      maxlink = 20000
      allocate (newlist(maxnew))
      allocate (freespace(maxfree))
      allocate (killspace(maxkill))
      allocate (linkfacet(2,maxlink))
      allocate (linkindex(2,maxlink))
c
c     initialize the size of "free" space to zero
c
      ntfree = 0
      nnew = 0
c
c     build regular triangulation, now loop over all points
c
      tetra_last = -1
      iseed = -1
      do i = 1, npoint
         ival = i + 4
         nnew = 0
         if (btest(vinfo(ival),0)) then
            tetra_loc = tetra_last
            call locate_jw (iseed,ival,tetra_loc,iredund)
            if (iredund .eq. 1) then
               vinfo(ival) = ibclr(vinfo(ival),0)
               goto 10
            end if
            call flipjw_1_4 (ival,tetra_loc,tetra_last)
            call flipjw (tetra_last)
            if (ntetra .gt. (9*maxtetra)/10)  call resize_tet
   10       continue
         end if
      end do
c
c     reorder tetrahedra, so vertices are in increasing order
c
      iflag = 1
      call reorder_tetra (iflag)
c
c     regular triangulation complete; remove the simplices
c     including infinite points, and define the convex hull
c
      call remove_inf
c
c     peel off flat tetrahedra at the boundary of the DT
c
      npeel_try = 1
      do while (npeel_try .gt. 0)
         call peel (npeel_try)
      end do
c
c     define the list of redundant points
c
      nredund = 0
      do i = 1, npoint
         if (.not. btest(vinfo(i+4),0)) then
            nredund = nredund + 1
            redlist(nredund) = i
         end if
      end do
c
c     perform deallocation of some global arrays
c
      deallocate (newlist)
      deallocate (freespace)
      deallocate (killspace)
      deallocate (linkfacet)
      deallocate (linkindex)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine alfcx  --  construction of the alpha complex  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "alfcx" builds the alpha complex based on the weighted
c     Delaunay triangulation used by UnionBall
c
c
      subroutine alfcx (alpha,nred,redlist)
      use shapes
      implicit none
      integer i,j,k,l,m
      integer ia,ib,i1,i2
      integer ntrig,icheck
      integer ntet_del,ntet_alp
      integer idx,iflag,nred
      integer irad,iattach,ival
      integer itrig,jtrig,iedge
      integer trig1,trig2,trig_in
      integer trig_out,triga,trigb
      integer jtetra,itetra,ktetra
      integer npass,ipair,i_out
      integer other3(3,4)
      integer face_info(2,6)
      integer face_pos(2,6)
      integer pair(2,6)
      integer redlist(*)
      integer, allocatable :: chklist(:)
      integer, allocatable :: tmask(:)
      real*8 ra,rb,rc,rd,re
      real*8 alpha
      real*8 a(4),b(4),c(4)
      real*8 d(4),e(4),cg(3)
      logical testa,testb,test_edge
      data other3   / 2, 3, 4, 1, 3, 4, 1, 2, 4, 1, 2, 3 /
      data face_info  / 1, 2, 1, 3, 1, 4, 2, 3, 2, 4, 3, 4 /
      data face_pos  / 2, 1, 3, 1, 4, 1, 3, 2, 4, 2, 4, 3 /
      data pair  / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 /
      save
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (chklist(40000))
      allocate (tmask(ntetra))
c
c     perform dynamic allocation of some global arrays
c
      if (allocated(tedge)) then
         if (size(tedge) .lt. ntetra)  deallocate (tedge)
      end if
      if (.not. allocated(tedge))  allocate (tedge(ntetra))
c
c     initialization and setup of masking variables
c
      ival = 0
      do i = 1, ntetra
         tmask(i) = 0
         call mvbits (ival,0,5,tinfo(i),3)
      end do
c
c     loop over all tetrahedra, any "dead" tetrahedra are ignored
c
      ntet_del = 0
      ntet_alp = 0
      do idx = 1, ntetra
         if (btest(tinfo(idx),1)) then
            ntet_del = ntet_del + 1
            i = tetra(1,idx)
            j = tetra(2,idx)
            k = tetra(3,idx)
            l = tetra(4,idx)
            call get_coord4 (i,j,k,l,a,b,c,d,ra,rb,rc,rd,cg)
            call alf_tetra (a,b,c,d,ra,rb,rc,rd,iflag,alpha)
            if (iflag .eq. 1) then
               tinfo(idx) = ibset(tinfo(idx),7)
               ntet_alp = ntet_alp + 1
            end if
         end if
      end do
c
c     loop over all triangles; each triangle is defined implicitly
c     as the interface between two tetrahedra i and j with i < j
c
      ntrig = 0
      do idx = 1, ntetra
         if (btest(tinfo(idx),1)) then
            do itrig = 1, 4
               jtetra = tneighbor(itrig,idx)
               ival = ibits(tnindex(idx),2*(itrig-1),2)
               jtrig = ival + 1
               if (jtetra.eq.0 .or. jtetra.gt.idx) then
c
c     checking the triangle defined by itetra and jtetra,
c     if one of them belongs to the alpha complex, then
c     the triangle belongs to the alpha complex
c
                  if (btest(tinfo(idx),7)) then
                     tinfo(idx) = ibset(tinfo(idx),2+itrig)
                     ntrig = ntrig + 1
                     if (jtetra .ne. 0) then
                        tinfo(jtetra) = ibset(tinfo(jtetra),2+jtrig)
                     end if
                     goto 10
                  end if
                  if (jtetra .ne. 0) then
                     if (btest(tinfo(jtetra),7)) then
                        tinfo(idx) = ibset(tinfo(idx),2+itrig)
                        tinfo(jtetra) = ibset(tinfo(jtetra),2+jtrig)
                        ntrig = ntrig + 1
                        goto 10
                     end if
                  end if
c
c     the two attached tetrahedra do not belong to the alpha complex,
c     so need to check the triangle itself; define the three vertices
c     of the triangle, as well as the two remaining vertices of the
c     two tetrahedra attached to triangle
c
                  i = tetra(other3(1,itrig),idx)
                  j = tetra(other3(2,itrig),idx)
                  k = tetra(other3(3,itrig),idx)
                  l = tetra(itrig,idx)
                  if (jtetra .ne. 0) then
                     m = tetra(jtrig,jtetra)
                     call get_coord5 (i,j,k,l,m,a,b,c,d,e,
     &                                ra,rb,rc,rd,re,cg)
                  else
                     m = 0
                     call get_coord4 (i,j,k,l,a,b,c,d,ra,rb,rc,rd,cg)
                  end if
                  call alf_trig (a,b,c,d,e,ra,rb,rc,rd,re,
     &                           m,irad,iattach,alpha)
                  if (iattach.eq.0 .and. irad.eq.1) then
                     l = 1
                     tinfo(idx) = ibset(tinfo(idx),2+itrig)
                     ntrig = ntrig + 1
                     if (jtetra .ne. 0) then
                        tinfo(jtetra) = ibset(tinfo(jtetra),2+jtrig)
                     end if
                  end if
               end if
   10          continue
            end do
         end if
      end do
c
c     loop over all edges; each edge is defined implicitly
c     by the tetrahedra to which it belongs
c
      do idx = 1, ntetra
         tmask(idx) = 0
         tedge(idx) = 0
      end do
      maxedge = 0
      do itetra = 1, ntetra
         if (btest(tinfo(itetra),1)) then
            do iedge = 1, 6
               if (btest(tmask(itetra),iedge-1))  goto 50
               test_edge = .false.
c
c     for each edge, check triangles attached to the edge
c     if at least one of these triangles is in alpha complex,
c     then the edge is in the alpha complex;
c     put the two vertices directly in the alpha complex;
c     otherwise, build list of triangles to check
c
c     itetra is one tetrahedron (a,b,c,d) containing the edge
c
c     iedge is the edge number in the tetrahedron itetra, with:
c     iedge=1 (c,d), iedge=2 (b,d), iedge=3 (b,c),
c     iedge=4 (a,d), iedge=5 (a,c), iedge=6 (a,b)
c
c     define indices of the edge
c
               i = tetra(pair(1,iedge),itetra)
               j = tetra(pair(2,iedge),itetra)
c
c     trig1 and trig2 are the two faces of itetra sharing iedge, i1
c     and i2 are positions of the third vertices of trig1 and trig2
c
               trig1 = face_info(1,iedge)
               i1 = face_pos(1,iedge)
               trig2 = face_info(2,iedge)
               i2 = face_pos(2,iedge)
               ia = tetra(i1,itetra)
               ib = tetra(i2,itetra)
               icheck = 0
               if (btest(tinfo(itetra),2+trig1)) then
                  test_edge = .true.
               else
                  icheck = icheck + 1
                  chklist(icheck) = ia
               end if
               if (btest(tinfo(itetra),2+trig2)) then
                  test_edge = .true.
               else
                  icheck = icheck + 1
                  chklist(icheck) = ib
               end if
c
c     now we look at the star of the edge
c
               ktetra = itetra
               npass = 1
               trig_out = trig1
               jtetra = tneighbor(trig_out,ktetra)
   20          continue
c
c     leave this side of the star if we hit the convex hull
c
               if (jtetra .eq. 0)  goto 30
c
c     leave the loop completely if we have described the full cycle
c
               if (jtetra .eq. itetra)  goto 40
c
c     identify the position of iedge in tetrahedron jtetra
c
               if (i .eq. tetra(1,jtetra)) then
                  if (j .eq. tetra(2,jtetra)) then
                     ipair = 6
                  else if (j .eq. tetra(3,jtetra)) then
                     ipair = 5
                  else
                     ipair = 4
                  end if
               else if (i .eq. tetra(2,jtetra)) then
                  if (j .eq. tetra(3,jtetra)) then
                     ipair = 3
                  else
                     ipair = 2
                  end if
               else
                  ipair = 1
               end if
               tmask(jtetra) = ibset(tmask(jtetra),ipair-1)
c
c     determine the face we "went in"
c
               ival = ibits(tnindex(ktetra),2*(trig_out-1),2)
               trig_in = ival + 1
c
c     we know the two faces of jtetra that share iedge
c
               triga = face_info(1,ipair)
               i1 = face_pos(1,ipair)
               trigb = face_info(2,ipair)
               i2 = face_pos(2,ipair)
               trig_out = triga
               i_out = i1
               if (trig_in .eq. triga) then
                  i_out = i2
                  trig_out = trigb
               end if
c
c     check if trig_out is already in the alpha complex; if it
c     is then iedge is in, otherwise, will need an attach test
c
               if (btest(tinfo(jtetra),2+trig_out)) then
                  test_edge = .true.
               end if
               ktetra = jtetra
               jtetra = tneighbor(trig_out,ktetra)
               if (jtetra .eq. itetra)  goto 40
               icheck = icheck + 1
               chklist(icheck) = tetra(i_out,ktetra)
               goto 20
   30          continue
               if (npass .eq. 2)  goto 40
               npass = npass + 1
               ktetra = itetra
               trig_out = trig2
               jtetra = tneighbor(trig_out,ktetra)
               goto 20
   40          continue
               if (test_edge) then
                  tedge(itetra) = ibset(tedge(itetra),iedge-1)
                  maxedge = maxedge + 1
                  vinfo(i) = ibset(vinfo(i),7)
                  vinfo(j) = ibset(vinfo(j),7)
                  goto 50
               end if
c
c     if here, it means that none of the triangles in the star
c     of the edge belongs to the alpha complex, so a singular edge
c    
c     check if the edge is attached, and if alpha is smaller than
c     the radius of the sphere orthogonal to the two balls
c     corresponding to the edge
c
               call get_coord2 (i,j,a,b,ra,rb,cg)
               call alf_edge (a,b,ra,rb,cg,icheck,chklist,
     &                        irad,iattach,alpha)
               if (iattach.eq.0 .and. irad.eq.1) then
                  tedge(itetra) = ibset(tedge(itetra),iedge-1)
                  maxedge = maxedge + 1
                  vinfo(i) = ibset(vinfo(i),7)
                  vinfo(j) = ibset(vinfo(j),7)
                  goto 50
               end if
c
c     edge is not in alpha complex: now check if the two vertices
c     could be attached to each other: 
c
               call vertex_attach (a,b,ra,rb,testa,testb)        
               if (testa)  vinfo(i) = ibset(vinfo(i),6)
               if (testb)  vinfo(j) = ibset(vinfo(j),6)
   50          continue
            end do
         end if
      end do
c
c     safeguard minimum edge count to handle small system dimensions
c
      maxedge = max(maxedge,nvertex+10)
c
c     loop over each of the vertices; nothing to do if vertex
c     was already set in alpha complex; vertex is in alpha complex,
c     unless it is attached
c
      nred = 0
      do i = 1, nvertex
         if (btest(vinfo(i),0)) then
            if (.not. btest(vinfo(i),7)) then
               if (.not. btest(vinfo(i),6)) then
                  vinfo(i) = ibset(vinfo(i),7)
               else
                  nred = nred + 1
                  redlist(nred) = i
               end if
            end if
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (chklist)
      deallocate (tmask)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine readjust_sphere  --  remove artificial spheres  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "readjust_sphere" removes artificial spheres for UnionBall
c     systems containing fewer than four spheres
c
c
      subroutine readjust_sphere (nsphere,nredund,redlist)
      use shapes
      implicit none
      integer i,j
      integer nsphere
      integer nredund
      integer redlist(*)
      save
c
c
c     if fewer than four balls, set artificial spheres as redundant
c
      if (nsphere .lt. 4) then
         do i = nsphere+5, 8
            vinfo(i) = 1
         end do
         npoint = nsphere
         nvertex = npoint + 4
         j = 0
         do i = 1, nredund
            if (redlist(i) .le. nsphere) then
               j = j + 1
               redlist(j) = redlist(i)
            end if
         end do
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ball_surf  --  find area of union of spheres  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ball_surf" computes the weighted accessible surface area of
c     a union of spheres
c
c     variables and parameters:
c
c     coef        sphere weights for the weighted surface
c     wsurf       weighted surface area
c     surf        unweighted surface area
c     ballwsurf   weighted contribution of each ball
c
c
      subroutine ball_surf (coef,wsurf,surf,ballwsurf)
      use math
      use shapes
      implicit none
      integer i,j
      integer ia,ib,ic,id
      integer i1,nedge
      integer idx,ilast
      integer itrig,iedge
      integer ival,it1,it2
      integer jtetra
      integer face_info(2,6)
      integer face_pos(2,6)
      integer pair(2,6)
      integer, allocatable :: sparse_row (:)
      integer, allocatable :: edges (:,:)
      real*8 ra,rb,rc,rd
      real*8 ra2,rb2,rc2,rd2
      real*8 rab,rac,rad
      real*8 rbc,rbd,rcd
      real*8 rab2,rac2,rad2
      real*8 rbc2,rbd2,rcd2
      real*8 coefval
      real*8 surfa,surfb,surfc,surfd
      real*8 a(3),b(3),c(3),d(3)
      real*8 angle(6),cosine(6),sine(6)
      real*8 wsurf,surf
      real*8 coef(*),ballwsurf(*)
      real*8, allocatable :: coef_edge(:)
      real*8, allocatable :: coef_vertex(:)
      data face_info  / 1, 2, 1, 3, 1, 4, 2, 3, 2, 4, 3, 4 /
      data face_pos  / 2, 1, 3, 1, 4, 1, 3, 2, 4, 2, 4, 3 /
      data pair  / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 /
      save
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (sparse_row(nvertex+10))
      allocate (edges(2,maxedge))
      allocate (coef_edge(maxedge))
      allocate (coef_vertex(nvertex))
c
c     initialize result values
c
      wsurf = 0.0d0
      surf = 0.0d0
      do i = 1, nvertex
         ballwsurf(i) = 0.0d0
      end do
c
c     find list of all edges in the alpha complex
c
      nedge = 0
      call find_edges (nedge,edges)
c
c     define sparse structure for edges
c
      ilast = 0
      do i = 1, nedge
         ia = edges(1,i)
         ib = edges(2,i)
         if (ia .ne. ilast) then
            do j = ilast+1, ia
               sparse_row(j) = i
            end do 
            ilast = ia
         end if
         coef_edge(i) = 1.0d0
      end do
      do i = ia+1, nvertex
         sparse_row(i) = nedge + 1
      end do
c
c     build list of fully buried vertices; these vertices are part
c     of the alpha complex, and all edges that start or end at these
c     vertices are buried
c
      do i = 1, nvertex
         coef_vertex(i) = 1.0d0
      end do
c
c     contribution of four spheres; use the weighted inclusion-exclusion
c     formula; each tetrahedron in the Alpha Complex only contributes
c     to the weight of each its edges and each of its vertices
c
      do idx = 1, ntetra
         if (btest(tinfo(idx),7)) then
            ia = tetra(1,idx)
            ib = tetra(2,idx)
            ic = tetra(3,idx)
            id = tetra(4,idx)
            do i = 1, 3
               a(i) = crdball(3*(ia-1)+i)
               b(i) = crdball(3*(ib-1)+i)
               c(i) = crdball(3*(ic-1)+i)
               d(i) = crdball(3*(id-1)+i)
            end do
            ra = radball(ia)
            rb = radball(ib)
            rc = radball(ic)
            rd = radball(id)
            ra2 = ra * ra
            rb2 = rb * rb
            rc2 = rc * rc
            rd2 = rd * rd
            call distance2 (crdball,ia,ib,rab2)
            call distance2 (crdball,ia,ic,rac2)
            call distance2 (crdball,ia,id,rad2)
            call distance2 (crdball,ib,ic,rbc2)
            call distance2 (crdball,ib,id,rbd2)
            call distance2 (crdball,ic,id,rcd2)
            rab = sqrt(rab2)
            rac = sqrt(rac2)
            rad = sqrt(rad2)
            rbc = sqrt(rbc2)
            rbd = sqrt(rbd2)
            rcd = sqrt(rcd2)
            call tetra_dihed (rab2,rac2,rad2,rbc2,rbd2,
     &                        rcd2,angle,cosine,sine)
c
c     weights on each vertex; fraction of solid angle
c
            coef_vertex(ia) = coef_vertex(ia) + 0.25d0
     &                           - (angle(1)+angle(2)+angle(3))/2.0d0
            coef_vertex(ib) = coef_vertex(ib) + 0.25d0
     &                           - (angle(1)+angle(4)+angle(5))/2.0d0
            coef_vertex(ic) = coef_vertex(ic) + 0.25d0
     &                           - (angle(2)+angle(4)+angle(6))/2.0d0
            coef_vertex(id) = coef_vertex(id) + 0.25d0
     &                           - (angle(3)+angle(5)+angle(6))/2.0d0
c
c     weights on each edge; fraction of dihedral angle
c
c     iedge is the edge number in the tetrahedron idx with:
c     iedge = 1 (c,d), iedge = 2 (b,d), iedge = 3 (b,c),
c     iedge = 4 (a,d), iedge = 5 (a,c), iedge = 6 (a,b)
c
c     define indices of the edge
c
            do iedge = 1, 6
               i = tetra(pair(1,iedge),idx)
               j = tetra(pair(2,iedge),idx)
c
c     find which edge this corresponds to
c
               do i1 = sparse_row(i), sparse_row(i+1)-1
                  if (edges(2,i1) .eq. j)  goto 10
               end do
               goto 20
   10          continue
               if (coef_edge(i1) .ne. 0.0d0) then
                  coef_edge(i1) = coef_edge(i1) - angle(7-iedge)
               end if
   20          continue
            end do
c
c     all the edge lengths have been precomputed, check triangles
c
c     check the four faces of the tetrahedron; any exposed face
c     (on the convex hull, or facing a tetrahedron from the Delaunay
c     that is not part of the alpha complex), contributes
c
            do itrig = 1, 4
               jtetra = tneighbor(itrig,idx)
               if (jtetra.eq.0 .or. jtetra.gt.idx) then
                  if (btest(tinfo(idx),2+itrig)) then
                     if (jtetra .ne. 0) then
                        call mvbits (tinfo(jtetra),7,1,it2,0)
                     else
                        it2 = 0
                     end if
                     ival = 1 - it2
                     if (ival .eq. 0)  goto 30
                     coefval = 0.5d0 * dble(ival)
                     if (itrig .eq. 1) then
                        surfa = 0.0d0
                        call threesphere_surf (rb,rc,rd,rb2,rc2,rd2,
     &                                         rbc,rbd,rcd,rbc2,rbd2,
     &                                         rcd2,surfb,surfc,surfd)
                     else if (itrig .eq. 2) then
                        surfb = 0.0d0
                        call threesphere_surf (ra,rc,rd,ra2,rc2,rd2,
     &                                         rac,rad,rcd,rac2,rad2,
     &                                         rcd2,surfa,surfc,surfd)
                     else if (itrig .eq. 3) then
                        surfc = 0.0d0
                        call threesphere_surf (ra,rb,rd,ra2,rb2,rd2,
     &                                         rab,rad,rbd,rab2,rad2,
     &                                         rbd2,surfa,surfb,surfd)
                     else if (itrig .eq. 4) then
                        surfd = 0.0d0
                        call threesphere_surf (ra,rb,rc,ra2,rb2,rc2,
     &                                         rab,rac,rbc,rab2,rac2,
     &                                         rbc2,surfa,surfb,surfc)
                     end if
                     ballwsurf(ia) = ballwsurf(ia) + coefval*surfa
                     ballwsurf(ib) = ballwsurf(ib) + coefval*surfb
                     ballwsurf(ic) = ballwsurf(ic) + coefval*surfc
                     ballwsurf(id) = ballwsurf(id) + coefval*surfd
                  end if
               end if
   30          continue
            end do
         end if
      end do
c
c     contribution of three balls (triangles of the alpha complex);
c     already checked the triangles from tetrahedra that belongs
c     to the alpha complex; now we check any singular triangles
c     (face of a tetrahedron in the Delaunay complex, but not in
c     the alpha shape)
c
c     loop over all tetrahedra, and check its four faces; any face
c     that is exposed (on the convex hull, or facing a tetrahedron
c     from the Delaunay that is not in the alpha complex), contributes
c
      do idx = 1, ntetra
         if (btest(tinfo(idx),1)) then
            if (.not. btest(tinfo(idx),7)) then
               ia = tetra(1,idx)
               ib = tetra(2,idx)
               ic = tetra(3,idx)
               id = tetra(4,idx)
               do i = 1, 3
                  a(i) = crdball(3*(ia-1)+i)
                  b(i) = crdball(3*(ib-1)+i)
                  c(i) = crdball(3*(ic-1)+i)
                  d(i) = crdball(3*(id-1)+i)
               end do
               ra = radball(ia)
               rb = radball(ib)
               rc = radball(ic)
               rd = radball(id)
               ra2 = ra * ra
               rb2 = rb * rb
               rc2 = rc * rc
               rd2 = rd * rd
               rab = 0.0d0
               rac = 0.0d0
               rad = 0.0d0
               rbc = 0.0d0
               rbd = 0.0d0
               rcd = 0.0d0
c
c     check triangles
c
               do itrig = 1, 4
                  jtetra = tneighbor(itrig,idx)
                  if (jtetra.eq.0 .or. jtetra.gt.idx) then
                     if (btest(tinfo(idx),2+itrig)) then
                        call mvbits (tinfo(idx),7,1,it1,0)
                        if (jtetra .ne. 0) then
                           call mvbits (tinfo(jtetra),7,1,it2,0)
                        else
                            it2 = 0
                        end if
                        ival = 2 - it1 - it2
                        if (ival .eq. 0)  goto 40
                        coefval = 0.5d0 * dble(ival)
                        surfa = 0.0d0
                        surfb = 0.0d0
                        surfc = 0.0d0
                        surfd = 0.0d0
                        if (itrig .eq. 1) then
                           call triangle_surf (b,c,d,rbc,rbd,rcd,
     &                                         rbc2,rbd2,rcd2,rb,
     &                                         rc,rd,rb2,rc2,rd2,
     &                                         surfb,surfc,surfd)
                        else if (itrig .eq. 2) then
                           call triangle_surf (a,c,d,rac,rad,rcd,
     &                                         rac2,rad2,rcd2,ra,
     &                                         rc,rd,ra2,rc2,rd2,
     &                                         surfa,surfc,surfd)
                        else if (itrig .eq. 3) then
                           call triangle_surf (a,b,d,rab,rad,rbd,
     &                                         rab2,rad2,rbd2,ra,
     &                                         rb,rd,ra2,rb2,rd2,
     &                                         surfa,surfb,surfd)
                        else if (itrig .eq. 4) then
                           call triangle_surf (a,b,c,rab,rac,rbc,
     &                                         rab2,rac2,rbc2,ra,
     &                                         rb,rc,ra2,rb2,rc2,
     &                                         surfa,surfb,surfc)
                        end if
                        ballwsurf(ia) = ballwsurf(ia) + coefval*surfa
                        ballwsurf(ib) = ballwsurf(ib) + coefval*surfb
                        ballwsurf(ic) = ballwsurf(ic) + coefval*surfc
                        ballwsurf(id) = ballwsurf(id) + coefval*surfd
                     end if
                  end if
   40             continue
               end do
            end if
         end if
      end do
c
c     now add the contribution of two sphere
c
      do iedge = 1, nedge
         if (coef_edge(iedge) .ne. 0.0d0) then
            ia = edges(1,iedge)
            ib = edges(2,iedge)
            do i = 1, 3
               a(i) = crdball(3*(ia-1)+i)
               b(i) = crdball(3*(ib-1)+i)
            end do
            ra = radball(ia)
            rb = radball(ib)
            ra2 = ra * ra
            rb2 = rb * rb
            call distance2 (crdball,ia,ib,rab2)
            rab = sqrt(rab2)
            call twosphere_surf (ra,ra2,rb,rb2,rab,rab2,surfa,surfb)
            ballwsurf(ia) = ballwsurf(ia) - coef_edge(iedge)*surfa
            ballwsurf(ib) = ballwsurf(ib) - coef_edge(iedge)*surfb
         end if
      end do
c
c     next loop over all of the vertices
c
      do i = 1, nvertex
         if (.not. btest(vinfo(i),0))  goto 50
c
c     if vertex is not in alpha-complex, then nothing to do
c
         if (.not. btest(vinfo(i),7))  goto 50
c
c     vertex is in alpha complex; if its weight is 0 such
c     that it is buried, then nothing to do
c
         if (coef_vertex(i) .eq. 0.0d0)  goto 50
         ra = radball(i)
         ballwsurf(i) = ballwsurf(i) + coef_vertex(i)*4.0d0*pi*ra*ra
   50    continue
      end do
c
c     compute total surface (weighted, and unweighted)
c
      do i = 5, nvertex
         if (btest(vinfo(i),0)) then
            surf = surf + ballwsurf(i)
            ballwsurf(i-4) = ballwsurf(i) * coef(i-4)
            wsurf = wsurf + ballwsurf(i-4)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (sparse_row)
      deallocate (edges)
      deallocate (coef_edge)
      deallocate (coef_vertex)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ball_vol  --  find volume of union of spheres  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ball_vol" computes the weighted surface area of a union of
c     spheres and the corresponding weighted excluded volume
c
c     variables and parameters:
c
c     coef        weight of each sphere for the weighted surface
c     wsurf       weighted surface area
c     wvol        weighted volume
c     surf        unweighted surface area
c     vol         unweighted volume
c     ballwsurf   weighted contribution of each ball to wsurf
c     ballwvol    weighted contribution of each ball to wvol
c
c
      subroutine ball_vol (coef,wsurf,wvol,surf,
     &                     vol,ballwsurf,ballwvol)
      use math
      use shapes
      implicit none
      integer i,j,i1
      integer ia,ib,ic,id
      integer nedge,ntrig
      integer idx,ilast
      integer itrig,iedge,nred
      integer ival,it1,it2
      integer jtetra
      integer face_info(2,6)
      integer face_pos(2,6)
      integer pair(2,6)
      integer flag(6)
      integer, allocatable :: sparse_row (:)
      integer, allocatable :: edges (:,:)
      real*8 ra,rb,rc,rd
      real*8 ra2,rb2,rc2,rd2
      real*8 rab,rac,rad
      real*8 rbc,rbd,rcd
      real*8 rab2,rac2,rad2
      real*8 rbc2,rbd2,rcd2
      real*8 coefval
      real*8 surfa,surfb,surfc,surfd
      real*8 vola,volb,volc,vold
      real*8 a(3),b(3),c(3),d(3)
      real*8 angle(6),cosine(6),sine(6)
      real*8 coef(*)
      real*8 wsurf,surf
      real*8 wvol,vol
      real*8 ballwsurf(*)
      real*8 ballwvol(*)
      real*8, allocatable :: coef_edge(:)
      real*8, allocatable :: coef_vertex(:)
      data face_info  / 1, 2, 1, 3, 1, 4, 2, 3, 2, 4, 3, 4 /
      data face_pos  / 2, 1, 3, 1, 4, 1, 3, 2, 4, 2, 4, 3 /
      data pair  / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 /
      save
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (sparse_row(nvertex+10))
      allocate (edges(2,maxedge))
      allocate (coef_edge(maxedge))
      allocate (coef_vertex(nvertex))      
c
c     initialize results arrays
c
      wsurf = 0.0d0
      wvol = 0.0d0
      surf = 0.0d0
      vol = 0.0d0
      do i = 1, nvertex
         ballwsurf(i) = 0.0d0
         ballwvol(i) = 0.0d0
      end do
c
c     find list of all edges in the alpha complex
c
      nedge = 0
      call find_edges (nedge,edges)
c
c     sort list of all edges in increasing order
c
      ilast = 0
      do i = 1, nedge
         ia = edges(1,i)
         ib = edges(2,i)
         if (ia .ne. ilast) then
            do j = ilast+1, ia
               sparse_row(j) = i
            end do
            ilast = ia
         end if
         coef_edge(i) = 1
      end do
      do i = ia+1, nvertex
         sparse_row(i) = nedge + 1
      end do
c
c     set the weight of each vertex to one
c
      do i = 1, nvertex
         coef_vertex(i) = 1.0d0
      end do
c
c     contribution of four spheres using the weighted
c     inclusion-exclusion formula; each tetrahedron in the
c     alpha complex only contributes to the weight of each
c     its edges and each of its vertices
c
      ntrig = 0
      do idx = 1, ntetra
         if (btest(tinfo(idx),7)) then
            ia = tetra(1,idx)
            ib = tetra(2,idx)
            ic = tetra(3,idx)
            id = tetra(4,idx)
            do i = 1, 3
               a(i) = crdball(3*(ia-1)+i)
               b(i) = crdball(3*(ib-1)+i)
               c(i) = crdball(3*(ic-1)+i)
               d(i) = crdball(3*(id-1)+i)
            end do
            ra = radball(ia)
            rb = radball(ib)
            rc = radball(ic)
            rd = radball(id)
            ra2 = ra * ra
            rb2 = rb * rb
            rc2 = rc * rc
            rd2 = rd * rd
            call distance2 (crdball,ia,ib,rab2)
            call distance2 (crdball,ia,ic,rac2)
            call distance2 (crdball,ia,id,rad2)
            call distance2 (crdball,ib,ic,rbc2)
            call distance2 (crdball,ib,id,rbd2)
            call distance2 (crdball,ic,id,rcd2)
            rab = sqrt(rab2)
            rac = sqrt(rac2)
            rad = sqrt(rad2)
            rbc = sqrt(rbc2)
            rbd = sqrt(rbd2)
            rcd = sqrt(rcd2)
            call tetra_dihed (rab2,rac2,rad2,rbc2,rbd2,
     &                        rcd2,angle,cosine,sine)
c
c     if each ball has the same weight, add volume of the tetrahedron
c
            call tetra_voronoi (ra2,rb2,rc2,rd2,rab,rac,rad,rbc,rbd,
     &                          rcd,rab2,rac2,rad2,rbc2,rbd2,rcd2,
     &                          cosine,sine,vola,volb,volc,vold)
            ballwvol(ia) = ballwvol(ia) + vola
            ballwvol(ib) = ballwvol(ib) + volb
            ballwvol(ic) = ballwvol(ic) + volc
            ballwvol(id) = ballwvol(id) + vold
c
c     weights on each vertex: fraction of solid angle
c
            coef_vertex(ia) = coef_vertex(ia) + 0.25d0
     &                           - (angle(1)+angle(2)+angle(3))/2.0d0
            coef_vertex(ib) = coef_vertex(ib) + 0.25d0
     &                           - (angle(1)+angle(4)+angle(5))/2.0d0
            coef_vertex(ic) = coef_vertex(ic) + 0.25d0
     &                           - (angle(2)+angle(4)+angle(6))/2.0d0
            coef_vertex(id) = coef_vertex(id) + 0.25d0
     &                           - (angle(3)+angle(5)+angle(6))/2.0d0
c
c     weights on each edge: fraction of dihedral angle
c
c     iedge is the edge number in the tetrahedron idx, with
c     iedge = 1 (c,d), iedge = 2 (b,d), iedge = 3 (b,c),
c     iedge = 4 (a,d), iedge = 5 (a,c), iedge = 6 (a,b)
c
c     define indices of the edge
c
            do iedge = 1, 6
               i = tetra(pair(1,iedge),idx)
               j = tetra(pair(2,iedge),idx)
c
c     find which edge this corresponds to
c
               do i1 = sparse_row(i), sparse_row(i+1)-1
                  if (edges(2,i1) .eq. j)  goto 10
               end do
               goto 20
   10          continue
               if (coef_edge(i1) .ne. 0) then
                  coef_edge(i1) = coef_edge(i1) - angle(7-iedge)
               end if
   20          continue
            end do
c
c     since we have precomputed all the edge lengths, check triangles
c
c     we check the four faces of the tetrahedron; any face that
c     is exposed (on the convex hull, or facing a tetrahedron from
c     the Delaunay that is not part of the alpha complex), contributes
c
            do itrig = 1, 4
               jtetra = tneighbor(itrig,idx)
               if (jtetra.eq.0 .or. jtetra.gt.idx) then
                  if (btest(tinfo(idx),2+itrig)) then
                     if (jtetra .ne. 0) then
                        call mvbits (tinfo(jtetra),7,1,it2,0)
                     else
                        it2 = 0
                     end if
                     ival = 1 - it2
                     if (ival .eq. 0)  goto 30
                     coefval = 0.5d0 * dble(ival)
                     ntrig = ntrig + 1
                     if (itrig .eq. 1) then
                        surfa = 0.0d0
                        vola = 0.0d0
                        call threesphere_vol (rb,rc,rd,rb2,rc2,rd2,
     &                                        rbc,rbd,rcd,rbc2,rbd2,
     &                                        rcd2,surfb,surfc,surfd,
     &                                        volb,volc,vold)
                     else if (itrig.eq.2) then
                        surfb = 0.0d0
                        volb = 0.0d0
                        call threesphere_vol (ra,rc,rd,ra2,rc2,rd2,
     &                                        rac,rad,rcd,rac2,rad2,
     &                                        rcd2,surfa,surfc,surfd,
     &                                        vola,volc,vold)
                     else if (itrig .eq. 3) then
                        surfc = 0.0d0
                        volc = 0.0d0
                        call threesphere_vol (ra,rb,rd,ra2,rb2,rd2,
     &                                        rab,rad,rbd,rab2,rad2,
     &                                        rbd2,surfa,surfb,surfd,
     &                                        vola,volb,vold)
                     else if (itrig .eq. 4) then
                        surfd = 0.0d0
                        vold = 0.0d0
                        call threesphere_vol (ra,rb,rc,ra2,rb2,rc2,
     &                                        rab,rac,rbc,rab2,rac2,
     &                                        rbc2,surfa,surfb,surfc,
     &                                        vola,volb,volc)
                     end if
                     ballwsurf(ia) = ballwsurf(ia) + coefval*surfa
                     ballwsurf(ib) = ballwsurf(ib) + coefval*surfb
                     ballwsurf(ic) = ballwsurf(ic) + coefval*surfc
                     ballwsurf(id) = ballwsurf(id) + coefval*surfd
                     ballwvol(ia) = ballwvol(ia) + coefval*vola
                     ballwvol(ib) = ballwvol(ib) + coefval*volb
                     ballwvol(ic) = ballwvol(ic) + coefval*volc
                     ballwvol(id) = ballwvol(id) + coefval*vold
                  end if
               end if
   30          continue
            end do
         end if
      end do
c
c     contribution of 3-balls (i.e. triangles of the alpha complex);
c     already checked the triangles from tetrahedra that belongs to the
c     alpha complex; now we check any singular triangles (a face of a
c     tetrahedron in the Delaunay complex, but not in the alpha shape);
c     we loop over all tetrahedra, and check its four faces; any face
c     that is exposed (on the convex hull, or facing a tetrahedron from
c     the Delaunay that is not part of the alpha complex), contributes
c
      do idx = 1, ntetra
         if (btest(tinfo(idx),1)) then
            if (.not. btest(tinfo(idx),7)) then
               ia = tetra(1,idx)
               ib = tetra(2,idx)
               ic = tetra(3,idx)
               id = tetra(4,idx)
               do i = 1, 6
                  flag(i) = 0
               end do
               do i = 1, 3
                  a(i) = crdball(3*(ia-1)+i)
                  b(i) = crdball(3*(ib-1)+i)
                  c(i) = crdball(3*(ic-1)+i)
                  d(i) = crdball(3*(id-1)+i)
               end do
               ra = radball(ia)
               rb = radball(ib)
               rc = radball(ic)
               rd = radball(id)
               ra2 = ra * ra
               rb2 = rb * rb
               rc2 = rc * rc
               rd2 = rd * rd
               rab = 0.0d0
               rac = 0.0d0
               rad = 0.0d0
               rbc = 0.0d0
               rbd = 0.0d0
               rcd = 0.0d0
c
c     check triangles
c
               do itrig = 1, 4
                  jtetra = tneighbor(itrig,idx)
                  if (jtetra.eq.0 .or. jtetra.gt.idx) then
                     if (btest(tinfo(idx),2+itrig)) then
                        call mvbits (tinfo(idx),7,1,it1,0)
                        if (jtetra .ne. 0) then
                           call mvbits (tinfo(jtetra),7,1,it2,0)
                        else
                           it2 = 0
                        end if
                        ival = 2 - it1 - it2
                        if (ival .eq. 0)  goto 40
                        coefval = 0.5d0 * dble(ival)
                        ntrig = ntrig + 1
                        surfa = 0.0d0
                        surfb = 0.0d0
                        surfc = 0.0d0
                        surfd = 0.0d0
                        vola = 0.0d0
                        volb = 0.0d0
                        volc = 0.0d0
                        vold = 0.0d0
                        if (itrig .eq. 1) then
                           call triangle_vol (b,c,d,rbc,rbd,rcd,rbc2,
     &                                        rbd2,rcd2,rb,rc,rd,rb2,
     &                                        rc2,rd2,surfb,surfc,
     &                                        surfd,volb,volc,vold)
                        else if (itrig .eq. 2) then
                           call triangle_vol (a,c,d,rac,rad,rcd,rac2,
     &                                        rad2,rcd2,ra,rc,rd,ra2,
     &                                        rc2,rd2,surfa,surfc,
     &                                        surfd,vola,volc,vold)
                        else if (itrig .eq. 3) then
                           call triangle_vol (a,b,d,rab,rad,rbd,rab2,
     &                                        rad2,rbd2,ra,rb,rd,ra2,
     &                                        rb2,rd2,surfa,surfb,
     &                                        surfd,vola,volb,vold)
                        else if (itrig .eq. 4) then
                           call triangle_vol (a,b,c,rab,rac,rbc,rab2,
     &                                        rac2,rbc2,ra,rb,rc,ra2,
     &                                        rb2,rc2,surfa,surfb,
     &                                        surfc,vola,volb,volc)
                        end if
                        ballwsurf(ia) = ballwsurf(ia) + coefval*surfa
                        ballwsurf(ib) = ballwsurf(ib) + coefval*surfb
                        ballwsurf(ic) = ballwsurf(ic) + coefval*surfc
                        ballwsurf(id) = ballwsurf(id) + coefval*surfd
                        ballwvol(ia) = ballwvol(ia) + coefval*vola
                        ballwvol(ib) = ballwvol(ib) + coefval*volb
                        ballwvol(ic) = ballwvol(ic) + coefval*volc
                        ballwvol(id) = ballwvol(id) + coefval*vold
                     end if
                  end if
   40             continue
               end do
            end if
         end if
      end do
c
c     now add contribution of two sphere
c
      do iedge = 1, nedge
         if (coef_edge(iedge) .ne. 0.0d0) then
            ia = edges(1,iedge)
            ib = edges(2,iedge)
            do i = 1, 3
               a(i) = crdball(3*(ia-1)+i)
               b(i) = crdball(3*(ib-1)+i)
            end do
            ra = radball(ia)
            rb = radball(ib)
            ra2 = ra * ra
            rb2 = rb * rb
            call distance2 (crdball,ia,ib,rab2)
            rab = sqrt(rab2)
            call twosphere_vol (ra,ra2,rb,rb2,rab,rab2,
     &                          surfa,surfb,vola,volb)
            ballwsurf(ia) = ballwsurf(ia) - coef_edge(iedge)*surfa
            ballwsurf(ib) = ballwsurf(ib) - coef_edge(iedge)*surfb
            ballwvol(ia) = ballwvol(ia) - coef_edge(iedge)*vola
            ballwvol(ib) = ballwvol(ib) - coef_edge(iedge)*volb
         end if
      end do
c
c     next loop over all of the vertices
c
      nred = 0
      do i = 1, nvertex
         if (.not. btest(vinfo(i),0))  goto 50
c
c     if vertex is not in alpha complex, nothing to do
c
         if (.not. btest(vinfo(i),7))  goto 50
c
c     vertex is in alpha complex if its weight is 0 (buried)
c     in that case there is nothing to do
c
         if (coef_vertex(i) .eq. 0.0d0)  goto 50
         ra = radball(i)
         surfa = 4.0d0 * pi * ra * ra
         vola = ra * surfa / 3.0d0
         ballwsurf(i) = ballwsurf(i) + coef_vertex(i)*surfa
         ballwvol(i) = ballwvol(i) + coef_vertex(i)*vola
   50    continue
      end do
c
c     compute total surface, both weighted and unweighted
c
      do i = 1, nvertex
         if (btest(vinfo(i),0)) then
            surf = surf + ballwsurf(i)
            ballwsurf(i-4) = coef(i-4) * ballwsurf(i)
            wsurf = wsurf + ballwsurf(i-4)
            vol = vol + ballwvol(i)
            ballwvol(i-4) = coef(i-4) * ballwvol(i)
            wvol = wvol + ballwvol(i-4)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (sparse_row)
      deallocate (edges)
      deallocate (coef_edge)
      deallocate (coef_vertex)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ball_dsurf  --  find area & derivs of spheres  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ball_dsurf" computes the weighted surface area of a union
c     of spheres as well as its derivatives with respect to the
c     coordinates of the spheres
c
c     variables and parameters:
c
c     coef          weight of each sphere for weighted surface
c     option        flag to compute or not compute derivatives
c     wsurf         weighted surface area
c     surf          unweighted surface area
c     ballwsurf     weighted contribution of each ball
c     dsurf_dist    derivatives of surface area over distances
c     dsurf_coord   derivatives of surface area over coordinates
c
c
      subroutine ball_dsurf (coef,wsurf,surf,ballwsurf,dsurf_coord)
      use math
      use shapes
      implicit none
      integer i,j,i1
      integer ia,ib,ic,id
      integer nedge
      integer idx,ilast
      integer itrig,iedge
      integer ival,it1,it2
      integer jtetra,option
      integer pair(2,6)
      integer edge_list(6)
      integer, allocatable :: sparse_row(:)
      integer, allocatable :: edges(:,:)
      real*8 ra,rb,rc,rd
      real*8 ra2,rb2,rc2,rd2
      real*8 rab,rac,rad
      real*8 rbc,rbd,rcd
      real*8 rab2,rac2,rad2
      real*8 rbc2,rbd2,rcd2
      real*8 val,val1,val2,val3
      real*8 val4,vala,valb
      real*8 r1,r2,r1_2,r2_2,r12
      real*8 coefval
      real*8 surfa,surfb
      real*8 surfc,surfd
      real*8 u(3),dist(6)
      real*8 deriv(6,6)
      real*8 dsurfa3(3),dsurfb3(3)
      real*8 dsurfc3(3),dsurfd3(3)
      real*8 dsurfa2,dsurfb2
      real*8 angle(6),cosine(6),sine(6)
      real*8 wsurf,surf
      real*8 coef(*),ballwsurf(*)
      real*8 dsurf_coord(3,*)
      real*8, allocatable :: coef_edge(:)
      real*8, allocatable :: edge_dist(:)
      real*8, allocatable :: coef_vertex(:)
      real*8, allocatable :: dsurf_dist(:)
      data pair  / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 /
      save
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (sparse_row(10*maxedge))
      allocate (edges(2,maxedge))
      allocate (coef_edge(maxedge))
      allocate (coef_vertex(nvertex))
      allocate (edge_dist(maxedge))
      allocate (dsurf_dist(10*maxedge))
c
c     initialize some input and result values
c
      option = 1
      wsurf = 0.0d0
      surf = 0.0d0
      do i = 1, nvertex
         ballwsurf(i) = 0.0d0
      end do
c
c     find list of all edges in the alpha complex
c
      nedge = 0
      call find_all_edges (nedge,edges)
c
c     define sparse structure for edges
c
      ilast = 0
      do i = 1, nedge
         ia = edges(1,i)
         ib = edges(2,i)
         if (ia .ne. ilast) then
            do j = ilast+1, ia
               sparse_row(j) = i
            end do
            ilast = ia
         end if
         coef_edge(i) = 1
         ra = radball(ia)
         ra2 = ra * ra
         rb = radball(ib)
         rb2 = rb * rb
         call distance2 (crdball,ia,ib,rab2)
         rab = sqrt(rab2)
         edge_dist(i) = rab
         dsurf_dist(i) = 0.0d0
      end do
      do i = ia+1, nvertex
         sparse_row(i) = nedge + 1
      end do
c
c     build list of fully buried vertices; these vertices are part
c     of the alpha complex, and all edges that start or end at these
c     vertices are buried
c
      do i = 1, nvertex
         coef_vertex(i) = 1.0d0
      end do
c
c     contribution of four spheres; use weighted inclusion-exclusion
c     formula; each tetrahedron in the Alpha Complex only contributes
c     to the weight of each its edges and each of its vertices
c
      do idx = 1, ntetra
         if (btest(tinfo(idx),7)) then
            ia = tetra(1,idx)
            ib = tetra(2,idx)
            ic = tetra(3,idx)
            id = tetra(4,idx)
            ra = radball(ia)
            rb = radball(ib)
            rc = radball(ic)
            rd = radball(id)
            ra2 = ra * ra
            rb2 = rb * rb
            rc2 = rc * rc
            rd2 = rd * rd
c
c     weights on each edge; fraction of dihedral angle
c
c     iedge is the edge number in the tetrahedron idx with:
c     iedge = 1 (c,d), iedge = 2 (b,d), iedge = 3 (b,c),
c     iedge = 4 (a,d), iedge = 5 (a,c), iedge = 6 (a,b)
c               
c     define indices of the edge
c
            do iedge = 1, 6
               i = tetra(pair(1,iedge),idx)
               j = tetra(pair(2,iedge),idx)
c
c     find which edge this corresponds to
c
               do i1 = sparse_row(i), sparse_row(i+1)-1
                  if (edges(2,i1) .eq. j)  goto 10
               end do
               goto 20
   10          continue
               edge_list(7-iedge) = i1
   20          continue
            end do
            rab = edge_dist(edge_list(1))
            rac = edge_dist(edge_list(2))
            rad = edge_dist(edge_list(3))
            rbc = edge_dist(edge_list(4))
            rbd = edge_dist(edge_list(5))
            rcd = edge_dist(edge_list(6))
            rab2 = rab * rab
            rac2 = rac * rac
            rad2 = rad * rad
            rbc2 = rbc * rbc
            rbd2 = rbd * rbd
            rcd2 = rcd * rcd
            dist(1) = rab
            dist(2) = rac
            dist(3) = rad
            dist(4) = rbc
            dist(5) = rbd
            dist(6) = rcd
c
c     weights on each vertex, fraction of solid angle
c
            if (option .eq. 0) then
               call tetra_dihed (rab2,rac2,rad2,rbc2,rbd2,
     &                           rcd2,angle,cosine,sine)
            else
               call tetra_dihed_der (rab2,rac2,rad2,rbc2,rbd2,
     &                               rcd2,angle,cosine,sine,deriv)
            end if
c
c     weights on each vertex, fraction of solid angle
c
            coef_vertex(ia) = coef_vertex(ia) + 0.25d0
     &                           - (angle(1)+angle(2)+angle(3))/2.0d0
            coef_vertex(ib) = coef_vertex(ib) + 0.25d0
     &                           - (angle(1)+angle(4)+angle(5))/2.0d0
            coef_vertex(ic) = coef_vertex(ic) + 0.25d0
     &                           - (angle(2)+angle(4)+angle(6))/2.0d0
            coef_vertex(id) = coef_vertex(id) + 0.25d0
     &                           - (angle(3)+angle(5)+angle(6))/2.0d0
c
c     weights on each edge, fraction of dihedral angle
c
            do iedge = 1, 6
               i1 = edge_list(iedge)
               if (coef_edge(i1) .ne. 0.0d0) then
                  coef_edge(i1) = coef_edge(i1) - angle(iedge)
               end if
            end do
c
c     take into account the der ivatives of the edge weight
c     in weighted inclusion-exclusion formula
c
            if (option .eq. 1) then
               do iedge = 1, 6
                  i1 = edge_list(iedge)
                  ia = edges(1,i1)
                  ib = edges(2,i1)
                  r1 = radball(ia)
                  r1_2 = r1 * r1
                  r2 = radball(ib)
                  r2_2 = r2 * r2
                  r12 = edge_dist(i1)
                  val1 = (r1_2-r2_2) / r12
                  vala = r1 * (2.0d0*r1-r12-val1)
                  valb = r2 * (2.0d0*r2-r12+val1)
                  val = coef(ia-4)*vala + coef(ib-4)*valb
                  do i = 1, 6
                     j = edge_list(i)
                     dsurf_dist(j) = dsurf_dist(j)
     &                                  + dist(i)*deriv(iedge,i)*val
                  end do
               end do
c
c     take into account the derivatives of the vertex weight 
c     in weightedinclusion-exclusion formula
c
               val1 = ra2 * coef(ia-4)
               val2 = rb2 * coef(ib-4)
               val3 = rc2 * coef(ic-4)
               val4 = rd2 * coef(id-4)
               do i = 1, 6
                  j = edge_list(i)
                  val = val1*(deriv(1,i)+deriv(2,i)+deriv(3,i))
     &                     + val2*(deriv(1,i)+deriv(4,i)+deriv(5,i))
     &                     + val3*(deriv(2,i)+deriv(4,i)+deriv(6,i))
     &                     + val4*(deriv(3,i)+deriv(5,i)+deriv(6,i))
                  dsurf_dist(j) = dsurf_dist(j) - 2.0d0*dist(i)*val
               end do
            end if
         end if
      end do
c
c     contribution of three balls (triangles of the alpha complex)
c
c     we loop over all tetrahedra, and check its four faces;
c     any face that is exposed (on the convex hull, or facing
c     a tetrahedron from the Delaunay that is not part of the
c     alpha complex), contributes
c
      do idx = 1, ntetra
         if (btest(tinfo(idx),1)) then
            ia = tetra(1,idx)
            ib = tetra(2,idx)
            ic = tetra(3,idx)
            id = tetra(4,idx)
            ra = radball(ia)
            rb = radball(ib)
            rc = radball(ic)
            rd = radball(id)
            ra2 = ra * ra
            rb2 = rb * rb
            rc2 = rc * rc
            rd2 = rd * rd
c
c     define indices of the edge
c
            do iedge = 1, 6
               i = tetra(pair(1,iedge),idx)
               j = tetra(pair(2,iedge),idx)
c
c     find which edge this corresponds to
c
               do i1 = sparse_row(i), sparse_row(i+1)-1
                  if (edges(2,i1) .eq. j)  goto 30
               end do
               goto 40
   30          continue
               edge_list(7-iedge) = i1
   40          continue
            end do
c
c     check triangles
c
            do itrig = 1, 4
               jtetra = tneighbor(itrig,idx)
               if (jtetra.eq.0 .or. jtetra.gt.idx) then
                  if (btest(tinfo(idx),2+itrig)) then
                     call mvbits (tinfo(idx),7,1,it1,0)
                     if (jtetra .ne. 0) then
                        call mvbits (tinfo(jtetra),7,1,it2,0)
                     else
                        it2 = 0
                     end if
                     ival = 2 - it1 - it2
                     if (ival .eq. 0)  goto 50
                     coefval = 0.5d0 * dble(ival)
                     surfa = 0.0d0
                     surfb = 0.0d0
                     surfc = 0.0d0
                     surfd = 0.0d0
                     if (itrig .eq. 1) then
                        rbc = edge_dist(edge_list(4))
                        rbd = edge_dist(edge_list(5))
                        rcd = edge_dist(edge_list(6))
                        rbc2 = rbc * rbc
                        rbd2 = rbd * rbd
                        rcd2 = rcd * rcd
                        call threesphere_dsurf (rb,rc,rd,rb2,rc2,rd2,
     &                                          rbc,rbd,rcd,rbc2,rbd2,
     &                                          rcd2,surfb,surfc,surfd,
     &                                          dsurfb3,dsurfc3,
     &                                          dsurfd3,option)
                        if (option .eq. 1) then
                           call update_deriv (dsurf_dist,dsurfb3,
     &                                        dsurfc3,dsurfd3,
     &                                        coef(ib-4),coef(ic-4),
     &                                        coef(id-4),coefval,
     &                                        edge_list(4),
     &                                        edge_list(5),
     &                                        edge_list(6))
                        end if
                     else if (itrig .eq. 2) then
                        rac = edge_dist(edge_list(2))
                        rad = edge_dist(edge_list(3))
                        rcd = edge_dist(edge_list(6))
                        rac2 = rac * rac
                        rad2 = rad * rad
                        rcd2 = rcd * rcd
                        call threesphere_dsurf (ra,rc,rd,ra2,rc2,rd2,
     &                                          rac,rad,rcd,rac2,rad2,
     &                                          rcd2,surfa,surfc,surfd,
     &                                          dsurfa3,dsurfc3,
     &                                          dsurfd3,option)
                        if (option .eq. 1) then
                           call update_deriv (dsurf_dist,dsurfa3,
     &                                        dsurfc3,dsurfd3,
     &                                        coef(ia-4),coef(ic-4),
     &                                        coef(id-4),coefval,
     &                                        edge_list(2),
     &                                        edge_list(3),
     &                                        edge_list(6))
                        end if
                     else if (itrig .eq. 3) then
                        rab = edge_dist(edge_list(1))
                        rad = edge_dist(edge_list(3))
                        rbd = edge_dist(edge_list(5))
                        rab2 = rab * rab
                        rad2 = rad * rad
                        rbd2 = rbd * rbd
                        call threesphere_dsurf (ra,rb,rd,ra2,rb2,rd2,
     &                                          rab,rad,rbd,rab2,rad2,
     &                                          rbd2,surfa,surfb,surfd,
     &                                          dsurfa3,dsurfb3,
     &                                          dsurfd3,option)
                        if (option .eq. 1) then
                           call update_deriv (dsurf_dist,dsurfa3,
     &                                        dsurfb3,dsurfd3,
     &                                        coef(ia-4),coef(ib-4),
     &                                        coef(id-4),coefval,
     &                                        edge_list(1),
     &                                        edge_list(3),
     &                                        edge_list(5))
                        end if
                     else if (itrig .eq. 4) then
                        rab = edge_dist(edge_list(1))
                        rac = edge_dist(edge_list(2))
                        rbc = edge_dist(edge_list(4))
                        rab2 = rab * rab
                        rac2 = rac * rac
                        rbc2 = rbc * rbc
                        call threesphere_dsurf (ra,rb,rc,ra2,rb2,rc2,
     &                                          rab,rac,rbc,rab2,rac2,
     &                                          rbc2,surfa,surfb,surfc,
     &                                          dsurfa3,dsurfb3,
     &                                          dsurfc3,option)
                        if (option .eq. 1) then
                           call update_deriv (dsurf_dist,dsurfa3,
     &                                        dsurfb3,dsurfc3,
     &                                        coef(ia-4),coef(ib-4),
     &                                        coef(ic-4),coefval,
     &                                        edge_list(1),
     &                                        edge_list(2),
     &                                        edge_list(4))
                        end if
                     end if
                     ballwsurf(ia) = ballwsurf(ia) + coefval*surfa
                     ballwsurf(ib) = ballwsurf(ib) + coefval*surfb
                     ballwsurf(ic) = ballwsurf(ic) + coefval*surfc
                     ballwsurf(id) = ballwsurf(id) + coefval*surfd
                  end if
               end if
   50          continue
            end do
         end if
      end do
c
c     now add contribution of two sphere
c
      do iedge = 1, nedge
         if (coef_edge(iedge) .ne. 0.0d0) then
            ia = edges(1,iedge)
            ib = edges(2,iedge)
            ra = radball(ia)
            rb = radball(ib)
            ra2 = ra * ra
            rb2 = rb * rb
            rab = edge_dist(iedge)
            rab2 = rab * rab
            call twosphere_dsurf (ra,ra2,rb,rb2,rab,rab2,surfa,
     &                            surfb,dsurfa2,dsurfb2,option)
            ballwsurf(ia) = ballwsurf(ia) - coef_edge(iedge)*surfa
            ballwsurf(ib) = ballwsurf(ib) - coef_edge(iedge)*surfb
            if (option .eq. 1) then
               dsurf_dist(iedge) = dsurf_dist(iedge)
     &                                - coef_edge(iedge)
     &                      *(coef(ia-4)*dsurfa2+coef(ib-4)*dsurfb2)
            end if
         end if
      end do
c
c     now loop over vertices
c
      do i = 1, nvertex
         if (.not. btest(vinfo(i),0))  goto 60
c
c     if vertex is not in alpha complex, then nothing to do
c
         if (.not. btest(vinfo(i),7))  goto 60
c
c     vertex is in alpha complex; if its weight is 0 (i.e., buried)
c     nothing to do
c
         if (coef_vertex(i) .eq. 0)  goto 60
         ra = radball(i)
         ballwsurf(i) = ballwsurf(i) + 4.0d0*pi*ra*ra*coef_vertex(i)
   60    continue
      end do
c
c     compute total surface area, weighted and unweighted
c
      do i = 1, nvertex
         if (btest(vinfo(i),0)) then
            surf = surf + ballwsurf(i)
            ballwsurf(i-4) = ballwsurf(i) * coef(i-4)
            wsurf = wsurf + ballwsurf(i-4)
         end if
      end do
      if (option .ne. 1)  return
c
c     convert distance derivatives to coordinate derivatives
c
      do i = 1, nvertex
         do j = 1, 3
            dsurf_coord(j,i) = 0.0d0
         end do
      end do
      do iedge = 1, nedge
         if (dsurf_dist(iedge) .ne. 0.0d0) then
            ia = edges(1,iedge)
            ib = edges(2,iedge)
            do i = 1, 3
               u(i) = crdball(3*(ia-1)+i) - crdball(3*(ib-1)+i)
            end do
            rab = edge_dist(iedge)
            val = dsurf_dist(iedge) / rab
            do j = 1, 3
               dsurf_coord(j,ia-4) = dsurf_coord(j,ia-4) + u(j)*val
               dsurf_coord(j,ib-4) = dsurf_coord(j,ib-4) - u(j)*val
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (sparse_row)
      deallocate (edges)
      deallocate (coef_edge)
      deallocate (coef_vertex)
      deallocate (edge_dist)
      deallocate (dsurf_dist)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ball_dvol  --  find volume & derivs of spheres  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ball_dvol" computes the weighted surface area of a union of
c     spheres as well as the corresponding weighted excluded volume,
c     also finds their derivatives with respect sphere coordinates
c
c     variables and parameters:
c
c     coef          weight of each sphere for the weighted surface
c     option        computes derivatives or not
c     wsurf         weighted accessible surface area
c     wvol          weighted excluded volume
c     surf          unweighted accessible surface area
c     vol           unweighted excluded volume 
c     ballwsurf     weighted contribution of each sphere to the area
c     ballwvol      weighted contribution of each ball to the volume
c     dsurf_dist    derivatives of surface area over distances
c     dsurf_coord   derivatives of surface area over coordinates
c     dvol_dist     derivatives of volume over distances
c     dvol_coord    derivatives of volume over coordinates
c
c
      subroutine ball_dvol (coef,wsurf,wvol,surf,vol,ballwsurf,
     &                      ballwvol,dsurf_coord,dvol_coord)
      use math
      use shapes
      implicit none
      integer i,j,i1
      integer ia,ib,ic,id
      integer nedge
      integer idx,ilast
      integer itrig,iedge
      integer ival,it1,it2
      integer jtetra,option
      integer pair(2,6)
      integer edge_list(6)
      integer, allocatable :: sparse_row(:)
      integer, allocatable :: edges(:,:)
      real*8 ra,rb,rc,rd
      real*8 ra2,rb2,rc2,rd2
      real*8 rab,rac,rad
      real*8 rbc,rbd,rcd
      real*8 rab2,rac2,rad2
      real*8 rbc2,rbd2,rcd2
      real*8 val,val1,val2,val3,val4
      real*8 vala,valb,valc,vald
      real*8 coefval
      real*8 surfa,surfb,surfc,surfd
      real*8 dsurfa2,dsurfb2
      real*8 dvola2,dvolb2
      real*8 vola,volb,volc,vold
      real*8 wsurf,surf,wvol,vol
      real*8 u(3),dist(6)
      real*8 dsurfa3(3),dsurfb3(3)
      real*8 dsurfc3(3),dsurfd3(3)
      real*8 dvola3(3),dvolb3(3)
      real*8 dvolc3(3),dvold3(3)
      real*8 dvola(6),dvolb(6)
      real*8 dvolc(6),dvold(6)
      real*8 angle(6),cosine(6),sine(6)
      real*8 deriv(6,6)
      real*8 coef(*)
      real*8 ballwsurf(*),ballwvol(*)
      real*8 dsurf_coord(3,*)
      real*8 dvol_coord(3,*)
      real*8, allocatable :: coef_edge(:)
      real*8, allocatable :: coef_vertex(:)
      real*8, allocatable :: edge_dist(:)
      real*8, allocatable :: edge_surf(:)
      real*8, allocatable :: edge_vol(:)
      real*8, allocatable :: dsurf_dist(:)
      real*8, allocatable :: dvol_dist(:)
      data pair  / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 /
      save
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (sparse_row(10*maxedge))
      allocate (edges(2,maxedge))
      allocate (coef_edge(maxedge))
      allocate (coef_vertex(nvertex))
      allocate (edge_surf(maxedge))
      allocate (edge_vol(maxedge))
      allocate (edge_dist(maxedge))
      allocate (dsurf_dist(10*maxedge))
      allocate (dvol_dist(10*maxedge))
c
c     initialize some input and result values
c
      option = 1
      wsurf = 0.0d0
      surf = 0.0d0
      wvol = 0.0d0
      vol = 0.0d0
      do i = 1, nvertex
         ballwsurf(i) = 0.0d0
         ballwvol(i) = 0.0d0
      end do
c
c     find list of all edges in the alpha complex
c
      nedge = 0
      call find_all_edges (nedge,edges)
c
c     define sparse structure for edges
c
      ilast = 0
      do i = 1, nedge
         ia = edges(1,i)
         ib = edges(2,i)
         if (ia .ne. ilast) then
            do j = ilast+1, ia
               sparse_row(j) = i
            end do
            ilast = ia
         end if
         coef_edge(i) = 1
         ra = radball(ia)
         ra2 = ra * ra
         rb = radball(ib)
         rb2 = rb * rb
         call distance2 (crdball,ia,ib,rab2)
         rab = sqrt(rab2)
         call twosphere_vol (ra,ra2,rb,rb2,rab,rab2,
     &                       surfa,surfb,vola,volb)
         edge_dist(i) = rab
         edge_surf(i) = (coef(ia-4)*surfa+coef(ib-4)*surfb) / twopi
         edge_vol(i) = (coef(ia-4)*vola+coef(ib-4)*volb) / twopi
         dsurf_dist(i) = 0.0d0
         dvol_dist(i) = 0.0d0
      end do
      do i = ia+1, nvertex
         sparse_row(i) = nedge + 1
      end do
c
c     build list of fully buried vertices; these vertices are part
c     of the alpha complex, and all edges that start or end at these
c     vertices are buried
c
      do i = 1, nvertex
         coef_vertex(i) = 1.0d0
      end do
c
c     contribution of four spheres; use the weighted inclusion-exclusion
c     formula; each tetrahedron in the Alpha Complex only contributes
c     to the weight of each its edges and each of its vertices
c
      do idx = 1, ntetra
         if (btest(tinfo(idx),7)) then
            ia = tetra(1,idx)
            ib = tetra(2,idx)
            ic = tetra(3,idx)
            id = tetra(4,idx)
            ra = radball(ia)
            rb = radball(ib)
            rc = radball(ic)
            rd = radball(id)
            ra2 = ra * ra
            rb2 = rb * rb
            rc2 = rc * rc
            rd2 = rd * rd
c
c     weights on each edge; fraction of dihedral angle
c
c     iedge is the edge number in the tetrahedron idx with:
c     iedge = 1 (c,d), iedge = 2 (b,d), iedge = 3 (b,c),
c     iedge = 4 (a,d), iedge = 5 (a,c), iedge = 6 (a,b)
c               
c     define indices of the edge
c
            do iedge = 1, 6
               i = tetra(pair(1,iedge),idx)
               j = tetra(pair(2,iedge),idx)
c
c     find which edge this corresponds to
c
               do i1 = sparse_row(i), sparse_row(i+1)-1
                  if (edges(2,i1) .eq. j)  goto 10
               end do
               goto 20
   10          continue
               edge_list(7-iedge) = i1
   20          continue
            end do
            rab = edge_dist(edge_list(1))
            rac = edge_dist(edge_list(2))
            rad = edge_dist(edge_list(3))
            rbc = edge_dist(edge_list(4))
            rbd = edge_dist(edge_list(5))
            rcd = edge_dist(edge_list(6))
            rab2 = rab * rab
            rac2 = rac * rac
            rad2 = rad * rad
            rbc2 = rbc * rbc
            rbd2 = rbd * rbd
            rcd2 = rcd * rcd
            dist(1) = rab
            dist(2) = rac
            dist(3) = rad
            dist(4) = rbc
            dist(5) = rbd
            dist(6) = rcd
c
c     characterize the tetrahedron based on A, B, C and D
c
            if (option .eq. 0) then
               call tetra_dihed (rab2,rac2,rad2,rbc2,rbd2,
     &                           rcd2,angle,cosine,sine)
            else
               call tetra_dihed_der (rab2,rac2,rad2,rbc2,rbd2,
     &                               rcd2,angle,cosine,sine,deriv)
            end if
c
c     add fraction of tetrahedron that belongs to each ball
c
            call tetra_voronoi_der (ra2,rb2,rc2,rd2,rab,rac,rad,rbc,
     &                              rbd,rcd,rab2,rac2,rad2,rbc2,rbd2,
     &                              rcd2,cosine,sine,deriv,vola,volb,
     &                              volc,vold,dvola,dvolb,dvolc,
     &                              dvold,option)
            ballwvol(ia) = ballwvol(ia) + vola
            ballwvol(ib) = ballwvol(ib) + volb
            ballwvol(ic) = ballwvol(ic) + volc
            ballwvol(id) = ballwvol(id) + vold
            if (option .eq. 1) then
               do iedge = 1, 6
                  i1 = edge_list(iedge)
                  dvol_dist(i1) = dvol_dist(i1)
     &                               + coef(ia-4)*dvola(iedge)
     &                               + coef(ib-4)*dvolb(iedge)
     &                               + coef(ic-4)*dvolc(iedge)
     &                               + coef(id-4)*dvold(iedge)
               end do
            end if
c       
c     weights on each vertex, fraction of solid angle
c
            coef_vertex(ia) = coef_vertex(ia) + 0.25d0
     &                           - (angle(1)+angle(2)+angle(3))/2.0d0
            coef_vertex(ib) = coef_vertex(ib) + 0.25d0
     &                           - (angle(1)+angle(4)+angle(5))/2.0d0
            coef_vertex(ic) = coef_vertex(ic) + 0.25d0
     &                           - (angle(2)+angle(4)+angle(6))/2.0d0
            coef_vertex(id) = coef_vertex(id) + 0.25d0
     &                           - (angle(3)+angle(5)+angle(6))/2.0d0
c
c     weights on each edge, fraction of dihedral angle
c
            do iedge = 1, 6
               i1 = edge_list(iedge)
               if (coef_edge(i1) .ne. 0.0d0) then
                  coef_edge(i1) = coef_edge(i1) - angle(iedge)
               end if
            end do
c
c     take into account the derivatives of the edge weight
c     in weighted inclusion-exclusion formula
c
            if (option .eq. 1) then
               do iedge = 1, 6
                  i1 = edge_list(iedge)
                  val1 = 2.0d0 * edge_surf(i1)
                  val2 = 2.0d0 * edge_vol(i1)
                  do i = 1, 6
                     j = edge_list(i)
                     dsurf_dist(j) = dsurf_dist(j)
     &                                  + dist(i)*deriv(iedge,i)*val1
                     dvol_dist(j) = dvol_dist(j)
     &                                 + dist(i)*deriv(iedge,i)*val2
                  end do
               end do
c
c     take into account the derivatives of the vertex weight
c     in weighted inclusion-exclusion formula
c
               val1 = ra2 * coef(ia-4)
               val2 = rb2 * coef(ib-4)
               val3 = rc2 * coef(ic-4)
               val4 = rd2 * coef(id-4)
               vala = val1 * ra/3.0d0
               valb = val2 * rb/3.0d0
               valc = val3 * rc/3.0d0
               vald = val4 * rd/3.0d0
               do i = 1, 6
                  j = edge_list(i)
                  val = val1*(deriv(1,i)+deriv(2,i)+deriv(3,i))
     &                     + val2*(deriv(1,i)+deriv(4,i)+deriv(5,i))
     &                     + val3*(deriv(2,i)+deriv(4,i)+deriv(6,i))
     &                     + val4*(deriv(3,i)+deriv(5,i)+deriv(6,i))
                  dsurf_dist(j) = dsurf_dist(j) - 2.0d0*dist(i)*val
                  val = vala*(deriv(1,i)+deriv(2,i)+deriv(3,i))
     &                     + valb*(deriv(1,i)+deriv(4,i)+deriv(5,i))
     &                     + valc*(deriv(2,i)+deriv(4,i)+deriv(6,i))
     &                     + vald*(deriv(3,i)+deriv(5,i)+deriv(6,i))
                  dvol_dist(j) = dvol_dist(j) - 2.0d0*dist(i)*val
               end do
            end if
         end if
      end do
c
c     contribution of three balls (triangles of the alpha complex)
c
c     we loop over all tetrahedra, and check its four faces;
c     any face that is exposed (on the convex hull, or facing
c     a tetrahedron from the Delaunay that is not part of the
c     alpha complex), contributes
c
      do idx = 1, ntetra
         if (btest(tinfo(idx),1)) then
            ia = tetra(1,idx)
            ib = tetra(2,idx)
            ic = tetra(3,idx)
            id = tetra(4,idx)
            ra = radball(ia)
            rb = radball(ib)
            rc = radball(ic)
            rd = radball(id)
            ra2 = ra * ra
            rb2 = rb * rb
            rc2 = rc * rc
            rd2 = rd * rd
            do iedge = 1, 6
c
c     define indices of the edge
c
               i = tetra(pair(1,iedge),idx)
               j = tetra(pair(2,iedge),idx)
c
c     find which edge this corresponds to:
c
               do i1 = sparse_row(i), sparse_row(i+1)-1
                  if (edges(2,i1) .eq. j)  goto 30
               end do
               goto 40
   30          continue
               edge_list(7-iedge) = i1
   40          continue
            end do
c
c     check triangles
c
            do itrig = 1, 4
               jtetra = tneighbor(itrig,idx)
               if (jtetra.eq.0 .or. jtetra.gt.idx) then
                  if (btest(tinfo(idx),2+itrig)) then
                     call mvbits (tinfo(idx),7,1,it1,0)
                     if (jtetra .ne. 0) then
                        call mvbits (tinfo(jtetra),7,1,it2,0)
                     else
                        it2 = 0
                     end if
                     ival = 2 - it1 - it2
                     if (ival .eq. 0)  goto 50
                     coefval = 0.5d0 * dble(ival)
                     surfa = 0.0d0
                     surfb = 0.0d0
                     surfc = 0.0d0
                     surfd = 0.0d0
                     vola = 0.0d0
                     volb = 0.0d0
                     volc = 0.0d0
                     vold = 0.0d0
                     if (itrig .eq. 1) then
                        rbc = edge_dist(edge_list(4))
                        rbd = edge_dist(edge_list(5))
                        rcd = edge_dist(edge_list(6))
                        rbc2 = rbc * rbc
                        rbd2 = rbd * rbd
                        rcd2 = rcd * rcd
                        call threesphere_dvol (rb,rc,rd,rb2,rc2,rd2,
     &                                         rbc,rbd,rcd,rbc2,rbd2,
     &                                         rcd2,surfb,surfc,surfd,
     &                                         volb,volc,vold,dsurfb3,
     &                                         dsurfc3,dsurfd3,dvolb3,
     &                                         dvolc3,dvold3,option)
                        if (option .eq. 1) then
                           call update_deriv (dsurf_dist,dsurfb3,
     &                                        dsurfc3,dsurfd3,
     &                                        coef(ib-4),coef(ic-4),
     &                                        coef(id-4),coefval,
     &                                        edge_list(4),
     &                                        edge_list(5),
     &                                        edge_list(6))
                           call update_deriv (dvol_dist,dvolb3,
     &                                        dvolc3,dvold3,
     &                                        coef(ib-4),coef(ic-4),
     &                                        coef(id-4),coefval,
     &                                        edge_list(4),
     &                                        edge_list(5),
     &                                        edge_list(6))
                        end if
                     else if (itrig .eq. 2) then
                        rac = edge_dist(edge_list(2))
                        rad = edge_dist(edge_list(3))
                        rcd = edge_dist(edge_list(6))
                        rac2 = rac * rac
                        rad2 = rad * rad
                        rcd2 = rcd * rcd
                        call threesphere_dvol (ra,rc,rd,ra2,rc2,rd2,
     &                                         rac,rad,rcd,rac2,rad2,
     &                                         rcd2,surfa,surfc,surfd,
     &                                         vola,volc,vold,dsurfa3,
     &                                         dsurfc3,dsurfd3,dvola3,
     &                                         dvolc3,dvold3,option)
                        if (option .eq. 1) then
                           call update_deriv (dsurf_dist,dsurfa3,
     &                                        dsurfc3,dsurfd3,
     &                                        coef(ia-4),coef(ic-4),
     &                                        coef(id-4),coefval,
     &                                        edge_list(2),
     &                                        edge_list(3),
     &                                        edge_list(6))
                           call update_deriv (dvol_dist,dvola3,
     &                                        dvolc3,dvold3,
     &                                        coef(ia-4),coef(ic-4),
     &                                        coef(id-4),coefval,
     &                                        edge_list(2),
     &                                        edge_list(3),
     &                                        edge_list(6))
                        end if
                     else if (itrig .eq. 3) then
                        rab = edge_dist(edge_list(1))
                        rad = edge_dist(edge_list(3))
                        rbd = edge_dist(edge_list(5))
                        rab2 = rab * rab
                        rad2 = rad * rad
                        rbd2 = rbd * rbd
                        call threesphere_dvol (ra,rb,rd,ra2,rb2,rd2,
     &                                         rab,rad,rbd,rab2,rad2,
     &                                         rbd2,surfa,surfb,surfd,
     &                                         vola,volb,vold,dsurfa3,
     &                                         dsurfb3,dsurfd3,dvola3,
     &                                         dvolb3,dvold3,option)
                        if (option .eq. 1) then
                           call update_deriv (dsurf_dist,dsurfa3,
     &                                        dsurfb3,dsurfd3,
     &                                        coef(ia-4),coef(ib-4),
     &                                        coef(id-4),coefval,
     &                                        edge_list(1),
     &                                        edge_list(3),
     &                                        edge_list(5))
                           call update_deriv (dvol_dist,dvola3,
     &                                        dvolb3,dvold3,
     &                                        coef(ia-4),coef(ib-4),
     &                                        coef(id-4),coefval,
     &                                        edge_list(1),
     &                                        edge_list(3),
     &                                        edge_list(5))
                        end if
                     else if (itrig .eq. 4) then
                        rab = edge_dist(edge_list(1))
                        rac = edge_dist(edge_list(2))
                        rbc = edge_dist(edge_list(4))
                        rab2 = rab * rab
                        rac2 = rac * rac
                        rbc2 = rbc * rbc
                        call threesphere_dvol (ra,rb,rc,ra2,rb2,rc2,
     &                                         rab,rac,rbc,rab2,rac2,
     &                                         rbc2,surfa,surfb,surfc,
     &                                         vola,volb,volc,dsurfa3,
     &                                         dsurfb3,dsurfc3,dvola3,
     &                                         dvolb3,dvolc3,option)
                        if (option .eq. 1) then
                           call update_deriv (dsurf_dist,dsurfa3,
     &                                        dsurfb3,dsurfc3,
     &                                        coef(ia-4),coef(ib-4),
     &                                        coef(ic-4),coefval,
     &                                        edge_list(1),
     &                                        edge_list(2),
     &                                        edge_list(4))
                           call update_deriv (dvol_dist,dvola3,
     &                                        dvolb3,dvolc3,
     &                                        coef(ia-4),coef(ib-4),
     &                                        coef(ic-4),coefval,
     &                                        edge_list(1),
     &                                        edge_list(2),
     &                                        edge_list(4))
                         end if
                      end if
                      ballwsurf(ia) = ballwsurf(ia) + coefval*surfa
                      ballwsurf(ib) = ballwsurf(ib) + coefval*surfb
                      ballwsurf(ic) = ballwsurf(ic) + coefval*surfc
                      ballwsurf(id) = ballwsurf(id) + coefval*surfd
                      ballwvol(ia) = ballwvol(ia) + coefval*vola
                      ballwvol(ib) = ballwvol(ib) + coefval*volb
                      ballwvol(ic) = ballwvol(ic) + coefval*volc
                      ballwvol(id) = ballwvol(id) + coefval*vold
                   end if
                end if
   50           continue
            end do
         end if
      end do
c
c     now add contribution of two sphere
c
      do iedge = 1, nedge
         if (coef_edge(iedge) .ne. 0.0d0) then
            ia = edges(1,iedge)
            ib = edges(2,iedge)
            ra = radball(ia)
            rb = radball(ib)
            ra2 = ra * ra
            rb2 = rb * rb
            rab = edge_dist(iedge)
            rab2 = rab * rab
            call twosphere_dvol (ra,ra2,rb,rb2,rab,rab2,surfa,surfb,
     &                           vola,volb,dsurfa2,dsurfb2,dvola2,
     &                           dvolb2,option)
            ballwsurf(ia) = ballwsurf(ia) - coef_edge(iedge)*surfa
            ballwsurf(ib) = ballwsurf(ib) - coef_edge(iedge)*surfb
            ballwvol(ia) = ballwvol(ia) - coef_edge(iedge)*vola
            ballwvol(ib) = ballwvol(ib) - coef_edge(iedge)*volb
            if (option .eq. 1) then
               dsurf_dist(iedge) = dsurf_dist(iedge) - coef_edge(iedge)
     &            * (coef(ia-4)*dsurfa2+coef(ib-4)*dsurfb2)
               dvol_dist(iedge) = dvol_dist(iedge) - coef_edge(iedge)
     &            * (coef(ia-4)*dvola2 + coef(ib-4)*dvolb2)
            end if
         end if
      end do
c
c     now loop over vertices
c
      do i = 1, nvertex
         if (.not. btest(vinfo(i),0))  goto 60
c
c     if vertex is not in alpha complex, then nothing to do
c
         if (.not. btest(vinfo(i),7))  goto 60
c
c     vertex is in alpha complex if its weight is 0 (buried),
c     then nothing to do
c
         if (coef_vertex(i) .eq. 0.0d0)  goto 60
         ra = radball(i)
         surfa = 4.0d0 * pi * ra * ra
         vola = surfa * ra / 3.0d0
         ballwsurf(i) = ballwsurf(i) + coef_vertex(i)*surfa
         ballwvol(i) = ballwvol(i) + coef_vertex(i)*vola
   60    continue
      end do
c
c     compute total surface (weighted, and unweighted):
c
      do i = 1, nvertex
         if (btest(vinfo(i),0)) then
            surf = surf + ballwsurf(i)
            ballwsurf(i-4) = ballwsurf(i) * coef(i-4)
            wsurf = wsurf + ballwsurf(i-4)
            vol = vol + ballwvol(i)
            ballwvol(i-4) = ballwvol(i) * coef(i-4)
            wvol = wvol + ballwvol(i-4)
         end if
      end do
      if (option .ne. 1)  return
c
c     convert distance derivatives to coordinate derivatives
c
      do i = 1, nvertex
         do j = 1, 3
            dsurf_coord(j,i) = 0.0d0
            dvol_coord(j,i) = 0.0d0
         end do
      end do
      do iedge = 1,nedge
         ia = edges(1,iedge)
         ib = edges(2,iedge)
         do i = 1, 3
            u(i) = crdball(3*(ia-1)+i) - crdball(3*(ib-1)+i)
         end do
         rab = edge_dist(iedge)
         val = dsurf_dist(iedge) / rab
         val2 = dvol_dist(iedge) / rab
         do j = 1, 3
            dsurf_coord(j,ia-4) = dsurf_coord(j,ia-4) + u(j)*val
            dsurf_coord(j,ib-4) = dsurf_coord(j,ib-4) - u(j)*val
            dvol_coord(j,ia-4) = dvol_coord(j,ia-4) + u(j)*val2
            dvol_coord(j,ib-4) = dvol_coord(j,ib-4) - u(j)*val2
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (sparse_row)
      deallocate (edges)
      deallocate (coef_edge)
      deallocate (coef_vertex)
      deallocate (edge_surf)
      deallocate (edge_vol)
      deallocate (edge_dist)
      deallocate (dsurf_dist)
      deallocate (dvol_dist)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine alf_tetra  --  sphere radius orthogonal to four  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "alf_tetra" computes the radius of the sphere orthogonal
c     to the four spheres that define a tetrahedron
c
c     need to know how the radius compares to alpha, so the output
c     is the result of the comparison, not the radius itself
c
c     variables and parameters:
c
c     a,b,c,d       coordinates of four points defining tetrahedron
c     ra,rb,rc,rd   radii of the four points
c     alpha         value of alpha for the alpha shape (usually 0)
c     iflag         set to 1 if tetrahedron belongs to alpha complex,
c                     set to 0 otherwise
c
c
      subroutine alf_tetra (a,b,c,d,ra,rb,rc,rd,iflag,alpha)
      use shapes
      implicit none
      integer i,j,k
      integer iflag
      real*8 dabc,dabd,dacd,dbcd
      real*8 d1,d2,d3,d4,det
      real*8 num,den,alpha
      real*8 test,val
      real*8 ra,rb,rc,rd
      real*8 a(4),b(4),c(4),d(4)
      real*8 sab(3),sac(3),sad(3)
      real*8 sbc(3),sbd(3),scd(3)
      real*8 sa(3),sb(3),sc(3),sd(3)
      real*8 sam1(3),sbm1(3)
      real*8 scm1(3),sdm1(3)
      real*8 deter(3)
      save
c
c
      iflag = 0
      val = a(4)+b(4) - 2.0d0*(a(1)*b(1)+a(2)*b(2)+a(3)*b(3)+ra*rb)
      if (val .gt. 0)  return
      val = a(4)+c(4) - 2.0d0*(a(1)*c(1)+a(2)*c(2)+a(3)*c(3)+ra*rc)
      if (val .gt. 0)  return
      val = a(4)+d(4) - 2.0d0*(a(1)*d(1)+a(2)*d(2)+a(3)*d(3)+ra*rd)
      if (val .gt. 0)  return
      val = b(4)+c(4) - 2.0d0*(b(1)*c(1)+b(2)*c(2)+b(3)*c(3)+rb*rc)
      if (val .gt. 0)  return
      val = b(4)+d(4) - 2.0d0*(b(1)*d(1)+b(2)*d(2)+b(3)*d(3)+rb*rd)
      if (val .gt. 0)  return
      val = c(4)+d(4) - 2.0d0*(c(1)*d(1)+c(2)*d(2)+c(3)*d(3)+rc*rd)
      if (val .gt. 0)  return
c
c     compute all minors of the form:
c
c     Smn(i+j-2) = M(m,n,i,j) = Det | m(i) m(j) |
c                                   | n(i) n(j) |
c
c     for all i in [1,2] and all j in [i+1,3]
c
      do i = 1, 2
         do j = i+1, 3
            k = i + j - 2
            sab(k) = a(i)*b(j) - a(j)*b(i)
            sac(k) = a(i)*c(j) - a(j)*c(i)
            sad(k) = a(i)*d(j) - a(j)*d(i)
            sbc(k) = b(i)*c(j) - b(j)*c(i)
            sbd(k) = b(i)*d(j) - b(j)*d(i)
            scd(k) = c(i)*d(j) - c(j)*d(i)
         end do
      end do
c
c     compute all Minors of the form:
c
c     sq(i+j-2) = M(m,n,p,i,j,0) = Det | m(i) m(j) 1 |
c                                      | n(i) n(j) 1 |
c                                      | p(i) p(j) 1 |
c
c     and all Minors of the form:
c
c     det(i+j-2) = M(m,n,p,q,i,j,4,0) = Det | m(i) m(j) m(4) 1 |
c                                           | n(i) n(j) n(4) 1 |
c                                           | p(i) p(j) p(4) 1 |
c                                           | q(i) q(j) q(4) 1 |
c
c     m,n,p,q are the four vertices of the tetrahedron, i and j
c     correspond to two of the coordinates of the vertices, and
c     m(4) refers to the "weight" of vertices m
c
      do i = 1, 3
         sa(i) = scd(i) - sbd(i) + sbc(i)
         sb(i) = scd(i) - sad(i) + sac(i)
         sc(i) = sbd(i) - sad(i) + sab(i)
         sd(i) = sbc(i) - sac(i) + sab(i)
         sam1(i) = -sa(i)
         sbm1(i) = -sb(i)
         scm1(i) = -sc(i)
         sdm1(i) = -sd(i)
      end do
      do i = 1, 3
         deter(i) = a(4)*sa(i) - b(4)*sb(i) + c(4)*sc(i) - d(4)*sd(i)
      end do
c
c     find the determinant needed to compute the radius of the
c     sphere orthogonal to the four balls defining the tetrahedron
c
c     d1 = Minor(a,b,c,d,4,2,3,0)
c     d2 = Minor(a,b,c,d,1,3,4,0)
c     d3 = Minor(a,b,c,d,1,2,4,0)
c     d4 = Minor(a,b,c,d,1,2,3,0)
c
      d1 = deter(3)
      d2 = deter(2)
      d3 = deter(1)
      d4 = a(1)*sa(3) - b(1)*sb(3) + c(1)*sc(3) - d(1)*sd(3)
c
c     compute all minors of the form:
c
c     Dmnp = Minor(m,n,p,1,2,3) = Det | m(1) m(2) m(3) |
c                                     | n(1) n(2) n(3) |
c                                     | p(1) p(2) p(3) |
c
      dabc = a(1)*sbc(3) - b(1)*sac(3) + c(1)*sab(3)
      dabd = a(1)*sbd(3) - b(1)*sad(3) + d(1)*sab(3)
      dacd = a(1)*scd(3) - c(1)*sad(3) + d(1)*sac(3)
      dbcd = b(1)*scd(3) - c(1)*sbd(3) + d(1)*sbc(3)
c
c     also need to determine:
c
c     det = Det | m(1) m(2) m(3) m(4) |
c               | n(1) n(2) n(3) n(4) |
c               | p(1) p(2) p(3) p(4) |
c               | q(1) q(2) q(3) q(4) |
c
      det = -a(4)*dbcd + b(4)*dacd - c(4)*dabd + d(4)*dabc
c
c     get radius of the circumsphere of the weighted tetrahedron
c
      num = d1*d1 + d2*d2 + d3*d3 + 4*d4*det
      den = 4.0d0 * d4 * d4
c
c     if radius is too close to the value of alpha
c
      test = alpha*den - num
c
c     spectrum for a tetrahedron is [R_t Infinity]. If alpha is in
c     that interval, the tetrahedron is part of the alpha shape,
c     otherwise it is discarded
c
c     if tetrahedron is part of the alpha shape, then its triangles,
c     the edges and the vertices are also part of the alpha complex
c
      iflag = 0
      if (test .gt. 0)  iflag = 1
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine alf_trig  --  checks triangle in alpha complex  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "alf_trig" checks if whether a triangle belongs to the alpha
c     complex; computes the radius of the sphere orthogonal to the
c     three balls defining the triangle; if this radius is smaller
c     than alpha the triangle belongs to the alpha complex
c
c     also check if the triangle is "attached", i.e., if the fourth
c     vertex of any of the tetrahedra attached to the triangle is
c     "hidden" by the triangle (there are up to two such vertices,
c     D and E, depending if the triangle is on convex hull or not)
c
c     variables and parameters:
c
c     a,b,c,d,e         coordinates of the points A, B, C, D and E
c                         defining the triangle and the two vertices
c                         "attached" to it (from the two tetrahedra
c                         sharing A, B and C)
c     ra,rb,rc,rd,re    radii of the five points
c     ie                flag: 0 is e does not exist, not 0 otherwise
c     alpha             value of alpha for the alpha shape
c                         (usually 0 for measures of molecule)
c     irad              integer flag set to 1 if radius(trig) < alpha
c     iattach           integer flag set to 1 if triangle is attached
c
c
      subroutine alf_trig (a,b,c,d,e,ra,rb,rc,rd,re,
     &                     ie,irad,iattach,alpha)
      use shapes
      implicit none
      integer i,j,ie
      integer irad,iattach
      real*8 ra,rb,rc,rd,re,val
      real*8 alpha,dabc
      real*8 a(4),b(4),c(4),d(4),e(4)
      real*8 sab(3,4),sac(3,4),sbc(3,4)
      real*8 s(3,4),t(2,3)
      logical attach,testr
      save
c
c
      irad = 0
      val = a(4) + b(4) - 2.0d0*(a(1)*b(1)+a(2)*b(2)+a(3)*b(3)+ra*rb)
      if (val .gt. 0)  return
      val = a(4) + c(4) - 2.0d0*(a(1)*c(1)+a(2)*c(2)+a(3)*c(3)+ra*rc)
      if (val .gt. 0)  return
      val = b(4) + c(4) - 2.0d0*(b(1)*c(1)+b(2)*c(2)+b(3)*c(3)+rb*rc)
      if (val .gt. 0)  return
      iattach = 0
      irad = 0
c
c     compute all Minors of the form
c
c     smn(i,j) = M(m,n,i,j) = Det | m(i)  m(j) |
c                                 | n(i)  n(j) |
c
c     m,n are two vertices of the triangle, i and j correspond
c     to two of the coordinates of the vertices
c
c     for all i in [1,3] and all j in [i+1,4]
c
      do i = 1, 3
         do j = i+1, 4
            sab(i,j) = a(i)*b(j) - a(j)*b(i)
            sac(i,j) = a(i)*c(j) - a(j)*c(i)
            sbc(i,j) = b(i)*c(j) - b(j)*c(i)
         end do
      end do
c
c     next compute all Minors of the form
c 
c     s(i,j) = M(a,b,c,i,j,0) = Det | a(i) a(j) 1 |
c                                   | b(i) b(j) 1 |
c                                   | c(i) c(j) 1 |
c
c     A, B and C are the vertices of the triangle, i and j
c     correspond to two of the coordinates of the vertices
c
c     for all i in [1,3] and all j in [i+1,4]
c
      do i = 1, 3
         do j = i+1, 4
            s(i,j) = sbc(i,j) - sac(i,j) + sab(i,j)
         end do
      end do
c
c     now compute all Minors of the form
c
c     t(i,j) = M(a,b,c,i,j,4) = Det | a(i) a(j) a(4) |
c                                   | b(i) b(j) b(4) |
c                                   | c(i) c(j) c(4) |
c
c     for all i in [1,2] and all j in [i+1,3]
c
      do i = 1, 2
         do j = i+1, 3
            t(i,j) = a(4)*sbc(i,j) - b(4)*sac(i,j) + c(4)*sab(i,j)
         end do
      end do
c
c     finally, find dabc = M(a,b,c,1,2,3) = Det | a(1) a(2) a(3) |
c                                               | b(2) b(2) b(3) |
c                                               | c(3) c(2) c(3) |
c
      dabc = a(1)*sbc(2,3) - b(1)*sac(2,3) + c(1)*sab(2,3)
c
c     first check if A, B and C ate attached to D
c
      call triangle_attach (a,b,c,d,ra,rb,rc,rd,s,t,dabc,attach)
c
c     if attached, stop here as the triangle will not be part
c     of the alpha complex
c
      if (attach) then
         iattach = 1
         return
      end if
c
c     if E exists, check if A,B,C attached to E
c
      if (ie .ne. 0) then
         call triangle_attach (a,b,c,e,ra,rb,rc,re,s,t,dabc,attach)
c
c     if attached, stop here as the triangle will not be part
c     of the alpha complex
c
         if (attach) then
            iattach = 1
            return
         end if
      end if
c
c     now check if alpha is bigger than the radius of the sphere
c     orthogonal to the three balls at A, B and C
c
      call triangle_radius (a,b,c,ra,rb,rc,s,t,dabc,testr,alpha)
      if (testr)  irad = 1
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine alf_edge  --  checks edge in to alpha complex  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "alf_edge" checks if an edge belongs to the alpha complex;
c     computes the radius of the sphere orthogonal to the two
c     balls defining the edge, if this radius is smaller than
c     alpha then the edge belongs to the alpha complex
c
c     also checked if the edge is "attached", i.e., if the third
c     vertex of any of the triangles attached to the edge is
c     hidden by the edge
c
c     variables and parameters:
c
c     a,b         coordinates of the points defining the edge
c     ra,rb       radii of the two points
c     ncheck      number of triangles in the star of the edge
c     chklist   list of vertices to check
c     alpha       value of alpha for the alpha shape
c                   (usually 0 for measures of molecule)
c     irad        integer flag set to 1 if radius(edge) < alpha
c     iattach     integer flag set to 1 if edge is attached
c
c
      subroutine alf_edge (a,b,ra,rb,cg,ncheck,chklist,
     &                        irad,iattach,alpha)
      use shapes
      implicit none
      integer i,j,k,ic
      integer ncheck
      integer irad
      integer iattach
      integer chklist(*)
      real*8 alpha,val
      real*8 ra,rb,rc
      real*8 dab(4),sab(3),tab(3)
      real*8 a(4),b(4),c(4),cg(3)
      logical attach,rad
      save
c
c
      iattach = 1
      irad = 0
      val = a(4) + b(4) - 2.0d0*(a(1)*b(1)+a(2)*b(2)+a(3)*b(3)+ra*rb)
      if (val .gt. 0)  return
c
c     compute all Minors of the form
c
c     dab(i) = M(a,b,i,0) = Det | a(i) 1 |
c                               | b(i) 1 |
c
c     for all i in [1,4]
c
      do i = 1, 4
         dab(i) = a(i) - b(i)
      end do
c
c     compute all Minors of the form
c
c     sab(i,j) = M(a,b,i,j) = Det | a(i)  a(j) |
c                                 | b(i)  b(j) |
c
      do i = 1, 2
         do j = i+1, 3
            k = i + j - 2
            sab(k) = a(i)*b(j) - b(i)*a(j)
         end do
      end do
c
c     compute all Minors of the form
c
c     tab(i) = M(a,b,i,4) = Det | a(i)  a(4) |
c                               | b(i)  b(4) |
c
      do i = 1, 3
         tab(i) = a(i)*b(4) - b(i)*a(4)
      end do
c
c     first check the attachment
c
      do i = 1, ncheck
         ic = chklist(i)
         do j = 1, 3
            c(j) = crdball(3*(ic-1)+j) - cg(j)
         end do
         rc = radball(ic)
         c(4) = c(1)*c(1) + c(2)*c(2) + c(3)*c(3) - rc*rc
         call edge_attach (a,b,c,ra,rb,rc,dab,sab,tab,attach)
         if (attach)  return
      end do
      iattach = 0
c
c     edge is not attached, check radius
c
      call edge_radius (a,b,ra,rb,dab,sab,tab,rad,alpha)
      if (rad)  irad = 1
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine edge_radius  --  radius to edge circumsphere  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "edge_radius" computes the radius of the smallest circumsphere
c     to an edge, and compares it to alpha
c
c     variables and parameters:
c
c     a,b      coordinate of the two vertices defining the edge
c     dab      minor(a,b,i,0) for all i=1,2,3,4
c     sab      minor(a,b,i,j) for i = 1,2 and j =i+1,3
c     tab      minor(a,b,i,4) for i = 1,2,3
c     alpha    value of alpha considered
c     testr    flag that defines if radius smaller than alpha
c
c
      subroutine edge_radius (a,b,ra,rb,dab,sab,tab,testr,alpha)
      use iounit
      use shapes
      implicit none
      integer i
      real*8 d0,d1,d2,d3,d4
      real*8 alpha
      real*8 num,den,rho2
      real*8 ra,rb
      real*8 r_11,r_22,r_33
      real*8 r_14,r_313,r_212,diff
      real*8 a(4),b(4)
      real*8 sab(3),dab(4),tab(3)
      real*8 res(0:3,1:4)
      logical testr
      save
c
c
c     formula have been derived by projection on 4D space, which
c     requires caution when some coordinates are equal
c
      testr = .false.
      res(0,4) = dab(4)
      if (a(1) .ne. b(1)) then
         do i = 1, 3
            res(0,i) = dab(i)
            res(i,4) = tab(i)
         end do
         res(1,2) = sab(1)
         res(1,3) = sab(2)
         res(2,3) = sab(3)
      else if (a(2) .ne. b(2)) then
         res(0,1) = dab(2)
         res(0,2) = dab(3)
         res(0,3) = dab(1)
         res(1,2) = sab(3)
         res(1,3) = -sab(1)
         res(2,3) = -sab(2)
         res(1,4) = tab(2)
         res(2,4) = tab(3)
         res(3,4) = tab(1)
      else if (a(3) .ne. b(3)) then
         res(0,1) = dab(3)
         res(0,2) = dab(1)
         res(0,3) = dab(2)
         res(1,2) = -sab(2)
         res(1,3) = -sab(3)
         res(2,3) = sab(1)
         res(1,4) = tab(3)
         res(2,4) = tab(1)
         res(3,4) = tab(2)
      else
         write (iout,10)
   10    format (/,' EDGE_RADIUS  --  A Fatal Error has Occurred')
         call fatal
      end if
      r_11 = res(0,1) * res(0,1)
      r_22 = res(0,2) * res(0,2)
      r_33 = res(0,3) * res(0,3)
      r_14 = res(0,1) * res(0,4)
      r_313 = res(0,3) * res(1,3)
      r_212 = res(0,2) * res(1,2)
      diff = res(0,3)*res(1,2) - res(0,2)*res(1,3)
c
c     first compute the radius of circumsphere
c
      d0 = -2.0d0 * res(0,1) * (r_11+r_22+r_33)
      d1 = res(0,1) * (2.0d0*(r_313+r_212)-r_14)
      d2 = -2.0d0*res(1,2)*(r_11+r_33) - res(0,2)*(r_14-2.0d0*r_313)
      d3 = -2.0d0*res(1,3)*(r_11+r_22) - res(0,3)*(r_14-2*r_212)
      d4 = 2.0d0 * res(0,1) * (res(0,1)*res(1,4) + res(0,2)*res(2,4)
     &        + res(0,3)*res(3,4)) + 4.0d0*(res(2,3)*diff
     &        - res(0,1)*(res(1,2)*res(1,2) + res(1,3)*res(1,3)))
      num = d1*d1 + d2*d2 + d3*d3 - d0*d4
      den = d0 * d0
c
c     for efficiency, assume this routine is only used to compute
c     the dual complex (i.e., alpha=0) and thus do not consider
c     the denominator as it is always positive
c
c     rho2 = num / den
      rho2 = num
      if (alpha .gt. rho2)  testr = .true.
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine edge_attach  --  edge attached to tetrahedron  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "edge_attach" checks if edge AB of a tetrahedron is "attached"
c     to a given vertex C
c
c     variables and parameters:
c
c     a,b,c       coordinates of the three points
c     ra,rb,rc    radii of the three pointd
c     dab         minor(a,b,i,0) for all i=1,2,3,4
c     sab         minor(a,b,i,j) for i = 1,2 and j =i+1,3
c     tab         minor(a,b,i,4) for all i=1,2,3
c     testa       logical flag marks if edge is attached or not
c
c
      subroutine edge_attach (a,b,c,ra,rb,rc,dab,sab,tab,testa)
      use iounit
      use shapes
      implicit none
      integer i,j,k
      real*8 dtest
      real*8 r_11,r_22,r_33
      real*8 diff,d0,d5
      real*8 ra,rb,rc
      real*8 sab(3),dab(4),tab(3)
      real*8 sc(3),tc(3)
      real*8 a(4),b(4),c(4)
      real*8 res(0:3,1:3)
      real*8 res2_c(3,4)
      logical testa
      save
c
c
c     need to compute:
c     sc as minor(a,b,c,i,j,0) for i = 1,2 and j = i+1,3
c     tc as minor(a,b,c,i,4,0) for i = 1,2,3
c
      testa = .false.
      do i = 1, 2
         do j = i+1, 3
            k = i + j - 2
            sc(k) = c(i)*dab(j) - c(j)*dab(i) + sab(k)
         end do
      end do
      do i = 1, 3
         tc(i) = c(i)*dab(4) - c(4)*dab(i) + tab(i)
      end do
c
c     formula have been derived by projection on 4D space, which
c     requires caution when some coordinates are equal
c
      if (a(1) .ne. b(1)) then
         do i = 1, 3
            res(0,i) = dab(i)
            res2_c(i,4) = tc(i)
         end do
         res(1,2) = sab(1)
         res(1,3) = sab(2)
         res(2,3) = sab(3)
         res2_c(1,2) = sc(1)
         res2_c(1,3) = sc(2)
         res2_c(2,3) = sc(3)
      else if (a(2) .ne. b(2)) then
         res(0,1) = dab(2)
         res(0,2) = dab(3)
         res(0,3) = dab(1)
         res(1,2) = sab(3)
         res(1,3) = -sab(1)
         res(2,3) = -sab(2)
         res2_c(1,2) = sc(3)
         res2_c(1,3) = -sc(1)
         res2_c(2,3) = -sc(2)
         res2_c(1,4) = tc(2)
         res2_c(2,4) = tc(3)
         res2_c(3,4) = tc(1)
      else if (a(3) .ne. b(3)) then
         res(0,1) = dab(3)
         res(0,2) = dab(1)
         res(0,3) = dab(2)
         res(1,2) = -sab(2)
         res(1,3) = -sab(3)
         res(2,3) = sab(1)
         res2_c(1,2) = -sc(2)
         res2_c(1,3) = -sc(3)
         res2_c(2,3) = sc(1)
         res2_c(1,4) = tc(3)
         res2_c(2,4) = tc(1)
         res2_c(3,4) = tc(2)
      else
         write (iout,10)
   10    format (/,' EDGE_ATTACH  --  A Fatal Error has Occurred')
         call fatal
      end if
      r_11 = res(0,1) * res(0,1)
      r_22 = res(0,2) * res(0,2)
      r_33 = res(0,3) * res(0,3)
      diff = res(0,3)*res(1,2) - res(0,2)*res(1,3)
c
c     check the attachment with vertex C
c
      d0 = -2.0d0 * res(0,1) * (r_11+r_22+r_33)
      d5 = res(0,1) * (res(0,1)*res2_c(1,4) + res(0,2)*res2_c(2,4)
     &        + res(0,3)*res2_c(3,4) - 2.0d0*(res(1,3)*res2_c(1,3)
     &        + res(1,2)*res2_c(1,2))) + 2.0d0*res2_c(2,3)*diff
      dtest = d0 * d5
      if (dtest .lt. 0)  testa = .true.
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine triangle_attach  --  test point in circumsphere  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "triangle_attach" tests whether a point D is inside the
c     circumsphere defined by three other points A, B and C
c
c     for the three points A,B,C that form the triangles, the code
c     needs as input the following determinants:
c
c     s(i,j) = Minor(a,b,c,i,j,0) = det | a(i) a(j) 1 |
c                                       | b(i) b(j) 1 |
c                                       | c(i) c(j) 1 |
c     for all i in [1,3], j in [i+1,4]
c
c     t(i,j) = Minor(a,b,c,i,j,4) = det | a(i) a(j) a(4) |
c                                       | b(i) b(j) b(4) |
c                                       | c(i) c(j) c(4) |
c
c     for all i in [1,2] and all j in [i+1,3]
c
c     dabc = det | a(1) a(2) a(3) |
c                | b(1) b(2) b(3) |
c                | c(1) c(2) c(3) |
c
c     and the coordinates of the fourth vertex d
c
c     upon output "testa" is set to 1 if the fourth point d is
c     inside the circumsphere of {a,b,c}
c
c
      subroutine triangle_attach (a,b,c,d,ra,rb,rc,rd,s,t,dabc,testa)
      use shapes
      implicit none
      real*8 test
      real*8 dabc,deter
      real*8 det1,det2,det3
      real*8 ra,rb,rc,rd
      real*8 a(4),b(4)
      real*8 c(4),d(4)
      real*8 s(3,4),t(2,3)
      logical testa
      save
c
c
      testa = .false.
      det1 = -d(2)*s(3,4) + d(3)*s(2,4) - d(4)*s(2,3) + t(2,3)
      det2 = -d(1)*s(3,4) + d(3)*s(1,4) - d(4)*s(1,3) + t(1,3)
      det3 = -d(1)*s(2,4) + d(2)*s(1,4) - d(4)*s(1,2) + t(1,2)
      deter = -d(1)*s(2,3) + d(2)*s(1,3) - d(3)*s(1,2) + dabc
c
c     check if the face is attached to the fourth vertex of
c     the parent tetrahedron
c
      test = det1*s(2,3) + det2*s(1,3) + det3*s(1,2)
     &          - 2.0d0*deter*dabc 
      if (test .gt. 0)  testa = .true.
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine triangle_radius  --  radius containing triangle  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "triangle_radius" finds the radius of the smallest circumsphere
c     to a triangle
c
c     for the three points A,B,C that form the triangles, the code
c     needs as input the following determinants:
c
c     s(i,j) = Minor(a,b,c,i,j,0) = det | a(i) a(j) 1 |
c                                       | b(i) b(j) 1 |
c                                       | c(i) c(j) 1 |
c
c     for i in [1,3] and j in [i+1,4]
c
c     t(i,j) = Minor(a,b,c,i,j,4) = det | a(i) a(j) a(4) |
c                                       | b(i) b(j) b(4) |
c                                       | c(i) c(j) c(4) |
c
c     dabc = Minor(a,b,c,1,2,3)
c
c     upon output "testr" is set to 1 if alpha is larger than rho,
c     the radius of the circumsphere of the triangle
c
c
      subroutine triangle_radius (a,b,c,ra,rb,rc,s,t,
     &                            dabc,testr,alpha)
      use shapes
      implicit none
      real*8 dabc
      real*8 d0,d1,d2,d3,d4
      real*8 alpha
      real*8 sums2,num
      real*8 ra,rb,rc
      real*8 a(4),b(4),c(4)
      real*8 s(3,4),t(2,3)
      logical testr
      save
c
c
      testr = .false.
      sums2 = s(1,2)*s(1,2) + s(1,3)*s(1,3) + s(2,3)*s(2,3)
      d0 = sums2
      d1 = s(1,3)*s(3,4) + s(1,2)*s(2,4) - 2.0d0*dabc*s(2,3)
      d2 = s(1,2)*s(1,4) - s(2,3)*s(3,4) - 2.0d0*dabc*s(1,3)
      d3 = s(2,3)*s(2,4) + s(1,3)*s(1,4) + 2.0d0*dabc*s(1,2)
      d4 = s(1,2)*t(1,2) + s(1,3)*t(1,3) + s(2,3)*t(2,3)
     &        - 2.0d0*dabc*dabc
      num = 4.0d0*(d1*d1+d2*d2+d3*d3) + 16.0d0*d0*d4
      if (alpha .gt. num)  testr = .true.
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine vertex_attach  --  vertex-vertex attachment  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "vertex_attach" tests for a vertex is attached to another
c     vertex, the computation is done in both directions
c
c     let S be a simplex, and y_S the center of the ball orthogonal
c     to all balls in S; point p is attached to S if and only if
c     pi(y_S, p) < 0, where pi is the power distance between the
c     two weighted points y_S and p
c
c     let S = {a}, with a weight of ra**2, then y_S is the ball
c     centered at a, but with weight -ra**2, the power distance
c     between y_S and a point b is:
c
c     pi(y_S, b) = dist(a,b)**2 + ra**2 - rb**2
c
c
      subroutine vertex_attach (a,b,ra,rb,testa,testb)
      use shapes
      implicit none
      integer i
      real*8 ra,rb,ra2,rb2
      real*8 dist2
      real*8 test1,test2
      real*8 dab(3)
      real*8 a(4),b(4)
      logical testa,testb
      save
c
c
      testa = .false.
      testb = .false.
      do i = 1, 3
         dab(i) = a(i) - b(i)
      end do
      ra2 = ra * ra
      rb2 = rb * rb
      dist2 = dab(1)*dab(1) + dab(2)*dab(2) + dab(3)*dab(3)
      test1 = dist2 + ra2 - rb2
      test2 = dist2 - ra2 + rb2
      if (test1 .lt. 0)  testa = .true.
      if (test2 .lt. 0)  testb = .true.
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine locate_jw  --  find tetrahedron with new point  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "locate_jw" finds the tetrahedron containing a new point to be
c     added in the triangulation
c
c     variables and parameters:
c
c     ival         index of the points to be located
c     tetra_loc    tetrahedron containing the point
c     iredund      flag set to 0 if not redundant, 1 otherwise
c
c     the point location scheme uses a "jump-and-walk" technique;
c     first, N active tetrahedra are chosen at random, the distances
c     between these tetrahedra and the point to be added are computed,
c     and the tetrahedron closest to the point is chosen as a starting
c     point, then walk from that tetrahedron to the point, until a
c     tetrahedron containing the point is found; also checks if the
c     point is redundant in the current tetrahedron, ending the search
c
c
      subroutine locate_jw (iseed,ival,tetra_loc,iredund)
      use shapes
      implicit none
      integer i,ival,itetra
      integer a,b,c,d
      integer idx,iorient,iseed
      integer tetra_loc,iredund
      logical test_in,test_red
      save
c
c
c     start at the root of the history dag with tetra(1)
c
      iredund = 0
      if (ntetra .eq. 1) then
         tetra_loc = 1
         return
      end if
      if (tetra_loc .le. 0) then
         do i = ntetra, 1, -1
            if (btest(tinfo(i),1)) then
               itetra = i
               goto 10
            end if
         end do
   10    continue
      else
         itetra = tetra_loc
      end if
   20 continue
      a = tetra(1,itetra)
      b = tetra(2,itetra)
      c = tetra(3,itetra)
      d = tetra(4,itetra)
      iorient = -1
      if (btest(tinfo(itetra),0))  iorient = 1
      call inside_tetra_jw (ival,a,b,c,d,iorient,test_in,test_red,idx)
      if (test_in)  goto 30
      itetra = tneighbor(idx,itetra)
      goto 20
   30 continue
      tetra_loc = itetra
c
c     tetrahedron is found, so check if point is redundant
c
      if (test_red)  iredund = 1
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine inside_tetra_jw  --  tests point in tetrahedron  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "inside_tetra_jw" tests if a point P is inside the tetrahedron
c     defined by four points ABCD with orientation "iorient", if P
c     is inside the tetrahedron, then also checks if it is redundant
c
c     variables and parameters:
c
c     p           index of the point to be checked
c     a,b,c,d     four vertices of the tetrahedron
c     iorient     orientation of the tetrahedron
c     inside      logical flag to mark P inside the ABCD tetrahedron
c     redund      logical flag to mark whether point P is redundant
c     ifail       index of the face that fails the orientation test
c                   in case where P is not inside the tetrahedron
c
c
      subroutine inside_tetra_jw (p,a,b,c,d,iorient,inside,
     &                                redund,ifail)
      use shapes
      implicit none
      integer i,j,k,l,m
      integer p,a,b,c,d
      integer ia,ib,ic,id,ie,idx
      integer ic1,ic5,ic1_k,ic1_l
      integer sign,sign5
      integer sign_k,sign_l
      integer nswap,iswap,ninf
      integer iorient,ifail,val
      integer list(4)
      integer sign4_3(4)
      integer infpoint(4)
      integer inf4_1(4),sign4_1(4)
      integer inf4_2(4,4),sign4_2(4,4)
      integer inf5_2(4,4),sign5_2(4,4)
      integer inf5_3(4),sign5_3(4)
      integer order1(3,4),order2(2,6)
      integer order3(2,6)
      real*8 sij_1,sij_2,sij_3
      real*8 skl_1,skl_2,skl_3
      real*8 det_pijk,det_pjil
      real*8 det_pkjl,det_pikl
      real*8 det_pijkl
      real*8 detij(3)
      real*8 coordp(3)
      real*8 i_p(4),j_p(4)
      real*8 k_p(4),l_p(4)
      logical test_pijk,test_pjil
      logical test_pkjl,test_pikl
      logical inside,redund
      logical doweight
      data inf4_1  / 2, 2, 1, 1 /
      data sign4_1  / -1, 1, 1, -1 /
      data inf4_2  / 0, 2, 3, 3, 2, 0, 3, 3, 3, 3, 0, 1, 3, 3, 1, 0 /
      data sign4_2  / 0, 1, -1, 1, -1, 0, 1, -1,
     &                1, -1, 0, 1, -1, 1, -1, 0 /
      data sign4_3  / -1, 1, -1, 1 /
      data inf5_2  / 0, 2, 1, 1, 2, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 0 /
      data sign5_2  / 0, -1, -1, 1, 1, 0, -1, 1,
     &                1, 1, 0, 1, -1, -1, -1, 0 /
      data inf5_3  / 1, 1, 3, 3/
      data sign5_3  / 1, 1, -1, 1 /
      data order1  / 3, 2, 4, 1, 3, 4, 2, 1, 4, 1, 2, 3 /
      data order2  / 3, 4, 4, 2, 2, 3, 1, 4, 3, 1, 1, 2 /
      data order3  / 1, 2, 1, 3, 1, 4, 2, 3, 2, 4, 3, 4 /
      save
c
c
c     if IJKL is the tetrahedron in positive orientation, then test
c     PIJK, PJIL, PKJL and PIKL, if all four are positive, than P is
c     inside the tetrahedron, all four tests rely on the sign of the
c     corresponding 4x4 determinant. Interestingly, these four
c     determinants share some common lines, which can be used to
c     speed up the computation
c
c     consider:  det(p,i,j,k) = | p(1) p(2) p(3) 1 |
c                               | i(1) i(2) i(3) 1 |
c                               | j(1) j(2) j(3) 1 |
c                               | k(1) k(2) k(3) 1 |
c
c     note P appears in each determinant, so the corresponding line
c     can be substraced from all other lines; using the example
c     above gives:
c
c     det(i,j,k,l) = - | ip(1) ip(2) ip(3) |
c                      | jp(1) jp(2) jp(3) |
c                      | kp(1) kp(2) kp(3) |
c
c     where xp(m) = x(m)-p(m) for x = i,j,k and m = 1,2,3
c
c     notice the first two lines of det(p,i,j,k) and det(p,i,j,l)
c     are the same
c
c     let us define:
c
c     Sij_3=|ip(1) ip(2)|  Sij_2=|ip(1) ip(3)|  Sij_1=|ip(2) ip(3)|
c           |jp(1) jp(2)|        |jp(1) jp(3)|        |jp(2) jp(3)|
c
c     then det(p,i,j,k) = -kp(1)*Sij_1 + kp(2)*Sij_2 - kp(3)*Sij_3,
c     and det(p,j,i,l) = lp(1)*Sij_1 - lp(2)*Sij_2 + lp(3)*Sij_3
c
c     similarly, define: 
c
c     Skl_3=|kp(1) kp(2)|  Skl_2=|kp(1) kp(3)|  Skl_1=|kp(2) kp(3)|
c           |lp(1) lp(2)|        |lp(1) lp(3)|        |lp(2) lp(3)|
c
c     then det(p,k,j,l) = jp(1)*Skl_1 - jp(2)*Skl_2 + jp(3)*Skl_3,
c     and det(p,i,k,l) = -ip(1)*Skl_1 + ip(2)*Skl_2 - ip(3)*Skl_3
c
c     furthermore:
c
c     det(p,i,j,k,l) = -ip(4)*det(p,k,j,l) - jp(4)*det(p,i,k,l)
c                         - kp(4)*det(p,j,i,l) - lp(4)*det(p,i,j,k)
c
c     the equations above hold for the general case, but special
c     care is required to take in account infinite points
c
      doweight = .true.
      inside = .false.
      redund = .false.
      list(1) = a
      list(2) = b
      list(3) = c
      list(4) = d
      infpoint(1) = 0
      infpoint(2) = 0
      infpoint(3) = 0
      infpoint(4) = 0
      if (a .le. 4)  infpoint(1) = 1
      if (b .le. 4)  infpoint(2) = 1
      if (c .le. 4)  infpoint(3) = 1
      if (d .le. 4)  infpoint(4) = 1
      ninf = infpoint(1) + infpoint(2) + infpoint(3) + infpoint(4)
c
c     the general case, with no infinite point
c
      do m = 1, 3
         coordp(m) = crdball(3*p-3+m)
      end do
c
c     set coordinates using i=a, j=b, k=c and l=d for convenience
c
      if (ninf .eq. 0) then
         do m = 1, 3
            i_p(m) = crdball(3*a-3+m) - coordp(m)
            j_p(m) = crdball(3*b-3+m) - coordp(m)
            k_p(m) = crdball(3*c-3+m) - coordp(m)
            l_p(m) = crdball(3*d-3+m) - coordp(m)
         end do
c
c     compute the 2x2 determinants for Sij and Skl
c
         sij_1 = i_p(2)*j_p(3) - i_p(3)*j_p(2)
         sij_2 = i_p(1)*j_p(3) - i_p(3)*j_p(1)
         sij_3 = i_p(1)*j_p(2) - i_p(2)*j_p(1)
         skl_1 = k_p(2)*l_p(3) - k_p(3)*l_p(2)
         skl_2 = k_p(1)*l_p(3) - k_p(3)*l_p(1)
         skl_3 = k_p(1)*l_p(2) - k_p(2)*l_p(1)
c
c     tests for all determinants, start with inside set to false
c
         inside = .false.
         det_pijk = -k_p(1)*sij_1 + k_p(2)*sij_2 - k_p(3)*sij_3
         det_pijk = det_pijk * dble(iorient)
         test_pijk = (abs(det_pijk) .gt. epsln4)
         if (test_pijk .and. det_pijk.gt.0.0d0) then
            ifail = 4
            return
         end if
         det_pjil = l_p(1)*sij_1 - l_p(2)*sij_2 + l_p(3)*sij_3
         det_pjil = det_pjil * dble(iorient)
         test_pjil = (abs(det_pjil) .gt. epsln4)
         if (test_pjil .and. det_pjil.gt.0.0d0) then
            ifail = 3
            return
         end if
         det_pkjl = j_p(1)*skl_1 - j_p(2)*skl_2 + j_p(3)*skl_3
         det_pkjl = det_pkjl * dble(iorient)
         test_pkjl = (abs(det_pkjl) .gt. epsln4)
         if (test_pkjl .and. det_pkjl.gt.0.0d0) then
            ifail = 1
            return
         end if
         det_pikl = -i_p(1)*skl_1 + i_p(2)*skl_2 - i_p(3)*skl_3
         det_pikl = det_pikl * dble(iorient)
         test_pikl = (abs(det_pikl) .gt. epsln4)
         if (test_pikl .and. det_pikl.gt.0.0d0) then
            ifail = 2
            return
         end if
c
c     either all four determinants are positive, or one of the
c     determinants is imprecise in which case pecial care is
c     needed and the indices will be ranked
c
         if (.not. test_pijk) then
            call valsort4 (p,a,b,c,ia,ib,ic,id,nswap)
            call minor4 (crdball,ia,ib,ic,id,val)
            val = val * nswap * iorient
            if (val .eq. 1) then
               ifail = 4
               return
            end if
         end if
         if (.not. test_pjil) then
            call valsort4 (p,b,a,d,ia,ib,ic,id,nswap)
            call minor4 (crdball,ia,ib,ic,id,val)
            val = val * nswap * iorient
            if (val .eq. 1) then
               ifail = 3
               return
            end if
         end if
         if (.not. test_pkjl) then
            call valsort4 (p,c,b,d,ia,ib,ic,id,nswap)
            call minor4 (crdball,ia,ib,ic,id,val)
            val = val * nswap * iorient
            if (val .eq. 1) then
               ifail = 1
               return
            end if
         end if
         if (.not. test_pikl) then
            call valsort4 (p,a,c,d,ia,ib,ic,id,nswap)
            call minor4 (crdball,ia,ib,ic,id,val)
            val = val * nswap * iorient
            if (val .eq. 1) then
               ifail = 2
               return
            end if
         end if
c
c     at this point P is inside the tetrahedron, then check
c     to see whether P is redundant
c
         inside = .true.
         if (.not. doweight)  return
         i_p(4) = wghtball(a) - wghtball(p)
         j_p(4) = wghtball(b) - wghtball(p)
         k_p(4) = wghtball(c) - wghtball(p)
         l_p(4) = wghtball(d) - wghtball(p)
         det_pijkl = -i_p(4)*det_pkjl - j_p(4)*det_pikl
     &                  - k_p(4)*det_pjil - l_p(4)*det_pijk
         if (abs(det_pijkl) .lt. epsln5) then
            call valsort5 (p,a,b,c,d,ia,ib,ic,id,ie,nswap)
            call minor5 (crdball,radball,ia,ib,ic,id,ie,val)
            det_pijkl = val * nswap * iorient
         end if
         redund = (det_pijkl .lt. 0.0d0)
c
c     one of the vertices A, B, C or D is infinite, to find which
c     it is, we use a map between (inf(a),inf(b),inf(c),inf(d))
c     and X, where inf(i) is 1 if i is infinite, 0 otherwise,
c     and X = 1,2,3,4 if A, B, C or D are infinite, respectively;
c     a good mapping function is: X = 3-inf(a)-inf(a)-inf(b)+inf(d)
c
      else if (ninf .eq. 1) then
         idx = 3 - infpoint(1) - infpoint(1) - infpoint(2) + infpoint(4)
         l = list(idx)
         i = list(order1(1,idx))
         j = list(order1(2,idx))
         k = list(order1(3,idx))
         ic1 = inf4_1(l)
         sign = sign4_1(l)
c
c     there are four determinants that need to be computed:
c
c     det_pijk   unchanged
c     det_pjil   1 infinite point (l), becomes det3_pji
c                  where det3_pij = | p(ic1) p(ic2) 1 |
c                                   | i(ic1) i(ic2) 1 |
c                                   | j(ic1) j(ic2) 1 |
c                  and ic1 and ic2 depends on which infinite
c                  (ic2 is always 3) point is considered
c     det_pkjl   1 infinite point (l), becomes det3_pkj
c     det_pikl   1 infinite point (l), becomes det3_pik
c
         do m = 1, 3
            i_p(m) = crdball(3*i-3+m) - coordp(m)
            j_p(m) = crdball(3*j-3+m) - coordp(m)
            k_p(m) = crdball(3*k-3+m) - coordp(m)
         end do
         detij(1) = i_p(1)*j_p(3) - i_p(3)*j_p(1)
         detij(2) = i_p(2)*j_p(3) - i_p(3)*j_p(2)
         detij(3) = i_p(1)*j_p(2) - i_p(2)*j_p(1)
c
c     tests for all determinants, start with inside set to false
c
         inside = .false.
         det_pijk = -k_p(1)*detij(2) + k_p(2)*detij(1)
     &                 - k_p(3)*detij(3)
         det_pijk = det_pijk * dble(iorient)
         test_pijk = (abs(det_pijk) .gt. epsln4)
         if (test_pijk .and. det_pijk.gt.0) then
            ifail = idx
            return
         end if
         det_pjil = -detij(ic1) * sign * iorient
         test_pjil = (abs(det_pjil) .gt. epsln3)
         if (test_pjil .and. det_pjil.gt.0.0d0) then
            ifail = order1(3,idx)
            return
         end if
         det_pkjl = k_p(ic1)*j_p(3) - k_p(3)*j_p(ic1)
         det_pkjl = det_pkjl * sign * iorient
         test_pkjl = (abs(det_pkjl) .gt. epsln3)
         if (test_pkjl .and. det_pkjl.gt.0.0d0) then
            ifail = order1(1,idx)
            return
         end if
         det_pikl = i_p(ic1)*k_p(3) - i_p(3)*k_p(ic1)
         det_pikl = det_pikl * sign * iorient
         test_pikl = (abs(det_pikl) .gt. epsln3)
         if (test_pikl .and. det_pikl.gt.0.0d0) then
            ifail = order1(2,idx)
            return
         end if
c
c     either all four determinants are positive, or one of the
c     determinants is imprecise in which case special care is
c     needed and the indices will be ranked
c
         if (.not. test_pijk) then
            call valsort4 (p,i,j,k,ia,ib,ic,id,nswap)
            call minor4 (crdball,ia,ib,ic,id,val)
            val = val * nswap * iorient
            if (val .eq. 1) then
               ifail = idx
               return
            end if
         end if
         if (.not. test_pjil) then
            call valsort3 (p,j,i,ia,ib,ic,nswap)
            call minor3 (crdball,ia,ib,ic,ic1,3,val)
            val = val * sign * nswap * iorient
            if (val .eq. 1) then
               ifail = order1(3,idx)
               return
            end if
         end if
         if (.not. test_pkjl) then
            call valsort3 (p,k,j,ia,ib,ic,nswap)
            call minor3 (crdball,ia,ib,ic,ic1,3,val)
            val = val * sign * nswap * iorient
            if (val .eq. 1) then
               ifail = order1(1,idx)
               return
            end if
         end if
         if (.not. test_pikl) then
            call valsort3 (p,i,k,ia,ib,ic,nswap)
            call minor3 (crdball,ia,ib,ic,ic1,3,val)
            val = val * sign * nswap * iorient
            if (val .eq. 1) then
               ifail = order1(2,idx)
               return
            end if
         end if
c
c     at this point P is inside the tetrahedron, and since
c     det_pijkl = det_pijk > 1, P cannot be redundant
c
         inside = .true.
         redund = .false.
c
c     two of the vertices A, B, C and D are infinite, to find which
c     they are, we use a map between (inf(a),inf(b),inf(c),inf(d))
c     and X, where inf(i) is 1 if i is infinite, 0 otherwise,
c     and X = 1,2,3,4,5,6 if (a,b), (a,c), (a,d), (b,c), (b,d) or
c     (c,d) are infinite, respectively, a good mapping function is:
c     X = 3-inf(a)-inf(a)+inf(c)+inf(d)+inf(d)
c
      else if (ninf .eq. 2) then
         idx = 3 - infpoint(1) - infpoint(1) + infpoint(3)
     &            + infpoint(4) + infpoint(4)
         k = list(order3(1,idx))
         l = list(order3(2,idx))
         i = list(order2(1,idx))
         j = list(order2(2,idx))
         ic1_k = inf4_1(k)
         ic1_l = inf4_1(l)
         sign_k = sign4_1(k)
         sign_l = sign4_1(l)
         ic1 = inf4_2(k,l)
         sign = sign4_2(k,l)
c
c     tests for all determinants, start with inside set to false
c
         do m = 1, 3
            i_p(m) = crdball(3*i-3+m) - coordp(m)
            j_p(m) = crdball(3*j-3+m) - coordp(m)
         end do
         inside = .false.
         det_pijk = i_p(ic1_k)*j_p(3) - i_p(3)*j_p(ic1_k)
         det_pijk = det_pijk * sign_k * iorient
         test_pijk = (abs(det_pijk) .gt. epsln3)
         if (test_pijk .and. det_pijk.gt.0.0d0) then
            ifail = order3(2,idx)
            return
         end if
         det_pjil = i_p(3)*j_p(ic1_l) - i_p(ic1_l)*j_p(3)
         det_pjil = det_pjil * sign_l * iorient
         test_pjil = (abs(det_pjil) .gt. epsln3)
         if (test_pjil .and. det_pjil.gt.0.0d0) then
            ifail = order3(1,idx)
            return
         end if
         det_pkjl = j_p(ic1) * sign * iorient
         test_pkjl = (abs(det_pkjl) .gt. epsln2)
         if (test_pkjl .and. det_pkjl.gt.0.0d0) then
            ifail = order2(1,idx)
            return
         end if
         det_pikl = -i_p(ic1) * sign * iorient
         test_pikl = (abs(det_pikl) .gt. epsln2)
         if (test_pikl .and. det_pikl.gt.0.0d0) then
            ifail = order2(2,idx)
            return
         end if
c
c     either all four determinants are positive, or one of the
c     determinants is imprecise in which case special care is
c     needed and the indices will be ranked
c
         if (.not. test_pijk) then
            call valsort3 (p,i,j,ia,ib,ic,nswap)
            call minor3 (crdball,ia,ib,ic,ic1_k,3,val)
            val = val * sign_k * nswap * iorient
            if (val .eq. 1) then
               ifail = order3(2,idx)
               return
            end if
         end if
         if (.not. test_pjil) then
            call valsort3 (p,j,i,ia,ib,ic,nswap)
            call minor3 (crdball,ia,ib,ic,ic1_l,3,val)
            val = val * sign_l * nswap * iorient
            if (val .eq. 1) then
               ifail = order3(1,idx)
               return
            end if
         end if
         if (.not. test_pkjl) then
            call valsort2 (p,j,ia,ib,nswap)
            call minor2 (crdball,ia,ib,ic1,val)
            val = -val * sign * nswap * iorient
            if (val .eq. 1) then
               ifail = order2(1,idx)
               return
            end if
         end if
         if (.not. test_pikl) then
            call valsort2 (p,i,ia,ib,nswap)
            call minor2 (crdball,ia,ib,ic1,val)
            val = val * sign * nswap * iorient
            if (val .eq. 1) then
               ifail = order2(2,idx)
               return
            end if
         end if
c
c     at this point P is inside the tetrahedron, then check
c     to see whether P is redundant
c
         inside = .true.
         redund = .false.
         if (.not. doweight)  return
         ic5 = inf5_2(k,l)
         sign5 = sign5_2(k,l)
         det_pijkl = i_p(ic5)*j_p(3) - i_p(3)*j_p(ic5)
         if (abs(det_pijkl) .lt. epsln3) then
            call valsort3 (p,i,j,ia,ib,ic,nswap)
            call minor3 (crdball,ia,ib,ic,ic5,3,val)
            det_pijkl = val * nswap
         end if
         det_pijkl = det_pijkl * sign5 * iorient
         redund = (det_pijkl .lt. 0.0d0)
c
c     three of vertices a, b, c and d are infinite, to find which
c     is finite, use a map between (inf(a),inf(b),inf(c),inf(d))
c     and X, where inf(i) is 1 if i is infinite, 0 otherwise, and
c     X = 1,2,3,4 if a,b,c or d are finite, respectively; a good
c     mapping function is X = 1+inf(a)+inf(a)+inf(b)-inf(d)
c
      else if (ninf .eq. 3) then
         idx = 1 + infpoint(1) + infpoint(1)
     &             + infpoint(2) - infpoint(4)
         i = list(idx) 
         j = list(order1(1,idx))
         k = list(order1(2,idx))
         l = list(order1(3,idx))
         call missinf_sign (j,k,l,ie,iswap)
         do m = 1, 3
            i_p(m) = crdball(3*i-3+m) - coordp(m)
         end do
c
c     tests for all determinants, start with inside set to false
c
         inside = .false.
         det_pijk = i_p(inf4_2(j,k)) * iorient * sign4_2(j,k)
         test_pijk = (abs(det_pijk) .gt. epsln2)
         if (test_pijk .and. det_pijk.gt.0.0d0) then
            ifail = order1(3,idx)
            return
         end if
         det_pjil = -i_p(inf4_2(j,l)) * iorient * sign4_2(j,l)
         test_pjil = (abs(det_pjil) .gt. epsln2)
         if (test_pjil .and. det_pjil.gt.0.0d0) then
            ifail = order1(2,idx)
            return
         end if
         det_pkjl = iorient * iswap * sign4_3(ie)
         if (det_pkjl .gt. 0.0d0) then
            ifail = idx
            return
         end if
         det_pikl = i_p(inf4_2(k,l)) * iorient * sign4_2(k,l)
         test_pikl = (abs(det_pikl) .gt. epsln2)
         if (test_pikl .and. det_pikl.gt.0.0d0) then
            ifail = order1(1,idx)
            return
         end if
c
c     either all four determinants are positive, or one of the
c     determinants is imprecise in which case special care is
c     needed and the indices will be ranked
c
         if (.not. test_pijk) then
            call valsort2 (p,i,ia,ib,nswap)
            call minor2 (crdball,ia,ib,inf4_2(j,k),val)
            val = -val * sign4_2(j,k) * iorient * nswap
            if (val .eq. 1) then
               ifail = order1(3,idx)
               return
            end if
         end if
         if (.not. test_pjil) then
            call valsort2 (p,i,ia,ib,nswap)
            call minor2 (crdball,ia,ib,inf4_2(j,l),val)
            val = val * sign4_2(j,l) * iorient * nswap
            if (val .eq. 1) then
               ifail = order1(2,idx)
               return
            end if
         end if
         if (.not. test_pikl) then
            call valsort2 (p,i,ia,ib,nswap)
            call minor2 (crdball,ia,ib,inf4_2(k,l),val)
            val = -val * sign4_2(k,l) * iorient * nswap
            if (val .eq. 1) then
               ifail = order1(1,idx)
               return
            end if
         end if
c
c     at this point P is inside the tetrahedron, then check
c     to see whether P is redundant
c
         inside = .true.
         redund = .false.
         if (.not. doweight)  return
         ic1 = inf5_3(ie)
         sign5 = sign5_3(ie)
         det_pijkl = -i_p(ic1)
         if (abs(det_pijkl) .lt. epsln2) then
            call valsort2 (p,i,ia,ib,nswap)
            call minor2 (crdball,ia,ib,ic1,val)
            det_pijkl = val * nswap
         end if
         det_pijkl = -det_pijkl * sign5 * iorient * iswap
         redund = (det_pijkl .lt. 0.0d0)
c
c     if all four points ia, ib, ic and id are infinite,
c     then inside must be true and redundant is false
c
      else
         inside = .true.
         redund = .false.
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine regular_convex  --  locally regular link facet  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "regular_convex" checks if a link facet (a,b,c) is locally
c     regular, as well as if the union of the two tetrahedra ABCP
c     and ABCO that connect to the facet is convex
c
c     for floating point, points need not be in lexicographic order
c     prior to computing a determinant; this is not true if the
c     value is near zero where special care is needed and the points
c     are ordered using a series of "valsort" routines
c
c     variables and parameters:
c
c     a,b,c        three points defining the link facet
c     p            current point inserted in the triangulation
c     o            fourth point of the tetrahedron that attaches
c                    to ABC opposite to the tetrahedron ABCP
c     itest_abcp   orientation of the tetrahedron ABCP
c     convex       set "true" if ABCP U ABCO is convex, else "false"
c     regular      set "true" if ABC is locally regular, in which
c                    case it does not matter if convex
c
c
      subroutine regular_convex (a,b,c,p,o,itest_abcp,regular,convex,
     &                              test_abpo,test_bcpo,test_capo)
      use iounit
      use shapes
      implicit none
      integer i,j,k,l,m
      integer p,a,b,c,o
      integer ia,ib,ic,id,ie
      integer ninf,infp,info
      integer iswap,iswap2,idx,val
      integer icol1,sign1,icol2,sign2
      integer icol4,sign4,icol5,sign5
      integer itest_abcp
      integer list(3)
      integer sign4_3(4)
      integer infpoint(4)
      integer inf4_1(4),sign4_1(4)
      integer inf5_3(4),sign5_3(4)
      integer inf4_2(4,4),sign4_2(4,4)
      integer inf5_2(4,4),sign5_2(4,4)
      integer order(2,3)
      integer order1(3,3)
      real*8 det_abpo,det_bcpo,det_capo
      real*8 det_abcpo,det_abpc
      real*8 a_p(4),b_p(4),c_p(4),o_p(0:4)
      real*8 i_p(0:3),j_p(0:3)
      real*8 mbo(3),mca(3),mjo(3),mio(0:3)
      real*8 coordp(3)
      logical convex,regular
      logical test_abpo,test_bcpo
      logical test_capo
      logical testc(3)
      data inf4_1  / 2, 2, 1, 1 /
      data sign4_1  / -1, 1, 1, -1 /
      data inf4_2  / 0, 2, 3, 3, 2, 0, 3, 3, 3, 3, 0, 1, 3, 3, 1, 0 /
      data sign4_2  / 0, 1, -1, 1, -1, 0, 1, -1,
     &                1, -1, 0, 1, -1, 1, -1, 0 /
      data sign4_3  / -1, 1, -1, 1 /
      data inf5_2  / 0, 2, 1, 1, 2, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 0 /
      data sign5_2  / 0, -1, -1, 1, 1, 0, -1, 1,
     &                1, 1, 0, 1, -1, -1, -1, 0 /
      data inf5_3  / 1, 1, 3, 3 /
      data sign5_3  / 1, 1, -1, 1 /
      data order1  / 1, 2, 3, 3, 1, 2, 2, 3, 1 /
      data order  / 2, 3, 3, 1, 1, 2 /
      save
c
c
c     test if the union of the two tetrahedra is convex; check the
c     position of O with respect to the three faces ABP, BCP and CAP
c     of ABCP; to do that, we evaluate the three determinants:
c     det(ABPO), det(BCPO) and det(CAPO)
c
c     if the determinants are positive, and det(ABCP) is negative,
c     then the union is convex; also, if the three determinants are
c     negative, and det(ABCP) is positive, then the union is convex;
c     in all other cases, the union is non convex
c
c     the regularity is tested by computing det(ABCPO) 
c
c     count how many infinite points we have, except for O, note
c     only A, B and C can be infinite points
c
      regular = .true.
      convex  = .true.
      test_abpo = .false.
      test_bcpo = .false.
      test_capo = .false.
      list(1) = a
      list(2) = b
      list(3) = c
      infpoint(1) = 0
      infpoint(2) = 0
      infpoint(3) = 0
      if (a .le. 4)  infpoint(1) = 1
      if (b .le. 4)  infpoint(2) = 1
      if (c .le. 4)  infpoint(3) = 1
      ninf = infpoint(1) + infpoint(2) + infpoint(3)
      do m = 1, 3
         coordp(m) = crdball(3*p-3+m)
      end do
c
c     handle the general case with no infinite points; first is
c     when O is infinite, then det(ABCPO) = -det(ABCP) and thus 
c     ABCPO is regular, so there is nothing to do
c
      if (ninf .eq. 0) then
         if (o .le. 4) then
            regular = .true.
            return
         end if
c
c     determinants det(ABPO), det(BCPO), and det(CAPO) are "real"
c     4x4 determinants; first substract the row corresponding to
c     P from the other row, and develop with respect to P
c
c     the determinants become:
c
c     det(a,b,p,o) = - | ap(1) ap(2) ap(3) |
c                      | bp(1) bp(2) bp(3) |
c                      | op(1) op(2) op(3) |
c
c     det(b,c,p,o) = - | bp(1) bp(2) bp(3) |
c                      | cp(1) cp(2) cp(3) |
c                      | op(1) op(2) op(3) |
c
c     det(c,a,p,o) = - | cp(1) cp(2) cp(3) |
c                      | ap(1) ap(2) ap(3) |
c                      | op(1) op(2) op(3) |
c
c     where ip(j) = i(j)-p(j) for all i in {a,b,c,o} and j in {1,2,3}
c
c     compute two types of minors: mbo_ij = bp(i)op(j) - bp(j)op(i)
c     and mca_ij = cp(i)ap(j) - cp(j)op(i), store mbo_12 in mbo(3),
c     mbo_13 in mbo(2), and so on
c
         do m = 1, 3
            a_p(m) = crdball(3*a-3+m) - coordp(m)
            b_p(m) = crdball(3*b-3+m) - coordp(m)
            c_p(m) = crdball(3*c-3+m) - coordp(m)
            o_p(m) = crdball(3*o-3+m) - coordp(m)
         end do
         a_p(4) = wghtball(a) - wghtball(p)
         b_p(4) = wghtball(b) - wghtball(p)
         c_p(4) = wghtball(c) - wghtball(p)
         o_p(4) = wghtball(o) - wghtball(p)
         mbo(1) = b_p(2)*o_p(3) - b_p(3)*o_p(2)
         mbo(2) = b_p(1)*o_p(3) - b_p(3)*o_p(1)
         mbo(3) = b_p(1)*o_p(2) - b_p(2)*o_p(1)
         mca(1) = c_p(2)*a_p(3) - c_p(3)*a_p(2)
         mca(2) = c_p(1)*a_p(3) - c_p(3)*a_p(1)
         mca(3) = c_p(1)*a_p(2) - c_p(2)*a_p(1)
         det_abpo = -a_p(1)*mbo(1) + a_p(2)*mbo(2) - a_p(3)*mbo(3)
         det_bcpo = c_p(1)*mbo(1) - c_p(2)*mbo(2) + c_p(3)*mbo(3)
         det_capo = -o_p(1)*mca(1) + o_p(2)*mca(2) - o_p(3)*mca(3)
         det_abpc = -b_p(1)*mca(1) + b_p(2)*mca(2) - b_p(3)*mca(3)
c
c     now compute det(a,b,c,p,o) = | a(1) a(2) a(3) a(4) 1 |
c                                  | b(1) b(2) b(3) b(4) 1 |
c                                  | c(1) c(2) c(3) c(4) 1 |
c                                  | p(1) p(2) p(3) p(4) 1 |
c                                  | o(1) o(2) o(3) o(4) 1 |
c
c     which after substraction of row P gives:
c
c               det(a,b,c,p,o) = - | ap(1) ap(2) ap(3) ap(4) |
c                                  | bp(1) bp(2) bp(3) bp(4) |
c                                  | cp(1) cp(2) cp(3) cp(4) |
c                                  | op(1) op(2) op(3) op(4) |
c
c     then developing with respect to the last column yields:
c
         det_abcpo = -a_p(4)*det_bcpo - b_p(4)*det_capo 
     &                  - c_p(4)*det_abpo + o_p(4)*det_abpc
c
c     test if (ABCPO) is regular, in which case no flip is needed
c
         if (abs(det_abcpo) .lt. epsln5) then
            call valsort5 (a,b,c,p,o,ia,ib,ic,id,ie,iswap)
            call minor5 (crdball,radball,ia,ib,ic,id,ie,val)
            det_abcpo = val * iswap
         end if
         if (det_abcpo*itest_abcp .lt. 0.0d0) then
            regular = .true.
            return
         end if
         regular = .false.
c
c     if (ABCPO) is not regular, then test for convexity
c
         if (abs(det_abpo) .lt. epsln4) then
            call valsort4 (a,b,p,o,ia,ib,ic,id,iswap)
            call minor4 (crdball,ia,ib,ic,id,val)
            det_abpo = val * iswap
         end if
         if (abs(det_bcpo) .lt. epsln4) then
            call valsort4 (b,c,p,o,ia,ib,ic,id,iswap)
            call minor4 (crdball,ia,ib,ic,id,val)
            det_bcpo = val * iswap
         end if
         if (abs(det_capo) .lt. epsln4) then
            call valsort4 (c,a,p,o,ia,ib,ic,id,iswap)
            call minor4 (crdball,ia,ib,ic,id,val)
            det_capo = val * iswap
         end if
         test_abpo = (det_abpo .gt. 0.0d0)
         test_bcpo = (det_bcpo .gt. 0.0d0)
         test_capo = (det_capo .gt. 0.0d0)
         convex = .false.
         if (itest_abcp*det_abpo .gt. 0)  return
         if (itest_abcp*det_bcpo .gt. 0)  return
         if (itest_abcp*det_capo .gt. 0)  return
         convex = .true.
c
c     second case where one of A, B or C is infinite; define X
c     as the infinite point, and (i,j) the pair of finite points
c
c     if X=A then (i,j)=(b,c), or if X=B then (i,j)=(c,a), or
c     if X=C then (i,j)=(a,b)
c
c     define inf(a)=1 if A is infinite, or 0 otherwise, then
c     idx_X = 2-inf(a)+inf(c)
c
      else if (ninf .eq. 1) then
         idx = 2 -infpoint(1) + infpoint(3)
         infp = list(idx)
         i = list(order(1,idx))
         j = list(order(2,idx))
         do m = 1, 3
            i_p(m) = crdball(3*i-3+m) - coordp(m)
            j_p(m) = crdball(3*j-3+m) - coordp(m)
            o_p(m) = crdball(3*o-3+m) - coordp(m)
         end do
c
c     handle the case where O is finite
c
         if (o .gt. 4) then
            icol1 = inf4_1(infp)
            sign1 = sign4_1(infp)
c
c     the three 4x4 determinants become -det(i,p,o) [X missing],
c     det(j,p,o) [X missing], and det(i,j,p,o)
c
c     and the 5x5 determinant becomes -det(i,j,p,o)
c
            mjo(1) = j_p(1)*o_p(3) - j_p(3)*o_p(1)
            mjo(2) = j_p(2)*o_p(3) - j_p(3)*o_p(2)
            mjo(3) = j_p(1)*o_p(2) - j_p(2)*o_p(1)
c 
c     the correspondence between A,B,C and i,j is not essential
c     here use the correspondence for A infinite; in the two other
c     cases (B or C infinite), compute the same determinants, but
c     they are not in the same order
c
            det_abpo = i_p(icol1)*o_p(3) - i_p(3)*o_p(icol1)
            if (abs(det_abpo) .lt. epsln3) then
               call valsort3 (i,p,o,ia,ib,ic,iswap)
               call minor3 (crdball,ia,ib,ic,icol1,3,val)
               det_abpo = -val * iswap
            end if
            det_abpo = det_abpo * sign1
            det_capo = -mjo(icol1)
            if (abs(det_capo) .lt. epsln3) then
               call valsort3 (j,p,o,ia,ib,ic,iswap)
               call minor3 (crdball,ia,ib,ic,icol1,3,val)
               det_capo = val * iswap
            end if
            det_capo = det_capo * sign1
            det_bcpo = -i_p(1)*mjo(2) + i_p(2)*mjo(1) - i_p(3)*mjo(3)
            if (abs(det_bcpo) .lt. epsln3) then
               call valsort4 (i,j,p,o,ia,ib,ic,id,iswap)
               call minor4 (crdball,ia,ib,ic,id,val)
               det_bcpo = val * iswap
            end if
            det_abcpo = -det_bcpo
c
c     handle the case where O is infinite
c
c     the three 4x4 determinants become -det(i,p) [O,X missing],
c     det(j,p) [O,X missing], and det(i,j,p) [O missing]
c
c     and the 5x5 determinant becomes det(i,j,p) [O,X missing]
c
         else
            info = o
            icol1 = inf4_2(info,infp)
            sign1 = sign4_2(info,infp)
            icol2 = inf4_1(info)
            sign2 = sign4_1(info)
            icol5 = inf5_2(info,infp)
            sign5 = sign5_2(info,infp)
            det_abpo = -i_p(icol1) * sign1
            if (abs(det_abpo) .lt. epsln2) then
               call valsort2 (i,p,ia,ib,iswap)
               call minor2 (crdball,ia,ib,icol1,val)
               det_abpo = -val * iswap * sign1
            end if
            det_capo = j_p(icol1) * sign1
            if (abs(det_capo) .lt. epsln2) then
               call valsort2 (j,p,ia,ib,iswap)
               call minor2 (crdball,ia,ib,icol1,val)
               det_capo = val * iswap * sign1
            end if
            det_bcpo = i_p(icol2)*j_p(3) - i_p(3)*j_p(icol2)
            if (abs(det_bcpo) .lt. epsln3) then
               call valsort3 (i,j,p,ia,ib,ic,iswap)
               call minor3 (crdball,ia,ib,ic,icol2,3,val)
               det_bcpo = val * iswap
            end if
            det_bcpo = det_bcpo * sign2
            det_abcpo = i_p(icol5)*j_p(3) - i_p(3)*j_p(icol5)
            if (abs(det_abcpo) .lt. epsln3) then
               call valsort3 (i,j,p,ia,ib,ic,iswap)
               call minor3 (crdball,ia,ib,ic,icol5,3,val)
               det_abcpo = val * iswap
            end if
            det_abcpo = det_abcpo * sign5
         end if
c
c     test if (ABCPO) is regular, in which case no flip is needed
c
         if (det_abcpo*itest_abcp .lt. 0) then
            regular = .true.
            return
         end if
         regular = .false.
c
c     if (ABCPO) is not regular, then test for convexity
c
         testc(1) = (det_abpo .gt. 0.0d0)
         testc(2) = (det_bcpo .gt. 0.0d0)
         testc(3) = (det_capo .gt. 0.0d0)
         test_abpo = testc(order1(1,idx))
         test_bcpo = testc(order1(2,idx))
         test_capo = testc(order1(3,idx))
         convex = .false.
         if (itest_abcp*det_abpo .gt. 0)  return
         if (itest_abcp*det_bcpo .gt. 0)  return
         if (itest_abcp*det_capo .gt. 0)  return
         convex = .true.
c
c     third case where two points are infinite; define (k,l) as
c     the two infinite points, and i the point that is finite
c
c     if i=A then (k,l)=(b,c), or if i=B then (k,l)=(c,a), or
c     if i=C then (k,l)=(a,b); again i = 2+inf(a)-inf(c)
c
      else if (ninf .eq. 2) then
         idx = 2 + infpoint(1) - infpoint(3)
         i = list(idx)
         k = list(order(1,idx))
         l = list(order(2,idx))
         do m = 1, 3
            i_p(m) = crdball(3*i-3+m) - coordp(m)
            o_p(m) = crdball(3*o-3+m) - coordp(m)
         end do
c
c     handle the case where O is finite
c
c     the three 4x4 determinants become det(i,p,o) [k missing],
c     -det(i,p,o) [l missing], and S*det(p,o) [k,l missing,
c     with S=1 if k<l, -1 otherwise]
c
c     and the 5x5 determinant becomes S*det(i,p,o) [k,l missing,
c     with S=1 if k<l, -1 otherwise]
c
         if (o .gt. 4) then
            icol1 = inf4_1(k)
            sign1 = sign4_1(k)
            icol2 = inf4_1(l)
            sign2 = sign4_1(l)
            icol4 = inf4_2(k,l)
            sign4 = sign4_2(k,l)
            icol5 = inf5_2(k,l)
            sign5 = sign5_2(k,l)
            mio(1) = i_p(1)*o_p(3) - i_p(3)*o_p(1)
            mio(2) = i_p(2)*o_p(3) - i_p(3)*o_p(2)
            mio(3) = i_p(1)*o_p(2) - i_p(2)*o_p(1)
c 
c     the correspondence between A,B,C and i,j,k is not essential
c     here use the correspondence for A finite; in the two other
c     cases (B or C finite), compute the same determinants, but
c     they are not in the same order
c
            det_abpo = -mio(icol1) * sign1
            if (abs(det_abpo) .lt. epsln3) then
               call valsort3 (i,p,o,ia,ib,ic,iswap)
               call minor3 (crdball,ia,ib,ic,icol1,3,val)
               det_abpo = val * iswap * sign1
            end if
            det_capo = mio(icol2) * sign2
            if (abs(det_capo) .lt. epsln3) then
               call valsort3 (i,p,o,ia,ib,ic,iswap)
               call minor3 (crdball,ia,ib,ic,icol2,3,val)
               det_capo = -val * iswap * sign2
            end if
            det_bcpo = -o_p(icol4) * sign4
            if (abs(det_bcpo) .lt. epsln3) then
               call valsort2 (p,o,ia,ib,iswap)
               call minor2 (crdball,ia,ib,icol4,val)
               det_bcpo = val * sign4 * iswap
            end if
            det_abcpo = -mio(icol5) * sign5
            if (abs(det_abcpo) .lt. epsln3) then
               call valsort3 (i,p,o,ia,ib,ic,iswap)
               call minor3 (crdball,ia,ib,ic,icol5,3,val)
               det_abcpo = val * iswap * sign5
            end if
c
c     handle the case where O is infinite
c
c     the three 4x4 determinants become -det(i,p) [O,k missing],
c     -det(i,p) [O,l missing], and Const [O,k,l missing]
c
c     and the 5x5 determinant becomes Const*det(i,p) [O,k,l missing]
c
         else
            info = o
            icol1 = inf4_2(info,k)
            sign1 = sign4_2(info,k)
            icol2 = inf4_2(info,l)
            sign2 = sign4_2(info,l)
            call missinf_sign (info,k,l,icol4,iswap)
            det_abpo = i_p(icol1) * sign1
            if (abs(det_abpo) .lt. epsln2) then
               call valsort2 (i,p,ia,ib,iswap2)
               call minor2 (crdball,ia,ib,icol1,val)
               det_abpo = val * iswap2 * sign1
            end if
            det_capo = -i_p(icol2) * sign2
            if (abs(det_capo) .lt. epsln2) then
               call valsort2 (i,p,ia,ib,iswap2)
               call minor2 (crdball,ia,ib,icol2,val)
               det_capo = -val * iswap2 * sign2
            end if
            det_bcpo = sign4_3(icol4) * iswap
            det_abcpo = sign5_3(icol4) * iswap * i_p(inf5_3(icol4))
            if (abs(det_abcpo) .lt. epsln2) then
               call valsort2 (i,p,ia,ib,iswap2)
               call minor2 (crdball,ia,ib,inf5_3(icol4),val)
               det_abcpo = val * iswap2 * iswap * sign5_3(icol4)
            end if
         end if
c
c     test if (ABCPO) is regular, in which case no flip is needed
c
         if (det_abcpo*itest_abcp .lt. 0) then
            regular = .true.
            return
         end if
         regular = .false.
c
c     if (ABCPO) is not regular, then test for convexity
c
         testc(1) = (det_abpo .gt. 0.0d0)
         testc(2) = (det_bcpo .gt. 0.0d0)
         testc(3) = (det_capo .gt. 0.0d0)
         test_abpo = testc(order1(1,idx))
         test_bcpo = testc(order1(2,idx))
         test_capo = testc(order1(3,idx))
         convex = .false.
         if (itest_abcp*det_abpo .gt. 0)  return
         if (itest_abcp*det_bcpo .gt. 0)  return
         if (itest_abcp*det_capo .gt. 0)  return
         convex = .true.
c
c     cannot have all three points A, B and C infinite, as in
c     this case the facet ABC would be on the convex hull
c
      else if (ninf .eq. 3) then
         write (iout,10)
   10    format (/,' REGULAR_CONVEX  --  An Error has Occurred')
         call fatal
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine missinf_sign  --  missing infinite point index  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "missinf_sign" takes as input the indices of three infinite
c     points, then finds the index of the missing fourth infinite
c     point, and gives the signature of the permutation required
c     to put the three infinite points in order
c
c     variables and parameters:
c
c     i,j,k    three known infinite points
c     m        the "missing" infinite point
c     sign     signature of the permutation that orders i,j,k
c
c
      subroutine missinf_sign (i,j,k,m,sign)
      implicit none
      integer i,j,k,m
      integer sign
      integer a,b,c,d
      save
c
c
      m = 10 - i - j - k
      a = i
      b = j
      c = k
      sign = 1
      if (a .gt. b) then
         d = a
         a = b
         b = d
         sign = -sign
      end if
      if (a .gt. c) then
         d = a
         a = c
         c = d
         sign = -sign
      end if
      if (b .gt. c) then
         sign = -sign
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine valsort2  --  sort two integers & track flips  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "valsort2" sorts numbers A and B, where input values are
c     kept unaffected, and new output values are generated
c
c
      subroutine valsort2 (a,b,ia,ib,iswap)
      implicit none
      integer a,b
      integer ia,ib
      integer iswap
      save
c
c
      iswap = 1
      if (a .gt. b) then
         ia = b
         ib = a
         iswap = -iswap
      else
         ia = a
         ib = b
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine valsort3  --  sort three integers & track flips  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "valsort3" sorts numbers A, B and C, where input values
c     are kept unaffected, and new output values are generated
c
c
      subroutine valsort3 (a,b,c,ia,ib,ic,iswap)
      implicit none
      integer a,b,c
      integer ia,ib,ic
      integer iswap,temp
      save
c
c
      call valsort2 (a,b,ia,ib,iswap)
      ic = c
      if (ib .gt. ic) then
         temp = ib
         ib = ic
         ic = temp
         iswap = -iswap
         if (ia .gt. ib) then
            temp = ia
            ia = ib
            ib = temp
            iswap = -iswap
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine valsort4  --  sort four integers & track flips  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "valsort4" sorts numbers A, B, C and D, where input values
c     are kept unaffected, and new output values are generated
c
c
      subroutine valsort4 (a,b,c,d,ia,ib,ic,id,iswap)
      implicit none
      integer a,b,c,d
      integer ia,ib,ic,id
      integer iswap,temp
      save
c
c
      call valsort3 (a,b,c,ia,ib,ic,iswap)
      id = d
      if (ic .gt. id) then
         temp = ic
         ic = id
         id = temp
         iswap = -iswap
         if (ib .gt. ic) then
            temp = ib
            ib = ic
            ic = temp
            iswap = -iswap
            if (ia .gt. ib) then
               temp = ia
               ia = ib
               ib = temp
               iswap = -iswap
            end if
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine valsort5  --  sort five integers & track flips  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "valsort5" sorts numbers A, B, C, D and E, where input values
c     are kept unaffected, and new output values are generated
c
c
      subroutine valsort5 (a,b,c,d,e,ia,ib,ic,id,ie,iswap)
      implicit none
      integer a,b,c,d,e
      integer ia,ib,ic,id,ie
      integer iswap,temp
      save
c
c
      call valsort4 (a,b,c,d,ia,ib,ic,id,iswap)
      ie = e
      if (id .gt. ie) then
         temp = id
         id = ie
         ie = temp
         iswap = -iswap
         if (ic .gt. id) then
            temp = ic
            ic = id
            id = temp
            iswap = -iswap
            if (ib .gt. ic) then
               temp = ib
               ib = ic
               ic = temp
               iswap = -iswap
               if (ia .gt. ib) then
                  temp = ia
                  ia = ib
                  ib = temp
                  iswap = -iswap
               end if
            end if
         end if
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine flipjw  --  restore regularity to facet list  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "flipjw" goes over the linkfacet list to restore regularity
c     after a point has been inserted; when a linkfacet is found
c     nonregular and flippable, attempt to flip it; if the flip is
c     successful, new linkfacets are added to the queue; terminate
c     when the linkfacet list is empty
c
c
      subroutine flipjw (tetra_last)
      use iounit
      use shapes
      implicit none
      integer j
      integer a,b,c,o,p
      integer ierr,ifind
      integer itetra,jtetra
      integer tetra_ab,tetra_ac
      integer tetra_bc
      integer iorder,ival
      integer ireflex,iflip
      integer idx_p,idx_o,itest_abcp
      integer idx_a,idx_b,idx_c
      integer ntkill_top
      integer ntfreemax,ns
      integer tetra_last
      integer idxi,idxj,idxk,idxl
      integer ia,ib,ic,ii,ij
      integer facei(3),facej(3)
      integer edgei(2),edgej(2)
      integer edgek(2)
      integer edge_val(2,3)
      integer tetra_flip(3)
      integer list_flip(3)
      integer table32(3,3)
      integer table32_2(2,3)
      integer table41(3,3)
      integer table41_2(2,3)
      integer vert_flip(5)
      logical test,test_or(2,3),regular,convex
      logical test_abpo,test_abpc,test_capo,test_acpb
      logical test_bcpo,test_bcpa,test_acpo
      data table32  / 1, 2, 3, 1, 3, 2, 3, 1, 2 /
      data table32_2  / 1, 2, 1, 3, 2, 3 /
      data table41  / 2, 1, 3, 1, 2, 3, 1, 3, 2 /
      data table41_2  / 1, 1, 2, 1, 2, 2 /
      save
c
c
c     initialize some sizes related to free and kill space
c
      ntfreemax = 10000
      ntkill_top = nint(0.9d0*dble(ntfreemax))
c
c     first perform a loop over all of the link facets
c
      j = 0
   10 continue
      if (j .eq. nlinkfacet)  goto 30
      if (ntkill .ge. ntkill_top) then
         ntkill = ntkill_top
c        ns = ntfree
c        ntfree = min(ntfree+ntkill,ntkill_top)
c        do j = ns+1, ntfree
c           freespace(j) = killspace(j-ns)
c        end do
c        ntkill = 0
      end if
      j = j + 1
c
c     first define the two tetrahedra containing the link facet
c     as itetra and jtetra
c
      itetra = linkfacet(1,j)
      jtetra = linkfacet(2,j)
      idx_p = linkindex(1,j)
      idx_o = linkindex(2,j)
c
c     if the link facet is on the convex hull, then discard
c
      if (itetra.eq.0 .or. jtetra.eq.0)  goto 10
c
c     if tetrahedra are already discarded, discard this link facet
c
      if (.not.btest(tinfo(itetra),1)) then
         if (.not.btest(tinfo(jtetra),1)) then
            goto 10
         else
            itetra = tneighbor(idx_o,jtetra)
            ival = ibits(tnindex(itetra),2*(idx_o-1),2)
            idx_p = ival + 1
         end if
      end if
      if (.not.btest(tinfo(jtetra),1)) then
         jtetra = tneighbor(idx_p,itetra)
         ival = ibits(tnindex(itetra),2*(idx_o-1),2)
         idx_o = ival + 1
      end if
c
c     define the vertices of the two tetrahedra with itetra as ABCP
c     and jtetra as ABCO
c
      a = tetra(1,itetra)
      b = tetra(2,itetra)
      c = tetra(3,itetra)
      p = tetra(4,itetra)
      o = tetra(idx_o,jtetra)
      itest_abcp = -1
      if (btest(tinfo(itetra),0))  itest_abcp = 1
c
c     check for local regularity (and for convexity, at very
c     little extra cost)
c
      call regular_convex (a,b,c,p,o,itest_abcp,regular,convex,
     &                     test_abpo,test_bcpo,test_capo)
c
c     if the link facet is locally regular, then discard
c
      if (regular)  goto 10
c
c     define neighbors of the facet on itetra and jtetra
c
      call define_facet (itetra,jtetra,idx_o,facei,facej)
      test_abpc = (itest_abcp .ne. 1)
c
c     after discarding the trivial case, test if the tetrahedra
c     can be flipped
c
c     at this stage, the link facet is not locally regular, but
c     it is unknown if it is "flippable"
c
c     check if {itetra} U {jtetra} is convex; if it is, perform
c     a 2-3 flip (this is the convexity test performed at the
c     same time as the regularity test)
c
      if (convex) then
         vert_flip(1) = a
         vert_flip(2) = b
         vert_flip(3) = c
         vert_flip(4) = p
         vert_flip(5) = o
         call flipjw_2_3 (itetra,jtetra,vert_flip,facei,facej,
     &                    test_abpo,test_bcpo,test_capo,ierr,
     &                    tetra_last)
         goto 10
      end if
c
c     the union of the two tetrahedra is not convex; check edges of
c     the triangle in the link facet to see if they are "reflexes"
c     (see Edelsbrunner and Shah, Algorithmica 15, 223-241, 1996)
c
      ireflex = 0
      iflip = 0
c
c     check edge AB; it is reflex if and only if O and C lie on
c     opposite sides of the hyperplane defined by ABP; test the
c     orientation of ABPO and ABPC, and if they differ AB is reflex
c
c     if AB is reflex, we test if it is of degree three, i.e., if it
c     is shared by three tetrahedra, namely ABCP, ABCO and ABPO; the
c     first two are itetra and jtetra, so we only need to check if
c     ABPO exists
c
c     since ABPO contains P, ABP should then be a link facet of P,
c     so test all tetrahedra that define link facets
c
      if (test_abpo .neqv. test_abpc) then
         ireflex = ireflex + 1
         call find_tetra (itetra,3,a,b,o,ifind,tetra_ab,idx_a,idx_b)
         if (ifind .eq. 1) then
            iflip = iflip + 1
            tetra_flip(iflip) = tetra_ab
            list_flip(iflip) = 1
            edge_val(1,iflip) = idx_a
            edge_val(2,iflip) = idx_b
            test_or(1,iflip) = test_bcpo
            test_or(2,iflip) = (.not. test_capo)
         end if
      end if
c
c     check edge AC; it is reflex if and only if O and B lie on
c     opposite sides of the hyperplane defined by ACP; test the
c     orientation of ACPO and ACPB, and if they differ AC is reflex
c
c     if AC is reflex, we test if it is of degree three, i.e., if it
c     is shared by three tetrahedra, namely ABCP, ABCO and ACPO; the
c     first two are itetra and jtetra, so we only need to check if
c     ACPO exists
c
c     since ACPO contains P, ACP should then be a link facet of P,
c     so test all tetrahedra that define link facets
c
      test_acpo = (.not. test_capo)
      test_acpb = (.not. test_abpc)
      if (test_acpo .neqv. test_acpb) then
         ireflex = ireflex + 1
         call find_tetra (itetra,2,a,c,o,ifind,tetra_ac,idx_a,idx_c)
         if (ifind .eq. 1) then
            iflip = iflip + 1
            tetra_flip(iflip) = tetra_ac
            list_flip(iflip) = 2
            edge_val(1,iflip) = idx_a
            edge_val(2,iflip) = idx_c
            test_or(1,iflip) = (.not. test_bcpo)
            test_or(2,iflip) = test_abpo
         end if
      end if
c
c     check edge BC; it is reflex if and only if O and A lie on
c     opposite sides of the hyperplane defined by BCP; test the
c     orientation of BCPO and BCPA, and if they differ BC is reflex
c
c     if BC is reflex, we test if it is of degree three, i.e., if it
c     is shared by three tetrahedra, namely ABCP, ABCO and BCPO; the
c     first two are itetra and jtetra, so we only need to check if
c     BCPO exists
c
c     since BCPO contains P, BCP should then be a link facet of P,
c     so test all tetrahedra that define link facets
c
      test_bcpa = test_abpc
      if (test_bcpo .neqv. test_bcpa) then
         ireflex = ireflex + 1
         call find_tetra (itetra,1,b,c,o,ifind,tetra_bc,idx_b,idx_c)
         if (ifind .eq. 1) then
            iflip = iflip + 1
            tetra_flip(iflip) = tetra_bc
            list_flip(iflip) = 3
            edge_val(1,iflip) = idx_b
            edge_val(2,iflip) = idx_c
            test_or(1,iflip) = test_capo
            test_or(2,iflip) = (.not. test_abpo)
         end if
      end if
      if (ireflex .ne. iflip)  goto 10
c
c     if only one edge is flippable, so perform a 3-2 flip
c
      if (iflip .eq. 1) then
         iorder = list_flip(iflip)
         ia = table32(1,iorder)
         ib = table32(2,iorder)
         ic = table32(3,iorder)
         vert_flip(ia) = a
         vert_flip(ib) = b
         vert_flip(ic) = c
         vert_flip(4) = p
         vert_flip(5) = o
         ia = table32_2(1,iorder)
         ib = table32_2(2,iorder)
         edgei(1) = ia
         edgei(2) = ib
         edgej(1) = facej(ia)
         edgej(2) = facej(ib)
         edgek(1) = edge_val(1,iflip)
         edgek(2) = edge_val(2,iflip)
         call flipjw_3_2 (itetra,jtetra,tetra_flip(1),vert_flip,
     &                    edgei,edgej,edgek,test_or(1,iflip),
     &                    test_or(2,iflip),ierr,tetra_last)
c
c     in this case, one point is redundant, the point common to
c     the two edges that can be flipped, so perform a 4-1 flip
c
      else if (iflip .eq. 2) then
         iorder = list_flip(1) + list_flip(2) - 2
         vert_flip(table41(1,iorder)) = a
         vert_flip(table41(2,iorder)) = b
         vert_flip(table41(3,iorder)) = c
         vert_flip(4) = p
         vert_flip(5) = o
         ii = table41_2(1,iorder)
         ij = table41_2(2,iorder)
         idxi = iorder
         idxj = facej(iorder)
         idxk = edge_val(ii,1)
         idxl = edge_val(ij,2)
         if (iorder .eq. 1) then
            test = test_bcpo
         else if (iorder .eq. 2) then
            test = (.not. test_capo)
         else
            test = test_abpo
         end if
         call flipjw_4_1 (itetra,jtetra,tetra_flip(1),tetra_flip(2),
     &                    vert_flip,idxi,idxj,idxk,idxl,test,ierr,
     &                    tetra_last)
c
c     note that the following case should never occur
c
      else
         write (iout,20)
   20    format (/,' FLIPJW  --  Three Flippable Edges',
     &              ' Should Not Occur')
         call fatal
      end if
      goto 10
c
c     add all of the "killed" tetrahedra into the free zone
c
   30 continue
      ns = ntfree
      ntfree = min(ns+ntkill,ntfreemax)
      do j = ns+1, ntfree
         freespace(j) = killspace(j-ns)
      end do
      ntkill = 0
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine flipjw_1_4  --  1->4 flip for triangulation  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "flipjw_1_4" performs a 1->4 flip for regular triangulation
c     where a 1->4 flip is a transformation in which a tetrahedron
c     and a single vertex included in the tetrahedron are transformed
c     to four tetrahedra defined from the four faces of the initial
c     tetrahedron, connected to the new point, each of the faces is
c     then called a "linkfacet" and is stored on a queue
c
c     variables and parameters:
c
c     ipoint      index of the point P to be included
c     itetra      index of the tetrahedra considered (ABCD)
c
c
      subroutine flipjw_1_4 (ipoint,itetra,tetra_last)
      use shapes
      implicit none
      integer i,j,k
      integer ipoint
      integer newtetra
      integer ival,ikeep
      integer itetra,jtetra
      integer fact,idx
      integer tetra_last
      integer vertex(4)
      integer nindex(4)
      integer neighbor(4)
      integer position(4)
      integer idx_list(3,4)
      data idx_list  / 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3 /
      save
c
c
c     store information about the old tetrahedron
c
      ikeep = tinfo(itetra)
      do i = 1, 4
         vertex(i) = tetra(i,itetra)
         neighbor(i) = tneighbor(i,itetra)
         ival = ibits(tnindex(itetra),2*(i-1),2)
         nindex(i) = ival + 1
      end do
      fact = -1
      if (btest(tinfo(itetra),0))  fact = 1
c
c     the four new tetrahedra are stored in free space in the
c     tetrahedron list and at the end of the known tetrahedra list
c
      k = 0
      do i = ntfree, max(ntfree-3,1), -1
         k = k + 1
         position(k) = freespace(i)
      end do
      ntfree = max(ntfree-4,0)
      do i = k+1, 4
         ntetra = ntetra + 1
         position(i) = ntetra
      end do
      tetra_last = position(4)
c
c     "itetra" is set to 0, and added to the kill list
c
      tinfo(itetra) = ibclr(tinfo(itetra),1)
      ntkill = 1
      killspace(ntkill) = itetra
c
c     the tetrahedron is defined as (IJKL), then four new tetrahedra
c     are created: JKLP, IKLP, IJLP, and IJKP, where P is the new
c     point to be included
c
c     for each new tetrahedron define all four neighbors, for
c     each neighbor store the index of the vertex opposite to 
c     the common face in "tnindex"
c
c     for JKLP, the neighbors are IKLP, IJLP, IJKP and neighbor
c        of IJKL on face JKL
c     for IKLP, the neighbors are JKLP, IJLP, IJKP and neighbor
c        of IJKL on face IKL
c     for IJLP, the neighbors are JKLP, IKLP, IJKP and neighbor
c        of IJKL on face IJL
c     for IJKP, the neighbors are JKLP, IKLP, IJLP and neighbor
c        of IJKL on face IJK
c
      do i = 1, 4
         newtetra = position(i)
         nnew = nnew + 1
         newlist(nnew) = newtetra
         tinfo(newtetra) = 0
         tnindex(newtetra) = 0
         k = 0
         do j = 1, 4
            if (j .ne. i) then
               k = k + 1
               tetra(k,newtetra) = vertex(j)
               tneighbor(k,newtetra) = position(j)
               ival = idx_list(k,i) - 1
               call mvbits (ival,0,2,tnindex(newtetra),2*(k-1))
            end if
         end do
         jtetra = neighbor(i)
         idx = nindex(i)
         tetra(4,newtetra) = ipoint
         tneighbor(4,newtetra) = jtetra
         ival = idx - 1
         call mvbits (ival,0,2,tnindex(newtetra),6)
         call mvbits (ikeep,2+i,1,tinfo(newtetra),2+i)
         if (jtetra.ne.0 .and. idx.ne.0) then
            tneighbor(idx,jtetra) = newtetra
            ival = 3
            call mvbits (ival,0,2,tnindex(jtetra),2*(idx-1))
         end if
         tinfo(newtetra) = ibset(tinfo(newtetra),1)
c
c     store the tetrahedron orientation, (jklp) and (ijlp) are
c     clockwise, while (iklp) and (ijkp) are counter-clockwise 
c
         fact = -fact
         if (fact .eq. 1)  tinfo(newtetra) =
     &                        ibset(tinfo(newtetra),0)
      end do
c
c     add all four faces of new tetraheda in the linkfacet queue,
c     each linkfacet is a triangle implicitly defined as intersection
c     of two tetrahedra
c
c     for facet JKL, tetrahedra are JKLP and neighbor of IJKL on JKL
c     for facet IKL, tetrahedra are IKLP and neighbor of IJKL on IKL
c     for facet IJL, tetrahedra are IJLP and neighbor of IJKL on IJL
c     for facet IJK, tetrahedra are IJKP and neighbor of IJKL on IJK
c
      nlinkfacet = 0
      do i = 1, 4
         newtetra = position(i)
         nlinkfacet = nlinkfacet + 1
         linkfacet(1,nlinkfacet) = newtetra
         linkfacet(2,nlinkfacet) = tneighbor(4,newtetra)
         linkindex(1,nlinkfacet) = 4
         ival = ibits(tnindex(newtetra),6,2)
         linkindex(2,nlinkfacet) = ival + 1
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine define_facet  --  facet between two tetrahedra  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "define_facet" a triangle or facet is defined by intersection
c     of two tetrahedra; knowing the position of its three vertices
c     in the first tetrahedron, find the indices of these vertices
c     in the second tetrahedron; also stores information about the
c     neighbors of the two tetrahedra considered
c
c     note the vertices are called A, B, C, P and O, where (ABC) is
c     the common facet
c
c     variables and parameters:
c
c     itetra    index of the tetrahedra (a,b,c,p) considered
c     jtetra    index of the tetrahedra (a,b,c,o) considered
c     idx_o     position of o in the vertices of jtetra
c     itouch    itouch(i) is the tetrahedron sharing
c                 the face opposite to i in tetrahedron itetra
c     idx       idx(i) is the vertex of itouch(i) opposite
c                 to the face shared with itetra
c     jtouch    jtouch(i) is the tetrahedron sharing
c                 the face opposite to i in tetrahedron jtetra
c     jdx       jdx(i) is the vertex of jtouch(i) opposite
c                 to the face shared with jtetra
c
c
      subroutine define_facet (itetra,jtetra,idx_o,facei,facej)
      use shapes
      implicit none
      integer i,k,idx_o
      integer ia,ib,ie,if
      integer itetra,jtetra
      integer other(3,4)
      integer other2(2,4,4)
      integer facei(3)
      integer facej(3)
      data other   / 2, 3, 4, 1, 3, 4, 1, 2, 4, 1, 2, 3 /
      data other2  / 0, 0, 3, 4, 2, 4, 2, 3, 3, 4, 0, 0,
     &               1, 4, 1, 3, 2, 4, 1, 4, 0, 0, 1, 2,
     &               2, 3, 1, 3, 1, 2, 0, 0 /
      save
c
c
c     find the three vertices that define the common face and
c     store in the array triangle, then find vertices P and O
c
      do i = 1, 3
         facei(i) = i
      end do
      ia = tetra(1,itetra)
      do i = 1, 3
         k = other(i,idx_o)
         ie = tetra(k,jtetra)
         if (ia .eq. ie) then
            facej(1) = k
            goto 10
         end if
      end do
   10 continue
      ib = tetra(2,itetra)
      ie = other2(1,facej(1),idx_o)
      if = other2(2,facej(1),idx_o)
      if (ib .eq. tetra(ie,jtetra)) then
         facej(2) = ie
         facej(3) = if
      else
         facej(2) = if
         facej(3) = ie
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine find_tetra  --  tests for existing tetrahedron  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "find_tetra" tests if four given points form an existing
c     tetrahedron in the current Delaunay
c
c     variables and parameters:
c
c     itetra      index of tetrahedron ABCP
c     idx_c       index of C in tetrahedron ABCP
c     o           index of the vertex O
c     ifind       set to 1 if tetrahedron exists, 0 otherwise
c     tetra_loc   index of existing tetrahedron, if it exists
c
c     first test if tetrahedron ABPO exists, if it exists it is a
c     neighbor of ABCP, on the face opposite to vertex C, then test
c     that tetrahedron and see if it contains O
c
c
      subroutine find_tetra (itetra,idx_c,a,b,o,ifind,
     &                       tetra_loc,idx_a,idx_b)
      use shapes
      implicit none
      integer i,ifind,ival
      integer itetra,tetra_loc
      integer ot,otx,otest
      integer idx_c,idx_a,idx_b
      integer o,a,b
      save
c
c
      ot = tneighbor(idx_c,itetra)
      ival = ibits(tnindex(itetra),2*(idx_c-1),2)
      otx = ival + 1
      otest = tetra(otx,ot)
c
c     locate the tetrahedron, then find the position of A and B
c
      if (otest .eq. o) then
         ifind = 1
         tetra_loc = ot
         do i = 1, 4
            if (tetra(i,tetra_loc) .eq. a) then
               idx_a = i
            else if (tetra(i,tetra_loc) .eq. b) then
               idx_b = i
            end if
         end do
      else
         ifind = 0
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine flipjw_2_3  --  2->3 flip for triangulation  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "flipjw_2_3" implements a 2->3 flip for regular triangulation
c
c     the 2->3 flip is a transformation in which two tetrahedra are
c     flipped into three tetrahedra. The two tetrahedra ABCP and
c     ABCO share a triangle ABC which is in the linkfacet of the
c     current point P added to the triangulation
c
c     this flip is only possible if the union of the two tetrahedra
c     is convex, and if their shared triangle is not locally regular
c
c     assume that these tests have been performed and satisfied,
c     once the flip has been performed three tetrahedra are added
c     and three new link facets are added to the link facet queue
c
c     variables and parameters:
c
c     itetra       index of the tetrahedra (a,b,c,p) considered
c     jtetra       index of the tetrahedra (a,b,c,o) considered
c     vertices     the five vertices a,b,c,o,p
c     facei        indices of the vertices a,b,c in (a,b,c,p)
c     facej        indices of the vertices a,b,c in (a,b,c,o)
c     test_abpo    orientation of the four points a,b,p,o
c     test_bcpo    orientation of the four points b,c,p,o
c     test_capo    orientation of the four points c,a,p,o
c     nlinkfacet   three new link facets are added
c     linkfacet    the three faces of the initial tetrahedron
c                    (a,b,c,o) containing the vertex o are added
c                    as link facets
c     linkindex    linkfacet is a triangle defined from its
c                    two neighboring tetrahedra; store the position
c                    of the vertex opposite to the triangle in each
c                    tetrehedron in the array linkindex
c     ierr         set to 1 if flip was not possible
c
c
      subroutine flipjw_2_3 (itetra,jtetra,vertices,facei,facej,
     &                       test_abpo,test_bcpo,test_capo,ierr,
     &                       tetra_last)
      use shapes
      implicit none
      integer i,j,k,o,p
      integer ierr
      integer itetra,jtetra
      integer it,jt,idx,jdx
      integer ival,ikeep,jkeep
      integer newtetra
      integer tetra_last
      integer jtetra_touch(3)
      integer itetra_touch(3)
      integer jtetra_idx(3)
      integer itetra_idx(3)
      integer idx_list(2,3)
      integer face(3),vertices(5)
      integer facei(3),facej(3)
      integer tests(3),position(3)
      logical test_abpo,test_bcpo,test_capo
      data idx_list  / 1, 1, 1, 2, 2, 2 /
      save
c
c
c     if itetra or jtetra are inactive, then cannot flip
c
      ierr = 0
      if (.not.btest(tinfo(itetra),1) .or. 
     &    .not.btest(tinfo(jtetra),1)) then
         ierr = 1
         return
      end if
c
c     itetra_touch   the three tetrahedra that touches itetra on
c                      the faces opposite to the 3 vertices a,b,c
c     itetra_idx     for the three tetrahedra defined by itetra_touch,
c                      index of the vertex opposite to the face
c                      common with itetra
c     jtetra_touch   the three tetrahedra that touches jtetra on the
c                      faces opposite to the 3 vertices a,b,c
c     jtetra_idx     for the three tetrahedra defined by jtetra_touch,
c                      index of the vertex opposite to the face
c                      common with jtetra
c
      do i = 1, 3
         itetra_touch(i) = tneighbor(facei(i),itetra)
         ival = ibits(tnindex(itetra),2*(facei(i)-1),2)
         itetra_idx(i) = ival + 1
         jtetra_touch(i) = tneighbor(facej(i),jtetra)
         ival = ibits(tnindex(jtetra),2*(facej(i)-1),2)
         jtetra_idx(i) = ival + 1
      end do
c
c     first three vertices define triangle that is removed
c
      face(1) = vertices(1)
      face(2) = vertices(2)
      face(3) = vertices(3)
      p = vertices(4)
      o = vertices(5)
c
c     three tetrahedra are stored in free space in the tetrahedron
c     list and at the end of the list of known tetrahedra if needed
c
      k = 0
      do i = ntfree, max(ntfree-2,1), -1
         k = k + 1
         position(k) = freespace(i)
      end do
      ntfree = max(ntfree-3,0)
      do i = k+1, 3
         ntetra = ntetra + 1
         position(i) = ntetra
      end do
      tetra_last = position(3)
c
c     set itetra and jtetra to 0, and add them to kill list
c
      ikeep = tinfo(itetra)
      jkeep = tinfo(jtetra)
      tinfo(itetra) = ibclr(tinfo(itetra),1)
      tinfo(jtetra) = ibclr(tinfo(jtetra),1)
      killspace(ntkill+1) = itetra
      killspace(ntkill+2) = jtetra
      ntkill = ntkill + 2
c
c     the vertices A, B and C are the first vertices of itetra,
c        and the other two vertices P and O
c     for each vertex in the triangle, define the opposing faces
c        in the two tetrahedra itetra and jtetra, and tetrahedra
c        that share faces with itetra and jtetra, respectively,
c     this information is stored in itetra_touch and jtetra_touch
c
c     for bookkeeping reasons, always store P as the last vertex
c
c     define the three new tetrahedra BCOP, ACOP and ABOP as well
c     as their neighbors
c
c     for BCOP, the neighbors are ACOP, ABOP, neighbor of ABCP on
c        on face BCP, and neighbor of ABCO on face BCO
c     for ACOP, the neighbors are BCOP, ABOP, neighbor of ABCP on
c        on face ACP, and neighbor of ABCO on face ACO
c     for ABOP, the neighbors are BCOP, ACOP, neighbor of ABCP on
c        on face ABP, and neighbor of ABCO on face ABO
c
      tests(1) = 1
      if (test_bcpo)  tests(1) = -1
      tests(2) = -1
      if (test_capo)  tests(2) = 1
      tests(3) = 1
      if (test_abpo)  tests(3) = -1
      do i = 1, 3
         newtetra = position(i)
         nnew = nnew + 1
         newlist(nnew) = newtetra
         tinfo(newtetra) = 0
         tnindex(newtetra) = 0
         k = 0
         do j = 1, 3
            if (j .ne. i) then
               k = k + 1
               tetra(k,newtetra) = face(j)
               tneighbor(k,newtetra) = position(j)
               ival = idx_list(k,i) - 1
               call mvbits (ival,0,2,tnindex(newtetra),2*(k-1))
            end if
         end do
         tetra(3,newtetra) = o
         it = itetra_touch(i)
         idx = itetra_idx(i)
         tneighbor(3,newtetra) = it
         ival = idx - 1
         call mvbits (ival,0,2,tnindex(newtetra),4)
         call mvbits (ikeep,2+facei(i),1,tinfo(newtetra),5)
         if (idx.ne.0 .and. it.ne.0) then
            tneighbor(idx,it) = newtetra
            ival = 2
            call mvbits (ival,0,2,tnindex(it),2*(idx-1))
         end if
         tetra(4,newtetra) = p
         jt = jtetra_touch(i)
         jdx = jtetra_idx(i)
         tneighbor(4,newtetra) = jt
         ival = jdx - 1
         call mvbits (ival,0,2,tnindex(newtetra),6)
         call mvbits (jkeep,2+facej(i),1,tinfo(newtetra),6)
         if (jdx.ne.0 .and. jt.ne.0) then
            tneighbor(jdx,jt) = newtetra
            ival = 3
            call mvbits (ival,0,2,tnindex(jt),2*(jdx-1))
         end if
         tinfo(newtetra) = ibset(tinfo(newtetra),1)
         if (tests(i) .eq. 1) then
            tinfo(newtetra) = ibset(tinfo(newtetra),0)
         end if
      end do
c
c     add all three faces of jtetra containing O in the linkfacet
c     queue, each linkfacet is a triangle implicitly defined as the 
c     intersection of two tetrahedra
c
c     for facet BCO, tetrahedra are BCOP and neighbor of ABCO on BCO
c     for facet ACO, tetrahedra are ACOP and neighbor of ABCO on ACO
c     for facet ABO, tetrahedra are ABOP and neighbor of ABCO on ABO
c
      do i = 1, 3
         newtetra = position(i)
         nlinkfacet = nlinkfacet + 1
         linkfacet(1,nlinkfacet) = newtetra
         linkfacet(2,nlinkfacet) = tneighbor(4,newtetra)
         linkindex(1,nlinkfacet) = 4
         ival = ibits(tnindex(newtetra),6,2)
         linkindex(2,nlinkfacet) = ival + 1
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine flipjw_3_2  --  3->2 flip for triangulation  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "flipjw_3_2" implements a 3->2 flip for regular triangulation
c
c     the 3->2 flip is a transformation in which three tetrahedra are
c     flipped into two tetrahedra, the three tetrahedra ABPO, ABCP and
c     ABCO share an edge AB which is in the linkfacet of the current
c     point P added to the triangulation
c
c     this flip is only possible if the edge AB is reflex, with degree
c     three, assume these tests have been performed and satisfied, 
c     once the flip has been performed, two new tetrahedra are added
c     and two new "link facet" are added to the link facet queue
c
c     variables and parameters:
c
c     itetra       index of the tetrahedron ABCP considered
c     jtetra       index of the tetrahedron ABCO considered
c     ktetra       index of the tetrahedron ABOP considered
c     vertices     the five vertices A, B, C, P and O
c     edgei        indices of AB in ABCP
c     edgej        indices of AB in ABCO
c     edgek        indices of AB in ABOP
c     test_bcpo    orientation of the four points BCPO
c     test_acpo    orientation of the four points ACPO
c     nlinkfacet   two new link facets are added
c     linkfacet    the two faces of the initial tetrahedron
c                    ABOP containing the edge op are added
c                    as link facets
c     linkindex    linkfacet is a triangle defined from its two
c                    neighboring tetrahedra, store the position
c                    of the vertex opposite to the triangle in each
c                    tetrehedron in the array linkindex
c     ierr         set to 1 if flip was not possible
c
c
      subroutine flipjw_3_2 (itetra,jtetra,ktetra,vertices,edgei,
     &                       edgej,edgek,test_bcpo,test_acpo,ierr,
     &                       tetra_last)
      use shapes
      implicit none
      integer i,j,k,c,o,p
      integer ierr,ival
      integer ikeep,jkeep,kkeep
      integer itetra,jtetra,ktetra
      integer it,jt,kt,idx,jdx,kdx
      integer newtetra
      integer tetra_last
      integer edge(2),tests(2)
      integer vertices(5)
      integer itetra_touch(2)
      integer jtetra_touch(2)
      integer ktetra_touch(2)
      integer itetra_idx(2)
      integer jtetra_idx(2)
      integer ktetra_idx(2)
      integer position(2)
      integer edgei(2),edgej(2)
      integer edgek(2)
      logical test_bcpo,test_acpo
      save
c
c
      tests(1) = 1
      if (test_bcpo)  tests(1) = -1
      tests(2) = 1
      if (test_acpo)  tests(2) = -1
      ierr = 0
c
c     if itetra, jtetra or ktetra are inactive, cannot flip
c
      if (.not.btest(tinfo(itetra),1) .or.
     &    .not.btest(tinfo(jtetra),1) .or.
     &    .not.btest(tinfo(ktetra),1)) then
         ierr = 1
         return
      end if
c
c     store the old information
c
      ikeep = tinfo(itetra)
      jkeep = tinfo(jtetra)
      kkeep = tinfo(ktetra)
c
c     itetra_touch   indices of the two tetrahedra that share the
c                      faces opposite to A and B in itetra
c     itetra_idx     for the two tetrahedra defined by itetra_touch,
c                      index position of vertex opposite the face
c                      common with itetra
c     jtetra_touch   indices of the two tetrahedra that share the
c                      faces opposite to a and b in jtetra
c     jtetra_idx     for the two tetrahedra defined by jtetra_touch,
c                      index position of vertex opposite the face
c                      common with jtetra
c     ktetra_touch   indices of the two tetrahedra that share the
c                      faces opposite to a and b in ktetra
c     ktetra_idx     for the two tetrahedra defined by ktetra_touch,
c                      index position of vertex opposite the face
c                      common with ktetra
c
      do i = 1, 2
         itetra_touch(i) = tneighbor(edgei(i),itetra)
         jtetra_touch(i) = tneighbor(edgej(i),jtetra)
         ktetra_touch(i) = tneighbor(edgek(i),ktetra)
         ival = ibits(tnindex(itetra),2*(edgei(i)-1),2)
         itetra_idx(i) = ival + 1
         ival = ibits(tnindex(jtetra),2*(edgej(i)-1),2)
         jtetra_idx(i) = ival + 1
         ival = ibits(tnindex(ktetra),2*(edgek(i)-1),2)
         ktetra_idx(i) = ival + 1
      end do
      edge(1) = vertices(1)
      edge(2) = vertices(2)
      c = vertices(3)
      p = vertices(4)
      o = vertices(5)
c
c     store the new tetrahedra in "free" space or at the list end
c
      k = 0
      do i = ntfree, max(ntfree-1,1), -1
         k = k + 1
         position(k) = freespace(i)
      end do
      ntfree = max(ntfree-2,0)
      do i = k+1, 2
         ntetra = ntetra + 1
         position(i) = ntetra
      end do
      tetra_last = position(2)
c
c     itetra, jtetra and ktetra become available and are added
c     to the kill list
c
      tinfo(itetra) = ibclr(tinfo(itetra),1)
      tinfo(jtetra) = ibclr(tinfo(jtetra),1)
      tinfo(ktetra) = ibclr(tinfo(ktetra),1)
      killspace(ntkill+1) = itetra
      killspace(ntkill+2) = jtetra
      killspace(ntkill+3) = ktetra
      ntkill = ntkill + 3
c
c     the two vertices that define their common edge AB are
c        stored in the array edge
c     the vertices C, P and O form the new triangle
c     for each vertex in the edge AB, define the opposing faces
c        in the tetrahedra itetra, jtetra and ktetra, and the
c        tetrahedron that share these faces with itetra, jtetra
c        and ktetra, respectively
c     this info is stored in itetra_touch, jtetra_touch and
c        ktetra_touch
c
c     always set P to be the last vertex of the new tetrahedra
c
c     define new tetrahedra BCOP and ACOP as well as their neighbors
c
c     for BCOP, the neighbors are ACOP, neighbor of ABOP on face
c        BPO, neighbor of ABCP on face BCP, and neighbor of ABCO
c        on face BCO
c     for ACOP, the neighbors are BCOP, neighbor of ABOP on face
c        APO, neighbor of ABCP on face ACP, and neighbor of ABCO
c        on face ACO
c
      do i = 1, 2
         newtetra = position(i)
         nnew = nnew + 1
         newlist(nnew) = newtetra
         tinfo(newtetra) = 0
         tnindex(newtetra) = 0
         k = 0
         do j = 1, 2
            if (j .ne. i) then
               k = k + 1
               tetra(k,newtetra) = edge(j)
               tneighbor(k,newtetra) = position(j)
            end if
         end do
         tetra(2,newtetra) = c
         kt = ktetra_touch(i)
         kdx = ktetra_idx(i)
         tneighbor(2,newtetra) = kt
         ival = kdx - 1
         call mvbits (ival,0,2,tnindex(newtetra),2)
         call mvbits (kkeep,2+edgek(i),1,tinfo(newtetra),4)
         if (kdx.ne.0 .and. kt.ne.0) then
            tneighbor(kdx,kt) = newtetra
            ival = 1
            call mvbits (ival,0,2,tnindex(kt),2*(kdx-1))
         end if
         tetra(3,newtetra) = o
         it = itetra_touch(i)
         idx = itetra_idx(i)
         tneighbor(3,newtetra) = it
         ival = idx - 1
         call mvbits (ival,0,2,tnindex(newtetra),4)
         call mvbits (ikeep,2+edgei(i),1,tinfo(newtetra),5)
         if (idx.ne.0 .and. it.ne.0) then
            tneighbor(idx,it) = newtetra
            ival = 2
            call mvbits (ival,0,2,tnindex(it),2*(idx-1))
         end if
         tetra(4,newtetra) = p
         jt = jtetra_touch(i)
         jdx = jtetra_idx(i)
         tneighbor(4,newtetra) = jt
         ival = jdx - 1
         call mvbits (ival,0,2,tnindex(newtetra),6)
         call mvbits (jkeep,2+edgej(i),1,tinfo(newtetra),6)
         if (jdx.ne.0 .and. jt.ne.0) then
            tneighbor(jdx,jt) = newtetra
            ival = 3
            call mvbits (ival,0,2,tnindex(jt),2*(jdx-1))
         end if
         tinfo(newtetra) = ibset(tinfo(newtetra),1)
         if (tests(i) .eq. 1) then
            tinfo(newtetra) = ibset(tinfo(newtetra),0)
         end if
      end do
c
c     add the two faces of ktetra containing CO in the linkfacet
c     queue, each linkfacet is a triangle implicitly defined as the 
c     intersection of two tetrahedra
c
c     for facet BCO, tetrahedra are BCOP and neighbor of ABCO on BCO
c     for facet ACO, tetrahedra are ACOP and neighbor of ABCO on ACO
c
      do i = 1, 2
         newtetra = position(i)
         nlinkfacet = nlinkfacet + 1
         linkfacet(1,nlinkfacet) = newtetra
         linkfacet(2,nlinkfacet) = tneighbor(4,newtetra)
         linkindex(1,nlinkfacet) = 4
         ival = ibits(tnindex(newtetra),6,2) + 1
         linkindex(2,nlinkfacet) = ival
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine flipjw_4_1  --  4->1 flip for triangulation  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "flipjw_4_1" implements a 4->1 flip for regular triangulation
c
c     the 4->1 flip is a transformation where four tetrahedra are
c     flipped into one tetrahedron; the four tetrahedra ABOP, BCOP,
c     ABCP and ABO share a vertex B which is in the linkfacet of
c     the current point P added to the triangulation, after the
c     flip, B is set to redundant
c
c     this flip is only possible if the two edges AB and BC are
c     reflex of order 3
c
c     assume that these tests have been performed and satisfied,
c     once the flip has been performed one tetrahedron is added
c     and one new link facet is added to the link facet queue
c
c     variables and parameters:
c
c     itetra      index of the tetrahedra ABCP considered
c     jtetra      index of the tetrahedra ABCO considered
c     ktetra      index of the tetrahedra ABOP considered
c     ltetra      index of the tetrahedra BCOP considered
c     vertices    index of A, B, C, P, O
c     idp         index of B in ABCP
c     jdp         index of B in ABCO
c     kdp         index of B in ABOP
c     ldp         index of B in BCOP
c     test_acpo   orientation of the four points A, C, P and O
c     linkfacet   face of the initial tetrahedron ABCO opposite
c                   to the vertex b is added as link facet
c     linkindex   linkfacet is a triangle defined from its two
c                   neighboring tetrahedra, store the position
c                   of the vertex opposite to the triangle in
c                   each tetrehedron in the array "linkindex"
c     ierr        set to 1 if flip was not possible
c
c
      subroutine flipjw_4_1 (itetra,jtetra,ktetra,ltetra,vertices,idp,
     &                       jdp,kdp,ldp,test_acpo,ierr,tetra_last)
      use shapes
      implicit none
      integer a,b,c,o,p
      integer ierr,ival
      integer ikeep,jkeep
      integer kkeep,lkeep
      integer itetra,jtetra
      integer ktetra,ltetra
      integer ishare,jshare
      integer kshare,lshare
      integer idx,jdx,kdx,ldx
      integer idp,jdp,kdp,ldp
      integer test1,newtetra
      integer tetra_last
      integer vertices(5)
      logical test_acpo
      save
c
c
      ierr = 0
      test1 = 1
      if (test_acpo)  test1 = -1
c
c     if itetra, jtetra, ktetra, ltetra are inactive, cannot flip
c
      if (.not.btest(tinfo(itetra),1) .or. 
     &    .not.btest(tinfo(jtetra),1) .or.
     &    .not.btest(tinfo(ktetra),1) .or.
     &    .not.btest(tinfo(ltetra),1)) then
         ierr = 1
         return
      end if
c
c     store the "old" info
c
      ikeep = tinfo(itetra)
      jkeep = tinfo(jtetra)
      kkeep = tinfo(ktetra)
      lkeep = tinfo(ltetra)
c
c     ishare   index of tetrahedron sharing the face 
c                opposite to b in itetra
c     idx      index of the vertex of ishare opposite to the
c                face of ishare shared with itetra
c     jshare   index of tetrahedron sharing the face 
c                opposite to b in jtetra
c     jdx      index of the vertex of jshare opposite to the
c                face of jshare shared with jtetra
c     kshare   index of tetrahedron sharing the face 
c                opposite to b in ktetra
c     kdx      index of the vertex of kshare opposite to the
c                face of kshare shared with ktetra
c     lshare   index of tetrahedron sharing the face 
c                opposite to b in ltetra
c     ldx      index of the vertex of lshare opposite to the
c                face of lshare shared with ltetra
c
      ishare = tneighbor(idp,itetra)
      jshare = tneighbor(jdp,jtetra)
      kshare = tneighbor(kdp,ktetra)
      lshare = tneighbor(ldp,ltetra)
      ival = ibits(tnindex(itetra),2*(idp-1),2)
      idx = ival + 1
      ival = ibits(tnindex(jtetra),2*(jdp-1),2)
      jdx = ival + 1
      ival = ibits(tnindex(ktetra),2*(kdp-1),2)
      kdx = ival + 1
      ival = ibits(tnindex(ltetra),2*(ldp-1),2)
      ldx = ival + 1
c
c     store the new tetrahedron in place of itetra
c
      if (ntfree .ne. 0) then
         newtetra = freespace(ntfree)
         ntfree = ntfree - 1
      else
         ntetra = ntetra + 1
         newtetra = ntetra
      end if
      tetra_last = newtetra
      nnew = nnew + 1
      newlist(nnew) = newtetra
      tinfo(newtetra) = 0
      tnindex(newtetra) = 0
c
c     jtetra, ktetra and ltetra become "available", so they
c     are added to the "kill" zone
c
      killspace(ntkill+1) = itetra
      killspace(ntkill+2) = jtetra
      killspace(ntkill+3) = ktetra
      killspace(ntkill+4) = ltetra
      ntkill = ntkill + 4
      tinfo(itetra) = ibclr(tinfo(itetra),1)
      tinfo(jtetra) = ibclr(tinfo(jtetra),1)
      tinfo(ktetra) = ibclr(tinfo(ktetra),1)
      tinfo(ltetra) = ibclr(tinfo(ltetra),1)
c
c     the vertex B that is shared by all four tetrahedra, the other
c     vertices are A, C, P and O; for each tetrahedron, find neighbor
c     attached to the face oposite to B
c
      a = vertices(1)
      b = vertices(2)
      c = vertices(3)
      p = vertices(4)
      o = vertices(5)
c
c     note P is set to be the last vertex of the new tetrahedron,
c     define the new tetrahedron, ACOP
c
      vinfo(b) = ibclr(vinfo(b),0)
      tetra(1,newtetra) = a
      tneighbor(1,newtetra) = lshare
      ival = ldx - 1
      call mvbits (ival,0,2,tnindex(newtetra),0)
      call mvbits (lkeep,2+ldp,1,tinfo(newtetra),3)
      if (lshare.ne.0 .and. ldx.ne.0) then
         tneighbor(ldx,lshare) = newtetra
         ival = 0
         call mvbits (ival,0,2,tnindex(lshare),2*(ldx-1))
      end if
      tetra(2,newtetra) = c
      tneighbor(2,newtetra) = kshare
      ival = kdx - 1
      call mvbits (ival,0,2,tnindex(newtetra),2)
      call mvbits (kkeep,2+kdp,1,tinfo(newtetra),4)
      if (kshare.ne.0 .and. kdx.ne.0) then
         tneighbor(kdx,kshare) = newtetra
         ival = 1
         call mvbits (ival,0,2,tnindex(kshare),2*(kdx-1))
      end if
      tetra(3,newtetra) = o
      tneighbor(3,newtetra) = ishare
      ival = idx - 1
      call mvbits (ival,0,2,tnindex(newtetra),4)
      call mvbits (ikeep,2+idp,1,tinfo(newtetra),5)
      if (ishare.ne.0 .and. idx.ne.0) then
         tneighbor(idx,ishare) = newtetra
         ival = 2
         call mvbits (ival,0,2,tnindex(ishare),2*(idx-1))
      end if
      tetra(4,newtetra) = p
      tneighbor(4,newtetra) = jshare
      ival = jdx - 1
      call mvbits (ival,0,2,tnindex(newtetra),6)
      call mvbits (jkeep,2+jdp,1,tinfo(newtetra),6)
      if (jshare.ne.0 .and. jdx.ne.0) then
         tneighbor(jdx,jshare) = newtetra
         ival = 3
         call mvbits (ival,0,2,tnindex(jshare),2*(jdx-1))
      end if
      tinfo(newtetra) = ibset(tinfo(newtetra),1)
      if (test1 .eq. 1) then
         tinfo(newtetra) = ibset(tinfo(newtetra),0)
      end if
c
c     for facet ACO, tetrahedra are ACOP and neighbor of ABCO on ACO
c
      nlinkfacet = nlinkfacet + 1
      linkfacet(1,nlinkfacet) = newtetra
      linkfacet(2,nlinkfacet) = jshare
      linkindex(1,nlinkfacet) = 4
      linkindex(2,nlinkfacet) = jdx
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine remove_inf  --  sets status of tetrahedron   ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "remove_inf" sets the status to zero for tetrahedra that
c     contain infinite points
c
c
      subroutine remove_inf
      use shapes
      implicit none
      integer i,a,b,c,d
      save
c
c
      do i = 1, ntetra
         if (btest(tinfo(i),1)) then
            a = tetra(1,i)
            b = tetra(2,i)
            c = tetra(3,i)
            d = tetra(4,i)
            if (a.le.4 .or. b.le.4 .or. c.le.4 .or. d.le.4) then
               tinfo(i) = ibset(tinfo(i),2)
               tinfo(i) = ibclr(tinfo(i),1)
               if (a .le. 4)  call mark_zero (i,1)
               if (b .le. 4)  call mark_zero (i,2)
               if (c .le. 4)  call mark_zero (i,3)
               if (d .le. 4)  call mark_zero (i,4)
            end if
         end if
      end do
      do i = 1, 4
         vinfo(i) = ibclr(vinfo(i),0)
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine mark_zero  --  marks a touching tetrahedron  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "mark_zero" marks the tetrahedron that touches a tetrahedron
c     with infinite point as part of the convex hull (i.e., one of
c     its neighbors is zero)
c
c
      subroutine mark_zero (itetra,ivertex)
      use shapes
      implicit none
      integer ival
      integer itetra,ivertex
      integer jtetra,jvertex
      save
c
c
      jtetra = tneighbor(ivertex,itetra)
      if (jtetra .ne. 0) then
         ival = ibits(tnindex(itetra),2*(ivertex-1),2)
         jvertex = ival + 1
         tneighbor(jvertex,jtetra) = 0
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine peel  --  removes flat tetrahedra at boundary  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "peel" removes the flat tetrahedra at the boundary of the DT
c
c
      subroutine peel (ntry)
      use shapes
      implicit none
      integer i,j,k,m
      integer ia,ib,ic,id,val
      integer ntry,ival
      real*8 vol
      save
c
c
c     loop over all tetrahedra, and test the tetrahedra at
c     the boundary
c
      ntry = 0
      do i = 1, ntetra
         if (btest(tinfo(i),1)) then
            do j = 1, 4
               if (tneighbor(j,i) .eq. 0)  goto 10
            end do
c
c     the tetrahedron idx is interior, and cannot be flat
c
            goto 20
   10       continue
c
c     the tetrahedron is at the boundary; test if it is flat,
c     i.e., if its volume is 0
c
            ia = tetra(1,i)
            ib = tetra(2,i)
            ic = tetra(3,i)
            id = tetra(4,i)
            call tetra_vol (crdball,ia,ib,ic,id,vol)
            if (abs(vol) .lt. epsln4) then
               call minor4x (crdball,ia,ib,ic,id,val)
               if (val .eq. 0) then
                  tinfo(i) = ibset(tinfo(i),2)
                  ntry = ntry + 1
               end if
            end if
   20       continue
         end if
      end do
c
c     remove flat tetrahedra and update links to their neighbors
c
      do i = 1, ntetra
         if (btest(tinfo(i),2)) then
            if (btest(tinfo(i),1)) then
               tinfo(i) = ibclr(tinfo(i),1)
               do j = 1, 4
                  k = tneighbor(j,i)
                  if (k .ne. 0) then
                     ival = ibits(tnindex(i),2*(j-1),2)
                     m = ival + 1
                     tneighbor(m,k) = 0
                  end if
               end do
            end if
         end if
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine tetra_vol  --  find the volume of tetrahedron  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "tetra_vol" computes the volume of a tetrahedron
c
c     variables and parameters:
c
c     coord         array containing coordinates of all vertices
c     ia,ib,ic,id   four vertices defining the tetrahedron
c     vol           volume of the tetrahedron via floating point
c
c
      subroutine tetra_vol (crdball,ia,ib,ic,id,vol)
      implicit none
      integer i
      integer ia,ib,ic,id
      real*8 vol
      real*8 ad(3),bd(3),cd(3)
      real*8 sbcd(3)
      real*8 crdball(*)
      save
c
c     volume of the tetrahedron is proportional to:
c
c     vol = det | a(1)  a(2)  a(3) 1 |
c               | b(1)  b(2)  b(3) 1 |
c               | c(1)  c(2)  c(3) 1 |
c               | d(1)  d(2)  d(3) 1 |
c
c     after substracting the last row from the first 3 rows, and
c     developping with respect to the last column, we obtain:
c
c     vol = det | ad(1)  ad(2)  ad(3) |
c               | bd(1)  bd(2)  bd(3) |
c               | cd(1)  cd(2)  cd(3) |
c
c     where ad(i) = a(i) - d(i), etc.
c
      do i = 1, 3
         ad(i) = crdball(3*(ia-1)+i) - crdball(3*(id-1)+i)
         bd(i) = crdball(3*(ib-1)+i) - crdball(3*(id-1)+i)
         cd(i) = crdball(3*(ic-1)+i) - crdball(3*(id-1)+i)
      end do
      sbcd(3) = bd(1)*cd(2) - cd(1)*bd(2)
      sbcd(2) = bd(1)*cd(3) - cd(1)*bd(3)
      sbcd(1) = bd(2)*cd(3) - cd(2)*bd(3)
      vol = ad(1)*sbcd(1) - ad(2)*sbcd(2) + ad(3)*sbcd(3)
      if (vol < 0.0d0) vol = 0.0d0
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine sort4_sign  --  sort integers and permutation  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "sort4_sign" sorts a list of four numbers, and computes the
c     signature of the permutation
c
c
      subroutine sort4_sign (list,index,nswap,n)
      integer i,j,k
      integer n,nswap
      integer list(*)
      integer index(*)
      save
c
c
      do i = 1, n
         index(i) = i
      end do
      nswap = 1
      do i = 1, n-1
         do j = i+1, n
            if (list(i) .gt. list(j)) then
               k = list(i)
               list(i) = list(j)
               list(j) = k
               k = index(i)
               index(i) = index(j)
               index(j) = k
               nswap = -nswap
            end if
         end do
      end do
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine reorder_tetra  --  reorder tetrahedron vertices  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "reorder_tetra" reorders the vertices of a list of tetrahedra
c     such that the indices are in increasing order
c
c     if iflag is set to 1, all tetrahedra are reordered
c     if iflag is set to 0, only new tetrahedra are reordered,
c       and stored in list_tetra
c
c
      subroutine reorder_tetra (iflag)
      use shapes
      implicit none
      integer i,j,idx
      integer iflag,ival
      integer ntot,nswap
      integer index(4)
      integer vertex(4)
      integer neighbor(4)
      integer nsurf(4)
      integer nindex(4)
      save
c
c
      if (iflag .eq. 1) then
         ntot = ntetra
      else
         ntot = nnew
      end if
      do idx = 1, ntot
         if (iflag .eq. 1) then
            i = idx
         else
            i = newlist(idx)
         end if
         if (btest(tinfo(i),1)) then
            do j = 1, 4
               vertex(j) = tetra(j,i)
            end do
            call sort4_sign (vertex,index,nswap,4)
            do j = 1, 4
               neighbor(j) = tneighbor(index(j),i)
               nindex(j) = ibits(tnindex(i),2*(index(j)-1),2)
               nsurf(j) = ibits(tinfo(i),2+index(j),1)
               if (neighbor(j) .ne. 0) then
                  ival = j - 1
                  call mvbits (ival,0,2,tnindex(neighbor(j)),
     &                            2*nindex(j))
               end if
            end do
            do j = 1, 4
               tetra(j,i) = vertex(j)
               tneighbor(j,i) = neighbor(j)
               call mvbits (nindex(j),0,2,tnindex(i),2*(j-1))
               call mvbits (nsurf(j),0,1,tinfo(i),2+j)
            end do
            if (nswap .eq. -1) then
               if (btest(tinfo(i),0)) then
                  tinfo(i) = ibclr(tinfo(i),0)
               else
                  tinfo(i) = ibset(tinfo(i),0)
               end if
            end if
         end if
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine find_edges  --  list edges not fully buried  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "find_edges" builds a list of edges that are not fully buried,
c     returns the total number of edges and definition of the edges
c
c
      subroutine find_edges (nedge,edges)
      use shapes
      implicit none
      integer i,j,idx
      integer ia,ib,ic,id
      integer i1,i2,i3,i4
      integer nedge,iedge
      integer ival,edge_b
      integer trig1,trig2,trig_in
      integer trig_out,triga,trigb
      integer jtetra,ktetra,npass
      integer ipair,i_out
      integer face_info(2,6)
      integer face_pos(2,6)
      integer pair(2,6)
      integer edges(2,*)
      integer, allocatable :: tmask(:)
      data face_info  / 1, 2, 1, 3, 1, 4, 2, 3, 2, 4, 3, 4 /
      data face_pos  / 2, 1, 3, 1, 4, 1, 3, 2, 4, 2, 4, 3 /
      data pair  / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 /
      save
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (tmask(ntetra))
c
c     find list of all edges in the alpha complex
c
      do i = 1, ntetra
         tmask(i) = 0
      end do
c
c     loop over tetrahedra, if belong to the Delaunay triangulation,
c     check the edges and include in edge list if not seen before
c
c     nedge = 0
      do idx = 1, ntetra
         if (btest(tinfo(idx),1)) then
            ia = tetra(1,idx)
            ib = tetra(2,idx)
            ic = tetra(3,idx)
            id = tetra(4,idx)
c
c     check all six edges
c
            do iedge = 1, 6
c
c     if this edge has already been considered, from another
c     tetrahedron, then discard
c
               if (btest(tmask(idx),iedge-1))  goto 40
c
c     if this edge is not in the alpha complex, then discard
c
               if (.not. btest(tedge(idx),iedge-1))  goto 40
c
c     note iedge is the edge number in the tetrahedron idx, with:
c     iedge = 1 (c,d); iedge = 2 (b,d); iedge = 3 (b,c)
c     iedge = 4 (a,d); iedge = 5 (a,c); iedge = 6 (a,b)
c
c     define indices of the edge
c
               i = tetra(pair(1,iedge),idx)
               j = tetra(pair(2,iedge),idx)
c
c     set edge as buried
c
               edge_b = 1
               if (.not. btest(tinfo(idx),7))  edge_b = 0
c
c     trig1 and trig2 are the two faces of idx that share iedge
c     i1 and i2 are positions of the third vertices of trig1 and trig2
c
               trig1 = face_info(1,iedge)
               i1 = face_pos(1,iedge)
               trig2 = face_info(2,iedge)
               i2 = face_pos(2,iedge)
               i3 = tetra(i1,idx)
               i4 = tetra(i2,idx)
c
c     now we look at the star of the edge
c
               ktetra = idx
               npass = 1
               trig_out = trig1
               jtetra = tneighbor(trig_out,ktetra)
   10          continue
c
c     leave this side of the star if we hit the convex hull
c     in this case, the edge is not buried
c
               if (jtetra .eq. 0) then
                  edge_b = 0
                  goto 20
               end if
c
c     leave the loop completely if we have described the full cycle
c
               if (jtetra .eq. idx)  goto 30
c
c     identify the position of iedge in tetrahedron jtetra
c
               if (i .eq. tetra(1,jtetra)) then
                  if (j .eq. tetra(2,jtetra)) then
                     ipair = 6
                  else if (j .eq. tetra(3,jtetra)) then
                     ipair = 5
                  else
                     ipair = 4
                  end if
               else if (i .eq. tetra(2,jtetra)) then
                  if (j .eq. tetra(3,jtetra)) then
                     ipair = 3
                  else
                     ipair = 2
                  end if
               else
                  ipair = 1
               end if
               tmask(jtetra) = ibset(tmask(jtetra),ipair-1)
               if (.not. btest(tinfo(jtetra),7))  edge_b = 0
c
c     find out the face we "went in"
c
               ival = ibits(tnindex(ktetra),2*(trig_out-1),2)
               trig_in = ival + 1
c
c     we know the two faces of jtetra that share iedge
c
               triga = face_info(1,ipair)
               i1 = face_pos(1,ipair)
               trigb = face_info(2,ipair)
               i2 = face_pos(2,ipair)
               trig_out = triga
               i_out = i1
               if (trig_in .eq. triga) then
                  i_out = i2
                  trig_out = trigb
               end if
               ktetra = jtetra
               jtetra = tneighbor(trig_out,ktetra)
               if (jtetra .eq. idx)  goto 30
               goto 10
   20          continue
               if (npass .eq. 2)  goto 30
               npass = npass + 1
               ktetra = idx
               trig_out = trig2
               jtetra = tneighbor(trig_out,ktetra)
               goto 10
   30          continue
               if (edge_b .eq. 0) then
                  nedge = nedge + 1
                  edges(1,nedge) = i
                  edges(2,nedge) = j
               end if
   40          continue
            end do
         end if
      end do
c
c     sort the list of all edges into increasing order
c
      call hpsort_two_int (edges,nedge)
c
c     perform deallocation of some local arrays
c
      deallocate (tmask)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine find_all_edges  --  construct list of all edges  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "find_all_edges" builds a list of all edges in the alpha complex,
c     returns the total number of edges and definition of the edges
c
c
      subroutine find_all_edges (nedge,edges)
      use shapes
      implicit none
      integer i,j,idx
      integer ia,ib,ic,id
      integer i1,i2,i3,i4
      integer nedge,iedge,ival
      integer trig1,trig2,trig_in
      integer trig_out,triga,trigb
      integer jtetra,ktetra,npass
      integer ipair,i_out
      integer face_info(2,6)
      integer face_pos(2,6)
      integer pair(2,6)
      integer edges(2,*)
      integer, allocatable :: tmask(:)
      data face_info  / 1, 2, 1, 3, 1, 4, 2, 3, 2, 4, 3, 4 /
      data face_pos  / 2, 1, 3, 1, 4, 1, 3, 2, 4, 2, 4, 3 /
      data pair  / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 /
      save
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (tmask(ntetra))
c
c     find list of all edges in the alpha complex
c
      do i = 1, ntetra
         tmask(i) = 0
      end do
c
c     loop over tetrahedra, if belong to the Delaunay triangulation,
c     check the edges and include in edge list if not seen before
c
c     nedge = 0
      do idx = 1, ntetra
         if (btest(tinfo(idx),1)) then
            ia = tetra(1,idx)
            ib = tetra(2,idx)
            ic = tetra(3,idx)
            id = tetra(4,idx)
c
c     check all six edges
c
            do iedge = 1, 6
c
c     if this edge has already been considered, from another
c     tetrahedron, then discard
c
               if (btest(tmask(idx),iedge-1))  goto 30
c
c     if this edge is not in the alpha complex, then discard
c
               if (.not. btest(tedge(idx),iedge-1))  goto 30
c
c     note iedge is the edge number in the tetrahedron idx, with:
c     iedge = 1 (c,d); iedge = 2 (b,d); iedge = 3 (b,c)
c     iedge = 4 (a,d); iedge = 5 (a,c); iedge = 6 (a,b)
c
c     define indices of the edge
c
               i = tetra(pair(1,iedge),idx)
               j = tetra(pair(2,iedge),idx)
c
c     set edge as buried
c
               nedge = nedge + 1
               edges(1,nedge) = i
               edges(2,nedge) = j
c
c     trig1 and trig2 are the two faces of idx that share iedge
c     i1 and i2 are positions of the third vertices of trig1 and trig2
c
               trig1 = face_info(1,iedge)
               i1 = face_pos(1,iedge)
               trig2 = face_info(2,iedge)
               i2 = face_pos(2,iedge)
               i3 = tetra(i1,idx)
               i4 = tetra(i2,idx)
c
c     now we look at the star of the edge
c
               ktetra = idx
               npass = 1
               trig_out = trig1
               jtetra = tneighbor(trig_out,ktetra)
   10          continue
c
c     leave this side of the star if we hit the convex hull
c     in this case, the edge is not buried
c
               if (jtetra .eq. 0)  goto 20
c
c     leave the loop completely if we have described the full cycle
c
               if (jtetra .eq. idx)  goto 30
c
c     identify the position of iedge in tetrahedron jtetra
c
               if (i .eq. tetra(1,jtetra)) then
                  if (j .eq. tetra(2,jtetra)) then
                     ipair = 6
                  else if (j .eq. tetra(3,jtetra)) then
                     ipair = 5
                  else
                     ipair = 4
                  end if
               else if (i .eq. tetra(2,jtetra)) then
                  if (j .eq. tetra(3,jtetra)) then
                     ipair = 3
                  else
                     ipair = 2
                  end if
               else
                  ipair = 1
               end if
               tmask(jtetra) = ibset(tmask(jtetra),ipair-1)
c
c     find out the face we "went in"
c
               ival = ibits(tnindex(ktetra),2*(trig_out-1),2)
               trig_in = ival + 1
c
c     we know the two faces of jtetra that share iedge
c
               triga = face_info(1,ipair)
               i1 = face_pos(1,ipair)
               trigb = face_info(2,ipair)
               i2 = face_pos(2,ipair)
               trig_out = triga
               i_out = i1
               if (trig_in .eq. triga) then
                  i_out = i2
                  trig_out = trigb
               end if
               ktetra = jtetra
               jtetra = tneighbor(trig_out,ktetra)
               if (jtetra .eq. idx)  goto 30
               goto 10
   20          continue
               if (npass .eq. 2)  goto 30
               npass = npass + 1
               ktetra = idx
               trig_out = trig2
               jtetra = tneighbor(trig_out,ktetra)
               goto 10
   30          continue
            end do
         end if
      end do
c
c     sort list of all edges in increasing order
c
      call hpsort_two_int (edges,nedge)
c
c     perform deallocation of some local arrays
c
      deallocate (tmask)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine get_coords2  --  extracts and stores two atoms  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "get_coord2" extracts two atoms from the global array containing
c     all atoms, centers them on (0,0,0), recomputes their weights
c     and stores them in local arrays
c
c     variables and parameters:
c
c     ia,ja    indices of the four points considered
c     a,b      centered coordinates of the two points
c     ra,rb    radii of the two points
c     cg       center of gravity of the points
c
c
      subroutine get_coord2 (ia,ja,a,b,ra,rb,cg)
      use shapes
      implicit none
      integer i,ia,ja
      real*8 ra,rb
      real*8 a(*),b(*),cg(3)
c
c
c     get coordinates and center of mass, then center the points
c
      do i = 1, 3
         a(i) = crdball(3*(ia-1)+i)
         b(i) = crdball(3*(ja-1)+i)
         cg(i) = a(i) + b(i)
      end do
      do i = 1, 3
         cg(i) = 0.5d0 * cg(i)
      end do
      do i = 1, 3
         a(i) = a(i) - cg(i)
         b(i) = b(i) - cg(i)
      end do
      ra = radball(ia)
      rb = radball(ja)
      a(4) = a(1)*a(1) + a(2)*a(2) + a(3)*a(3) - ra*ra
      b(4) = b(1)*b(1) + b(2)*b(2) + b(3)*b(3) - rb*rb
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine get_coords4  --  extracts and stores four atoms  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "get_coord4" extracts four atoms from the global array containing
c     all atoms, centers them on (0,0,0), recomputes their weights and
c     stores them in local arrays
c
c     variables and parameters:
c
c     ia,ja,ka,la    indices of the four points considered
c     a,b,c,d        centered coordinates of the four points
c     ra,rb,rc,rd    radii of the four points
c     cg             center of gravity of the points
c
c
      subroutine get_coord4 (ia,ja,ka,la,a,b,c,d,ra,rb,rc,rd,cg)
      use shapes
      implicit none
      integer i,ia,ja,ka,la
      real*8 ra,rb,rc,rd
      real*8 a(*),b(*),c(*)
      real*8 d(*),cg(3)
c
c
c     get coordinates and center of mass, and center the points
c
      do i = 1, 3
         a(i) = crdball(3*(ia-1)+i)
         b(i) = crdball(3*(ja-1)+i)
         c(i) = crdball(3*(ka-1)+i)
         d(i) = crdball(3*(la-1)+i)
         cg(i) = a(i) + b(i) + c(i) + d(i)
      end do
      do i = 1, 3
         cg(i) = 0.25d0 * cg(i)
      end do
      do i = 1, 3
         a(i) = a(i) - cg(i)
         b(i) = b(i) - cg(i)
         c(i) = c(i) - cg(i)
         d(i) = d(i) - cg(i)
      end do
      ra = radball(ia)
      rb = radball(ja)
      rc = radball(ka)
      rd = radball(la)
      a(4) = a(1)*a(1) + a(2)*a(2) + a(3)*a(3) - ra*ra
      b(4) = b(1)*b(1) + b(2)*b(2) + b(3)*b(3) - rb*rb
      c(4) = c(1)*c(1) + c(2)*c(2) + c(3)*c(3) - rc*rc
      d(4) = d(1)*d(1) + d(2)*d(2) + d(3)*d(3) - rd*rd
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine get_coords5  --  extracts and stores five atoms  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "get_coord5" extracts five atoms from the global array containing
c     all atoms, centers them on (0,0,0), recomputes their weights and
c     stores them in local arrays
c
c     variables and parameters:
c
c     ia,ja,ka,la,ma    indices of the four points considered
c     a,b,c,d,e         centered coordinates of the five points
c     ra,rb,rc,rd,re    radii of the four points
c     cg                center of gravity of the points
c
c
      subroutine get_coord5 (ia,ja,ka,la,ma,a,b,c,d,e,
     &                          ra,rb,rc,rd,re,cg)
      use shapes
      implicit none
      integer i,ia,ja,ka,la,ma
      real*8 ra,rb,rc,rd,re
      real*8 a(*),b(*),c(*)
      real*8 d(*),e(*),cg(3)
c
c
c     get coordinates and center of mass, and center the points
c
      do i = 1, 3
         a(i) = crdball(3*(ia-1)+i)
         b(i) = crdball(3*(ja-1)+i)
         c(i) = crdball(3*(ka-1)+i)
         d(i) = crdball(3*(la-1)+i)
         e(i) = crdball(3*(ma-1)+i)
         cg(i) = a(i) + b(i) + c(i) + d(i) + e(i)
      end do
      do i = 1, 3
         cg(i) = 0.2d0 * cg(i)
      end do
      do i = 1, 3
         a(i) = a(i) - cg(i)
         b(i) = b(i) - cg(i)
         c(i) = c(i) - cg(i)
         d(i) = d(i) - cg(i)
         e(i) = e(i) - cg(i)
      end do
      ra = radball(ia)
      rb = radball(ja)
      rc = radball(ka)
      rd = radball(la)
      re = radball(ma)
      a(4) = a(1)*a(1) + a(2)*a(2) + a(3)*a(3) - ra*ra
      b(4) = b(1)*b(1) + b(2)*b(2) + b(3)*b(3) - rb*rb
      c(4) = c(1)*c(1) + c(2)*c(2) + c(3)*c(3) - rc*rc
      d(4) = d(1)*d(1) + d(2)*d(2) + d(3)*d(3) - rd*rd
      e(4) = e(1)*e(1) + e(2)*e(2) + e(3)*e(3) - re*re
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine resize_tet  --  resize all tetrahedron arrays  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "resize_tet" resizes all arrays related to tetrahedra, when
c     the initial estimate of the number of tetrahedron was wrong
c
c
      subroutine resize_tet
      use shapes
      implicit none
      integer i,j
      integer, allocatable :: tetra2(:,:)
      integer, allocatable :: tneighbor2(:,:)
      integer, allocatable :: tinfo2(:)
      integer, allocatable :: tnindex2(:)
      save
c
c
c     set size of space for tetrahedra-related arrays
c
      maxtetra = (3*ntetra) / 2
      maxtetra = max(maxtetra,ntetra+1000)
c 
c     perform dynamic allocation of some local arrays
c
      allocate (tinfo2(maxtetra))
      allocate (tnindex2(maxtetra))
      allocate (tetra2(4,maxtetra))
      allocate (tneighbor2(4,maxtetra))
c
c     copy prior information into resized arrays
c
      do i = 1, ntetra
         tinfo2(i) = tinfo(i)
         tnindex2(i) = tnindex(i)
         do j = 1, 4
            tetra2(j,i) = tetra(j,i)
            tneighbor2(j,i) = tneighbor(j,i)
         end do
      end do
c
c     move the extended array storage into prior arrays; note
c     deallocation of new temporary arrays happens automatically
c
      call move_alloc (tinfo2,tinfo)
      call move_alloc (tnindex2,tnindex)
      call move_alloc (tetra2,tetra)
      call move_alloc (tneighbor2,tneighbor)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine hpsort_three  --  heapsort 3D reals with index  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "hpsort_three" rearranges an array in ascending order and
c     provide an index of the ranked element
c
c
      subroutine hpsort_three (ra,index,n)
      implicit none
      integer i,j,k,m,n
      integer ir,idx,comp3
      integer index(n)
      real*8 rra(3)
      real*8 ra(3,n)
      save
c
c
      do i = 1, n
         index(i) = i
      end do
      if (n .lt. 2)  return
      m = n/2 + 1
      ir = n
   10 continue
      if (m .gt. 1) then
         m = m - 1
         do k = 1, 3
            rra(k) = ra(k,m)
         end do
         idx = m
      else
         do k = 1, 3
            rra(k) = ra(k,ir)
         end do
         idx = index(ir)
         do k = 1, 3
            ra(k,ir) = ra(k,1)
         end do
         index(ir) = index(1)
         ir = ir - 1
         if (ir .eq. 1) then
            do k = 1, 3
               ra(k,1) = rra(k)
            end do
            index(1) = idx
            return
         end if
      end if
      i = m
      j = m + m
   20 continue
      if (j .le. ir) then
         if (j .lt. ir) then
            if (comp3(ra(1,j),ra(1,j+1)) .eq. 1)  j = j + 1
         end if
         if (comp3(rra,ra(1,j)) .eq. 1) then
            do k = 1, 3
               ra(k,i) = ra(k,j)
            end do
            index(i) = index(j)
            i = j
            j = j + j
         else
            j = ir + 1
         end if
         goto 20
      end if
      do k = 1, 3
         ra(k,i) = rra(k)
      end do
      index(i) = idx
      goto 10
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  function comp3  --  compare two 3-dimensional real vectors  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "comp3" is a function comparing two arrays each containing
c     three real numbers
c
c
      function comp3 (a,b)
      implicit none
      integer i,comp3
      real*8 a(3),b(3)
      save
c
c
      comp3 = 0
      do i = 1, 3
         if (a(i) .lt. b(i)) then
            comp3 = 1
            return
         else if (a(i) .gt. b(i)) then
            return
         end if
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine hpsort_two_int  --  heapsort 2D integer array  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "hpsort_two_int" rearranges an array in ascending order and
c     provide an index of the ranked element
c
c
      subroutine hpsort_two_int (ra,n)
      implicit none
      integer i,j,k,m,n
      integer ir,idx,comp2
      integer rra(2)
      integer ra(2,n)
      save
c
c
      if (n .lt. 2)  return
      m = n/2 + 1
      ir = n
   10 continue
      if (m .gt. 1) then
         m = m - 1
         do k = 1, 2
            rra(k) = ra(k,m)
         end do
         idx = m
      else
         do k = 1, 2
            rra(k) = ra(k,ir)
         end do
         do k = 1, 2
            ra(k,ir) = ra(k,1)
         end do
         ir = ir - 1
         if (ir .eq. 1) then
            do k = 1, 2
               ra(k,1) = rra(k)
            end do
            return
         end if
      end if
      i = m
      j = m + m
   20 continue
      if (j .le. ir) then
         if (j .lt. ir) then
            if (comp2(ra(1,j),ra(1,j+1)) .eq. 1)  j = j + 1
         end if
         if (comp2(rra,ra(1,j)) .eq. 1) then
            do k = 1, 2
               ra(k,i) = ra(k,j)
            end do
            i = j
            j = j + j
         else
            j = ir + 1
         end if
         goto 20
      end if
      do k = 1, 2
         ra(k,i) = rra(k)
      end do
      goto 10
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  function comp2  --  compare two 2-dimensional real vectors  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "comp2" is a function comparing two arrays each containing
c     two real numbers
c
c
      function comp2 (a,b)
      implicit none
      integer i,comp2
      integer a(2),b(2)
      save
c
c
      comp2 = 0
      do i = 1, 2
         if (a(i) .lt. b(i)) then
            comp2 = 1
            return
         else if (a(i) .gt. b(i)) then
            return
         end if
      end do
      return
      end
c
c
c     ################################################################33
c     ##                                                              ##
c     ##  subroutine distance2  --  distance squares between spheres  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "distance2" computes the square of the distance between two
c     sphere centers
c
c
      subroutine distance2 (crdball,n1,n2,dist)
      implicit none
      integer i,n1,n2
      real*8 dist,val
      real*8 crdball(*)
      save
c
c
      dist = 0.0d0
      do i = 1, 3
         val = crdball(3*(n1-1)+i) - crdball(3*(n2-1)+i)
         dist = dist + val*val
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine plane_dist  --  find sphere to plane distance  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "plane_dist" computes the distance between the center of
c     sphere A and the Voronoi plane between this sphere and
c     another sphere B
c
c
      subroutine plane_dist (ra2,rb2,rab2,lambda)
      implicit none
      real*8 ra2,rb2,rab2
      real*8 lambda
      save
c
c
      lambda = 0.5d0 - (ra2-rb2)/(2.0d0*rab2)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine twosphere_surf  --  sphere intersection area  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "twosphere_surf" computes the surface area of the intersection
c     of two spheres, only called when the intersection exists
c
c     variables and parameters:
c
c     rab        distance between the centers of the two spheres
c     rab2       squared distance between the centers of spheres
c     ra,rb      radii of spheres A and B, respectively
c     ra2,rb2    squared radii of the spheres A and B
c     surfa      partial contribution of A to the total surface
c                  of the intersection
c     surfb      partial contribution of B to the total surface
c                  of the intersection
c
c
      subroutine twosphere_surf (ra,ra2,rb,rb2,rab,rab2,surfa,surfb)
      use math
      implicit none
      real*8 ra,rb,surfa,surfb
      real*8 vala,valb,lambda
      real*8 ra2,rb2,rab,rab2,ha,hb
      save
c
c
c     find the distance between center of sphere A and the
c     Voronoi plane between A and B
c
      call plane_dist (ra2,rb2,rab2,lambda)
      valb = lambda * rab
      vala = rab - valb
c
c     get height of the cap of sphere A occluded by sphere B
c
      ha = ra - vala
c
c     now do the same as above for sphere B
c
      hb = rb - valb
c
c     get the surface areas of intersection
c
      surfa = twopi * ra * ha
      surfb = twopi * rb * hb
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine twosphere_vol  --  sphere intersection volume  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "twosphere_vol" calculates the volume of the intersection of
c     two balls and the surface area  of the intersection of two
c     corresponding spheres
c
c     variables and parameters:
c
c     rab       distance between the centers of the two spheres
c     rab2      squared distance between the centers of spheres
c     ra,rb     radii of spheres A and B, respectively
c     ra2,rb2   squared radii of the spheres A and B
c     surfa     partial contribution of A to the total surface
c                 of the intersection
c     surfb     partial contribution of B to the total surface
c                 of the intersection
c     vola      partial contribution of A to the total volume
c                 of the intersection
c     volb      partial contribution of B to the total volume
c                 of the intersection
c
c
      subroutine twosphere_vol (ra,ra2,rb,rb2,rab,rab2,
     &                          surfa,surfb,vola,volb)
      use math
      implicit none
      real*8 ra,rb,surfa,surfb
      real*8 vola,volb
      real*8 vala,valb,lamda
      real*8 ra2,rb2,rab,rab2
      real*8 ha,hb,sa,ca,sb,cb
      real*8 aab
      save
c
c
c     find the distance between center of sphere A and the
c     Voronoi plane between A and B
c
      call plane_dist (ra2,rb2,rab2,lamda)
      valb = lamda * rab
      vala = rab - valb
c
c     get height of the cap of sphere A occluded by sphere B
c
      ha = ra - vala
c
c     now do the same as above for sphere B
c
      hb = rb - valb
c
c     get the surface areas of intersection
c
      surfa = twopi * ra * ha
      surfb = twopi * rb * hb
c
c     now get the associated volume
c
      aab = pi * (ra2-vala*vala)
      sa = ra * surfa
      ca = vala * aab
      vola = (sa-ca) / 3.0d0
      sb = rb * surfb
      cb = valb * aab
      volb = (sb-cb) / 3.0d0
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine threesphere_surf  --  find three sphere area  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "threesphere_surf" calculates the surface area of intersection 
c     of three spheres
c
c     variables and parameters:
c
c     ra,rb,rc       radii of spheres A, B and C, respectively
c     ra2,rb2,rc2    squared distance between the centers of spheres
c     rab,rab2       distance between the centers of sphere A and B
c     rac,rac2       distance between the centers of sphere A and C
c     rbc,rbc2       distance between the centers of sphere B and C
c     surfa,surfb,   contribution of A, B and C to the total surface
c       surfc          of the intersection of A, B and C
c
c
      subroutine threesphere_surf (ra,rb,rc,ra2,rb2,rc2,rab,rac,rbc,
     &                             rab2,rac2,rbc2,surfa,surfb,surfc)
      use math
      implicit none
      real*8 surfa,surfb,surfc
      real*8 ra,rb,rc
      real*8 rab,rac,rbc
      real*8 rab2,rac2,rbc2
      real*8 ra2,rb2,rc2
      real*8 a1,a2,a3
      real*8 seg_ang_ab,seg_ang_ac
      real*8 seg_ang_bc
      real*8 ang_dih_ap,ang_dih_bp
      real*8 ang_dih_cp
      real*8 l1,l2,l3
      real*8 val1,val2,val3
      real*8 val1b,val2b,val3b
      real*8 angle(6),cosine(6),sine(6)
      save
c
c
      call plane_dist (ra2,rb2,rab2,l1)
      call plane_dist (ra2,rc2,rac2,l2)
      call plane_dist (rb2,rc2,rbc2,l3)
      val1 = l1 * rab
      val2 = l2 * rac
      val3 = l3 * rbc
      val1b = rab - val1
      val2b = rac - val2
      val3b = rbc - val3
c
c     consider the tetrahedron (A,B,C,P) where P is the point
c     of intersection of the three spheres such that (A,B,C,P)
c     is counter-clockwise; the edge lengths in this tetrahedron
c     are rab, rac, rAP=ra, rbc, rBP=rb and rCP=rc
c
      call tetra_dihed (rab2,rac2,ra2,rbc2,rb2,rc2,angle,cosine,sine)
c
c     the seg_ang values are the dihedral angles around the three
c     edges AB, AC and BC
c
      seg_ang_ab = angle(1)
      seg_ang_ac = angle(2)
      seg_ang_bc = angle(4)
c
c     the ang_dih values are the dihedral angles around the three
c     edges AP, BP and CP
c
      ang_dih_ap = angle(3)
      ang_dih_bp = angle(5)
      ang_dih_cp = angle(6)
      a1 = ra * (1.0d0-2.0d0*ang_dih_ap)
      a2 = 2.0d0 * seg_ang_ab * val1b
      a3 = 2.0d0 * seg_ang_ac * val2b
      surfa = twopi * ra * (a1-a2-a3)
      a1 = rb * (1.0d0-2.0d0*ang_dih_bp)
      a2 = 2.0d0 * seg_ang_ab * val1
      a3 = 2.0d0 * seg_ang_bc * val3b
      surfb = twopi * rb * (a1-a2-a3)
      a1 = rc * (1.0d0-2.0d0*ang_dih_cp)
      a2 = 2.0d0 * seg_ang_ac * val2
      a3 = 2.0d0 * seg_ang_bc * val3
      surfc = twopi * rc * (a1-a2-a3)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine threesphere_vol  --  find three sphere volume  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "threesphere_vol" calculates the volume of intersection of
c     three balls as well as the surface area of intersection
c
c     variables and parameters:
c
c     ra,rb,rc       radii of spheres A, B and C, respectively
c     ra2,rb2,rc2    squared distance between the centers of spheres
c     rab,rab2       distance between the centers of sphere A and B
c     rac,rac2       distance between the centers of sphere A and C
c     rbc,rbc2       distance between the centers of sphere B and C
c     surfa,surfb,   contribution of A, B and C to the total surface
c       surfc          of the intersection of A, B and C
c     vola,volb,     contribution of A, B and C tothe total volume
c       volc           of the intersection of A, B and C
c
c
      subroutine threesphere_vol (ra,rb,rc,ra2,rb2,rc2,rab,rac,rbc,
     &                            rab2,rac2,rbc2,surfa,surfb,surfc,
     &                            vola,volb,volc)
      use math
      implicit none
      real*8 surfa,surfb,surfc
      real*8 vola,volb,volc
      real*8 ra,rb,rc
      real*8 rab,rac,rbc
      real*8 rab2,rac2,rbc2
      real*8 ra2,rb2,rc2
      real*8 a1,a2,a3,s2,c1,c2
      real*8 seg_ang_ab,seg_ang_ac
      real*8 seg_ang_bc
      real*8 ang_dih_ap,ang_dih_bp
      real*8 ang_dih_cp
      real*8 ang_abc,ang_acb,ang_bca
      real*8 cos_abc,cos_acb,cos_bca
      real*8 sin_abc,sin_acb,sin_bca
      real*8 s_abc,s_acb,s_bca
      real*8 l1,l2,l3
      real*8 val1,val2,val3
      real*8 val1b,val2b,val3b
      real*8 rho_ab2,rho_ac2,rho_bc2
      real*8 angle(6),cosine(6),sine(6)
      save
c
c
      call plane_dist (ra2,rb2,rab2,l1)
      call plane_dist (ra2,rc2,rac2,l2)
      call plane_dist (rb2,rc2,rbc2,l3)
      val1 = l1 * rab
      val2 = l2 * rac
      val3 = l3 * rbc
      val1b = rab - val1
      val2b = rac - val2
      val3b = rbc - val3
c
c     consider the tetrahedron (A,B,C,P) where P is the point
c     of intersection of the three spheres such that (A,B,C,P)
c     is counter-clockwise; the edge lengths in this tetrahedron
c     are rab, rac, rAP=ra, rbc, rBP=rb and rCP=rc
c
      call tetra_dihed (rab2,rac2,ra2,rbc2,rb2,rc2,angle,cosine,sine)
c
c     the seg_ang values are the dihedral angles around the three
c     edges AB, AC and BC
c
      seg_ang_ab = angle(1)
      seg_ang_ac = angle(2)
      seg_ang_bc = angle(4)
c
c     the ang_dih values are the dihedral angles around the three
c     edges AP, BP and CP
c
      ang_dih_ap = angle(3)
      ang_dih_bp = angle(5)
      ang_dih_cp = angle(6)
      a1 = ra * (1.0d0-2.0d0*ang_dih_ap)
      a2 = 2.0d0 * seg_ang_ab * val1b
      a3 = 2.0d0 * seg_ang_ac * val2b
      surfa = twopi * ra * (a1-a2-a3)
      a1 = rb * (1.0d0-2.0d0*ang_dih_bp)
      a2 = 2.0d0 * seg_ang_ab * val1
      a3 = 2.0d0 * seg_ang_bc * val3b
      surfb = twopi * rb * (a1-a2-a3)
      a1 = rc * (1.0d0-2.0d0*ang_dih_cp)
      a2 = 2.0d0 * seg_ang_ac * val2
      a3 = 2.0d0 * seg_ang_bc * val3
      surfc = twopi * rc * (a1-a2-a3)
      ang_abc = twopi * seg_ang_ab
      ang_acb = twopi * seg_ang_ac
      ang_bca = twopi * seg_ang_bc
      cos_abc = cosine(1)
      sin_abc = sine(1)
      cos_acb = cosine(2)
      sin_acb = sine(2)
      cos_bca = cosine(4)
      sin_bca = sine(4)
      rho_ab2 = ra2 - val1b*val1b
      rho_ac2 = ra2 - val2b*val2b
      rho_bc2 = rb2 - val3b*val3b
      s_abc = rho_ab2 * (ang_abc-sin_abc*cos_abc)
      s_acb = rho_ac2 * (ang_acb-sin_acb*cos_acb)
      s_bca = rho_bc2 * (ang_bca-sin_bca*cos_bca)
      s2 = ra * surfa
      c1 = val1b * s_abc
      c2 = val2b * s_acb
      vola = (s2-c1-c2) / 3.0d0
      s2 = rb * surfb
      c1 = val1 * s_abc
      c2 = val3b * s_bca
      volb = (s2-c1-c2) / 3.0d0
      s2 = rc * surfc
      c1 = val2 * s_acb
      c2 = val3 * s_bca
      volc = (s2-c1-c2) / 3.0d0
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine triangle_surf  --  three sphere area driver  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "triangle_surf" computes the surface area of intersection
c     of three balls, provides a wrapper to "threesphere_surf"
c
c
      subroutine triangle_surf (a,b,c,rab,rac,rbc,rab2,rac2,rbc2,ra,
     &                          rb,rc,ra2,rb2,rc2,surfa,surfb,surfc)
      implicit none
      real*8 rab,rac,rbc
      real*8 rab2,rac2,rbc2
      real*8 ra,rb,rc
      real*8 ra2,rb2,rc2
      real*8 surfa,surfb,surfc
      real*8 a(3),b(3),c(3),u(3)
c
c
      if (rab .eq. 0.0d0) then
         call diffvect (a,b,u)
         call normvect (u,rab)
         rab2 = rab * rab
      end if
      if (rac .eq. 0.0d0) then
         call diffvect (a,c,u)
         call normvect (u,rac)
         rac2 = rac * rac
      end if
      if (rbc .eq. 0.0d0) then
         call diffvect (b,c,u)
         call normvect (u,rbc)
         rbc2 = rbc * rbc
      end if
      call threesphere_surf (ra,rb,rc,ra2,rb2,rc2,rab,rac,rbc,
     &                       rab2,rac2,rbc2,surfa,surfb,surfc)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine triangle_vol  --  three sphere volume driver  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "triangle_vol" computes the volume of intersection of three
c     balls, provides a wrapper to "threesphere_vol"
c
c
      subroutine triangle_vol (a,b,c,rab,rac,rbc,rab2,rac2,rbc2,
     &                         ra,rb,rc,ra2,rb2,rc2,surfa,surfb,
     &                         surfc,vola,volb,volc)
      implicit none
      real*8 rab,rac,rbc
      real*8 rab2,rac2,rbc2
      real*8 ra,rb,rc
      real*8 ra2,rb2,rc2
      real*8 surfa,surfb,surfc
      real*8 vola,volb,volc
      real*8 a(3),b(3),c(3),u(3)
c
c
      if (rab .eq. 0.0d0) then
         call diffvect (a,b,u)
         call normvect (u,rab)
         rab2 = rab * rab
      end if
      if (rac .eq. 0.0d0) then
         call diffvect (a,c,u)
         call normvect (u,rac)
         rac2 = rac * rac
      end if
      if (rbc .eq. 0.0d0) then
         call diffvect (b,c,u)
         call normvect (u,rbc)
         rbc2 = rbc * rbc
      end if
      call threesphere_vol (ra,rb,rc,ra2,rb2,rc2,rab,rac,rbc,
     &                      rab2,rac2,rbc2,surfa,surfb,surfc,
     &                      vola,volb,volc)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine tetra_voronoi  --  find four sphere volume  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "tetra_voronoi" computes the volume of intersection of the
c     tetrahedron formed by the center of four balls with the
c     Voronoi cells corresponding to these balls
c
c     variables and parameters:
c
c     ra2,rb2,rc2,rd2    squared radii of the spheres A, B, C, D
c     rab,rac,rad,       all distances between the ball centers
c       rbc,rbd,rcd
c     rab2,rac2,rad2,    squared distances between ball centers
c       rbc2,rbd2,rcd2   
c     cos_ang            cosine of the six dihedral angles of the
c                          tetrahedron
c     sin_ang            sine of the six dihedral angles of the
c                          tetrahedron
c     vola,volb,         fraction of the volume of tetrahedron
c       volc,vold          corresponding to the four balls
c
c
      subroutine tetra_voronoi (ra2,rb2,rc2,rd2,rab,rac,rad,rbc,rbd,
     &                          rcd,rab2,rac2,rad2,rbc2,rbd2,rcd2,
     &                          cos_ang,sin_ang,vola,volb,volc,vold)
      integer i
      real*8 ra2,rb2,rc2,rd2
      real*8 rab,rac,rad
      real*8 rbc,rbd,rcd
      real*8 rab2,rac2,rad2
      real*8 rbc2,rbd2,rcd2
      real*8 vola,volb,volc,vold
      real*8 l1,l2,l3,l4,l5,l6
      real*8 val1,val2,val3
      real*8 val4,val5,val6
      real*8 val1b,val2b,val3b
      real*8 val4b,val5b,val6b
      real*8 cos_abc,cos_acb,cos_bca
      real*8 cos_abd,cos_adb,cos_bda
      real*8 cos_acd,cos_adc,cos_cda
      real*8 cos_bcd,cos_bdc,cos_cdb
      real*8 rho_ab2,rho_ac2,rho_ad2
      real*8 rho_bc2,rho_bd2,rho_cd2
      real*8 cap_ab,cap_ac,cap_ad
      real*8 cap_bc,cap_bd,cap_cd
      real*8 eps
      real*8 cosine_abc(3),cosine_abd(3)
      real*8 cosine_acd(3),cosine_bcd(3)
      real*8 cos_ang(6),sin_ang(6)
      real*8 invsin(6),cotan(6)
      save
c
c
      call plane_dist (ra2,rb2,rab2,l1)
      call plane_dist (ra2,rc2,rac2,l2)
      call plane_dist (ra2,rd2,rad2,l3)
      call plane_dist (rb2,rc2,rbc2,l4)
      call plane_dist (rb2,rd2,rbd2,l5)
      call plane_dist (rc2,rd2,rcd2,l6)
      val1 = l1 * rab
      val2 = l2 * rac
      val3 = l3 * rad
      val4 = l4 * rbc
      val5 = l5 * rbd
      val6 = l6 * rcd
      val1b = rab - val1
      val2b = rac - val2
      val3b = rad - val3
      val4b = rbc - val4
      val5b = rbd - val5
      val6b = rcd - val6
c
c     consider the tetrahedron (A,B,C,P) where P is the point
c     of intersection of the three spheres such that (A,B,C,P)
c     is counter-clockwise; the edge lengths in this tetrahedron
c     are rab, rac, rAP=ra, rbc, rBP=rb and rCP=rc
c
      call tetra_3dihed_cos (rab2,rac2,ra2,rbc2,rb2,rc2,cosine_abc)
c
c     repeat the above for tetrahedron (A,B,D,P)
c
      call tetra_3dihed_cos (rab2,rad2,ra2,rbd2,rb2,rd2,cosine_abd)
c
c     repeat the above for tetrahedron (A,C,D,P)
c
      call tetra_3dihed_cos (rac2,rad2,ra2,rcd2,rc2,rd2,cosine_acd)
c
c     repeat the above for tetrahedron (B,C,D,P)
c
      call tetra_3dihed_cos (rbc2,rbd2,rb2,rcd2,rc2,rd2,cosine_bcd)
c
      cos_abc = cosine_abc(1)
      cos_acb = cosine_abc(2)
      cos_bca = cosine_abc(3)
      cos_abd = cosine_abd(1)
      cos_adb = cosine_abd(2)
      cos_bda = cosine_abd(3)
      cos_acd = cosine_acd(1)
      cos_adc = cosine_acd(2)
      cos_cda = cosine_acd(3)
      cos_bcd = cosine_bcd(1)
      cos_bdc = cosine_bcd(2)
      cos_cdb = cosine_bcd(3)
      rho_ab2 = ra2 - val1b*val1b
      rho_ac2 = ra2 - val2b*val2b
      rho_ad2 = ra2 - val3b*val3b
      rho_bc2 = rb2 - val4b*val4b
      rho_bd2 = rb2 - val5b*val5b
      rho_cd2 = rc2 - val6b*val6b
      eps = 1.0d-14
      do i = 1, 6
         if (abs(sin_ang(i)) < eps) then
            invsin(i) = 0.0d0;
            cotan(i) = 0.0d0;
         else
            invsin(i) = 1.0d0 / sin_ang(i)
            cotan(i) = cos_ang(i)*invsin(i)
         end if
      end do
      cap_ab = -rho_ab2*(cos_abc*cos_abc+cos_abd*cos_abd)*cotan(1)
     &            + 2*rho_ab2*cos_abc*cos_abd*invsin(1)
      cap_ac = -rho_ac2*(cos_acb*cos_acb+cos_acd*cos_acd)*cotan(2)
     &            + 2*rho_ac2*cos_acb*cos_acd*invsin(2)
      cap_ad = -rho_ad2*(cos_adb*cos_adb+cos_adc*cos_adc)*cotan(3)
     &            + 2*rho_ad2*cos_adb*cos_adc*invsin(3)
      cap_bc = -rho_bc2*(cos_bca*cos_bca+cos_bcd*cos_bcd)*cotan(4)
     &            + 2*rho_bc2*cos_bca*cos_bcd*invsin(4)
      cap_bd = -rho_bd2*(cos_bda*cos_bda+cos_bdc*cos_bdc)*cotan(5)
     &            + 2*rho_bd2*cos_bda*cos_bdc*invsin(5)
      cap_cd = -rho_cd2*(cos_cda*cos_cda+cos_cdb*cos_cdb)*cotan(6)
     &            + 2*rho_cd2*cos_cda*cos_cdb*invsin(6)
      vola = (val1b*cap_ab+val2b*cap_ac+val3b*cap_ad) / 6.0d0
      volb = (val1*cap_ab+val4b*cap_bc+val5b*cap_bd) / 6.0d0
      volc = (val2*cap_ac+val4*cap_bc+val6b*cap_cd) / 6.0d0
      vold = (val3*cap_ad+val5*cap_bd+val6*cap_cd) / 6.0d0
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine twosphere_dsurf  --  two sphere area derivs  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "twosphere_dsurf" calculates the surface area of intersection
c     of two spheres; also computes the derivatives of the surface
c     area with respect to the distance between the sphere centers
c
c     note this version uses only the radii of the spheres and the
c     distance between their centers
c
c     variables and parameters:
c
c     rab        distance between the centers of the spheres
c     rab2       distance squared between the sphere centers
c     ra,rb      radii of spheres A and B, respectively
c     ra2,rb2    radii squared of the two spheres 
c     option     set to 1 to compute derivatives, or 0 if not
c     surfa      partial contribution of A to the total
c                  surface area of the intersection
c     surfb      partial contribution of B to the total
c                  surface area of the intersection
c     dsurfa     derivative of surfa with respect to rab
c     dsurfb     derivative of surfb with respect to rab
c
c
      subroutine twosphere_dsurf (ra,ra2,rb,rb2,rab,rab2,surfa,
     &                            surfb,dsurfa,dsurfb,option)
      use math
      implicit none
      integer option
      real*8 ra,rb
      real*8 surfa,surfb
      real*8 dsurfa,dsurfb
      real*8 vala,valb
      real*8 ra2,rb2
      real*8 rab,rab2
      real*8 ha,hb,lambda
      real*8 dera,derb
      save
c
c
c     get distance between center of sphere A and the Voronoi
c     plane between A and B
c
      call plane_dist (ra2,rb2,rab2,lambda)
      valb = lambda * rab
      vala = rab - valb
c
c     find height of the cap of sphere A occluded by sphere B
c
      ha = ra - vala
c
c     find height of the cap of sphere B occluded by sphere A
c
      hb = rb - valb
c
c     compute the surface areas of intersection
c
      surfa = twopi * ra * ha
      surfb = twopi * rb * hb
      if (option .ne. 1)  return
c
c     compute the accessible surface area derivatives
c
      dera = -lambda
      derb = lambda - 1.0d0
      dsurfa = twopi * ra * dera
      dsurfb = twopi * rb * derb
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine twosphere_dvol  --  two sphere volume derivs  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "twosphere_dvol" finds the volume of intersection of two balls
c     and the corresponding surface area of intersection; also finds
c     derivatives of the surface area and volume with respect to the
c     distance between the two centers
c
c     variables and parameters:
c
c     rab        distance between the centers of the spheres
c     rab2       distance squared between the sphere centers
c     ra,rb      radii of spheres A and B, respectively
c     ra2,rb2    radii squared of spheres A and B
c     option     set to 1 to compute derivatives, or 0 if not
c     surfa      partial contribution of A to the total
c                  surface area of the intersection
c     surfb      partial contribution of B to the total
c                  surface area of the intersection
c     vola       partial contribution of A to the total
c                  volume of the intersection
c     volb       partial contribution of B to the total
c                  volume of the intersection
c     dsurfa     derivative of surfa with respect to rab
c     dsurfb     derivative of surfb with respect to rab
c     dvola      derivative of vola with respect to rab
c     dvolb      derivative of volb with respect to rab
c
c
      subroutine twosphere_dvol (ra,ra2,rb,rb2,rab,rab2,surfa,surfb,
     &                           vola,volb,dsurfa,dsurfb,dvola,dvolb,
     &                           option)
      use math
      implicit none
      integer option
      real*8 ra,rb
      real*8 surfa,surfb
      real*8 vola,volb
      real*8 dsurfa,dsurfb
      real*8 dvola,dvolb
      real*8 vala,valb,lambda
      real*8 ra2,rb2,rab,rab2
      real*8 ha,hb,sa,ca,sb,cb
      real*8 dera,derb,aab
      save
c
c
c     get distance between center of sphere A and the Voronoi
c     plane between A and B
c
      call plane_dist (ra2,rb2,rab2,lambda)
      valb = lambda * rab
      vala = rab - valb
c
c     find height of the cap of sphere A occluded by sphere B
c
      ha = ra - vala
c
c     find height of the cap of sphere B occluded by sphere A
c
      hb = rb - valb
c
c     compute the surface areas of intersection
c
      surfa = twopi * ra * ha
      surfb = twopi * rb * hb
c
c     next get the volumes of intersection
c
      aab = pi * (ra2-vala*vala)
      sa = ra * surfa
      ca = vala * aab
      vola = (sa-ca) / 3.0d0
      sb = rb * surfb
      cb = valb * Aab
      volb = (sb-cb) / 3.0d0
      if (option .ne. 1)  return
c
c     compute the surface area and volume derivatives
c
      dera = -lambda
      derb = lambda - 1.0d0
      dsurfa = twopi * ra * dera
      dsurfb = twopi * rb * derb
      dvola = -aab * lambda
      dvolb = -dvola - Aab
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine threesphere_dsurf  --  three sphere area derivs  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "threesphere_dsurf" computes the surface area of intersection 
c     of three spheres A, B and C; also computes the derivatives of
c     the surface area with respect to the distances rAB, rAC and rBC
c
c     variables and parameters:
c
c     ra,rb,rc       radii of the spheres A, B and C
c     ra2,rb2,rc2    radii squared of the spheres A, B and C
c     rab,rab2       distance and square between spheres A and B
c     rac,rac2       distance and square between spheres A and C
c     rbc,rbc2       distance and square between spheres B and C
c     option         set to 1 to compute derivatives, or 0 if not
c     surfa,surfb,   contribution of A, B and C to total surface
c       surfc          of the intersection of A, B and C
c     dsurfa         derivatives of surfa over rAB, rAC and rBC
c     dsurfb         derivatives of surfb over rAB, rAC and rBC
c     dsurfc         derivatives of surfc over rAB, rAC and rBC
c
c
      subroutine threesphere_dsurf (ra,rb,rc,ra2,rb2,rc2,rab,rac,rbc,
     &                              rab2,rac2,rbc2,surfa,surfb,surfc,
     &                              dsurfa,dsurfb,dsurfc,option)
      use math
      implicit none
      integer option
      real*8 surfa,surfb,surfc
      real*8 ra,rb,rc
      real*8 rab,rac,rbc
      real*8 rab2,rac2,rbc2
      real*8 ra2,rb2,rc2
      real*8 a1,a2,a3
      real*8 seg_ang_ab,seg_ang_ac
      real*8 seg_ang_bc
      real*8 ang_dih_ap,ang_dih_bp
      real*8 ang_dih_cp
      real*8 val1,val2,val3,l1,l2,l3
      real*8 val1b,val2b,val3b
      real*8 der_val1b,der_val1,der_val2b
      real*8 der_val2,der_val3b,der_val3
      real*8 angle(6),cosine(6),sine(6)
      real*8 dsurfa(3),dsurfb(3),dsurfc(3)
      real*8 deriv(6,3)
      save
c
c
      call plane_dist (ra2,rb2,rab2,l1)
      call plane_dist (ra2,rc2,rac2,l2)
      call plane_dist (rb2,rc2,rbc2,l3)
      val1 = l1 * rab
      val2 = l2 * rac
      val3 = l3 * rbc
      val1b = rab - val1
      val2b = rac - val2
      val3b = rbc - val3
c
c     consider tetrahedron (A,B,C,P) where P is the intersection point
c     of the three spheres such that (A,B,C,P) is counter-clockwise
c
c     the edge lengths in this tetrahedron are rab, rac, rAP=ra, rbc,
c     rBP=rb and rCP=rc
c
      call tetra_dihed_der3 (rab2,rac2,ra2,rbc2,rb2,rc2,
     &                       angle,cosine,sine,deriv,option)
c
c     the seg_ang_ values are the dihedral angles around the three
c     edges AB, AC and BC
c
      seg_ang_ab = angle(1)
      seg_ang_ac = angle(2)
      seg_ang_bc = angle(4)
c
c     the ang_dih_ values are the dihedral angles around the three
c     edges AP, BP and CP
c
      ang_dih_ap = angle(3)
      ang_dih_bp = angle(5)
      ang_dih_cp = angle(6)
      a1 = ra * (1.0d0-2.0d0*ang_dih_ap)
      a2 = 2.0d0 * seg_ang_ab * val1b
      a3 = 2.0d0 * seg_ang_ac * val2b
      surfa = twopi * ra * (a1-a2-a3)
      a1 = rb * (1.0d0-2.0d0*ang_dih_bp)
      a2 = 2.0d0 * seg_ang_ab * val1
      a3 = 2.0d0 * seg_ang_bc * val3b
      surfb = twopi * rb * (a1-a2-a3)
      a1 = rc * (1.0d0-2.0d0*ang_dih_cp)
      a2 = 2.0d0 * seg_ang_ac * val2
      a3 = 2.0d0 * seg_ang_bc * val3
      surfc = twopi * rc * (a1-a2-a3)
      if (option .ne. 1)  return
c
c     compute the accessible surface area derivatives
c
      der_val1b = l1
      der_val1 = 1.0d0 - l1
      der_val2b = l2
      der_val2 = 1.0d0 - l2
      der_val3b = l3
      der_val3 = 1.0d0 - l3
      dsurfa(1) = -2.0d0 * ra * (twopi*seg_ang_ab*der_val1b
     &               + 2.0d0*rab*(ra*deriv(3,1)+val1b*deriv(1,1)
     &                               +val2b*deriv(2,1)))
      dsurfa(2) = -2.0d0 * ra * (twopi*seg_ang_ac*der_val2b
     &               + 2.0d0*rac*(ra*deriv(3,2)+val1b*deriv(1,2)
     &                               +val2b*deriv(2,2)))
      dsurfa(3) = ra * (-4.0d0*rbc*(ra*deriv(3,3)+val1b*deriv(1,3)
     &                                 +val2b*deriv(2,3)))
      dsurfb(1) = -2.0d0 * rb * (twopi*seg_ang_ab*der_val1
     &               +2.0d0*rab*(rb*deriv(5,1)+val1*deriv(1,1)
     &                              +val3b*deriv(4,1)))
      dsurfb(2) = rb * (-4.0d0*rac*(rb*deriv(5,2)+val1*deriv(1,2)
     &                                 +val3b*deriv(4,2)))
      dsurfb(3) = -2.0d0 * rb * (twopi*seg_ang_bc*der_val3b
     &               +2.0d0*rbc*(rb*deriv(5,3)+val1*deriv(1,3)
     &                              +val3b*deriv(4,3)))
      dsurfc(1) = rc * (-4.0d0*rab*(rc*deriv(6,1)+val2*deriv(2,1)
     &                                 +val3*deriv(4,1)))
      dsurfc(2) = -2.0d0 * rc * (twopi*seg_ang_ac*der_val2
     &               +2.0d0*rac*(rc*deriv(6,2)+val2*deriv(2,2)
     &                              +val3*deriv(4,2)))
      dsurfc(3) = -2.0d0 * rc * (twopi*seg_ang_bc*der_val3
     &               +2.0d0*rbc*(rc*deriv(6,3)+val2*deriv(2,3)
     &                              +val3*deriv(4,3)))
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine threesphere_dvol  --  three sphere volume deriv  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "threesphere_dvol" calculates the volume of the intersection of
c     three balls as well as the surface area of intersection of the
c     corresponding three spheres
c
c     variables and parameters:
c
c     ra,rb,rc       radii of spheres A, B and C
c     ra2,rb2,rc2    radii squared of spheres A, B and C
c     rab,rab2       distance and square between spheres A and B
c     rac,rac2       distance and square between spheres A and C
c     rbc,rbc2       distance and square between spheres B and C
c     surfa,surfb,   contribution of A, B and C to total surface of
c       surfc          the intersection of A, B and C
c     vola,volb,     contribution of A, B and C to total volume of
c       volc           the intersection of A, B and C
c
c
      subroutine threesphere_dvol (ra,rb,rc,ra2,rb2,rc2,rab,rac,rbc,
     &                             rab2,rac2,rbc2,surfa,surfb,surfc,
     &                             vola,volb,volc,dsurfa,dsurfb,dsurfc,
     &                             dvola,dvolb,dvolc,option)
      use math
      implicit none
      integer option
      real*8 surfa,surfb,surfc
      real*8 vola,volb,volc
      real*8 ra,rb,rc
      real*8 rab,rac,rbc
      real*8 rab2,rac2,rbc2
      real*8 ra2,rb2,rc2
      real*8 a1,a2,a3,s2,c1,c2
      real*8 seg_ang_ab,seg_ang_ac
      real*8 seg_ang_bc
      real*8 ang_dih_ap,ang_dih_bp
      real*8 ang_dih_cp
      real*8 ang_abc,ang_acb,ang_bca
      real*8 cos_abc,cos_acb,cos_bca
      real*8 sin_abc,sin_acb,sin_bca
      real*8 s_abc,s_acb,s_bca
      real*8 val1,val2,val3,l1,l2,l3
      real*8 val1b,val2b,val3b
      real*8 rho_ab2,rho_ac2,rho_bc2
      real*8 drho_ab2,drho_ac2,drho_bc2
      real*8 val_abc,val_acb,val_bca
      real*8 val2_abc,val2_acb,val2_bca
      real*8 der_val1b,der_val2b,der_val3b
      real*8 der_val1,der_val2,der_val3
      real*8 angle(6),cosine(6),sine(6)
      real*8 dsurfa(3),dsurfb(3),dsurfc(3)
      real*8 dvola(3),dvolb(3),dvolc(3)
      real*8 deriv(6,3)
      save
c
c
      call plane_dist (ra2,rb2,rab2,l1)
      call plane_dist (ra2,rc2,rac2,l2)
      call plane_dist (rb2,rc2,rbc2,l3)
      val1 = l1 * rab
      val2 = l2 * rac
      val3 = l3 * rbc
      val1b = rab - val1
      val2b = rac - val2
      val3b = rbc - val3
c
c     consider tetrahedron (A,B,C,P) where P is the intersection point
c     of the three spheres such that (A,B,C,P) is counter-clockwise
c
c     the edge lengths in this tetrahedron are rab, rac, rAP=ra, rbc,
c     rBP=rb and rCP=rc
c
      call tetra_dihed_der3 (rab2,rac2,ra2,rbc2,rb2,rc2,
     &                       angle,cosine,sine,deriv,option)
c
c     the seg_ang_ values are the dihedral angles around the three
c     edges AB, AC and BC
c
      seg_ang_ab = angle(1)
      seg_ang_ac = angle(2)
      seg_ang_bc = angle(4)
c
c     the ang_dih_ values are the dihedral angles around the three
c     edges AP, BP and CP
c
      ang_dih_ap = angle(3)
      ang_dih_bp = angle(5)
      ang_dih_cp = angle(6)
      a1 = ra * (1.0d0-2.0d0*ang_dih_ap)
      a2 = 2.0d0 * seg_ang_ab * val1b
      a3 = 2.0d0 * seg_ang_ac * val2b
      surfa = twopi * ra * (a1-a2-a3)
      a1 = rb * (1.0d0-2.0d0*ang_dih_bp)
      a2 = 2.0d0 * seg_ang_ab * val1
      a3 = 2.0d0 * seg_ang_bc * val3b
      surfb = twopi * rb * (a1-a2-a3)
      a1 = rc * (1.0d0-2.0d0*ang_dih_cp)
      a2 = 2.0d0 * seg_ang_ac * val2
      a3 = 2.0d0 * seg_ang_bc * val3
      surfc = twopi * rc * (a1-a2-a3)
      ang_abc = twopi * seg_ang_ab
      ang_acb = twopi * seg_ang_ac
      ang_bca = twopi * seg_ang_bc
      cos_abc = cosine(1)
      sin_abc = sine(1)
      cos_acb = cosine(2)
      sin_acb = sine(2)
      cos_bca = cosine(4)
      sin_bca = sine(4)
      rho_ab2 = ra2 - val1b*val1b
      rho_ac2 = ra2 - val2b*val2b
      rho_bc2 = rb2 - val3b*val3b
      val_abc = ang_abc - sin_abc*cos_abc
      val_acb = ang_acb - sin_acb*cos_acb
      val_bca = ang_bca - sin_bca*cos_bca
      s_abc = rho_ab2 * val_abc
      s_acb = rho_ac2 * val_acb
      s_bca = rho_bc2 * val_bca
      s2 = ra * surfa
      c1 = val1b * s_abc
      c2 = val2b * s_acb
      vola = (s2-c1-c2) / 3.0d0
      s2 = rb * surfb
      c1 = val1 * s_abc
      c2 = val3b * s_bca
      volb = (s2-c1-c2) / 3.0d0
      s2 = rc * surfc
      c1 = val2 * s_acb
      c2 = val3 * s_bca
      volc = (s2-c1-c2) / 3.0d0
      if (option .ne. 1)  return
c
c     compute the accessible surface area derivatives
c
      der_val1b = l1
      der_val1 = 1.0d0 - l1
      der_val2b = l2
      der_val2 = 1.0d0 - l2
      der_val3b = l3
      der_val3 = 1.0d0 - l3
      drho_ab2 = -2.0d0 * der_val1b * val1b
      drho_ac2 = -2.0d0 * der_val2b * val2b
      drho_bc2 = -2.0d0 * der_val3b * val3b
      dsurfa(1) = -2.0d0 * ra * (twopi*seg_ang_ab*der_val1b
     &               + 2.0d0*rab*(ra*deriv(3,1)+val1b*deriv(1,1)
     &                               +val2b*deriv(2,1)))
      dsurfa(2) = -2.0d0 * ra * (twopi*seg_ang_ac*der_val2b
     &               + 2.0d0*rac*(ra*deriv(3,2)+val1b*deriv(1,2)
     &                               +val2b*deriv(2,2)))
      dsurfa(3) = ra * (-4.0d0*rbc*(ra*deriv(3,3)+val1b*deriv(1,3)
     &                                 +val2b*deriv(2,3)))
      dsurfb(1) = -2.0d0 * rb * (twopi*seg_ang_ab*der_val1
     &               +2.0d0*rab*(rb*deriv(5,1)+val1*deriv(1,1)
     &                              +val3b*deriv(4,1)))
      dsurfb(2) = rb * (-4.0d0*rac*(rb*deriv(5,2)+val1*deriv(1,2)
     &                                 +val3b*deriv(4,2)))
      dsurfb(3) = -2.0d0 * rb * (twopi*seg_ang_bc*der_val3b
     &               +2.0d0*rbc*(rb*deriv(5,3)+val1*deriv(1,3)
     &                              +val3b*deriv(4,3)))
      dsurfc(1) = rc * (-4.0d0*rab*(rc*deriv(6,1)+val2*deriv(2,1)
     &                                 +val3*deriv(4,1)))
      dsurfc(2) = -2.0d0 * rc * (twopi*seg_ang_ac*der_val2
     &               +2.0d0*rac*(rc*deriv(6,2)+val2*deriv(2,2)
     &                              +val3*deriv(4,2)))
      dsurfc(3) = -2.0d0 * rc * (twopi*seg_ang_bc*der_val3
     &               +2.0d0*rbc*(rc*deriv(6,3)+val2*deriv(2,3)
     &                              +val3*deriv(4,3)))
c
c     compute the excluded volume derivatives
c
      val2_abc = rho_ab2 * (1.0d0-cos_abc*cos_abc+sin_abc*sin_abc)
      val2_acb = rho_ac2 * (1.0d0-cos_acb*cos_acb+sin_acb*sin_acb)
      val2_bca = rho_bc2 * (1.0d0-cos_bca*cos_bca+sin_bca*sin_bca)
      dvola(1) = ra*dsurfa(1) - der_val1b*s_abc
     &              - 2.0d0*rab*(val1b*deriv(1,1)*val2_abc
     &                          +val2b*deriv(2,1)*val2_acb)
     &              - val1b*drho_ab2*val_abc
      dvola(1) = dvola(1) / 3.0d0
      dvola(2) = ra*dsurfa(2) - der_val2b*s_acb
     &              - 2.0d0*rac*(val1b*deriv(1,2)*val2_abc
     &                          +val2b*deriv(2,2)*val2_acb)
     &              - val2b*drho_ac2*val_acb
      dvola(2) = dvola(2) / 3.0d0
      dvola(3) = ra*dsurfa(3) - 2.0d0*rbc*(val1b*deriv(1,3)*val2_abc
     &                                    +val2b*deriv(2,3)*val2_acb)
      dvola(3) = dvola(3) / 3.0d0
      dvolb(1) = rb*dsurfb(1) - der_val1*s_abc
     &              - 2.0d0*rab*(val1*deriv(1,1)*val2_abc
     &                          +val3b*deriv(4,1)*val2_bca)
     &              - val1*drho_ab2*val_abc
      dvolb(1) = dvolb(1) / 3.0d0
      dvolb(2) = rb*dsurfb(2) - 2.0d0*rac*(val1*deriv(1,2)*val2_abc
     &                                    +val3b*deriv(4,2)*val2_bca)
      dvolb(2) = dvolb(2) / 3.0d0
      dvolb(3) = rb*dsurfb(3) - der_val3b*s_bca
     &              - 2.0d0*rbc*(val1*deriv(1,3)*val2_abc
     &                         + val3b*deriv(4,3)*val2_bca)
     &              - val3b*drho_bc2*val_bca
      dvolb(3) = dvolb(3) / 3.0d0
      dvolc(1) = rc*dsurfc(1) - 2.0d0*rab*(val2*deriv(2,1)*val2_acb
     &                                    +val3*deriv(4,1)*val2_bca)
      dvolc(1) = dvolc(1) / 3.0d0
      dvolc(2) = rc*dsurfc(2) - der_val2*s_acb
     &              - 2.0d0*rac*(val2*deriv(2,2)*val2_acb
     &                          +val3*deriv(4,2)*val2_bca)
     &              - val2*drho_ac2*val_acb
      dvolc(2) = dvolc(2) / 3.0d0
      dvolc(3) = rc*dsurfc(3) - der_val3*s_bca
     &              - 2.0d0*rbc*(val2*deriv(2,3)*val2_acb
     &                          +val3*deriv(4,3)*val2_bca)
     &              - val3*drho_bc2*val_bca
      dvolc(3) = dvolc(3) / 3.0d0
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine tetra_voronoi_der  --  four sphere volume deriv  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "tetra_voronoi_der" computes the volume of the intersection
c     of the tetrahedron formed by the center of four balls with the
c     Voronoi cells corresponding to these balls; also computes the
c     derivatives of these volumes with respect to the edge lengths;
c     only computed if the four balls have a common intersection
c
c     variables and parameters:
c
c     ra,rb,rc,rd        radii of the four balls
c     ra2,rb2,rc2,rd2    radii squared of the four balls
c     rab,rac,rad,       distance between pairs of balls
c       rbc,rbd,rcd
c     rab2,rac2,rad2,    distance squared between pairs of balls
c       rbc2,rbd2,rcd2
c     cos_ang            cosine of the six tetrahedral dihedral angles
c     sin_ang            sine of the six tetrahedral dihedral angles
c     deriv              derivatives of the six dihedral angles
c                          with respect to edge lengths
c     vola,volb,         fraction of the volume of the tetrahedron
c       volc,vold          corresponding to balls a, b, c and d
c     dvola              derivatives of vola wrt the six edge lengths
c     dvolb              derivatives of volb wrt the six edge lengths
c     dvolc              derivatives of volc wrt the six edge lengths
c     dvold              derivatives of vold wrt the six edge lengths
c
c
      subroutine tetra_voronoi_der (ra2,rb2,rc2,rd2,rab,rac,rad,rbc,
     &                              rbd,rcd,rab2,rac2,rad2,rbc2,rbd2,
     &                              rcd2,cos_ang,sin_ang,deriv,vola,
     &                              volb,volc,vold,dvola,dvolb,dvolc,
     &                              dvold,option)
      implicit none
      integer i,j,option
      real*8 ra2,rb2,rc2,rd2
      real*8 rab,rac,rad
      real*8 rbc,rbd,rcd
      real*8 rab2,rac2,rad2
      real*8 rbc2,rbd2,rcd2
      real*8 vola,volb,volc,vold
      real*8 l1,l2,l3,l4,l5,l6
      real*8 val1,val2,val3
      real*8 val4,val5,val6
      real*8 val1b,val2b,val3b
      real*8 val4b,val5b,val6b
      real*8 cos_abc,cos_acb,cos_bca
      real*8 cos_abd,cos_adb,cos_bda
      real*8 cos_acd,cos_adc,cos_cda
      real*8 cos_bcd,cos_bdc,cos_cdb
      real*8 rho_ab2,rho_ac2,rho_ad2
      real*8 rho_bc2,rho_bd2,rho_cd2
      real*8 drho_ab2,drho_ac2,drho_ad2
      real*8 drho_bc2,drho_bd2,drho_cd2
      real*8 dval1,dval2,dval3
      real*8 dval4,dval5,dval6
      real*8 dval1b,dval2b,dval3b
      real*8 dval4b,dval5b,dval6b
      real*8 val_ab,val_ac,val_ad
      real*8 val_bc,val_bd,val_cd
      real*8 val1_ab,val1_ac,val1_ad
      real*8 val1_bc,val1_bd,val1_cd
      real*8 val2_ab,val2_ac,val2_ad
      real*8 val2_bc,val2_bd,val2_cd
      real*8 cap_ab,cap_ac,cap_ad
      real*8 cap_bc,cap_bd,cap_cd
      real*8 eps,tetvol,teteps
      real*8 dist(6),invsin(6),cotan(6)
      real*8 cosine_abc(3),cosine_abd(3)
      real*8 cosine_acd(3),cosine_bcd(3)
      real*8 cos_ang(6),sin_ang(6)
      real*8 deriv(6,6)
      real*8 deriv_abc(3,3),deriv_abd(3,3)
      real*8 deriv_acd(3,3),deriv_bcd(3,3)
      real*8 dinvsin(6,6),dcotan(6,6)
      real*8 dval1_ab(6),dval1_ac(6)
      real*8 dval1_ad(6),dval1_bc(6)
      real*8 dval1_bd(6),dval1_cd(6)
      real*8 dval2_ab(6),dval2_ac(6)
      real*8 dval2_ad(6),dval2_bc(6)
      real*8 dval2_bd(6),dval2_cd(6)
      real*8 dcap_ab(6),dcap_ac(6)
      real*8 dcap_ad(6),dcap_bc(6)
      real*8 dcap_bd(6),dcap_cd(6)
      real*8 dvola(6),dvolb(6)
      real*8 dvolc(6),dvold(6)
      save
c
c
      call plane_dist (ra2,rb2,rab2,l1)
      call plane_dist (ra2,rc2,rac2,l2)
      call plane_dist (ra2,rd2,rad2,l3)
      call plane_dist (rb2,rc2,rbc2,l4)
      call plane_dist (rb2,rd2,rbd2,l5)
      call plane_dist (rc2,rd2,rcd2,l6)
      val1 = l1 * rab
      val2 = l2 * rac
      val3 = l3 * rad
      val4 = l4 * rbc
      val5 = l5 * rbd
      val6 = l6 * rcd
      val1b = rab - val1
      val2b = rac - val2
      val3b = rad - val3
      val4b = rbc - val4
      val5b = rbd - val5
      val6b = rcd - val6
c
c     consider the tetrahedron (A,B,C,P_ABC) where P_ABC is the
c     point of intersection of the three spheres so that (A,B,C,P_ABC)
c     is counter-clockwise; the edge lengths for this tetrahedron are
c     rab, rac, rAP=ra, rbc, rBP=rb and rCP=rc
c
      call tetra_3dihed_dcos (rab2,rac2,ra2,rbc2,rb2,rc2,
     &                        cosine_abc,deriv_abc,option)
c
c     repeat the above for tetrahedron (A,B,D,P_ABD)
c
      call tetra_3dihed_dcos (rab2,rad2,ra2,rbd2,rb2,rd2,
     &                        cosine_abd,deriv_abd,option)
c
c     repeat the above for tetrahedron (A,C,D,P_ACD)
c
      call tetra_3dihed_dcos (rac2,rad2,ra2,rcd2,rc2,rd2,
     &                        cosine_acd,deriv_acd,option)
c
c     repeat the above for tetrahedron (B,C,D,P_BCD)
c
      call tetra_3dihed_dcos (rbc2,rbd2,rb2,rcd2,rc2,rd2,
     &                        cosine_bcd,deriv_bcd,option)
c
      cos_abc = cosine_abc(1)
      cos_acb = cosine_abc(2)
      cos_bca = cosine_abc(3)
      cos_abd = cosine_abd(1)
      cos_adb = cosine_abd(2)
      cos_bda = cosine_abd(3)
      cos_acd = cosine_acd(1)
      cos_adc = cosine_acd(2)
      cos_cda = cosine_acd(3)
      cos_bcd = cosine_bcd(1)
      cos_bdc = cosine_bcd(2)
      cos_cdb = cosine_bcd(3)
      rho_ab2 = ra2 - val1b*val1b
      rho_ac2 = ra2 - val2b*val2b
      rho_ad2 = ra2 - val3b*val3b
      rho_bc2 = rb2 - val4b*val4b
      rho_bd2 = rb2 - val5b*val5b
      rho_cd2 = rc2 - val6b*val6b
      eps = 1.0d-14
      do i = 1, 6
         if (abs(sin_ang(i)) < eps) then
            invsin(i) = 0.0d0;
            cotan(i) = 0.0d0;
         else
            invsin(i) = 1.0d0 / sin_ang(i)
            cotan(i) = cos_ang(i) * invsin(i)
         end if
      end do
      val_ab = -(cos_abc*cos_abc+cos_abd*cos_abd)*cotan(1)
     &            + 2.0d0*cos_abc*cos_abd*invsin(1)
      val_ac = -(cos_acb*cos_acb+cos_acd*cos_acd)*cotan(2)
     &            + 2.0d0*cos_acb*cos_acd*invsin(2)
      val_ad = -(cos_adb*cos_adb+cos_adc*cos_adc)*cotan(3)
     &            + 2.0d0*cos_adb*cos_adc*invsin(3)
      val_bc = -(cos_bca*cos_bca+cos_bcd*cos_bcd)*cotan(4)
     &            + 2.0d0*cos_bca*cos_bcd*invsin(4)
      val_bd = -(cos_bda*cos_bda+cos_bdc*cos_bdc)*cotan(5)
     &            + 2.0d0*cos_bda*cos_bdc*invsin(5)
      val_cd = -(cos_cda*cos_cda+cos_cdb*cos_cdb)*cotan(6)
     &            + 2.0d0*cos_cda*cos_cdb*invsin(6)
      cap_ab = rho_ab2 * val_ab
      cap_ac = rho_ac2 * val_ac
      cap_ad = rho_ad2 * val_ad
      cap_bc = rho_bc2 * val_bc
      cap_bd = rho_bd2 * val_bd
      cap_cd = rho_cd2 * val_cd
      vola = (val1b*cap_ab+val2b*cap_ac+val3b*cap_ad) / 6.0d0
      volb = (val1*cap_ab+val4b*cap_bc+val5b*cap_bd) / 6.0d0
      volc = (val2*cap_ac+val4*cap_bc+val6b*cap_cd) / 6.0d0
      vold = (val3*cap_ad+val5*cap_bd+val6*cap_cd) / 6.0d0
      if (option .ne. 1)  return
      do i = 1, 6
         dvola(i) = 0.0d0
         dvolb(i) = 0.0d0
         dvolc(i) = 0.0d0
         dvold(i) = 0.0d0
      end do
      teteps = 1.0d-5
      call tetra_volume (rab2,rac2,rad2,rbc2,rbd2,rcd2,tetvol)
      if (tetvol .lt. teteps)  return
      dist(1) = rab
      dist(2) = rac
      dist(3) = rad
      dist(4) = rbc
      dist(5) = rbd
      dist(6) = rcd
      dval1b = l1
      dval2b = l2
      dval3b = l3
      dval4b = l4
      dval5b = l5
      dval6b = l6
      dval1 = 1.0d0 - l1
      dval2 = 1.0d0 - l2
      dval3 = 1.0d0 - l3
      dval4 = 1.0d0 - l4
      dval5 = 1.0d0 - l5
      dval6 = 1.0d0 - l6
      drho_ab2 = -2.0d0 * dval1b * val1b
      drho_ac2 = -2.0d0 * dval2b * val2b
      drho_ad2 = -2.0d0 * dval3b * val3b
      drho_bc2 = -2.0d0 * dval4b * val4b
      drho_bd2 = -2.0d0 * dval5b * val5b
      drho_cd2 = -2.0d0 * dval6b * val6b
c
      do i = 1, 6
         do j = 1, 6
            dcotan(i,j) = -deriv(i,j) * (1.0d0+cotan(i)*cotan(i))
            dinvsin(i,j) = -deriv(i,j) * cotan(i) * invsin(i)
         end do
      end do
      val1_ab = cos_abc*cos_abc + cos_abd*cos_abd
      val2_ab = 2.0d0 * cos_abc * cos_abd
      dval1_ab(1) = 2.0d0 * (deriv_abc(1,1)*cos_abc
     &                          +deriv_abd(1,1)*cos_abd)
      dval1_ab(2) = 2.0d0 * deriv_abc(1,2) * cos_abc
      dval1_ab(3) = 2.0d0 * deriv_abd(1,2) * cos_abd
      dval1_ab(4) = 2.0d0 * deriv_abc(1,3) * cos_abc
      dval1_ab(5) = 2.0d0 * deriv_abd(1,3) * cos_abd
      dval1_ab(6) = 0.0d0
      dval2_ab(1) = 2.0d0 * (deriv_abc(1,1)*cos_abd
     &                          +deriv_abd(1,1)*cos_abc)
      dval2_ab(2) = 2.0d0 * deriv_abc(1,2) * cos_abd
      dval2_ab(3) = 2.0d0 * deriv_abd(1,2) * cos_abc
      dval2_ab(4) = 2.0d0 * deriv_abc(1,3) * cos_abd
      dval2_ab(5) = 2.0d0 * deriv_abd(1,3) * cos_abc
      dval2_ab(6) = 0.0d0
c
      do i = 1, 6
         dcap_ab(i) = -dval1_ab(i)*cotan(1) - val1_ab*dcotan(1,i)
     &                   + dval2_ab(i)*invsin(1) + val2_ab*dinvsin(1,i)
         dcap_ab(i) = 2.0d0 * dist(i) * rho_ab2 * dcap_ab(i)
      end do
      dcap_ab(1) = dcap_ab(1) + drho_ab2*val_ab
      val1_ac = cos_acb*cos_acb + cos_acd*cos_acd
      val2_ac = 2.0d0 * cos_acb * cos_acd
      dval1_ac(1) = 2.0d0 * deriv_abc(2,1) * cos_acb
      dval1_ac(2) = 2.0d0 * (deriv_abc(2,2)*cos_acb
     &                          +deriv_acd(1,1)*cos_acd)
      dval1_ac(3) = 2.0d0 * deriv_acd(1,2) * cos_acd
      dval1_ac(4) = 2.0d0 * deriv_abc(2,3) * cos_acb
      dval1_ac(5) = 0.0d0
      dval1_ac(6) = 2.0d0 * deriv_acd(1,3) * cos_acd
      dval2_ac(1) = 2.0d0 * deriv_abc(2,1) * cos_acd
      dval2_ac(2) = 2.0d0 * (deriv_abc(2,2)*cos_acd
     &                          +deriv_acd(1,1)*cos_acb)
      dval2_ac(3) = 2.0d0 * deriv_acd(1,2) * cos_acb
      dval2_ac(4) = 2.0d0 * deriv_abc(2,3) * cos_acd
      dval2_ac(5) = 0.0d0
      dval2_ac(6) = 2.0d0 * deriv_acd(1,3) * cos_acb
c
      do i = 1, 6
         dcap_ac(i) = -dval1_ac(i)*cotan(2) - val1_ac*dcotan(2,i)
     &                   + dval2_ac(i)*invsin(2) + val2_ac*dinvsin(2,i)
         dcap_ac(i) = 2.0d0 * dist(i) * rho_ac2 * dcap_ac(i)
      end do
      dcap_ac(2) = dcap_ac(2) + drho_ac2*val_ac
      val1_ad = cos_adb*cos_adb + cos_adc*cos_adc
      val2_ad = 2.0d0 * cos_adb * cos_adc
      dval1_ad(1) = 2.0d0 * deriv_abd(2,1) * cos_adb
      dval1_ad(2) = 2.0d0 * deriv_acd(2,1) * cos_adc
      dval1_ad(3) = 2.0d0 * (deriv_abd(2,2)*cos_adb
     &                          +deriv_acd(2,2)*cos_adc)
      dval1_ad(4) = 0.0d0
      dval1_ad(5) = 2.0d0 * deriv_abd(2,3) * cos_adb
      dval1_ad(6) = 2.0d0 * deriv_acd(2,3) * cos_adc
      dval2_ad(1) = 2.0d0 * deriv_abd(2,1) * cos_adc
      dval2_ad(2) = 2.0d0 * deriv_acd(2,1) * cos_adb
      dval2_ad(3) = 2.0d0 * (deriv_abd(2,2)*cos_adc
     &                          +deriv_acd(2,2)*cos_adb)
      dval2_ad(4) = 0.0d0
      dval2_ad(5) = 2.0d0 * deriv_abd(2,3) * cos_adc
      dval2_ad(6) = 2.0d0 * deriv_acd(2,3) * cos_adb
c
      do i = 1, 6
         dcap_ad(i) = -dval1_ad(i)*cotan(3) - val1_ad*dcotan(3,i)
     &                   + dval2_ad(i)*invsin(3) + val2_ad*dinvsin(3,i)
         dcap_ad(i) = 2.0d0 * dist(i) * rho_ad2 * dcap_ad(i)
      end do
      dcap_ad(3) = dcap_ad(3) + drho_ad2*val_ad
      val1_bc = cos_bca*cos_bca + cos_bcd*cos_bcd
      val2_bc = 2.0d0 * cos_bca * cos_bcd
      dval1_bc(1) = 2.0d0 * deriv_abc(3,1) * cos_bca
      dval1_bc(2) = 2.0d0 * deriv_abc(3,2) * cos_bca
      dval1_bc(3) = 0.0d0
      dval1_bc(4) = 2.0d0 * (deriv_abc(3,3)*cos_bca
     &                          +deriv_bcd(1,1)*cos_bcd)
      dval1_bc(5) = 2.0d0 * deriv_bcd(1,2) * cos_bcd
      dval1_bc(6) = 2.0d0 * deriv_bcd(1,3) * cos_bcd
      dval2_bc(1) = 2.0d0 * deriv_abc(3,1) * cos_bcd
      dval2_bc(2) = 2.0d0 * deriv_abc(3,2) * cos_bcd
      dval2_bc(3) = 0.0d0
      dval2_bc(4) = 2.0d0 * (deriv_abc(3,3)*cos_bcd
     &                          +deriv_bcd(1,1)*cos_bca)
      dval2_bc(5) = 2.0d0 * deriv_bcd(1,2) * cos_bca
      dval2_bc(6) = 2.0d0 * deriv_bcd(1,3) * cos_bca
c
      do i = 1, 6
         dcap_bc(i) = -dval1_bc(i)*cotan(4) - val1_bc*dcotan(4,i)
     &                   + dval2_bc(i)*invsin(4) + val2_bc*dinvsin(4,i)
         dcap_bc(i) = 2.0d0 * dist(i) * rho_bc2 * dcap_bc(i)
      end do
      dcap_bc(4) = dcap_bc(4) + drho_bc2*val_bc
      val1_bd = cos_bda*cos_bda + cos_bdc*cos_bdc
      val2_bd = 2.0d0 * cos_bda * cos_bdc
      dval1_bd(1) = 2.0d0*deriv_abd(3,1)*cos_bda
      dval1_bd(2) = 0.0d0
      dval1_bd(3) = 2.0d0*deriv_abd(3,2)*cos_bda
      dval1_bd(4) = 2.0d0*deriv_bcd(2,1)*cos_bdc
      dval1_bd(5) = 2.0d0*(deriv_abd(3,3)*cos_bda
     &                        +deriv_bcd(2,2)*cos_bdc)
      dval1_bd(6) = 2.0d0*deriv_bcd(2,3)*cos_bdc
      dval2_bd(1) = 2.0d0*deriv_abd(3,1)*cos_bdc
      dval2_bd(2) = 0.0d0
      dval2_bd(3) = 2.0d0*deriv_abd(3,2)*cos_bdc
      dval2_bd(4) = 2.0d0*deriv_bcd(2,1)*cos_bda
      dval2_bd(5) = 2.0d0*(deriv_abd(3,3)*cos_bdc
     &                        +deriv_bcd(2,2)*cos_bda)
      dval2_bd(6) = 2.0d0*deriv_bcd(2,3)*cos_bda
c
      do i = 1, 6
         dcap_bd(i) = -dval1_bd(i)*cotan(5) - val1_bd*dcotan(5,i)
     &                   + dval2_bd(i)*invsin(5) + val2_bd*dinvsin(5,i)
         dcap_bd(i) = 2.0d0 * dist(i) * rho_bd2 * dcap_bd(i)
      end do
      dcap_bd(5) = dcap_bd(5) + drho_bd2*val_bd
      val1_cd = cos_cda*cos_cda + cos_cdb*cos_cdb
      val2_cd = 2.0d0 * cos_cda * cos_cdb
      dval1_cd(1) = 0.0d0
      dval1_cd(2) = 2.0d0 * deriv_acd(3,1) * cos_cda
      dval1_cd(3) = 2.0d0 * deriv_acd(3,2) * cos_cda
      dval1_cd(4) = 2.0d0 * deriv_bcd(3,1) * cos_cdb
      dval1_cd(5) = 2.0d0 * deriv_bcd(3,2) * cos_cdb
      dval1_cd(6) = 2.0d0 * (deriv_acd(3,3)*cos_cda
     &                          +deriv_bcd(3,3)*cos_cdb)
      dval2_cd(1) = 0.0d0
      dval2_cd(2) = 2.0d0 * deriv_acd(3,1) * cos_cdb
      dval2_cd(3) = 2.0d0 * deriv_acd(3,2) * cos_cdb
      dval2_cd(4) = 2.0d0 * deriv_bcd(3,1) * cos_cda
      dval2_cd(5) = 2.0d0 * deriv_bcd(3,2) * cos_cda
      dval2_cd(6) = 2.0d0 * (deriv_acd(3,3)*cos_cdb
     &                          +deriv_bcd(3,3)*cos_cda)
c
      do i = 1, 6
         dcap_cd(i) = -dval1_cd(i)*cotan(6) - val1_cd*dcotan(6,i)
     &                   + dval2_cd(i)*invsin(6) + val2_cd*dinvsin(6,i)
         dcap_cd(i) = 2.0d0*dist(i)*rho_cd2*dcap_cd(i)
      end do
      dcap_cd(6) = dcap_cd(6) +drho_cd2*val_cd
      do i = 1, 6
         dvola(i) = (val1b*dcap_ab(i) + val2b*dcap_ac(i)
     &                  + val3b*dcap_ad(i)) / 6.0d0
         dvolb(i) = (val1*dcap_ab(i) + val4b*dcap_bc(i)
     &                  + val5b*dcap_bd(i)) / 6.0d0
         dvolc(i) = (val2*dcap_ac(i) + val4*dcap_bc(i)
     &                  + val6b*dcap_cd(i)) / 6.0d0
         dvold(i) = (val3*dcap_ad(i) + val5*dcap_bd(i)
     &                  + val6*dcap_cd(i)) / 6.0d0
      end do
      dvola(1) = dvola(1) + dval1b*cap_ab/6.0d0
      dvola(2) = dvola(2) + dval2b*cap_ac/6.0d0
      dvola(3) = dvola(3) + dval3b*cap_ad/6.0d0
      dvolb(1) = dvolb(1) + dval1*cap_ab/6.0d0
      dvolb(4) = dvolb(4) + dval4b*cap_bc/6.0d0
      dvolb(5) = dvolb(5) + dval5b*cap_bd/6.0d0
      dvolc(2) = dvolc(2) + dval2*cap_ac/6.0d0
      dvolc(4) = dvolc(4) + dval4*cap_bc/6.0d0
      dvolc(6) = dvolc(6) + dval6b*cap_cd/6.0d0
      dvold(3) = dvold(3) + dval3*cap_ad/6.0d0
      dvold(5) = dvold(5) + dval5*cap_bd/6.0d0
      dvold(6) = dvold(6) + dval6*cap_cd/6.0d0
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine update_deriv  --  update distance derivatives  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "update_deriv" updates the derivatives of the surface or volume
c     with respect to distances, it takes into account the info from
c     three sphere/ball intersection
c
      subroutine update_deriv (dsurf,dera,derb,derc,coefa,coefb,
     &                            coefc,coef,idx1,idx2,idx3)
      implicit none
      integer i,idx1,idx2,idx3
      integer list(3)
      real*8 coefa,coefb,coefc,coef
      real*8 dera(3),derb(3),derc(3)
      real*8 dsurf(*)
c
c
      list(1) = idx1
      list(2) = idx2
      list(3) = idx3
      do i = 1, 3
         dsurf(list(i)) = dsurf(list(i))
     &                       + coef*(coefa*dera(i)+coefb*derb(i)
     &                                  +coefc*derc(i))
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine tetra_dihed  --  tetrahedron dihedral angles  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "tetra_dihed" computes the six dihedral angles of a tetrahedron
c     from its edge lengths
c
c     literature reference:
c
c     L. Yang and Z. Zeng, "Constructing a Tetrahedron with Prescribed
c     Heights and Widths", in F. Botana and T. Recio, Proceedings of
c     ADG2006, 203-211 (2007)
c
c     variables and parameters:
c
c     angle    dihedral angles as fraction of 2*pi
c     cosine   cosine of the dihedral angles
c     sine     sine of the dihedral angle
c
c     the tetrahedron is defined by its vertices A1, A2, A3 and A4,
c     the edge between vertex Ai and Aj has length Rij
c
c     if T1=(A2,A3,A4), T2=(A1,A3,A4), T3=(A1,A2,A4), T4=(A1,A2,A3),
c     the dihedral angle "angij" is between the faces Ti and Tj
c
c     input is r12sq,r13sq,r14sq,r23sq,r24sq,r34sq, where r12sq is
c     the square of the distance between A1 and A2, etc.
c
c     ang12 is the dihedral angle between (A2,A3,A4) and (A1,A3,A4),
c     and alpha12 is the dihedral angle around the edge A1A2, then
c     ang12=alpha34, ang13=alpha24, ang14=alpha23, ang23=alpha14,
c     ang24=alpha13 and ang34=alpha12
c
c     upon output the angles are in order: alpha12, alpha13, alpha14,
c     alpha23, alpha24, alpha34; the derivatives form a 6x6 matrix
c
c
      subroutine tetra_dihed (r12sq,r13sq,r14sq,r23sq,r24sq,
     &                           r34sq,angle,cosine,sine)
      use math
      implicit none
      integer i
      real*8 r12sq,r13sq,r14sq
      real*8 r23sq,r24sq,r34sq
      real*8 val1,val2,val3,val4
      real*8 val123,val124,val134
      real*8 val234,val213,val214
      real*8 val314,val324,val312
      real*8 det12,det13,det14
      real*8 det23,det24,det34
      real*8 cosine(6),sine(6),angle(6)
      real*8 minori(4)
c
c
c     the Cayley Menger matrix is defined as:
c
c     M = ( 0       r12^2   r13^2   r14^2   1 )
c         ( r12^2   0       r23^2   r24^2   1 )
c         ( r13^2   r23^2   0       r34^2   1 )
c         ( r14^2   r24^2   r34^2   0       1 )
c         ( 1       1       1       1       0 )
c
c     find all minors M(i,i) as determinants of the Cayley-Menger
c     matrix with row i and column j removed
c
c     these determinants are of the form:
c
c     det = | 0   a   b   1 |
c           | a   0   c   1 |
c           | b   c   0   1 |
c           | 1   1   1   0 |
c
c     then det = (c - a - b )^2 - 4ab
c
      val234 = r34sq - r23sq - r24sq
      val134 = r34sq - r14sq - r13sq
      val124 = r24sq - r12sq - r14sq
      val123 = r23sq - r12sq - r13sq
      minori(1) = val234*val234 - 4.0d0*r23sq*r24sq
      minori(2) = val134*val134 - 4.0d0*r13sq*r14sq
      minori(3) = val124*val124 - 4.0d0*r12sq*r14sq
      minori(4) = val123*val123 - 4.0d0*r12sq*r13sq
      val4 = 1.0d0 / sqrt(-minori(1))
      val3 = 1.0d0 / sqrt(-minori(2))
      val2 = 1.0d0 / sqrt(-minori(3))
      val1 = 1.0d0 / sqrt(-minori(4))
c
c     next compute all angles, as the cosine of the angle
c
c                (-1)^(i+j) * det(Mij) 
c     cos(i,j) = ---------------------
c                 sqrt(M(i,i)*M(j,j))
c
c     where det(Mij) = M(i,j) is the determinant of the Cayley-Menger
c     matrix with row i and column j removed
c
      det12 = -2.0d0*r12sq*val134 - val123*val124
      det13 = -2.0d0*r13sq*val124 - val123*val134
      det14 = -2.0d0*r14sq*val123 - val124*val134
      val213 = r13sq -r12sq -r23sq
      val214 = r14sq -r12sq -r24sq
      val312 = r12sq -r13sq -r23sq
      val314 = r14sq -r13sq -r34sq
      val324 = r24sq -r23sq -r34sq
      det23 = -2.0d0*r23sq*val214 - val213*val234
      det24 = -2.0d0*r24sq*val213 - val214*val234
      det34 = -2.0d0*r34sq*val312 - val314*val324
      cosine(1) = det12 * val1 * val2
      cosine(2) = det13 * val1 * val3
      cosine(3) = det14 * val2 * val3
      cosine(4) = det23 * val1 * val4
      cosine(5) = det24 * val2 * val4
      cosine(6) = det34 * val3 * val4
      do i = 1, 6
         if (cosine(i) > 1.0d0) then
            cosine(i) = 1.0d0
         else if (cosine(i) .lt. -1.0d0) then
            cosine(i) = -1.0d0
         end if
      end do
      do i = 1, 6
         angle(i) = acos(cosine(i))
         sine(i) = sin(angle(i))
         angle(i) = angle(i) / twopi
      end do
c
c     surface area of the four faces of the tetrahedron
c
c     surf_234 = sqrt(-minori(1)/16.0d0)
c     surf_134 = sqrt(-minori(2)/16.0d0)
c     surf_124 = sqrt(-minori(3)/16.0d0)
c     surf_123 = sqrt(-minori(4)/16.0d0)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine tetra_3dihed_cos  --  tetrahedron cosine values  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "tetra_3dihed_cos" computes three of the six dihedral angles
c     of a tetrahedron from edge lengths, and outputs their cosines
c
c     literature reference:
c
c     L. Yang and Z. Zeng, "Constructing a Tetrahedron with Prescribed
c     Heights and Widths", in F. Botana and T. Recio, Proceedings of
c     ADG2006, 203-211 (2007)
c
c     the tetrahedron is defined by its vertices A1, A2, A3 and A4,
c     the edge between vertex Ai and Aj has length Rij; here we only
c     need the dihedral angles around A1A2, A1A3 and A2A3
c
c     input is r12sq,r13sq,r14sq,r23sq,r24sq,r34sq, where r12sq is
c     the square of the distance between A1 and A2, etc.; output is
c     the cosine of the three dihedral angles
c
c
      subroutine tetra_3dihed_cos (r12sq,r13sq,r14sq,r23sq,
     &                                r24sq,r34sq,cosine)
      implicit none
      real*8 r12sq,r13sq,r14sq
      real*8 r23sq,r24sq,r34sq
      real*8 val1,val2,val3,val4
      real*8 val123,val124,val134
      real*8 val234,val213,val214
      real*8 det12,det13,det23
      real*8 cosine(3)
      real*8 minori(4)
c
c
c     the Cayley Menger matrix is defined as:
c
c     M = ( 0       r12^2   r13^2   r14^2   1 )
c         ( r12^2   0       r23^2   r24^2   1 )
c         ( r13^2   r23^2   0       r34^2   1 )
c         ( r14^2   r24^2   r34^2   0       1 )
c         ( 1       1       1       1       0 )
c
c     find all minors M(i,i) as determinants of the Cayley-Menger
c     matrix with row i and column j removed
c
c     these determinants are of the form:
c
c     det = | 0   a   b   1 |
c           | a   0   c   1 |
c           | b   c   0   1 |
c           | 1   1   1   0 |
c
c     then det = (c - a - b )^2 - 4ab
c
      val234 = r34sq - r23sq - r24sq
      val134 = r34sq - r14sq - r13sq
      val124 = r24sq - r12sq - r14sq
      val123 = r23sq - r12sq - r13sq
      minori(1) = val234*val234 - 4.0d0*r23sq*r24sq
      minori(2) = val134*val134 - 4.0d0*r13sq*r14sq
      minori(3) = val124*val124 - 4.0d0*r12sq*r14sq
      minori(4) = val123*val123 - 4.0d0*r12sq*r13sq
      val4 = 1.0d0 / sqrt(-minori(1))
      val3 = 1.0d0 / sqrt(-minori(2))
      val2 = 1.0d0 / sqrt(-minori(3))
      val1 = 1.0d0 / sqrt(-minori(4))
c
c     next compute all angles, as the cosine of the angle
c
c                (-1)^(i+j) * det(Mij) 
c     cos(i,j) = ---------------------
c                 sqrt(M(i,i)*M(j,j))
c
c     where det(Mij) = M(i,j) is the determinant of the Cayley-Menger
c     matrix with row i and column j removed
c
      det12 = -2.0d0*r12sq*val134 - val123*val124
      det13 = -2.0d0*r13sq*val124 - val123*val134
      val213 = r13sq - r12sq -r23sq
      val214 = r14sq - r12sq -r24sq
      det23 = -2.0d0*r23sq*val214 - val213*val234
      cosine(1) = det12 * val1 * val2
      cosine(2) = det13 * val1 * val3
      cosine(3) = det23 * val1 * val4
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine tetra_dihed_der  --  tetrahedrn dihedral deriv  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "tetra_dihed_der" finds the six dihedral angles of a tetrahedron
c     from its edge lengths as well as their derivatives with respect
c     to these edge lengths
c
c     literature reference:
c
c     L. Yang and Z. Zeng, "Constructing a Tetrahedron with Prescribed
c     Heights and Widths", in F. Botana and T. Recio, Proceedings of
c     ADG2006, 203-211 (2007)
c
c     variables and parameters:
c
c     angle    dihedral angles as fraction of 2*pi
c     cosine   cosine of the dihedral angles
c     sine     sine of the dihedral angle
c     deriv    derivatives of the dihedral angles with
c                respect to the edge lengths AB, AC and BC
c
c     the tetrahedron is defined by its vertices A1, A2, A3 and A4,
c     the edge between vertex Ai and Aj has length Rij
c
c     if T1=(A2,A3,A4), T2=(A1,A3,A4), T3=(A1,A2,A4), T4=(A1,A2,A3),
c     the dihedral angle "angij" is between the faces Ti and Tj
c
c     if T1=(A2,A3,A4), T2=(A1,A3,A4), T3=(A1,A2,A4), T4=(A1,A2,A3),
c     the dihedral angle "angij" is between the faces Ti and Tj
c
c     input is r12sq,r13sq,r14sq,r23sq,r24sq,r34sq, where r12sq is
c     the square of the distance between A1 and A2, etc.
c
c     ang12 is the dihedral angle between (A2,A3,A4) and (A1,A3,A4),
c     and alpha12 is the dihedral angle around the edge A1A2, then
c     ang12=alpha34, ang13=alpha24, ang14=alpha23, ang23=alpha14,
c     ang24=alpha13 and ang34=alpha12
c
c     upon output the angles are in order: alpha12, alpha13, alpha14,
c     alpha23, alpha24, alpha34; the derivatives form a 6x6 matrix
c
c
      subroutine tetra_dihed_der (r12sq,r13sq,r14sq,r23sq,r24sq,r34sq,
     &                               angle,cosine,sine,deriv)
      use math
      implicit none
      integer i,j,k,m,jj
      real*8 r12sq,r13sq,r14sq
      real*8 r23sq,r24sq,r34sq
      real*8 val123,val124,val134
      real*8 val234,val213,val214
      real*8 val314,val324,val312
      real*8 vala,val1,val2,val3
      real*8 tetvol,teteps
      real*8 minori(4),val(4)
      real*8 cosine(6),sine(6),angle(6)
      real*8 det(6),deriv(6,6),dnum(6,6)
      real*8 dminori(4,6)
c
c
c     the Cayley Menger matrix is defined as:
c
c     M = ( 0       r12^2   r13^2   r14^2   1 )
c         ( r12^2   0       r23^2   r24^2   1 )
c         ( r13^2   r23^2   0       r34^2   1 )
c         ( r14^2   r24^2   r34^2   0       1 )
c         ( 1       1       1       1       0 )
c
c     find all minors M(i,i) as determinants of the Cayley-Menger
c     matrix with row i and column j removed
c
c     these determinants are of the form:
c
c     det = | 0   a   b   1 |
c           | a   0   c   1 |
c           | b   c   0   1 |
c           | 1   1   1   0 |
c
c     then det = (c - a - b )^2 - 4ab
c
      val234 = r34sq - r23sq - r24sq
      val134 = r34sq - r14sq - r13sq
      val124 = r24sq - r12sq - r14sq
      val123 = r23sq - r12sq - r13sq
      minori(1) = val234*val234 - 4.0d0*r23sq*r24sq
      minori(2) = val134*val134 - 4.0d0*r13sq*r14sq
      minori(3) = val124*val124 - 4.0d0*r12sq*r14sq
      minori(4) = val123*val123 - 4.0d0*r12sq*r13sq
      val(1) = 1.0d0 / sqrt(-minori(1))
      val(2) = 1.0d0 / sqrt(-minori(2))
      val(3) = 1.0d0 / sqrt(-minori(3))
      val(4) = 1.0d0 / sqrt(-minori(4))
c
c     next compute all angles, as the cosine of the angle
c
c                (-1)^(i+j) * det(Mij) 
c     cos(i,j) = ---------------------
c                 sqrt(M(i,i)*M(j,j))
c
c     where det(Mij) = M(i,j) is the determinant of the Cayley-Menger
c     matrix with row i and column j removed
c
      det(6) = -2.0d0*r12sq*val134 - val123*val124
      det(5) = -2.0d0*r13sq*val124 - val123*val134
      det(4) = -2.0d0*r14sq*val123 - val124*val134
      val213 = r13sq -r12sq -r23sq
      val214 = r14sq -r12sq -r24sq
      val312 = r12sq -r13sq -r23sq
      val314 = r14sq -r13sq -r34sq
      val324 = r24sq -r23sq -r34sq
      det(3) = -2.0d0*r23sq*val214 - val213*val234
      det(2) = -2.0d0*r24sq*val213 - val214*val234
      det(1) = -2.0d0*r34sq*val312 - val314*val324
      cosine(1) = det(6) * val(3) * val(4)
      cosine(2) = det(5) * val(2) * val(4)
      cosine(3) = det(4) * val(2) * val(3)
      cosine(4) = det(3) * val(1) * val(4)
      cosine(5) = det(2) * val(1) * val(3)
      cosine(6) = det(1) * val(1) * val(2)
      do i = 1, 6
         if (cosine(i) > 1.0d0) then
            cosine(i) = 1.0d0
         else if (cosine(i) .lt. -1.0d0) then
            cosine(i) = -1.0d0
         end if
      end do
      do i = 1, 6
         angle(i) = acos(cosine(i))
         sine(i) = sin(angle(i))
         angle(i) = angle(i) / twopi
      end do
      do i = 1, 6
         do j = 1, 6
            deriv(i,j) = 0.0d0
         end do
      end do
      teteps = 1.0d-5
      call tetra_volume (r12sq,r13sq,r14sq,r23sq,r24sq,r34sq,tetvol)
      if (tetvol .lt. teteps)  return
c
c     compute derivatives of angles with respect to edge lengths
c
c                          num(i,j)
c     cos(ang(i,j)) = -------------------
c                     sqrt(M(i,i)*M(j,j))
c
c     d(ang(i,j))                         dnum(i,j)
c     ----------- sin(ang(i,j)) = --------------------------
c       dr(a,b)                   sqrt(M(i,i)M(j,j)) dr(a,b)
c
c                                   M(i,i)dM(j,j) + M(j,j)*dM(i,i)
c                    - 0.5*num(i,j) -------------------------------
c                                   M(i,i)M(j,j) sqrt(M(i,i)M(j,j))
c
c     which we can rewrite as:
c
c     d(ang(i,j))                 cosine(i,j) dnum(i,j)
c     ----------- sin(ang(i,j)) = ----------- ---------
c       dr(a,b)                    num(i,j)    dr(a,b)
c
c                                       dM(j,j) +  dM(i,i))
c                    - 0.5*cosine(i,j) (-------- + --------)
c                                        M(j,j)     M(i,i)
c
      do i = 1, 6
         do j = 1, 4
            dminori(j,i) = 0.0d0
         end do
      end do
      dminori(1,4) = -val234 - 2.0d0*r24sq
      dminori(1,5) = -val234 - 2.0d0*r23sq
      dminori(1,6) = val234
      dminori(2,2) = -val134 - 2.0d0*r14sq
      dminori(2,3) = -val134 - 2.0d0*r13sq
      dminori(2,6) = val134
      dminori(3,1) = -val124 - 2.0d0*r14sq
      dminori(3,3) = -val124 - 2.0d0*r12sq
      dminori(3,5) = val124
      dminori(4,1) = -val123 - 2.0d0*r13sq
      dminori(4,2) = -val123 - 2.0d0*r12sq
      dminori(4,4) = val123
      dnum(6,1) = -2.0d0*val134 + val123+val124
      dnum(6,2) = 2.0d0*r12sq + val124
      dnum(6,3) = 2.0d0*r12sq + val123
      dnum(6,4) = -val124
      dnum(6,5) = -val123
      dnum(6,6) = -2.0d0 * r12sq
      dnum(5,1) = 2.0d0*r13sq + val134
      dnum(5,2) = -2.0d0*val124 + val123 + val134
      dnum(5,3) = 2.0d0*r13sq + val123
      dnum(5,4) = -val134
      dnum(5,5) = -2.0d0 * r13sq
      dnum(5,6) = -val123
      dnum(4,1) = 2.0d0*r14sq + val134
      dnum(4,2) = 2.0d0*r14sq + val124
      dnum(4,3) = -2.0d0*val123 + val124 + val134
      dnum(4,4) = -2.0d0 * r14sq
      dnum(4,5) = -val134
      dnum(4,6) = -val124
      dnum(3,1) = 2.0d0*r23sq + val234
      dnum(3,2) = -val234
      dnum(3,3) = -2.0d0 * r23sq
      dnum(3,4) = -2.0d0*val214 + val213 + val234
      dnum(3,5) = 2.0d0*r23sq + val213
      dnum(3,6) = -val213
      dnum(2,1) = 2.0d0*r24sq + val234
      dnum(2,2) = -2.0d0 * r24sq
      dnum(2,3) = -val234
      dnum(2,4) = 2.0d0*r24sq + val214
      dnum(2,5) = -2.0d0*val213 + val214 + val234
      dnum(2,6) = -val214
      dnum(1,1) = -2.0d0 * r34sq
      dnum(1,2) = 2.0d0*r34sq + val324
      dnum(1,3) = -val324
      dnum(1,4) = 2.0d0*r34sq + val314
      dnum(1,5) = -val314
      dnum(1,6) = -2.0d0*val312 + val314 + val324
      k = 0
      do i = 1, 3
         do j = i+1, 4
            k = k + 1
            jj = 7 - k
            if (det(k) .ne. 0) then
               vala = cosine(jj) / sine(jj)
               val1 = -vala / det(k)
               val2 = vala / minori(j)
               val3 = vala / minori(i)
               do m = 1, 6
                  deriv(jj,m) = val1*dnum(k,m) + val2*dminori(j,m)
     &                             + val3*dminori(i,m)
               end do
            else
               vala = -val(i) * val(j) / sine(jj)
               do m = 1, 6
                  deriv(jj,m) = vala * dnum(k,m)
               end do
            end if
         end do
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine tetra_dihed_der3  --  tetrahedron angle derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "tetra_dihed_der3" computes the six dihedral angles of the
c     tetrahedron (A, B, C, D) from its edge lengths as well as the
c     derivatives with respect to the edge lengths AB, AC and BC
c
c     literature reference:
c
c     L. Yang and Z. Zeng, "Constructing a Tetrahedron with Prescribed
c     Heights and Widths", in F. Botana and T. Recio, Proceedings of
c     ADG2006, 203-211 (2007)
c
c     variables and parameters:
c
c     angle    dihedral angles as fraction of 2*pi
c     cosine   cosine of the dihedral angles
c     sine     sine of the dihedral angle
c     deriv    derivatives of the dihedral angles with
c                respect to the edge lengths AB, AC and BC
c
c     the tetrahedron is defined by its vertices A1, A2, A3 and A4,
c     the edge between vertex Ai and Aj has length Rij
c
c     if T1=(A2,A3,A4), T2=(A1,A3,A4), T3=(A1,A2,A4), T4=(A1,A2,A3),
c     the dihedral angle "angij" is between the faces Ti and Tj
c
c     input is r12sq,r13sq,r14sq,r23sq,r24sq,r34sq, where r12sq is
c     the square of the distance between A1 and A2, etc.
c
c     ang12 is the dihedral angle between (A2,A3,A4) and (A1,A3,A4),
c     and alpha12 is the dihedral angle around the edge A1A2, then
c     ang12=alpha34, ang13=alpha24, ang14=alpha23, ang23=alpha14,
c     ang24=alpha13 and ang34=alpha12
c
c     upon output the angles are in the order: alpha12, alpha13,
c     alpha14, alpha23, alpha24, alpha34
c
c
      subroutine tetra_dihed_der3 (r12sq,r13sq,r14sq,r23sq,r24sq,r34sq,
     &                                angle,cosine,sine,deriv,option)
      use math
      implicit none
      integer i,j,k,m,jj,option
      real*8 r12sq,r13sq,r14sq
      real*8 r23sq,r24sq,r34sq
      real*8 val123,val124,val134
      real*8 val234,val213,val214
      real*8 val314,val324,val312
      real*8 vala,val1,val2,val3
      real*8 tetvol, teteps
      real*8 minori(4),val(4)
      real*8 cosine(6),sine(6),angle(6)
      real*8 det(6),deriv(6,3),dnum(6,3)
      real*8 dminori(4,3)
c
c
c     the Cayley Menger matrix is defined as:
c
c     M = ( 0       r12^2   r13^2   r14^2   1 )
c         ( r12^2   0       r23^2   r24^2   1 )
c         ( r13^2   r23^2   0       r34^2   1 )
c         ( r14^2   r24^2   r34^2   0       1 )
c         ( 1       1       1       1       0 )
c
c     find all minors M(i,i) as determinants of the Cayley-Menger
c     matrix with row i and column j removed
c
c     these determinants are of the form:
c
c     det = | 0   a   b   1 |
c           | a   0   c   1 |
c           | b   c   0   1 |
c           | 1   1   1   0 |
c
c     then det = (c - a - b )^2 - 4ab
c
      val234 = r34sq - r23sq - r24sq
      val134 = r34sq - r14sq - r13sq
      val124 = r24sq - r12sq - r14sq
      val123 = r23sq - r12sq - r13sq
      minori(1) = val234*val234 - 4.0d0*r23sq*r24sq
      minori(2) = val134*val134 - 4.0d0*r13sq*r14sq
      minori(3) = val124*val124 - 4.0d0*r12sq*r14sq
      minori(4) = val123*val123 - 4.0d0*r12sq*r13sq
      val(1) = 1.0d0 / sqrt(-minori(1))
      val(2) = 1.0d0 / sqrt(-minori(2))
      val(3) = 1.0d0 / sqrt(-minori(3))
      val(4) = 1.0d0 / sqrt(-minori(4))
c
c     next compute all angles, as the cosine of the angle
c
c                (-1)^(i+j) * det(Mij) 
c     cos(i,j) = ---------------------
c                 sqrt(M(i,i)*M(j,j))
c
c     where det(Mij) = M(i,j) is the determinant of the Cayley-Menger
c     matrix with row i and column j removed
c
      det(6) = -2.0d0*r12sq*val134 - val123*val124
      det(5) = -2.0d0*r13sq*val124 - val123*val134
      det(4) = -2.0d0*r14sq*val123 - val124*val134
      val213 = r13sq - r12sq - r23sq
      val214 = r14sq - r12sq - r24sq
      val312 = r12sq - r13sq - r23sq
      val314 = r14sq - r13sq - r34sq
      val324 = r24sq - r23sq - r34sq
      det(3) = -2.0d0*r23sq*val214 - val213*val234
      det(2) = -2.0d0*r24sq*val213 - val214*val234
      det(1) = -2.0d0*r34sq*val312 - val314*val324
      cosine(1) = det(6) * val(3) * val(4)
      cosine(2) = det(5) * val(2) * val(4)
      cosine(3) = det(4) * val(2) * val(3)
      cosine(4) = det(3) * val(1) * val(4)
      cosine(5) = det(2) * val(1) * val(3)
      cosine(6) = det(1) * val(1) * val(2)
      do i = 1, 6
         if (cosine(i) > 1.0d0) then
            cosine(i) = 1.0d0
         else if (cosine(i) .lt. -1.0d0) then
            cosine(i) = -1.0d0
         end if
      end do
      do i = 1, 6
         angle(i) = acos(cosine(i))
         sine(i) = sin(angle(i))
         angle(i) = angle(i) / twopi
      end do
      if (option .eq. 0)  return
      do i = 1, 6
         do j = 1, 3
            deriv(i,j) = 0.0d0
         end do
      end do
      teteps = 1.0d-5
      call tetra_volume (r12sq,r13sq,r14sq,r23sq,r24sq,r34sq,tetvol)
      if (tetvol .lt. teteps)  return
c
c     compute derivatives of angles with respect to edge lengths
c
c                          num(i,j)
c     cos(ang(i,j)) = -------------------
c                     sqrt(M(i,i)*M(j,j))
c
c     d(ang(i,j))                         dnum(i,j)
c     ----------- sin(ang(i,j)) = --------------------------
c       dr(a,b)                   sqrt(M(i,i)M(j,j)) dr(a,b)
c
c                                   M(i,i)dM(j,j) + M(j,j)*dM(i,i)
c                    - 0.5*num(i,j) -------------------------------
c                                   M(i,i)M(j,j) sqrt(M(i,i)M(j,j))
c
c     which we can rewrite as:
c
c     d(ang(i,j))                 cosine(i,j) dnum(i,j)
c     ----------- sin(ang(i,j)) = ----------- ---------
c       dr(a,b)                    num(i,j)    dr(a,b)
c
c                                       dM(j,j) +  dM(i,i))
c                    - 0.5*cosine(i,j) (-------- + --------)
c                                        M(j,j)     M(i,i)
c
      do i = 1, 3
         do j = 1, 4
            dminori(j,i) = 0.0d0
         end do
      end do
      dminori(1,3) = -val234 - 2.0d0*r24sq
      dminori(2,2) = -val134 - 2.0d0*r14sq
      dminori(3,1) = -val124 - 2.0d0*r14sq
      dminori(4,1) = -val123 - 2.0d0*r13sq
      dminori(4,2) = -val123 - 2.0d0*r12sq
      dminori(4,3) = val123
      dnum(6,1) = -2.0d0*val134 + val123+val124
      dnum(6,2) = 2.0d0*r12sq + val124
      dnum(6,3) = -val124
      dnum(5,1) = 2.0d0*r13sq + val134
      dnum(5,2) = -2.0d0*val124 + val123 + val134
      dnum(5,3) = -val134
      dnum(4,1) = 2.0d0*r14sq + val134
      dnum(4,2) = 2.0d0*r14sq + val124
      dnum(4,3) = -2.0d0 * r14sq
      dnum(3,1) = 2.0d0*r23sq + val234
      dnum(3,2) = -val234
      dnum(3,3) = -2.0d0*val214 + val213 + val234
      dnum(2,1) = 2.0d0*r24sq + val234
      dnum(2,2) = -2.0d0 * r24sq
      dnum(2,3) = 2.0d0*r24sq + val214
      dnum(1,1) = -2.0d0 * r34sq
      dnum(1,2) = 2.0d0*r34sq + val324
      dnum(1,3) = 2.0d0*r34sq + val314
      k = 0
      do i = 1, 3
         do j = i+1, 4
            k = k + 1
            jj = 7 - k
            if (det(k) .ne. 0) then
               vala = cosine(jj) / sine(jj)
               val1 = -vala / det(k)
               val2 = vala / minori(j)
               val3 = vala / minori(i)
               do m = 1, 3
                  deriv(jj,m) = val1*dnum(k,m) + val2*dminori(j,m)
     &                             + val3*dminori(i,m)
               end do
            else
               vala = -val(i) * val(j) / sine(jj)
               do m = 1, 3
                  deriv(jj,m) = vala * dnum(k,m)
               end do
            end if
         end do
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine tetra_3dihed_dcos  --  tetrahedrn cosine deriv  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "tetra_3dihed_dcos" computes three of the six dihedral angles
c     of a tetrahedron from its edge lengths, and outputs the cosines
c
c     literature reference:
c
c     L. Yang and Z. Zeng, "Constructing a Tetrahedron with Prescribed
c     Heights and Widths", in F. Botana and T. Recio, Proceedings of
c     ADG2006, 203-211 (2007)
c
c     the tetrahedron is defined by its vertices A1, A2, A3 and A4,
c     the edge between vertex Ai and Aj has length Rij
c
c     only need dihedral angles around A1A2, A1A3 and A2A3
c
c     variables and parameters:
c
c     r12sq,r13sq,r14sq,    distance squared between pairs of balls
c       r23sq,r24sq,r34sq
c     cosine                cosine of the three dihedral angles
c     deriv                 derivatives of the cosines over the
c                             AB, AC and BC distances
c
c
      subroutine tetra_3dihed_dcos (r12sq,r13sq,r14sq,r23sq,r24sq,
     &                                r34sq,cosine,deriv,option)
      implicit none
      integer i,j,option
      real*8 r12sq,r13sq,r14sq
      real*8 r23sq,r24sq,r34sq
      real*8 val1,val2,val3,val4
      real*8 val123,val124,val134
      real*8 val234,val213,val214
      real*8 det12,det13,det23
      real*8 cosine(3)
      real*8 minori(4)
      real*8 deriv(3,3)
      real*8 dminori(4,3)
      real*8 dnum(3,3)
c
c
c     the Cayley Menger matrix is defined as:
c
c     M = ( 0       r12^2   r13^2   r14^2   1 )
c         ( r12^2   0       r23^2   r24^2   1 )
c         ( r13^2   r23^2   0       r34^2   1 )
c         ( r14^2   r24^2   r34^2   0       1 )
c         ( 1       1       1       1       0 )
c
c     find all minors M(i,i) as determinants of the Cayley-Menger
c     matrix with row i and column j removed
c
c     these determinants are of the form:
c
c     det = | 0   a   b   1 |
c           | a   0   c   1 |
c           | b   c   0   1 |
c           | 1   1   1   0 |
c
c     then det = (c - a - b )^2 - 4ab
c
      val234 = r34sq - r23sq - r24sq
      val134 = r34sq - r14sq - r13sq
      val124 = r24sq - r12sq - r14sq
      val123 = r23sq - r12sq - r13sq
      minori(1) = val234*val234 - 4.0d0*r23sq*r24sq
      minori(2) = val134*val134 - 4.0d0*r13sq*r14sq
      minori(3) = val124*val124 - 4.0d0*r12sq*r14sq
      minori(4) = val123*val123 - 4.0d0*r12sq*r13sq
      val4 = 1.0d0 / sqrt(-minori(1))
      val3 = 1.0d0 / sqrt(-minori(2))
      val2 = 1.0d0 / sqrt(-minori(3))
      val1 = 1.0d0 / sqrt(-minori(4))
c
c     next compute all angles, as the cosine of the angle
c
c                (-1)^(i+j) * det(Mij) 
c     cos(i,j) = ---------------------
c                 sqrt(M(i,i)*M(j,j))
c
c     where det(Mij) = M(i,j) is the determinant of the Cayley-Menger
c     matrix with row i and column j removed
c
      det12 = -2.0d0*r12sq*val134 - val123*val124
      det13 = -2.0d0*r13sq*val124 - val123*val134
      val213 = r13sq -r12sq -r23sq
      val214 = r14sq -r12sq -r24sq
      det23 = -2.0d0*r23sq*val214 - val213*val234
      cosine(1) = det12 * val1 * val2
      cosine(2) = det13 * val1 * val3
      cosine(3) = det23 * val1 * val4
      if (option .eq. 0)  return
      do i = 1, 3
         do j = 1, 4
            dminori(j,i) = 0.0d0
         end do
      end do
      dminori(1,3) = -val234 - 2.0d0*r24sq
      dminori(2,2) = -val134 - 2.0d0*r14sq
      dminori(3,1) = -val124 - 2.0d0*r14sq
      dminori(4,1) = -val123 - 2.0d0*r13sq
      dminori(4,2) = -val123 - 2.0d0*r12sq
      dminori(4,3) = val123
      dnum(1,1) = -2.0d0*val134 + val123+val124
      dnum(1,2) = 2.0d0*r12sq + val124
      dnum(1,3) = -val124
      dnum(2,1) = 2.0d0*r13sq + val134
      dnum(2,2) = -2.0d0*val124 + val123 + val134
      dnum(2,3) = -val134
      dnum(3,1) = 2.0d0*r23sq + val234
      dnum(3,2) = -val234
      dnum(3,3) = -2.0d0*val214 + val213 + val234
      do i = 1, 3
         deriv(1,i) = dnum(1,i)*val1*val2 - cosine(1)*
     &                (dminori(3,i)/minori(3)+dminori(4,i)/minori(4))
         deriv(2,i) = dnum(2,i)*val1*val3 - cosine(2)*
     &                (dminori(2,i)/minori(2)+dminori(4,i)/minori(4))
         deriv(3,i) = dnum(3,i)*val1*val4 - cosine(3)*
     &                (dminori(1,i)/minori(1)+dminori(4,i)/minori(4))
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine truncate_real  --  truncate precision of real  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "truncate_real" converts a real number to a given accuracy
c     with a specified number of digits after the decimal point)
c
c
      subroutine truncate_real (x_in,x_out,ndigit)
      implicit none
      integer i,mantissa
      integer ndigit
      integer digit(16)
      real*8 x_in,x_out,y
      real*8 fact
c
c
      mantissa = int(x_in)
      y = x_in - mantissa
      x_out = mantissa
      fact = 1
      do i = 1, ndigit
         fact = fact * 10.0d0
         digit(i) = nint(y*10.0d0)
         y = 10.0d0 * (y-digit(i)/10.0d0)
         x_out = x_out + digit(i)/fact
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine crossvect  --  cross product of two vectors  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "crossvect" computes the cross product of two vectors
c
c
      subroutine crossvect (u1,u2,u3)
      implicit none
      real*8 u1(3),u2(3),u3(3)
c
c
      u3(1) = u1(2)*u2(3) - u1(3)*u2(2)
      u3(2) = -u1(1)*u2(3) + u1(3)*u2(1)
      u3(3) = u1(1)*u2(2) - u1(2)*u2(1)
      return
      end
c
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine dotvect  --  dot product of two vectors  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     dotvect" computes the dot product of two vectors
c
c
      subroutine dotvect (u1,u2,dot)
      implicit none
      integer i
      real*8 u1(3),u2(3),dot
c
c
      dot = 0.0d0
      do i = 1, 3
         dot = dot + u1(i)*u2(i)
      end do
      return
      end
c
c
c     #########################################################
c     ##                                                     ##
c     ##  subroutine normvect  --  compute norm of a vector  ##
c     ##                                                     ##
c     #########################################################
c
c
c     "normvect" compute the norm length of a vector
c
c
      subroutine normvect (u1,norm)
      implicit none
      real*8 u1(3),norm
c
c
      call dotvect (u1,u1,norm)
      norm = sqrt(norm)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine diffvect  --  difference between two vectors  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "diffvect" computes the difference between two vectors
c
c
      subroutine diffvect (u1,u2,u3)
      implicit none
      integer i
      real*8 u1(3),u2(3),u3(3)
c
c
      do i = 1, 3
         u3(i) = u2(i) - u1(i)
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine minor5  --  find the sign of 5x5 determinant  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "minor5" computes the value of a 5x5 determinant built from
c     coordinates of specified balls; if the determinant is zero,
c     then checks minors until a nonzero value is found
c
c
      subroutine minor5 (crdball,radball,a,b,c,d,e,result)
      implicit none
      integer a,b,c,d,e
      integer result
      integer isign
      integer ida1,ida2,ida3
      integer idb1,idb2,idb3
      integer idc1,idc2,idc3
      integer idd1,idd2,idd3
      integer ide1,ide2,ide3
      real*8 det,psub,padd,t1,t2
      real*8 r11,r21,r31,r41,r51
      real*8 r12,r22,r32,r42,r52
      real*8 r13,r23,r33,r43,r53
      real*8 r14,r24,r34,r44,r54
      real*8 rr1,rr2,rr3,rr4,rr5
      real*8 crdball(*)
      real*8 radball(*)
c
c
c     get the value of the determinant and find its sign
c
      ida1 = 3*a - 2
      ida2 = ida1 + 1
      ida3 = ida2 + 1
      idb1 = 3*b - 2
      idb2 = idb1 + 1
      idb3 = idb2 + 1
      idc1 = 3*c - 2
      idc2 = idc1 + 1
      idc3 = idc2 + 1
      idd1 = 3*d - 2
      idd2 = idd1 + 1
      idd3 = idd2 + 1
      ide1 = 3*e - 2
      ide2 = ide1 + 1
      ide3 = ide2 + 1
      r11 = crdball(ida1)
      r12 = crdball(ida2)
      r13 = crdball(ida3)
      r21 = crdball(idb1)
      r22 = crdball(idb2)
      r23 = crdball(idb3)
      r31 = crdball(idc1)
      r32 = crdball(idc2)
      r33 = crdball(idc3)
      r41 = crdball(idd1)
      r42 = crdball(idd2)
      r43 = crdball(idd3)
      r51 = crdball(ide1)
      r52 = crdball(ide2)
      r53 = crdball(ide3)
      rr1 = radball(a)
      rr2 = radball(b)
      rr3 = radball(c)
      rr4 = radball(d)
      rr5 = radball(e)
      t1 = rr1 * rr1
      t2 = r11 * r11
      t1 = psub (t2,t1)
      t2 = r12 * r12
      t1 = padd (t2,t1)
      t2 = r13 * r13
      r14 = padd (t2,t1)
      t1 = rr2 * rr2
      t2 = r21 * r21
      t1 = psub (t2,t1)
      t2 = r22 * r22
      t1 = padd (t2,t1)
      t2 = r23 * r23
      r24 = padd (t2,t1)
      t1 = rr3 * rr3
      t2 = r31 * r31
      t1 = psub (t2,t1)
      t2 = r32 * r32
      t1 = padd (t2,t1)
      t2 = r33 * r33
      r34 = padd (t2,t1)
      t1 = rr4 * rr4
      t2 = r41 * r41
      t1 = psub (t2,t1)
      t2 = r42 * r42
      t1 = padd (t2,t1)
      t2 = r43 * r43
      r44 = padd (t2,t1)
      t1 = rr5 * rr5
      t2 = r51 * r51
      t1 = psub (t2,t1)
      t2 = r52 * r52
      t1 = padd (t2,t1)
      t2 = r53 * r53
      r54 = padd (t2,t1)
      result = 1
      call deter5 (det,r11,r12,r13,r14,r21,r22,r23,r24,r31,r32,
     &             r33,r34,r41,r42,r43,r44,r51,r52,r53,r54,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
c
c     check signs of minors if full determinant is zero
c
      call deter4 (det,r21,r22,r23,r31,r32,r33,
     &             r41,r42,r43,r51,r52,r53,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter4 (det,r21,r22,r24,r31,r32,r34,
     &             r41,r42,r44,r51,r52,r54,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter4 (det,r21,r23,r24,r31,r33,r34,
     &             r41,r43,r44,r51,r53,r54,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter4 (det,r22,r23,r24,r32,r33,r34,
     &             r42,r43,r44,r52,r53,r54,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter4 (det,r11,r12,r13,r31,r32,r33,
     &             r41,r42,r43,r51,r52,r53,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r31,r32,r41,r42,r51,r52,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r31,r33,r41,r43,r51,r53,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r32,r33,r42,r43,r52,r53,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter4 (det,r11,r12,r14,r31,r32,r34,
     &             r41,r42,r44,r51,r52,r54,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r31,r34,r41,r44,r51,r54,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r32,r34,r42,r44,r52,r54,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter4 (det,r11,r13,r14,r31,r33,r34,
     &             r41,r43,r44,r51,r53,r54,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r33,r34,r43,r44,r53,r54,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter4 (det,r12,r13,r14,r32,r33,r34,
     &             r42,r43,r44,r52,r53,r54,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter4 (det,r11,r12,r13,r21,r22,r23,
     &             r41,r42,r43,r51,r52,r53,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r21,r22,r41,r42,r51,r52,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r21,r23,r41,r43,r51,r53,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r22,r23,r42,r43,r52,r53,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r11,r12,r41,r42,r51,r52,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter2 (det,r41,r51,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter2 (det,r42,r52,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r11,r13,r41,r43,r51,r53,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter2 (det,r43,r53,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r12,r13,r42,r43,r52,r53,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter4 (det,r11,r12,r14,r21,r22,r24,
     &             r41,r42,r44,r51,r52,r54,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r21,r24,r41,r44,r51,r54,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r22,r24,r42,r44,r52,r54,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r11,r14,r41,r44,r51,r54,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter2 (det,r44,r54,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r12,r14,r42,r44,r52,r54,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter4 (det,r11,r13,r14,r21,r23,r24,
     &             r41,r43,r44,r51,r53,r54,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r23,r24,r43,r44,r53,r54,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r13,r14,r43,r44,r53,r54,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter4 (det,r12,r13,r14,r22,r23,r24,
     &             r42,r43,r44,r52,r53,r54,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter4 (det,r11,r12,r13,r21,r22,r23,
     &             r31,r32,r33,r51,r52,r53,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r21,r22,r31,r32,r51,r52,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r21,r23,r31,r33,r51,r53,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r22,r23,r32,r33,r52,r53,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r11,r12,r31,r32,r51,r52,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter2 (det,r31,r51,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter2 (det,r32,r52,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r11,r13,r31,r33,r51,r53,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter2 (det,r33,r53,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r12,r13,r32,r33,r52,r53,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r11,r12,r21,r22,r51,r52,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter2 (det,r21,r51,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter2 (det,r22,r52,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter2 (det,r11,r51,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine deter5  --  get the value of 5x5 determinant  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "deter5" finds a 5x5 determinant value where the rightmost
c     column is all ones and other elements are given as arguments
c
c
      subroutine deter5 (det,r11,r12,r13,r14,r21,r22,r23,r24,r31,r32,
     &                   r33,r34,r41,r42,r43,r44,r51,r52,r53,r54,isign)
      implicit none
      integer isign
      real*8 det,psub,padd
      real*8 r11,r21,r31,r41,r51
      real*8 r12,r22,r32,r42,r52
      real*8 r13,r23,r33,r43,r53
      real*8 r14,r24,r34,r44,r54
      real*8 s11,s21,s31,s41
      real*8 s12,s22,s32,s42
      real*8 s13,s23,s33,s43
      real*8 s14,s24,s34,s44
      real*8 t1,t2,t3
      real*8 u1,u2,u3
      real*8 v1,v2,v3
      real*8 w1,w2,w3
      real*8 x1,x2,x3
      real*8 eps
c
c
c     compute the numerical value of the determinant
c
      s11 = psub (r21,r11)
      s12 = psub (r22,r12)
      s13 = psub (r23,r13)
      s14 = psub (r24,r14)
      s21 = psub (r31,r11)
      s22 = psub (r32,r12)
      s23 = psub (r33,r13)
      s24 = psub (r34,r14)
      s31 = psub (r41,r11)
      s32 = psub (r42,r12)
      s33 = psub (r43,r13)
      s34 = psub (r44,r14)
      s41 = psub (r51,r11)
      s42 = psub (r52,r12)
      s43 = psub (r53,r13)
      s44 = psub (r54,r14)
      t1 = s32 * s43
      t2 = s42 * s33
      u1 = psub (t1,t2)
      t1 = s32 * s44
      t2 = s42 * s34
      u2 = psub (t1,t2)
      t1 = s33 * s44
      t2 = s43 * s34
      u3 = psub (t1,t2)
      t1 = s12 * s23
      t2 = s22 * s13
      v1 = psub (t1,t2)
      t1 = s12 * s24
      t2 = s22 * s14
      v2 = psub (t1,t2)
      t1 = s13 * s24
      t2 = s23 * s14
      v3 = psub (t1,t2)
      t1 = s11 * s24
      t2 = s21 * s14
      w1 = psub (t1,t2)
      t1 = s11 * s23
      t2 = s21 * s13
      w2 = psub (t1,t2)
      t1 = s11 * s22
      t2 = s21 * s12
      w3 = psub (t1,t2)
      t1 = s31 * s44
      t2 = s41 * s34
      x1 = psub (t1,t2)
      t1 = s31 * s43
      t2 = s41 * s33
      x2 = psub (t1,t2)
      t1 = s31 * s42
      t2 = s41 * s32
      x3 = psub (t1,t2)
      t1 = v3 * x3
      t2 = v2 * x2
      t3 = psub (t1,t2)
      t1 = v1 * x1
      t3 = padd (t3,t1)
      t1 = u3 * w3
      t3 = padd (t3,t1)
      t1 = u2 * w2
      t3 = psub (t3,t1)
      t1 = u1 * w1
      det = padd (t3,t1)
      eps = 1.0d-10
      if (abs(det) .lt. eps)  det = 0.0d0
c
c     return value based on sign of the determinant
c
      isign = 0
      if (det .gt. 0.0d0) then
         isign = 1
      else if (det .lt. 0.0d0) then
         isign = -1
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine minor4  --  find the sign of 4x4 determinant  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "minor4" computes the value of a 4x4 determinant built from
c     coordinates of specified balls; if the determinant is zero,
c     then checks minors until a nonzero value is found
c
c
      subroutine minor4 (crdball,a,b,c,d,result)
      implicit none
      integer a,b,c,d
      integer result
      integer isign
      integer ida1,ida2,ida3
      integer idb1,idb2,idb3
      integer idc1,idc2,idc3
      integer idd1,idd2,idd3
      real*8 det
      real*8 r11,r21,r31,r41
      real*8 r12,r22,r32,r42
      real*8 r13,r23,r33,r43
      real*8 crdball(*)
c
c
c     get the value of the determinant and find its sign
c
      ida1 = 3*a - 2
      ida2 = ida1 + 1
      ida3 = ida2 + 1
      idb1 = 3*b - 2
      idb2 = idb1 + 1
      idb3 = idb2 + 1
      idc1 = 3*c - 2
      idc2 = idc1 + 1
      idc3 = idc2 + 1
      idd1 = 3*d - 2
      idd2 = idd1 + 1
      idd3 = idd2 + 1
      r11 = crdball(ida1)
      r12 = crdball(ida2)
      r13 = crdball(ida3)
      r21 = crdball(idb1)
      r22 = crdball(idb2)
      r23 = crdball(idb3)
      r31 = crdball(idc1)
      r32 = crdball(idc2)
      r33 = crdball(idc3)
      r41 = crdball(idd1)
      r42 = crdball(idd2)
      r43 = crdball(idd3)
      result = 1
      call deter4 (det,r11,r12,r13,r21,r22,r23,
     &             r31,r32,r33,r41,r42,r43,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
c
c     check signs of minors if full determinant is zero
c
      call deter3 (det,r21,r22,r31,r32,r41,r42,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r21,r23,r31,r33,r41,r43,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r22,r23,r32,r33,r42,r43,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r11,r12,r31,r32,r41,r42,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter2 (det,r31,r41,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter2 (det,r32,r42,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r11,r13,r31,r33,r41,r43,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter2 (det,r33,r43,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter3 (det,r12,r13,r32,r33,r42,r43,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter3 (det,r11,r12,r21,r22,r41,r42,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter2 (det,r21,r41,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter2 (det,r22,r42,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter2 (det,r11,r41,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine minor4x  --  find 4x4 determinant sign; no SOS  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "minor4x" computes the value of a 4x4 determinant built from
c     coordinates of specified balls and also finds the sign
c
c
      subroutine minor4x (crdball,a,b,c,d,result)
      implicit none
      integer a,b,c,d
      integer result
      integer isign
      integer ida1,ida2,ida3
      integer idb1,idb2,idb3
      integer idc1,idc2,idc3
      integer idd1,idd2,idd3
      real*8 det
      real*8 r11,r21,r31,r41
      real*8 r12,r22,r32,r42
      real*8 r13,r23,r33,r43
      real*8 crdball(*)
c
c
c     get the value of the determinant and find its sign
c
      ida1 = 3*a - 2
      ida2 = ida1 + 1
      ida3 = ida2 + 1
      idb1 = 3*b - 2
      idb2 = idb1 + 1
      idb3 = idb2 + 1
      idc1 = 3*c - 2
      idc2 = idc1 + 1
      idc3 = idc2 + 1
      idd1 = 3*d - 2
      idd2 = idd1 + 1
      idd3 = idd2 + 1
      r11 = crdball(ida1)
      r12 = crdball(ida2)
      r13 = crdball(ida3)
      r21 = crdball(idb1)
      r22 = crdball(idb2)
      r23 = crdball(idb3)
      r31 = crdball(idc1)
      r32 = crdball(idc2)
      r33 = crdball(idc3)
      r41 = crdball(idd1)
      r42 = crdball(idd2)
      r43 = crdball(idd3)
      call deter4 (det,r11,r12,r13,r21,r22,r23,
     &             r31,r32,r33,r41,r42,r43,isign)
      result = isign
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine deter4  --  get the value of 4x4 determinant  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "deter4" finds a 4x4 determinant value where the rightmost
c     column is all ones and other elements are given as arguments
c
c
      subroutine deter4 (det,r11,r12,r13,r21,r22,r23,
     &                   r31,r32,r33,r41,r42,r43,isign)
      implicit none
      integer isign
      real*8 det,psub,padd
      real*8 r11,r21,r31,r41
      real*8 r12,r22,r32,r42
      real*8 r13,r23,r33,r43
      real*8 s11,s21,s31
      real*8 s12,s22,s32
      real*8 s13,s23,s33
      real*8 t1,t2,t3
      real*8 u1,u2,u3
      real*8 eps
c
c
c     compute the numerical value of the determinant
c
      s11 = psub (r21,r11)
      s12 = psub (r22,r12)
      s13 = psub (r23,r13)
      s21 = psub (r31,r11)
      s22 = psub (r32,r12)
      s23 = psub (r33,r13)
      s31 = psub (r41,r11)
      s32 = psub (r42,r12)
      s33 = psub (r43,r13)
      t1 = s22 * s33
      t2 = s32 * s23
      u1 = psub (t1,t2)
      t1 = s12 * s33
      t2 = s32 * s13
      u2 = psub (t1,t2)
      t1 = s12 * s23
      t2 = s22 * s13
      u3 = psub (t1,t2)
      t1 = s21 * u2
      t2 = s11 * u1
      t3 = s31 * u3
      u1 = padd (t2,t3)
      det = psub (t1,u1)
      eps = 1.0d-10
      if (abs(det) .lt. eps)  det = 0.0d0
c
c     return value based on sign of the determinant
c
      isign = 0
      if (det .gt. 0.0d0) then
         isign = 1
      else if (det .lt. 0.0d0) then
         isign = -1
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine minor3  --  find the sign of 3x3 determinant  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "minor3" computes the value of a 3x3 determinant built from
c     coordinates of specified balls; if the determinant is zero,
c     then checks minors until a nonzero value is found
c
c
      subroutine minor3 (crdball,a,b,c,i1,i2,result)
      implicit none
      integer a,b,c
      integer i1,i2
      integer result
      integer isign
      integer ida1,ida2
      integer idb1,idb2
      integer idc1,idc2
      real*8 det
      real*8 r11,r21,r31
      real*8 r12,r22,r32
      real*8 crdball(*)
c
c
c     get the value of the determinant and find its sign
c
      ida1 = 3*a + i1 - 3
      ida2 = 3*a + i2 - 3
      idb1 = 3*b + i1 - 3
      idb2 = 3*b + i2 - 3
      idc1 = 3*c + i1 - 3
      idc2 = 3*c + i2 - 3
      r11 = crdball(ida1)
      r12 = crdball(ida2)
      r21 = crdball(idb1)
      r22 = crdball(idb2)
      r31 = crdball(idc1)
      r32 = crdball(idc2)
      result = 1
      call deter3 (det,r11,r12,r21,r22,r31,r32,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
c
c     check signs of minors if full determinant is zero
c
      call deter2 (det,r21,r31,isign)
      if (isign .ne. 0) then
         result = -isign
         return
      end if
      call deter2 (det,r22,r32,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      call deter2 (det,r11,r31,isign)
      if (isign .ne. 0) then
         result = isign
         return
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine deter3  --  get the value of 3x3 determinant  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "deter3" finds a 3x3 determinant value where the rightmost
c     column is all ones and other elements are given as arguments
c
c
      subroutine deter3 (det,r11,r12,r21,r22,r31,r32,isign)
      implicit none
      integer isign
      real*8 det,psub
      real*8 r11,r21,r31
      real*8 r12,r22,r32
      real*8 t1,t2,t3,t4
      real*8 t14,t23
      real*8 eps
c
c
c     compute the numerical value of the determinant
c
      t1 = psub (r21,r11)
      t2 = psub (r22,r12)
      t3 = psub (r31,r11)
      t4 = psub (r32,r12)
      t14 = t1 * t4
      t23 = t2 * t3
      det = psub (t14,t23)
      eps = 1.0d-10
      if (abs(det) .lt. eps)  det = 0.0d0
c
c     return value based on sign of the determinant
c
      isign = 0
      if (det .gt. 0.0d0) then
         isign = 1
      else if (det .lt. 0.0d0) then
         isign = -1
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine minor2  --  find the sign of 2x2 determinant  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "minor2" computes the value of a 2x2 determinant built from
c     coordinates of specified balls, and also return the sign
c
c
      subroutine minor2 (crdball,a,b,ia,result)
      implicit none
      integer a,b,ia
      integer result
      integer isign
      integer ida,idb
      real*8 det,r11,r12
      real*8 crdball(*)
c
c
c     get the value of the determinant and find its sign
c
      ida = 3*a + ia - 3
      idb = 3*b + ia - 3
      r11 = crdball(ida)
      r12 = crdball(idb)
      result = 1
      call deter2 (det,r11,r12,isign)
      if (isign .ne. 0)  result = isign
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine deter2  --  get the value of 2x2 determinant  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "deter2" finds a 2x2 determinant value where the rightmost
c     column is all ones and other elements are given as arguments
c
c
      subroutine deter2 (det,r11,r12,isign)
      implicit none
      integer isign
      real*8 det,psub
      real*8 r11,r12
      real*8 eps
c
c
c     compute the numerical value of the determinant
c
      det = psub (r11,r12)
      eps = 1.0d-10
      if (abs(det) .lt. eps)  det = 0.0d0
c
c     set return based on sign of the determinant
c
      isign = 0
      if (det .gt. 0.0d0) then
         isign = 1
      else if (det .lt. 0.0d0) then
         isign = -1
      end if
      return
      end
c
c
c     ##########################################################
c     ##                                                      ##
c     ##  function padd  --  addition with a precision check  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "padd" computes the sum of the two input arguments, and
c     sets the result to zero if the absolute sum or relative
c     values are less than the machine precision
c
c
      function padd (r1,r2)
      implicit none
      real*8 padd
      real*8 r1,r2,eps
      real*8 val,valmax
c
c
c     get the sum of input values using standard math
c
      val = r1 + r2
c
c     round small absolute sum or relative value to zero 
c
      eps = 1.0d-14
      if (abs(val) .lt. eps) then
         val = 0.0d0
      else
         valmax = max(abs(r1),abs(r2))
         if (valmax .ne. 0.0d0) then
            if (abs(val/valmax) .lt. eps)  val = 0.0d0
         end if
      end if
      padd = val
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  function psub  --  subtraction with a precision check  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "psub" computes the difference of the two input arguments,
c     and sets the result to zero if the absolute difference or
c     relative values are less than the machine precision
c
c
      function psub (r1,r2)
      implicit none
      real*8 psub
      real*8 r1,r2,eps
      real*8 val,valmax
c
c
c     get difference of input values using standard math
c
      val = r1 - r2
c
c     round small absolute or relative difference to zero 
c
      eps = 1.0d-14
      if (abs(val) .lt. eps) then
         val = 0.0d0
      else
         valmax = max(abs(r1),abs(r2))
         if (valmax .ne. 0.0d0) then
            if (abs(val/valmax) .lt. eps)  val = 0.0d0
         end if
      end if
      psub = val
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine build_weight  --  build weight for Delaunay  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "build_weight" builds and returns the weight for the weighted
c     Delaunay triangulation procedure
c
c
      subroutine build_weight (x,y,z,r,w)
      implicit none
      integer*8 ival1,ival2
      real*8 x,y,z,r,w
c
c
c     compute the weight for the Delaunay triangulation
c
      ival1 = nint(10000.0d0*r)
      ival2 = -ival1 * ival1
      ival1 = nint(10000.0d0*x)
      ival2 = ival2 + ival1*ival1
      ival1 = nint(10000.0d0*y)
      ival2 = ival2 + ival1*ival1
      ival1 = nint(10000.0d0*z)
      ival2 = ival2 + ival1*ival1
      w = dble(ival2) / 100000000.0d0
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine addbogus  --  add artificial points if needed  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "addbogus" adds artificial points to the system so the total
c     number of vertices is at least equal to four
c
c
      subroutine addbogus (bcoord,brad)
      use shapes
      implicit none
      integer np
      integer i
      real*8 brad(3),bcoord(9)
      real*8 cx,cy,cz
      real*8 c1x,c1y,c1z
      real*8 c2x,c2y,c2z
      real*8 c3x,c3y,c3z
      real*8 u1x,u1y,u1z
      real*8 v1x,v1y,v1z
      real*8 w1x,w1y,w1z
      real*8 c32x,c32y,c32z
      real*8 rmax,d,d1,d2,d3
c
c
c     set number of points to be added
c
      np = 4 - npoint
c
c     initialize the artificial coordinates
c
      do i = 1, 3*np
         bcoord(i) = 0.0d0
      end do
c
c     case for one atom
c
      if (npoint .eq. 1) then
         rmax = radball(1)
         bcoord(1) = crdball(1) + 3.0d0*rmax
         bcoord(3*1+2) = crdball(2) + 3.0d0*rmax
         bcoord(3*2+3) = crdball(3) + 3.0d0*rmax
         do i = 1, np
            brad(i) = rmax / 20.0d0
         end do
c
c     case for two atoms
c
      else if (npoint .eq. 2) then
         rmax = max(radball(1),radball(2))
         c1x = crdball(1)
         c1y = crdball(2)
         c1z = crdball(3)
         c2x = crdball(4)
         c2y = crdball(5)
         c2z = crdball(6)
         cx = 0.5d0 * (c1x+c2x)
         cy = 0.5d0 * (c1y+c2y)
         cz = 0.5d0 * (c1z+c2z)
         u1x = c2x - c1x
         u1y = c2y - c1y
         u1z = c2z - c1z
         if (u1z.ne.0.0d0 .or. u1x.ne.-u1y) then
            v1x = u1z
            v1y = u1z
            v1z = -u1x - u1z
         else
            v1x = -u1y - u1z
            v1y = u1x
            v1z = u1x
         end if
         w1x = u1y*v1z - u1z*v1y
         w1y = u1z*v1x - u1x*v1z
         w1z = u1x*v1y - u1y*v1x
         d = sqrt(u1x*u1x + u1y*u1y + u1z*u1z)
         bcoord(1) = cx + (2.0d0*d+3.0d0*rmax)*v1x
         bcoord(1+3) = cx + (2.0d0*d+3.0d0*rmax)*w1x
         bcoord(2) = cy + (2.0d0*d+3.0d0*rmax)*v1y
         bcoord(2+3) = cy + (2.0d0*d+3.0d0*rmax)*w1y
         bcoord(3) = cz + (2.0d0*d+3.0d0*rmax)*v1z
         bcoord(3+3) = cz + (2.0d0*d+3.0d0*rmax)*w1z
         brad(1) = rmax / 20.0d0
         brad(2) = rmax / 20.0d0
c
c     case for three atoms
c
      else if (npoint .eq. 3) then
         rmax = max(max(radball(1),radball(2)),radball(3))
         c1x = crdball(1)
         c1y = crdball(2)
         c1z = crdball(3)
         c2x = crdball(4)
         c2y = crdball(5)
         c2z = crdball(6)
         c3x = crdball(7)
         c3y = crdball(8)
         c3z = crdball(9)
         cx = (c1x+c2x+c3x) / 3.0d0
         cy = (c1y+c2y+c3y) / 3.0d0
         cz = (c1z+c2z+c3z) / 3.0d0
         u1x = c2x - c1x
         u1y = c2y - c1y
         u1z = c2z - c1z
         v1x = c3x - c1x
         v1y = c3y - c1y
         v1z = c3z - c1z
         w1x = u1y*v1z - u1z*v1y
         w1y = u1z*v1x - u1x*v1z
         w1z = u1x*v1y - u1y*v1x
         d1 = sqrt(w1x*w1x + w1y*w1y + w1z*w1z)
         if (d1 .eq. 0.0d0) then
            if (u1x .ne. 0.0d0) then
               w1x = u1y
               w1y = -u1x
               w1z = 0.0d0
            else if (u1y .ne. 0.0d0) then
               w1x = u1y
               w1y = -u1x
               w1z = 0.0d0
            else
               w1x = u1z
               w1y = -u1z
               w1z = 0.0d0
            end if
         end if
         d1 = sqrt(u1x*u1x + u1y*u1y + u1z*u1z)
         d2 = sqrt(v1x*v1x + v1y*v1y + v1z*v1z)
         c32x = c3x - c2x
         c32y = c3y - c2y
         c32z = c3z - c2z
         d3 = sqrt(c32x*c32x + c32y*c32y + c32z*c32z)
         d = max(d1,max(d2,d3))
         bcoord(1) = cx + (2.0d0*d+3.0d0*rmax)*w1x
         bcoord(2) = cy + (2.0d0*d+3.0d0*rmax)*w1y
         bcoord(3) = cz + (2.0d0*d+3.0d0*rmax)*w1z
         brad(1) = rmax / 20.0d0
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine tetra_volume  --  compute volume of tetrahedron  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "tetra_volume" computes the volume of the tetrahedron
c
c
      subroutine tetra_volume (r12sq,r13sq,r14sq,r23sq,r24sq,r34sq,vol)
      implicit none
      real*8 val1,val2,val3
      real*8 r12sq,r13sq,r14sq
      real*8 r23sq,r24sq,r34sq
      real*8 det5,vol
      real*8 mat5(5,5)
c
c
c     set the values of the matrix elements
c
      mat5(1,1) = 0.0d0
      mat5(1,2) = r12sq
      mat5(1,3) = r13sq
      mat5(1,4) = r14sq
      mat5(1,5) = 1.0d0
      mat5(2,1) = r12sq
      mat5(2,2) = 0.0d0
      mat5(2,3) = r23sq
      mat5(2,4) = r24sq
      mat5(2,5) = 1.0d0
      mat5(3,1) = r13sq
      mat5(3,2) = r23sq
      mat5(3,3) = 0.0d0
      mat5(3,4) = r34sq
      mat5(3,5) = 1.0d0
      mat5(4,1) = r14sq
      mat5(4,2) = r24sq
      mat5(4,3) = r34sq
      mat5(4,4) = 0.0d0
      mat5(4,5) = 1.0d0
      mat5(5,1) = 1.0d0
      mat5(5,2) = 1.0d0
      mat5(5,3) = 1.0d0
      mat5(5,4) = 1.0d0
      mat5(5,5) = 0.0d0
c
c     compute the value of the determinant
c
      val1 = mat5(2,3) - mat5(1,2) - mat5(1,3)
      val2 = mat5(2,4) - mat5(1,2) - mat5(1,4)
      val3 = mat5(3,4) - mat5(1,3) - mat5(1,4)
      det5 = 8.0d0*mat5(1,2)*mat5(1,3)*mat5(1,4)
     &          - 2.0d0*val1*val2*val3 - 2.0d0*mat5(1,2)*val3*val3
     &          - 2.0d0*mat5(1,3)*val2*val2 - 2.0d0*mat5(1,4)*val1*val1
      if (det5 .lt. 0.0d0)  det5 = 0.0d0
      vol = sqrt(det5/288.0d0);
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine unitcell  --  get periodic boundary conditions  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "unitcell" gets the periodic boundary box size and related
c     values from an external keyword file
c
c
      subroutine unitcell
      use bound
      use boxes
      use keys
      use math
      implicit none
      integer i,next
      real*8 boxmax
      character*20 keyword
      character*240 record
      character*240 string
c
c
c     set the default values for periodic boundary conditions
c
      use_bounds = .false.
      use_replica = .false.
c
c     set the default values for the unit cell variables
c
      orthogonal = .false.
      monoclinic = .false.
      triclinic = .false.
      octahedron = .false.
      dodecadron = .false.
      nonprism = .false.
      nosymm = .false.
      spacegrp = '          '
c
c     get keywords containing crystal lattice dimensions
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:7) .eq. 'X-AXIS ') then
            if (xbox .eq. 0.0d0)  read (string,*,err=10,end=10)  xbox
         else if (keyword(1:7) .eq. 'Y-AXIS ') then
            if (ybox .eq. 0.0d0)  read (string,*,err=10,end=10)  ybox
         else if (keyword(1:7) .eq. 'Z-AXIS ') then
            if (zbox .eq. 0.0d0)  read (string,*,err=10,end=10)  zbox
         else if (keyword(1:7) .eq. 'A-AXIS ') then
            if (xbox .eq. 0.0d0)  read (string,*,err=10,end=10)  xbox
         else if (keyword(1:7) .eq. 'B-AXIS ') then
            if (ybox .eq. 0.0d0)  read (string,*,err=10,end=10)  ybox
         else if (keyword(1:7) .eq. 'C-AXIS ') then
            if (zbox .eq. 0.0d0)  read (string,*,err=10,end=10)  zbox
         else if (keyword(1:6) .eq. 'ALPHA ') then
            if (alpha .eq. 0.0d0)  read (string,*,err=10,end=10)  alpha
         else if (keyword(1:5) .eq. 'BETA ') then
            if (beta .eq. 0.0d0)  read (string,*,err=10,end=10)  beta
         else if (keyword(1:6) .eq. 'GAMMA ') then
            if (gamma .eq. 0.0d0)  read (string,*,err=10,end=10)  gamma
         else if (keyword(1:11) .eq. 'OCTAHEDRON ') then
            octahedron = .true.
         else if (keyword(1:13) .eq. 'DODECAHEDRON ') then
            dodecadron = .true.
         else if (keyword(1:11) .eq. 'NOSYMMETRY ') then
            nosymm = .true.
         else if (keyword(1:11) .eq. 'SPACEGROUP ') then
            call getword (record,spacegrp,next)
         end if
   10    continue
      end do
c
c     use periodic boundary conditions if a cell was defined
c
      boxmax = max(xbox,ybox,zbox)
      if (boxmax .ne. 0.0d0)  use_bounds = .true.
c
c     set unspecified periodic boundary box lengths and angles
c
      if (use_bounds) then
         if (xbox .eq. 0.0d0)  xbox = boxmax
         if (ybox .eq. 0.0d0)  ybox = boxmax
         if (zbox .eq. 0.0d0)  zbox = boxmax
         if (alpha .eq. 0.0d0)  alpha = 90.0d0
         if (beta .eq. 0.0d0)  beta = 90.0d0
         if (gamma .eq. 0.0d0)  gamma = 90.0d0
c
c     determine the general periodic boundary lattice type
c
         if (nosymm) then
            triclinic = .true.
         else if (alpha.eq.90.0d0 .and. beta.eq.90.0d0
     &               .and. gamma.eq.90.0d0) then
            orthogonal = .true.
         else if (alpha.eq.90.0d0 .and. gamma.eq.90.0d0) then
            monoclinic = .true.
         else
            triclinic = .true.
         end if
      end if
c
c     set lattice values for non-prism periodic boundaries
c
      if (octahedron .or. dodecadron) then
         orthogonal = .false.
         monoclinic = .false.
         triclinic = .false.
         nonprism = .true.
         ybox = xbox
         if (octahedron) then
            zbox = xbox
         else if (dodecadron) then
            zbox = xbox * root2
         end if         
         alpha = 90.0d0
         beta = 90.0d0
         gamma = 90.0d0
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  module units  --  physical constants and unit conversions  ##
c     ##                                                             ##
c     #################################################################
c
c
c     literature references:
c
c     M. Stock, R. Davis, E. de Mirandes and M. J. T. Milton, "The
c     Revision of the SI - The Result of Three Decades of Progress
c     in Metrology", Metrologia, 56, 022001 (2019)
c
c     P. J. Mohr, D. B. Newell, B. N. Taylor and E. Teisinga, "CODATA
c     Recommended Values of the Fundamental Physical Constants: 2022",
c     Reviews of Modern Physics, 97, 025002 (2025)
c
c     Where appropriate, values are from the November 2018 revision
c     of SI units to fixed values by the 26th General Conference on
c     Weights and Measures; other values are taken from the CODATA
c     recommended values or are as described below
c
c     The conversion from calorie to Joule is the definition of the
c     thermochemical calorie as 1 cal = 4.1840 J from ISO 31-4 (1992)
c
c     The "coulomb" energy conversion factor is found by dimensional
c     analysis of Coulomb's Law, that is by dividing the square of the
c     elementary charge in Coulombs by 4*pi*eps0*rij, where eps0 is
c     the vacuum electric permittivity (the "electric constant"); note
c     eps0 is typically given in F/m, equivalent to C**2/(J-m)
c
c     The approximate value for the Debye, 3.33564 x 10-30 C-m, is
c     from the IUPAC Compendium of Chemical Technology, 2nd Ed. (1997)
c
c     The value of "prescon" is based on definition of 1 atmosphere
c     as 101325 Pa set by the 10th Conference Generale des Poids et
c     Mesures (Paris, 1954), where a Pascal (Pa) is equal to a J/m**3
c
c     avogadro    Avogadro's number (N) in particles/mole
c     lightspd    speed of light in vacuum (c) in cm/ps
c     boltzmann   Boltzmann constant (kB) in g*Ang**2/ps**2/mole/K
c     gasconst    ideal gas constant (R) in kcal/mole/K
c     elemchg     elementary charge of a proton in Coulombs
c     vacperm     vacuum permittivity (electric constant, eps0) in F/m
c     emass       mass of an electron in atomic mass units
c     planck      Planck's constant (h) in J-s
c     joule       conversion from calorie to joule
c     ekcal       conversion from kcal to g*Ang**2/ps**2
c     bohr        conversion from Bohr to Angstrom
c     hartree     conversion from Hartree to kcal/mole
c     evolt       conversion from Hartree to electron-volt
c     efreq       conversion from Hartree to cm-1
c     coulomb     conversion from electron**2/Ang to kcal/mole
c     elefield    conversion from electron**2/Ang to megavolt/cm
c     debye       conversion from electron-Ang to Debye
c     prescon     conversion from kcal/mole/Ang**3 to Atm
c
c
      module units
      implicit none
      real*8 avogadro
      real*8 lightspd
      real*8 boltzmann
      real*8 gasconst
      real*8 elemchg
      real*8 vacperm
      real*8 emass,planck
      real*8 joule,ekcal
      real*8 bohr,hartree
      real*8 evolt,efreq
      real*8 coulomb
      real*8 elefield
      real*8 debye,prescon
      parameter (avogadro=6.02214076d+23)
      parameter (lightspd=2.99792458d-2)
      parameter (boltzmann=0.8314462618d0)
      parameter (gasconst=1.9872042586d-3)
      parameter (elemchg=1.602176634d-19)
      parameter (vacperm=8.8541878188d-12)
      parameter (emass=5.485799090441d-4)
      parameter (planck=6.62607015d-34)
      parameter (joule=4.1840d0)
      parameter (ekcal=4.1840d+2)
      parameter (bohr=0.529177210544d0)
      parameter (hartree=627.509474063d0)
      parameter (evolt=27.211386245981d0)
      parameter (efreq=2.194746314d+5)
      parameter (coulomb=332.0637133d0)
      parameter (elefield=1439.96455d0)
      parameter (debye=4.803206802d0)
      parameter (prescon=6.85684112d+4)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2011  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  module uprior  --  previous values of induced dipoles  ##
c     ##                                                         ##
c     #############################################################
c
c
c     maxpred   maximum number of predictor induced dipoles to save
c
c     nualt     number of sets of prior induced dipoles in storage
c     maxualt   number of sets of induced dipoles needed for predictor
c     gear      coefficients for Gear predictor binomial method
c     aspc      coefficients for always stable predictor-corrector
c     bpred     coefficients for induced dipole predictor polynomial
c     bpredp    coefficients for predictor polynomial in energy field
c     bpreds    coefficients for predictor for PB/GK solvation
c     bpredps   coefficients for predictor in PB/GK energy field
c     udalt     prior values for induced dipoles at each site
c     upalt     prior values for induced dipoles in energy field
c     usalt     prior values for induced dipoles for PB/GK solvation
c     upsalt    prior values for induced dipoles in PB/GK energy field
c     use_pred  flag to control use of induced dipole prediction
c     polpred   type of predictor polynomial (ASPC, GEAR or LSQR)
c
c
      module uprior
      implicit none
      integer maxpred
      parameter (maxpred=17)
      integer nualt
      integer maxualt
      real*8 gear(maxpred)
      real*8 aspc(maxpred)
      real*8 bpred(maxpred)
      real*8 bpredp(maxpred)
      real*8 bpreds(maxpred)
      real*8 bpredps(maxpred)
      real*8, allocatable :: udalt(:,:,:)
      real*8, allocatable :: upalt(:,:,:)
      real*8, allocatable :: usalt(:,:,:)
      real*8, allocatable :: upsalt(:,:,:)
      logical use_pred
      character*4 polpred
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module urey  --  Urey-Bradley interactions in structure  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     nurey   total number of Urey-Bradley terms in the system
c     iury    numbers of the atoms in each Urey-Bradley interaction
c     uk      Urey-Bradley force constants (kcal/mole/Ang**2)
c     ul      ideal 1-3 distance values in Angstroms
c
c
      module urey
      implicit none
      integer nurey
      integer, allocatable :: iury(:,:)
      real*8, allocatable :: uk(:)
      real*8, allocatable :: ul(:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2000  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module urypot  --  Urey-Bradley functional form details  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     cury       cubic coefficient in Urey-Bradley potential
c     qury       quartic coefficient in Urey-Bradley potential
c     ureyunit   convert Urey-Bradley energy to kcal/mole
c
c
      module urypot
      implicit none
      real*8 cury
      real*8 qury
      real*8 ureyunit
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module usage  --  atoms active during energy computation  ##
c     ##                                                            ##
c     ################################################################
c
c
c     nuse   total number of active atoms in energy calculation
c     iuse   numbers of the atoms active in energy calculation
c     use    true if an atom is active, false if inactive
c
c
      module usage
      implicit none
      integer nuse
      integer, allocatable :: iuse(:)
      logical, allocatable :: use(:)
      save
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 2009 by Chuanjie Wu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  program valence  --  derive valence force field parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "valence" refines force field parameters for valence terms based
c     on a quantum mechanical optimized structure and frequencies
c
c
      program valence
      use atomid
      use atoms
      use files
      use inform
      use iounit
      use keys
      use linmin
      use output
      use potent
      use qmstuf
      use valfit
      implicit none
      integer i,nvar,next
      integer mode,length
      integer maxcls
      real*8 minimum,grdmin
      real*8 valrms,value
      real*8 valfit1
      real*8, allocatable :: xx(:)
      logical exist,query
      logical doguess
      logical dotarget
      logical dofit
      character*20 keyword
      character*240 record
      character*240 string
      character*240 xyzfile
      external valfit1
      external optsave
c
c
c     initialization of the various modes of operation
c
      call initial
      fit_bond = .true.
      fit_angle = .true.
      fit_strbnd = .false.
      fit_urey = .false.
      fit_opbend = .false.
      fit_tors = .false.
      fit_force = .false.
      fit_struct = .false.
      doguess = .false.
      dotarget = .false.
      dofit = .false.
c
c     find out which valence term protocol is to be performed
c
      mode = 0
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  mode
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' The Tinker Valence Parameter Utility Can :',
     &           //,4x,'(1) Set Initial Values for Valence Parameters',
     &           /,4x,'(2) Compare QM and MM Vibrational Frequencies',
     &           /,4x,'(3) Force Fit of Parameters to QM Results',
     &           /,4x,'(4) Structure Fit of Parameters to QM Results')
         do while (mode.lt.1 .or. mode.gt.4)
            mode = 0
            write (iout,30)
   30       format (/,' Enter the Number of the Desired Choice :  ',$)
            read (input,40,err=50,end=50)  mode
   40       format (i10)
   50       continue
         end do
      end if
      if (mode .eq. 1) then
         doguess = .true.
      else if (mode .eq. 2) then
         dotarget = .true.
      else if (mode .eq. 3) then
         dotarget = .true.
         dofit = .true.
         fit_force = .true.
      else if (mode .eq. 4) then
         dotarget = .true.
         dofit = .true.
         fit_struct = .true.
      end if
c
c     read the Cartesian coordinates and connectivity info
c
      call getxyz
      xyzfile = filename
      length = leng
c
c     read structure and vibrational data from Gaussian output
c
      call readgau
      filename = xyzfile
      leng = length
      call getkey
c
c     assign connectivities and read a force field
c
      call attach
      call bonds
      call angles
      call torsions
      call bitors
      call rings
      call field
c
c     assign estimated values to the valence parameters
c
      if (doguess) then
         call katom
         call valguess
      else
         maxcls = 0
         do i = 1, n
            maxcls = max(class(i),maxcls)
         end do
         if (maxcls .eq. 0) then
            write (*,60)
   60       format (/,' VALENCE  --  Force Field Atom Class Values',
     &                 ' must be Assigned')
            call fatal
         end if
         call katom
         call kbond
         call kangle
         call kstrbnd
         call kurey
         call kangang
         call kopbend
         call kopdist
         call kimprop
         call kimptor
         call ktors
         call kpitors
         call kstrtor
         call kangtor
         call ktortor
      end if
c
c     get control parameters and target values from keyfile
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:9) .eq. 'FIT-BOND ') then
            fit_bond = .true.
         else if (keyword(1:9) .eq. 'FIX-BOND ') then
            fit_bond = .false.
         else if (keyword(1:10) .eq. 'FIT-ANGLE ') then
            fit_angle = .true.
         else if (keyword(1:10) .eq. 'FIX-ANGLE ') then
            fit_angle = .false.
         else if (keyword(1:11) .eq. 'FIT-STRBND ') then
            fit_strbnd = .true.
         else if (keyword(1:11) .eq. 'FIX-STRBND ') then
            fit_strbnd = .false.
         else if (keyword(1:9) .eq. 'FIT-UREY ') then
            fit_urey = .true.
         else if (keyword(1:9) .eq. 'FIX-UREY ') then
            fit_urey = .false.
         else if (keyword(1:11) .eq. 'FIT-OPBEND ') then
            fit_opbend = .true.
         else if (keyword(1:11) .eq. 'FIX-OPBEND ') then
            fit_opbend = .false.
         else if (keyword(1:12) .eq. 'FIT-TORSION ') then
            fit_tors = .true.
         else if (keyword(1:12) .eq. 'FIX-TORSION ') then
            fit_tors = .false.
         end if
      end do
c
c     try to increase robustness of polarization calculations
c
      if (dofit .and. use_polar)  stpmax = 1.0d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(35*n))
c
c     comparison of QM and Tinker structure and frequencies
c
      if (dotarget) then
         if (.not. dofit) then
            do i = 1, n
               x(i) = gx(i)
               y(i) = gy(i)
               z(i) = gz(i)
            end do
            value = valrms (1)
c
c     optimize the valence term force field parameters
c
         else
            call prmvar (nvar,xx)
            value = valrms (1)
            grdmin = -1.0d0
            call nextarg (string,exist)
            if (exist)  read (string,*,err=70,end=70)  grdmin
   70       continue
            if (grdmin .le. 0.0d0) then
               write (iout,80)
   80          format (/,' Enter RMS Gradient Termination Criterion',
     &                    ' [0.01] :  ',$)
               read (input,90)  grdmin
   90          format (f20.0)
            end if
            if (grdmin .le. 0.0d0)  grdmin = 0.01d0
            coordtype = 'NONE'
            call ocvm (nvar,xx,minimum,grdmin,valfit1,optsave)
            call varprm (nvar,xx,0,0.0d0)
            call prmvar (nvar,xx)
            value = valrms (1)
            call prtval
         end if
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine valguess  --  estimate valence parameter values  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "valguess" sets approximate valence parameter values based on
c     quantum mechanical structure and frequency data
c
c
      subroutine valguess
      use angbnd
      use atomid
      use atoms
      use bndstr
      use iounit
      use kangs
      use kbonds
      use kopbnd
      use kstbnd
      use ktorsn
      use kurybr
      use kvdws
      use math
      use opbend
      use qmstuf
      use strbnd
      use tors
      use urey
      use valfit
      use vdwpot
      implicit none
      integer i,j,k
      integer size,number
      integer ia,ib,ic,id
      integer iia,iib,isba,isbb
      integer ita,itb,itc,itd
      integer iva,ivb,ivc
      integer iita,iitb
      integer nv,nb,na
      integer nsb,nop,nt
      integer vnum(maxtyp)
      integer, allocatable :: nequiv(:)
      real*8 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 xac,yac,zac
      real*8 rab2,rcb2
      real*8 cosine,dot
      real*8 bndguess
      real*8 angguess
      real*8 uryguess
      real*8 opbguess
      logical done
      character*4 pa,pb
      character*4 pc,pd
      character*8 ptb
      character*12 pta
      character*16 ptt
c
c
c     check the number of atoms in QM output and Tinker xyz file
c
      if (n .ne. ngatom) then
         write (iout,10)
   10    format (/,' VALENCE  --  The Number of Atoms is Not',
     &              ' Consistent')
         call fatal
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(bl))  allocate (bl(nbond))
      if (.not. allocated(anat))  allocate (anat(nangle))
c
c     assign initial values to van der Waals parameters
c
      nv = 0
      do i = 1, n
         ita = class(i)
         if (vdwindex .eq. 'TYPE')  ita = type(i)
         done = .false.
         if (i .gt. 1) then
            do j = 1, nv
               if (ita .eq. vnum(j))  done = .true.
            end do
         end if
         if (.not. done) then
            nv = nv + 1
            vnum(nv) = ita
            call vdwguess (i,rad(ita),eps(ita),reduct(ita))
         end if
      end do
c
c     print the initial van der Waals parameter values
c
      if (nv .gt. 0) then
         write (iout,20)
   20    format (/,' Estimated van der Waals Parameters :',/)
      end if
      do i = 1, nv
         ia = vnum(i)
         if (reduct(ia) .eq. 0) then
            write (iout,30)  ia,rad(ia),eps(ia)
   30       format (' vdw',7x,i5,10x,f10.3,f11.4)
         else
            write (iout,40)  ia,rad(ia),eps(ia),reduct(ia)
   40       format (' vdw',7x,i5,10x,f10.3,f11.4,f9.2)
         end if
      end do
c
c     find and store the unique bond stretches in the system
c
      nb = 0
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ita = class(ia)
         itb = class(ib)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            ptb = pa//pb
         else
            ptb = pb//pa
         end if
         done = .false.
         do j = 1, nb
            if (ptb .eq. kb(j))  done = .true.
         end do
         if (.not. done) then
            nb = nb + 1
            kb(nb) = ptb
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (nequiv(4*n))
c
c     assign initial values to bond stretch parameters
c
      k = 0
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ita = class(ia)
         itb = class(ib)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            ptb = pa//pb
         else
            ptb = pb//pa
         end if
         xab = gx(ia) - gx(ib)
         yab = gy(ia) - gy(ib)
         zab = gz(ia) - gz(ib)
         bl(i) = sqrt(xab*xab + yab*yab + zab*zab)
         done = .false.
         do j = 1, k
            if (ptb .eq. kb(j)) then
               done = .true.
               blen(j) = blen(j) + bl(i)
               nequiv(j) = nequiv(j) + 1
            end if
         end do
         if (.not. done) then
            k = k + 1
            bcon(k) = bndguess (ia,ib)
            blen(k) = bl(i)
            nequiv(k) = 1
         end if
      end do
c
c     print the initial bond stretch parameter values
c
      if (nb .gt. 0) then
         write (iout,50)
   50    format (/,' Estimated Bond Stretching Parameters :',/)
      end if
      do i = 1, nb
         blen(i) = blen(i) / dble(nequiv(i))
         ptb = kb(i)
         ia = number(ptb(1:4))
         ib = number(ptb(5:8))
         write (iout,60)  ia,ib,bcon(i),blen(i)
   60    format (' bond',6x,2i5,5x,f10.1,f11.4)
      end do
c
c     find and store the unique angle bends in the system
c
      na = 0
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pta = pa//pb//pc
         else
            pta = pc//pb//pa
         end if
         done = .false.
         do j = 1, na
            if (pta .eq. ka(j))  done = .true.
         end do
         if (.not. done) then
            na = na + 1
            ka(na) = pta
         end if
      end do
c
c     assign initial values to angle bend parameters
c
      k = 0
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pta = pa//pb//pc
         else
            pta = pc//pb//pa
         end if
         xab = gx(ia) - gx(ib)
         yab = gy(ia) - gy(ib)
         zab = gz(ia) - gz(ib)
         xcb = gx(ic) - gx(ib)
         ycb = gy(ic) - gy(ib)
         zcb = gz(ic) - gz(ib)
         rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
         rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
         dot = xab*xcb + yab*ycb + zab*zcb
         cosine = dot / sqrt(rab2*rcb2)
         cosine = min(1.0d0,max(-1.0d0,cosine))
         anat(i) = radian * acos(cosine)
         done = .false.
         do j = 1, k
            if (pta .eq. ka(j)) then
               done = .true.
               ang(1,j) = ang(1,j) + anat(i)
               nequiv(j) = nequiv(j) + 1
            end if
         end do
         if (.not. done) then
            k = k + 1
            acon(k) = angguess (ia,ib,ic)
            ang(1,k) = anat(i)
            nequiv(k) = 1
         end if
      end do
c
c     print the initial angle bend parameter values
c
      if (na .gt. 0) then
         write(iout,70)
   70    format(/,' Estimated Angle Bending Parameters :',/)
      end if
      do i = 1, na
         ang(1,i) = ang(1,i) / dble(nequiv(i))
         pta = ka(i)
         ia = number(pta(1:4))
         ib = number(pta(5:8))
         ic = number(pta(9:12))
         write (iout,80)  ia,ib,ic,acon(i),ang(1,i)
   80    format (' angle',5x,3i5,f10.2,f11.2)
      end do
c
c     assign initial values to stretch-bend parameters
c
      nsb = 0
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         iva = valnum(ia)
         ivb = valnum(ib)
         ivc = valnum(ic)
         if (iva.gt.1 .or. ivc.gt.1) then
            size = 4
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            if (ita .le. itc) then
               pta = pa//pb//pc
            else
               pta = pc//pb//pa
            end if
            done = .false.
            do j = 1, nsb
               if (pta .eq. ksb(j))  done = .true.
            end do
            if (.not. done) then
               nsb = nsb + 1
               ksb(nsb) = pta
               if (ita .le. itc) then
                  call sbguess (ia,ib,ic,stbn(1,nsb),stbn(2,nsb))
               else
                  call sbguess (ic,ib,ia,stbn(1,nsb),stbn(2,nsb))
               end if
            end if
         end if
      end do
c
c     print the initial stretch-bend parameter values
c
      if (nsb .gt. 0) then
         write (iout,90)
   90    format (/,' Estimated Stretch-Bend Parameters :',/)
      end if
      do i = 1, nsb
         pta = ksb(i)
         ia = number(pta(1:4))
         ib = number(pta(5:8))
         ic = number(pta(9:12))
         write (iout,100)  ia,ib,ic,stbn(1,i),stbn(2,i)
  100    format (' strbnd',4x,3i5,f10.2,f11.2)
      end do
c
c     assign initial values to Urey-Bradley parameters
c
      k = 0
      do i = 1, nurey
         ia = iury(1,i)
         ib = iury(2,i)
         ic = iury(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pta = pa//pb//pc
         else
            pta = pc//pb//pa
         end if
         xac = gx(ia) - gx(ic)
         yac = gy(ia) - gy(ic)
         zac = gz(ia) - gz(ic)
         ul(i) = sqrt(xac*xac + yac*yac + zac*zac)
         done = .false.
         do j = 1, k
            if (pta .eq. ku(j)) then
               done = .true.
               dst13(j) = dst13(j) + ul(i)
               nequiv(j) = nequiv(j) + 1
            end if
         end do
         if (.not. done) then
            k = k + 1
            ucon(k) = uryguess (ia,ib,ic)
            dst13(k) = ul(i)
            nequiv(k) = 1
         end if
      end do
c
c     print the initial Urey-Bradley parameter values
c
      if (nurey .gt. 0) then
         write (iout,110)
  110    format (/,' Estimated Urey-Bradley Parameters :',/)
      end if
      do i = 1, nsb
         dst13(i) = dst13(i) / dble(nequiv(i))
         pta = ku(i)
         ia = number(pta(1:4))
         ib = number(pta(5:8))
         ic = number(pta(9:12))
         write (iout,120)  ia,ib,ic,ucon(i),dst13(i)
  120    format (' ureybrad',2x,3i5,f10.1,f11.4)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (nequiv)
c
c     assign initial values to out-of-plane bend parameters
c
      nop = 0
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ic = 0
         id = 0
         iva = valnum(ia)
         ivb = valnum(ib)
         if (iva.eq.3 .or. ivb.eq.3) then
            ita = class(ia)
            itb = class(ib)
            itc = 0
            itd = 0
            size = 4
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            call numeral (itd,pd,size)
            if (iva .eq. 3) then
               ptt = pb//pa//pc//pd
               isba = ia
               isbb = ib
            else
               ptt = pa//pb//pc//pd
               isba = ib
               isbb = ia
            end if
            if (atomic(isba) .eq. 6) then
               done = .false.
               do j = 1, nop
                  if (ptt .eq. kopb(j))  done = .true.
               end do
               if (.not. done) then
                  nop = nop + 1
                  kopb(nop) = ptt
                  opbn(nop) = opbguess (isba,isbb,ic,id)
                  do j = i+1, nbond
                     iia = ibnd(1,j)
                     iib = ibnd(2,j)
                     if (iia.eq.isba .or. iib.eq.isba) then
                        iita = class(iia)
                        iitb = class(iib)
                        size = 4
                        call numeral (iita,pa,size)
                        call numeral (iitb,pb,size)
                        if (iia .eq. isba) then
                           ptt = pb//pa//pc//pd
                        else if (iib .eq. isba) then
                           ptt = pa//pb//pc//pd
                        end if
                        done = .false.
                        do k = 1, nop
                           if (ptt .eq. kopb(k))  done = .true.
                        end do
                        if (.not. done) then
                           nop = nop + 1
                           kopb(nop) = ptt
                           if (iia .eq. isba) then
                              opbn(nop) = opbguess (iia,iib,ic,id)
                           else if (iib .eq. isba) then
                              opbn(nop) = opbguess (iib,iia,ic,id)
                           end if
                        end if
                     end if
                  end do
               end if
            else if (atomic(isba) .eq. 7) then
               if (valnum(isbb).eq.3 .and. atomic(isbb).eq.6) then
                  nop = nop + 1
                  kopb(nop) = ptt
                  opbn(nop) = opbguess (isba,isbb,ic,id)
                  do j = 1, nbond
                     if (j.ne.i .and. (ibnd(1,j).eq.isba
     &                               .or. ibnd(2,j).eq.isba)) then
                        if (ibnd(1,j) .eq. isba) then
                           iia = ibnd(2,j)
                        else
                           iia = ibnd(1,j)
                        end if
                        size = 4
                        call numeral (class(isba),pa,size)
                        call numeral (class(iia),pb,size)
                        ptt = pb//pa//pc//pd
                        done = .false.
                        do k = 1, nop
                           if (ptt .eq. ksb(k))  done = .true.
                        end do
                        if (.not. done) then
                           nop = nop + 1
                           kopb(nop) = ptt
                           opbn(nop) = opbguess (isba,iia,ic,id)
                        end if
                     end if
                  end do
               end if
            end if
         end if
      end do
c
c     print the initial out-of-plane bend parameter values
c
      if (nop .gt .0) then
         write (iout,130)
  130    format (/,' Estimated Out-of-Plane Parameters :',/)
      end if
      do i = 1, nop
         ptt = kopb(i)
         ia = number(ptt(1:4))
         ib = number(ptt(5:8))
         ic = number(ptt(9:12))
         id = number(ptt(13:16))
         write (iout,140)  ia,ib,ic,id,opbn(i)
  140    format (' opbend',4x,4i5,6x,f10.2)
      end do
c
c     assign initial values to torsional parameters
c
      nt = 0
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         if (itb .le. itc) then
            ptt = pa//pb//pc//pd
         else
            ptt = pd//pc//pb//pa
         end if
         done = .false.
         do j = 1, nt
            if (ptt .eq. kt(j))  done = .true.
         end do
         if (.not. done) then
            nt = nt + 1
            kt(nt) = ptt
            call torguess (ia,ib,ic,id,t1(1,nt),t2(1,nt),t3(1,nt))
         end if
      end do
c
c     print the initial torsional parameter values
c
      if (nt .gt. 0) then
         write (iout,150)
  150    format (/,' Estimated Torsional Parameters :'/)
      end if
      do i = 1, nt
         ptt = kt(i)
         ia = number(ptt(1:4))
         ib = number(ptt(5:8))
         ic = number(ptt(9:12))
         id = number(ptt(13:16))
         write (iout,160)  ia,ib,ic,id,t1(1,i),t2(1,i),t3(1,i)
  160    format (' torsion',3x,4i5,3x,f8.3,' 0.0 1',f8.3,
     &              ' 180.0 2',f8.3,' 0.0 3')
      end do
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine vdwguess  --  estimate van der Waals parameters  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "vdwguess" sets initial VDW parameters based on atom type
c     and connected atoms
c
c
      subroutine vdwguess (ia,rad,eps,reduce)
      use atomid
      use couple
      use math
      use vdwpot
      implicit none
      integer i,j,k,ia
      integer ita,itb
      integer iva,ivb
      real*8 rad,eps,reduce
c
c
c     set default value for radius, well depth and reduction factor
c
      rad = 1.0d0
      eps = 0.1d0
      reduce = 0.0d0
c
c     get atomic number and valence for the atom and its neighbor
c
      ita = atomic(ia)
      iva = valnum(ia)
      itb = 0
      ivb = 0
      do i = 1, n12(ia)
         j = i12(i,ia)
         k = atomic(j)
         if (k .gt. itb) then
            itb = k
            ivb = valnum(j)
         end if
      end do
c
c     assign specific values based on atom type and connectivity
c
      if (ita .eq. 1) then
         if (itb .eq. 6) then
            if (ivb .eq. 3) then
               rad = 2.980d0
               eps = 0.0260d0
               reduce = 0.92d0
            else if (ivb .eq. 4) then
               rad = 2.780d0
               eps = 0.0260d0
               reduce = 0.91d0
            else
               rad = 2.780d0
               eps = 0.0260d0
               reduce = 0.91d0
            end if
         else if (itb .eq. 7) then
            rad = 2.700d0
            eps = 0.0200d0
            reduce = 0.91d0
         else if (itb .eq. 8) then
            rad = 2.655d0
            eps = 0.0135d0
            reduce = 0.91d0
         else if (itb .eq. 16) then
            rad = 3.000d0
            eps = 0.0265d0
            reduce = 0.98d0
         else
            rad = 2.980d0
            eps = 0.0260d0
            reduce = 0.92d0
         end if
      else if (ita .eq. 6) then
         if (iva .eq. 3) then
            rad = 3.800d0
            eps = 0.0890d0
         else if (iva .eq. 4) then
            rad = 3.820d0
            eps = 0.1010d0
         else
            rad = 3.820d0
            eps = 0.1010d0
         end if
      else if (ita .eq. 7) then
         if (iva .eq. 3) then
            rad = 3.710d0
            eps = 0.1050d0
         else if (iva .eq. 2) then
            rad = 3.710d0
            eps = 0.1100d0
         else
            rad = 3.710d0
            eps = 0.1050d0
         end if
      else if (ita .eq. 8) then
         if (iva .eq. 1) then
            if (itb .eq. 6) then
               rad = 3.300d0
               eps = 0.1120d0
            else if (itb .eq. 7) then
               rad = 3.300d0
               eps = 0.1120d0
            else if (itb .eq. 15) then
               rad = 3.360d0
               eps = 0.1120d0
            else if (itb .eq. 16) then
               rad = 3.510d0
               eps = 0.1120d0
            else
               rad = 3.300d0
               eps = 0.1120d0
            end if
         else if (iva .eq. 2) then
            if (itb .eq. 15) then
               rad = 3.405d0
               eps = 0.1120d0
            else
               rad = 3.405d0
               eps = 0.1100d0
            end if
         else
            rad = 3.405d0
            eps = 0.1100d0
         end if
      else if (ita .eq. 9) then
         if (iva .eq. 0) then
            rad = 3.400d0
            eps = 0.2500d0
         else if (iva .eq. 1) then
            rad = 3.220d0
            eps = 0.1200d0
         else
            rad = 3.220d0
            eps = 0.1200d0
         end if
      else if (ita .eq. 11) then
         rad = 3.020d0
         eps = 0.260d0
      else if (ita .eq. 12) then
         rad = 2.550d0
         eps = 0.850d0
      else if (ita .eq. 15) then
         rad = 4.450d0
         eps = 0.390d0
      else if (ita .eq. 16) then
         if (iva .eq. 2) then
            rad = 3.910d0
            eps = 0.3850d0
         else if (iva .eq. 3) then
            rad = 3.910d0
            eps = 0.3850d0
         else if (iva .eq. 4) then
            rad = 3.910d0
            eps = 0.3850d0
         else
            rad = 3.910d0
            eps = 0.3850d0
         end if
      else if (ita .eq. 17) then
         if (iva .eq. 0) then
            rad = 4.130d0
            eps = 0.340d0
         else if (iva .eq. 1) then
            rad = 4.130d0
            eps = 0.340d0
         else
            rad = 4.130d0
            eps = 0.340d0
         end if
      else if (ita .eq. 19) then
         rad = 3.710d0
         eps = 0.3500d0
      else if (ita .eq. 20) then
         rad = 3.150d0
         eps = 1.6000d0
      else if (ita .eq. 35) then
         if (iva .eq. 0) then
            rad = 4.380d0
            eps = 0.4300d0
         else if (iva .eq. 1) then
            rad = 4.380d0
            eps = 0.4300d0
         else
            rad = 4.380d0
            eps = 0.4300d0
         end if
      else if (ita .eq. 53) then
         if (iva .eq. 0) then
            rad = 4.660d0
            eps = 0.520d0
         else if (iva .eq. 1) then
            rad = 4.660d0
            eps = 0.520d0
         else
            rad = 4.660d0
            eps = 0.520d0
         end if
      end if
c
c     scale the vdw parameters to the desired units
c
      if (radsiz .eq. 'RADIUS')  rad = 0.5d0 * rad
      if (radsiz .eq. 'SIGMA')  rad = rad / twosix
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  function bndguess  --  estimate bond stretch parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "bndguess" sets approximate bond stretch force constants based
c     on atom type and connected atoms
c
c
      function bndguess (ia,ib)
      use atomid
      use bndpot
      implicit none
      integer ia,ib,tmp
      integer ita,itb
      integer iva,ivb
      real*8 bndguess
c
c
c     get the atomic number and valence of each atom
c
      ita = atomic(ia)
      itb = atomic(ib)
      iva = valnum(ia)
      ivb = valnum(ib)
c
c     reverse the atom order based on atomic number
c
      if (ita .gt. itb) then
         tmp = ita
         ita = itb
         itb = tmp
         tmp = iva
         iva = ivb
         ivb = tmp
      end if
c
c     assign estimated bond stretch force constants
c
      if (ita .eq. 1) then
         if (itb .eq. 6) then
            if (ivb .eq. 3) then
               bndguess = 410.0d0
            else if (ivb .eq. 4) then
               bndguess = 400.0d0
            else
               bndguess = 400.0d0
            end if
         else if (itb .eq. 7) then
            bndguess = 520.0d0
         else if (itb .eq. 8) then
            bndguess = 560.0d0
         else if (itb .eq. 9) then
            bndguess = 500.0d0
         else if (itb .eq. 14) then
            bndguess = 200.0d0
         else if (itb .eq. 15) then
            bndguess = 230.0d0
         else if (itb .eq. 16) then
            bndguess = 260.0d0
         else
            bndguess = 300.0d0
         end if
      else if (ita .eq. 6) then
         if (itb .eq. 6) then
            if (iva.eq.3 .and. ivb.eq.3) then
               bndguess = 680.0d0
            else if (iva.eq.4 .or. ivb.eq.4) then
               bndguess = 385.0d0
            else
               bndguess = 350.0d0
            end if
         else if (itb .eq. 7) then
            if (iva.eq.3 .and. ivb.eq.2) then
               bndguess = 435.0d0
            else if (iva.eq.3 .and. ivb.eq.3) then
               bndguess = 250.0d0
            else if (iva.eq.4) then
               bndguess = 400.0d0
            else
               bndguess = 450.0d0
            end if
         else if (itb .eq. 8) then
            if (ivb .eq. 1) then
               bndguess = 680.0d0
            else if (ivb .eq. 2) then
               bndguess = 465.0d0
            else
               bndguess = 465.0d0
            end if
         else if (itb .eq. 9) then
            bndguess = 350.0d0
         else if (itb .eq. 14) then
            bndguess = 350.0d0
         else if (itb .eq. 15) then
            bndguess = 350.0d0
         else if (itb .eq. 16) then
            bndguess = 216.0d0
         else if (itb .eq. 17) then
            bndguess = 350.0d0
         else
            bndguess = 450.0d0
         end if
      else if (ita .eq. 7) then
         if (itb .eq. 7) then
            if (iva .eq. 1) then
               bndguess = 1613.0d0
            else if (iva.eq.2 .and. ivb.eq.2) then
               bndguess = 950.0d0
            else
               bndguess = 850.0d0
            end if
         else if (itb .eq. 8) then
            if (ivb .eq. 1 ) then
               bndguess = 900.0d0
            else
               bndguess = 750.0d0
            end if
         else if (itb .eq. 14) then
            bndguess = 450.0d0
         else if (itb .eq. 15) then
            bndguess = 500.0d0
         else if (itb .eq. 16) then
            bndguess = 550.0d0
         else
            bndguess = 600.0d0
         end if
      else if (ita .eq. 8) then
         if (itb .eq. 8) then
            bndguess = 750.0d0
         else if (itb .eq. 14) then
            bndguess = 500.0d0
         else if (itb .eq. 15) then
            if (iva .eq. 2) then
               bndguess = 450.0d0
            else if (iva .eq. 1) then
               bndguess = 775.0d0
            else
               bndguess = 450.0d0
            end if
         else if (itb .eq. 16) then
            bndguess = 606.0d0
         else if (itb .eq. 17) then
            bndguess = 500.0d0
         else
            bndguess = 600.0d0
         end if
      else if (ita .eq. 14) then
         if (itb .eq. 14) then
            bndguess = 400.0d0
         else if (itb .eq. 15) then
            bndguess = 450.0d0
         else if (itb .eq. 16) then
            bndguess = 500.0d0
         else if (itb .eq. 17) then
            bndguess = 650.0d0
         else
            bndguess = 450.0d0
         end if
      else if (ita .eq. 16) then
         if (itb .eq. 16) then
            bndguess = 188.0d0
         else
            bndguess = 250.0d0
         end if
      else if (ita .eq. 17) then
         bndguess = 300.0d0
      else
         bndguess = 350.0d0
      end if
c
c     scale the force constant to the desired units
c
      bndguess = bndguess / bndunit
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function angguess  --  estimate angle bending parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "angguess" sets approximate angle bend force constants based
c     on atom type and connected atoms
c
c
      function angguess (ia,ib,ic)
      use atomid
      use angpot
      use math
      implicit none
      integer ia,ib,ic,tmp
      integer ita,itb,itc
      integer iva,ivb,ivc
      real*8 angguess
c
c
c     get the atomic number and valence of each atom
c
      ita = atomic(ia)
      itb = atomic(ib)
      itc = atomic(ic)
      iva = valnum(ia)
      ivb = valnum(ib)
      ivc = valnum(ic)
c
c     resort ja,jb,jc based on the atomic orders
c
      if (ita .gt. itc) then
         tmp = ita
         ita = itc
         itc = tmp
         tmp = iva
         iva = ivc
         ivc = tmp
      end if
c
c     assign estimated angle bend force constants
c
      if (itb .eq. 6) then
         if (ita .eq. 1) then
            if (ivb .eq. 4) then
               if (itc .eq. 1) then
                  angguess = 34.50d0
               else if (itc .eq. 6) then
                  angguess = 38.0d0
               else if (itc .eq. 7) then
                  angguess = 50.60d0
               else if (itc .eq. 8) then
                  angguess = 51.50d0
               else if (itc .eq. 9) then
                  angguess = 50.0d0
               else
                  angguess = 35.0d0
               end if
            else if (ivb .eq. 3) then
               angguess = 32.00d0
            else
               angguess = 32.00d0
            end if
         else if (ita .eq. 6) then
            if (ivb .eq. 4) then
               if (itc .eq. 6) then
                  angguess = 60.00d0
               else if (itc .eq. 7) then
                  angguess = 80.00d0
               else if (itc .eq. 8) then
                  angguess = 88.00d0
               else if (itc .eq. 9) then
                  angguess = 89.00d0
               else if (itc .eq. 14) then
                  angguess = 65.00d0
               else if (itc .eq. 15) then
                  angguess = 60.00d0
               else if (itc .eq. 16) then
                  angguess = 53.20d0
               else if (itc .eq. 17) then
                  angguess = 55.00d0
               else
                  angguess = 50.00d0
               end if
            else if (ivb .eq. 3) then
               angguess = 60.00d0
            else
               angguess = 60.00d0
            end if
         else if (ita .eq. 8) then
            if (ivb .eq. 4) then
               if (itc .eq. 8) then
                  angguess = 65.00d0
               else if (itc .eq. 9) then
                  angguess = 65.00d0
               else if (itc .eq. 15) then
                  angguess = 60.00d0
               else if (itc .eq. 16) then
                  angguess = 65.00d0
               else
                  angguess = 65.00d0
               end if
            else if (ivb .eq. 3) then
               angguess = 50.00d0
            else
               angguess = 60.00d0
            end if
         else
            angguess = 60.00d0
         end if
      else if (itb .eq. 8) then
         if (ita .eq. 1) then
            if (itc .eq. 1) then
               angguess = 34.05d0
            else if (itc .eq. 6) then
               angguess = 65.00d0
            else
               angguess = 60.00d0
            end if
         else if (ita .eq. 6) then
            if (itc .eq. 6) then
               angguess = 88.50d0
            else if (itc .eq. 8) then
               if (iva.eq.1 .or. ivc.eq.1) then
                  angguess = 122.30d0
               else
                  angguess = 85.00d0
               end if
            else if (itc .eq. 15) then
               angguess = 80.30d0
            else
               angguess = 80.0d0
            end if
         else
            angguess = 80.0d0
         end if
      else if (itb .eq. 15) then
         if (ita .eq. 1) then
            angguess = 30.0d0
         else if (ita .eq. 6) then
            if (itc .eq. 6) then
               angguess = 75.00d0
            else if (itc .eq. 8) then
               angguess = 80.00d0
            else
               angguess = 75.00d0
            end if
         else if (ita .eq. 8) then
            if (itc .eq. 8) then
               if (iva.eq.1 .and. ivc.eq.1) then
                  angguess = 89.88d0
               else if (iva.eq.1 .or. ivc.eq.1) then
                  angguess = 75.86d0
               else
                  angguess = 65.58d0
               end if
            else
               angguess = 70.00d0
            end if
         else
            angguess = 75.00d0
         end if
      else if (itb .eq. 16) then
         if (ita .eq. 1) then
            angguess = 30.00d0
         else if (ita .eq. 6) then
            if (itc .eq. 16) then
               angguess = 72.00d0
            else
               angguess = 80.00d0
            end if
         else if (ita .eq. 8) then
            if (itc .eq. 8) then
               if (iva.eq.1 .and. ivc.eq.1) then
                  angguess = 168.00d0
               else if (iva.eq.1 .or. ivc.eq.1) then
                  angguess = 85.00d0
               else
                  angguess = 80.00d0
               end if
            else if (itc .eq. 16) then
               angguess = 75.00d0
            else
               angguess = 75.00d0
            end if
         else
            angguess = 75.00d0
         end if
      else if (ita .eq. 1) then
         angguess = 35.00d0
      else
         angguess = 65.00d0
      end if
c
c     scale the force constant to the desired units
c
      angguess = angguess / (angunit*radian**2)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine sbguess  --  estimate stretch-bend parameters  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "sbguess" sets approximate stretch-bend force constants based
c     on atom type and connected atoms
c
c
      subroutine sbguess (ia,ib,ic,sb1,sb2)
      use angpot
      use atomid
      use math
      implicit none
      integer ia,ib,ic
      integer ita,itb,itc
      integer iva,ivb,ivc
      real*8 sb1,sb2
c
c
c     get the atomic number and valence of each atom
c
      ita = atomic(ia)
      itb = atomic(ib)
      itc = atomic(ic)
      iva = valnum(ia)
      ivb = valnum(ib)
      ivc = valnum(ic)
c
c     set initial stretch-bend parameters
c
      if (ita.eq.1 .and. itc.eq.1) then
         sb1 = 0.0d0
         sb2 = 0.0d0
      else if (itb .eq. 6) then
         if (ita .eq. 1 ) then
            sb1 = 11.50d0
            sb2 = 18.70d0
         else if (itc .eq. 1) then
            sb1 = 18.70d0
            sb2 = 11.50d0
         else
            sb1 = 18.70d0
            sb2 = 18.70d0
         end if
      else if (itb .eq. 6) then
         if (ita .eq. 1) then
            sb1 = 4.50d0
            sb2 = 12.95d0
         else if (itc .eq. 1) then
            sb1 = 12.95d0
            sb2 = 4.50d0
         else
            sb1 = 14.40d0
            sb2 = 14.40d0
         end if
      else if (itb .eq. 7) then
         if (ivb .ge. 3) then
            if (ita .eq. 1) then
               sb1 = 4.30d0
               sb2 = 7.20d0
            else if (itc .eq. 1) then
               sb1 = 7.20d0
               sb2 = 4.30d0
            else
               sb1 = 7.20d0
               sb2 = 7.20d0
            end if
         else
            if (ita .eq. 1) then
               sb1 = 4.30d0
               sb2 = 14.40d0
            else if (itc .eq. 1) then
               sb1 = 14.40d0
               sb2 = 4.30d0
            else
               sb1 = 14.40d0
               sb2 = 14.40d0
            end if
         end if
      else if (itb .eq. 14) then
         if (ita .eq. 1) then
            sb1 = 8.60d0
            sb2 = 14.40d0
         else if (itc .eq. 1) then
            sb1 = 14.40d0
            sb2 = 8.60d0
         else
            sb1 = 14.40d0
            sb2 = 14.40d0
         end if
      else if (itb .eq. 15) then
         if (ivb .eq. 4) then
            if (ita .eq. 1) then
               sb1 = 14.40d0
               sb2 = 14.40d0
            else if (itc .eq. 1) then
               sb1 = 14.40d0
               sb2 = 14.40d0
            else
               sb1 = 14.40d0
               sb2 = 14.40d0
            end if
         else
            if (ita .eq. 1) then
               sb1 = 8.60d0
               sb2 = 8.60d0
            else if (itc .eq. 1) then
               sb1 = 8.60d0
               sb2 = 8.60d0
            else
               sb1 = 8.60d0
               sb2 = 8.60d0
            end if
         end if
      else if (itb .eq. 16) then
         if (ita .eq. 1) then
            sb1 = 1.45d0
            sb2 = -5.75d0
         else if (itc .eq. 1) then
            sb1 = -5.75d0
            sb2 = 1.45d0
         else
            sb1 = -5.75d0
            sb2 = -5.75d0
         end if
      else if (ita.eq.1 .and. itc.gt.1) then
         sb1 = -4.50d0
         sb2 = 38.00d0
      else if (ita.gt.1 .and. itc.eq.1) then
         sb1 = 38.00d0
         sb2 = -4.50d0
      else if (ita.gt.1 .and. itc.gt.1) then
         sb1 = 38.00d0
         sb2 = 38.00d0
      else
         sb1 = 38.00d0
         sb2 = 38.00d0
      end if
c
c     scale the force constant to the desired units
c
      sb1 = sb1 / (stbnunit*radian)
      sb2 = sb2 / (stbnunit*radian)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  function uryguess  --  estimate Urey-Bradley parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "uryguess" sets approximate Urey-Bradley force constants
c     based on atom type and connected atoms
c
c
      function uryguess (ia,ib,ic)
      use atomid
      use urypot
      implicit none
      integer ia,ib,ic
      integer ita,itb,itc
      integer iva,ivb,ivc
      real*8 uryguess
c
c
c     get the atomic number and valence of each atom
c
      ita = atomic(ia)
      itb = atomic(ib)
      itc = atomic(ic)
      iva = valnum(ia)
      ivb = valnum(ib)
      ivc = valnum(ic)
c
c     assign estimated out-of-plane parameter values
c
      uryguess = 10.0d0
c
c     scale the force constant to the desired units
c
      uryguess = uryguess / ureyunit
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function opbguess  --  estimate out-of-plane bend values  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "opbguess" sets approximate out-of-plane bend force constants
c     based on atom type and connected atoms
c
c
      function opbguess (ia,ib,ic,id)
      use angpot
      use atomid
      use math
      implicit none
      integer ia,ib,ic,id
      integer ita,itb
      integer iva,ivb
      real*8 opbguess
c
c
c     get the atomic number and valence of each atom
c
      ita = atomic(ia)
      itb = atomic(ib)
      iva = valnum(ia)
      ivb = valnum(ib)
c
c     assign estimated out-of-plane parameter values
c
      opbguess = 14.40d0
c
c     scale the force constant to the desired units
c
      opbguess = opbguess / (opbunit*radian**2)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine torguess  --  estimate torsional parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "torguess" set approximate torsion amplitude parameters based
c     on atom type and connected atoms
c
c
      subroutine torguess (ia,ib,ic,id,tf1,tf2,tf3)
      use atomid
      use torpot
      implicit none
      integer ia,ib,ic,id,tmp
      integer ita,itb,itc,itd
      integer iva,ivb,ivc,ivd
      real*8 tf1,tf2,tf3
c
c
c     get the atomic number and valence of each atom
c
      ita = atomic(ia)
      itb = atomic(ib)
      itc = atomic(ic)
      itd = atomic(id)
      iva = valnum(ia)
      ivb = valnum(ib)
      ivc = valnum(ic)
      ivd = valnum(id)
c
c     reorder the atoms based on the atomic numbers
c
      if (itb.gt.itc .or. (itb.eq.itc.and.ita.gt.itd)) then
         tmp = itb
         itb = itc
         itc = tmp
         tmp = ivb
         ivb = ivc
         ivc = tmp
         tmp = ita
         ita = itd
         itd = tmp
         tmp = iva
         iva = ivd
         ivd = tmp
      end if
c
c     assign estimated torsional parameter values
c
      tf1 = 0.0d0
      tf2 = 0.0d0
      tf3 = 0.0d0
      if (itb.eq.6 .and. itc.eq.6) then
         if (ita.eq.6 .and. itd.eq.6) then
            if (ivb.eq.3 .and. ivc.eq.3) then
               if (iva.eq.3 .and. ivd.eq.3) then
                  tf1 = -0.335d0
                  tf2 = 2.00d0
                  tf3 = 0.00d0
               else if (iva.eq.3 .and. ivd.eq.4) then
                  tf1 = -0.305d0
                  tf2 = 2.105d0
                  tf3 = 0.00d0
               else if (iva.eq.4 .and. ivd.eq.4 ) then
                  tf1 = 0.00d0
                  tf2 = 4.00d0
                  tf3 = 0.00d0
               end if
            else if (ivb.eq.3 .and. ivc.eq.4) then
               tf1 = -0.40d0
               tf2 = -0.05d0
               tf3 = -0.275d0
            else if (ivb.eq.4 .and. ivc.eq.4) then
               tf1 = 0.09d0
               tf2 = 0.085d0
               tf3 = 0.26d0
            end if
         else if (ita.eq.1 .and. itd.eq.1) then
            if (ivb.eq.3 .and. ivc.eq.3) then
               tf1 = 0.00d0
               tf2 = 2.035d0
               tf3 = 0.00d0
            else
               tf1 = 0.00d0
               tf2 = 0.00d0
               tf3 = 0.15d0
            end if
         else if (ita.eq.1 .and. itd.eq.6) then
            if (ivb.eq.4 .and. ivc.eq.4) then
               tf1 = 0.00d0
               tf2 = 0.00d0
               tf3 = 0.17d0
            else if (ivb.eq.3 .and. ivc.eq.3 .and. ivd.eq.3) then
               tf1 = 0.00d0
               tf2 = 3.05d0
               tf3 = 0.00d0
            else if (ivb.eq.3 .and. ivc.eq.3 .and. ivd.eq.4) then
               tf1 = 0.00d0
               tf2 = 3.05d0
               tf3 = 0.00d0
            else if (ivb.eq.4 .and. ivc.eq.3) then
               tf1 = 0.00d0
               tf2 = 0.00d0
               tf3 = -0.045d0
            end if
         else if (ita.eq.1 .and. itd.eq.7) then
            if (ivb.eq.3 .and. ivc.eq.3) then
               tf1 = -1.575d0
               tf2 = 1.50d0
               tf3 = 0.00d0
            else
               tf1 = 0.00d0
               tf2 = 0.00d0
               tf3 = 0.25d0
            end if
         else if (ita.eq.1 .and. itd.eq.8) then
            tf1 = 0.00d0
            tf2 = 0.00d0
            tf3 = 0.15d0
         else if (ita.eq.6 .and. itd.eq.8) then
            if (ivb.eq.3 .and. ivc.eq.3) then
               tf1 = 0.00d0
               tf2 = 2.235d0
               tf3 = 0.00d0
            else
               tf1 = -0.575d0
               tf2 = 0.00d0
               tf3 = 0.64d0
            end if
         else if (ita.eq.8 .and. itd.eq.8) then
            tf1 = 1.11d0
            tf2 = -0.69d0
            tf3 = -0.59d0
         else if (ivb.eq.3 .and. ivc.eq.3) then
            tf1 = 0.00d0
            tf2 = 1.25d0
            tf3 = 0.00d0
         else
            tf1 = 0.00d0
            tf2 = 0.00d0
            tf3 = 0.15d0
         end if
      else if (itb.eq.6 .and. itc.eq.8) then
         if(ita.eq.1 .and. itd.eq.1) then
            tf1 = 0.00d0
            tf2 = 0.00d0
            tf3 = 0.135d0
         else if (ita.eq.1 .and. itd.eq.6) then
            if (ivc.eq.3 .and. ivd.eq.3) then
               tf1 = 0.00d0
               tf2 = 2.235d0
               tf3 = 0.00d0
            else
               tf1 = 0.00d0
               tf2 = 0.00d0
               tf3 = 0.355d0
            end if
         else if (ita .eq. 1) then
            tf1 = 0.00d0
            tf2 = 0.00d0
            tf3 = 0.375d0
         else if (ita.eq.6 .and. itd.eq.1 .and. ivb.eq.4) then
            tf1 = -0.885d0
            tf2 = 0.115d0
            tf3 = 0.38d0
         else if (ita.eq.6 .and. itd.eq.6) then
            tf1 = 1.00d0
            tf2 = -0.75d0
            tf3 = 0.445d0
         else if (ita.eq.6 .and. itd.eq.1 .and. ivb.eq.3) then
            tf1 = 0.00d0
            tf2 = 1.175d0
            tf3 = 0.00d0
         else if (ivb .eq. 3) then
            tf1 = 0.00d0
            tf2 = 1.25d0
            tf3 = 0.00d0
         else if (ivb .eq. 4) then
            tf1 = 1.00d0
            tf2 = -0.75d0
            tf3 = 0.445d0
         end if
      else if (itb.eq.6 .and. itc.eq.15) then
         tf1 = 0.00d0
         tf2 = 1.25d0
         tf3 = 0.25d0
      else if (itb.eq.6 .and. itc.eq.16) then
         tf1 = 0.00d0
         tf2 = 0.00d0
         tf3 = 0.25d0
      else if (itb.eq.8 .and. itc.eq.15) then
         tf1 = -1.00d0
         tf2 = -0.84d0
         tf3 = -0.40d0
      else if (itb.eq.8 .and. itc.eq.16) then
         tf1 = -0.75d0
         tf2 = -1.00d0
         tf3 = -0.40d0
      else
         tf1 = 0.00d0
         tf2 = 0.50d0
         tf3 = 0.25d0
      end if
c
c     scale the amplitude values to the desired units
c
      tf1 = tf1 / torsunit
      tf2 = tf2 / torsunit
      tf3 = tf3 / torsunit
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  function valrms  --  compute structure & vibration RMSD  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "valrms" evaluates a valence parameter goodness-of-fit error
c     function based on comparison of forces, frequencies, bond
c     lengths and angles to QM results
c
c
      function valrms (prtflg)
      use angbnd
      use atoms
      use atomid
      use bndstr
      use hescut
      use iounit
      use inform
      use kangs
      use kbonds
      use kopbnd
      use kstbnd
      use ktorsn
      use kvdws
      use linmin
      use math
      use minima
      use opbend
      use output
      use qmstuf
      use scales
      use strbnd
      use tors
      use units
      use valfit
      implicit none
      integer i,j,k
      integer m,m1,m2
      integer ia,ib,ic,id
      integer olditer
      integer oldprt,oldwrt
      integer prtflg,ihess
      integer nvar,nfreq
      integer, allocatable :: hindex(:)
      integer, allocatable :: hinit(:,:)
      integer, allocatable :: hstop(:,:)
      real*8 xab,yab,zab
      real*8 xba,yba,zba
      real*8 xcb,ycb,zcb
      real*8 xdc,ydc,zdc
      real*8 bond,gbond
      real*8 angle,gangle
      real*8 factor,grdmin
      real*8 oldstep
      real*8 delta,cosine,sine
      real*8 rab2,rcb,rcb2,rabc
      real*8 xt,yt,zt,xu,yu,zu
      real*8 xtu,ytu,ztu
      real*8 rt2,ru2,rtru
      real*8 valmin1,minimum
      real*8 valrms,energy
      real*8 bave,brms,bfac
      real*8 aave,arms,afac
      real*8 tave,trms,tfac
      real*8 gave,grms,gfac
      real*8 have,hrms,hfac
      real*8 fave,frms,ffac,fcut
      real*8, allocatable :: xx(:)
      real*8, allocatable :: mass2(:)
      real*8, allocatable :: eigen(:)
      real*8, allocatable :: h(:)
      real*8, allocatable :: matrix(:)
      real*8, allocatable :: derivs(:,:)
      real*8, allocatable :: hdiag(:,:)
      real*8, allocatable :: vects(:,:)
      character*1 axis(3)
      external valmin1
      external optsave
      data axis  / 'X','Y','Z' /
c
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(scale))  allocate (scale(3*n))
c
c     scale the coordinates of each active atom; use the
c     square root of median eigenvalue of typical Hessian
c
      if (fit_struct) then
         allocate (xx(3*n))
         set_scale = .true.
         nvar = 0
         do i = 1, n
            nvar = nvar + 1
            scale(nvar) = 12.0d0
            xx(nvar) = gx(i) * scale(nvar)
            nvar = nvar + 1
            scale(nvar) = 12.0d0
            xx(nvar) = gy(i) * scale(nvar)
            nvar = nvar + 1
            scale(nvar) = 12.0d0
            xx(nvar) = gz(i) * scale(nvar)
         end do
c
c     make the call to the optimization routine
c
         oldstep = stpmax
         olditer = maxiter
         oldprt = iprint
         oldwrt = iwrite
         stpmax = 0.0d0
         maxiter = 0
         iprint = 0
         iwrite = 0
         grdmin = 0.0001d0
         coordtype = 'CARTESIAN'
         call lbfgs (nvar,xx,minimum,grdmin,valmin1,optsave)
         coordtype = 'NONE'
         stpmax = oldstep
         maxiter = olditer
         iprint = oldprt
         iwrite = oldwrt
c
c     unscale the final coordinates for active atoms
c
         nvar = 0
         do i = 1, n
            nvar = nvar + 1
            x(i) = xx(nvar) / scale(nvar)
            scale(nvar) = 1.0d0
            nvar = nvar + 1
            y(i) = xx(nvar) / scale(nvar)
            scale(nvar) = 1.0d0
            nvar = nvar + 1
            z(i) = xx(nvar) / scale(nvar)
            scale(nvar) = 1.0d0
         end do
         deallocate (xx)
      end if
c
c     compute the RMS between QM and Tinker bond lengths
c
      bave = 0.0d0
      brms = 0.0d0
      if (fit_struct) then
         if (prtflg.eq.1 .and. nbond.ne.0) then
            write (iout,10)
   10       format (/,' Comparison of Bond Lengths :',
     &              //,6x,'Bond',8x,'Atoms',19x,'QM Bond',
     &                 6x,'MM Bond',8x,'Delta',/)
         end if
         do i = 1, nbond
            ia = ibnd(1,i)
            ib = ibnd(2,i)
            xab = x(ia) - x(ib)
            yab = y(ia) - y(ib)
            zab = z(ia) - z(ib)
            bond = sqrt(xab*xab + yab*yab + zab*zab)
            xab = gx(ia) - gx(ib)
            yab = gy(ia) - gy(ib)
            zab = gz(ia) - gz(ib)
            gbond = sqrt(xab*xab + yab*yab + zab*zab)
            delta = bond - gbond
            bave = bave + abs(delta)
            brms = brms + delta*delta
            if (prtflg .eq. 1) then
               write (iout,20)  i,ia,ib,gbond,bond,delta
   20          format (4x,i5,4x,2i5,13x,3f13.4)
            end if
         end do
         if (nbond .ne. 0)  bave = bave / (dble(nbond))
         if (nbond .ne. 0)  brms = sqrt(brms/dble(nbond))
         if (prtflg.eq.1 .and. nbond.ne.0) then
            write (iout,30)  bave,brms
   30       format (/,4x,'Average Unsigned Difference :',30x,f12.4,
     &              /,4x,'Root Mean Square Deviation :',31x,f12.4)
         end if
      end if
c
c     compute the RMS between QM and Tinker bond angles
c
      aave = 0.0d0
      arms = 0.0d0
      if (fit_struct) then
         if (prtflg.eq.1 .and. nangle.ne.0) then
            write (iout,40)
   40       format (/,' Comparison of Bond Angles :',
     &              //,5x,'Angle',10x,'Atoms',16x,'QM Angle',
     &                 5x,'MM Angle',8x,'Delta',/)
         end if
         do i = 1, nangle
            ia = iang(1,i)
            ib = iang(2,i)
            ic = iang(3,i)
            xab = x(ia) - x(ib)
            yab = y(ia) - y(ib)
            zab = z(ia) - z(ib)
            xcb = x(ic) - x(ib)
            ycb = y(ic) - y(ib)
            zcb = z(ic) - z(ib)
            rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
            rabc = sqrt(rab2*rcb2)
            cosine = (xab*xcb + yab*ycb + zab*zcb) / rabc
            cosine = min(1.0d0,max(-1.0d0,cosine))
            angle = radian * acos(cosine)
            xab = gx(ia) - gx(ib)
            yab = gy(ia) - gy(ib)
            zab = gz(ia) - gz(ib)
            xcb = gx(ic) - gx(ib)
            ycb = gy(ic) - gy(ib)
            zcb = gz(ic) - gz(ib)
            rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0)
            rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0)
            rabc = sqrt(rab2*rcb2)
            cosine = (xab*xcb + yab*ycb + zab*zcb) / rabc
            cosine = min(1.0d0,max(-1.0d0,cosine))
            gangle = radian * acos(cosine)
            delta = angle - gangle
            aave = aave + abs(delta)
            arms = arms + delta*delta
            if (prtflg .eq. 1) then
               write (iout,50)  i,ia,ib,ic,gangle,angle,delta
   50          format (4x,i5,4x,3i5,8x,2f13.2,f13.4)
            end if
         end do
         if (nangle .ne. 0)  aave = aave / (dble(nangle))
         if (nangle .ne. 0)  arms = sqrt(arms/dble(nangle))
         if (prtflg.eq.1 .and. nangle.ne.0) then
            write (iout,60)  aave,arms
   60       format (/,4x,'Average Unsigned Difference :',30x,f12.4,
     &              /,4x,'Root Mean Square Deviation :',31x,f12.4)
         end if
      end if
c
c     compute the RMS between QM and Tinker torsion angles
c
      tave = 0.0d0
      trms = 0.0d0
      if (fit_struct) then
         if (prtflg.eq.1 .and. ntors.ne.0) then
            write (iout,70)
   70       format (/,' Comparison of Torsion Angles :',
     &              //,4x,'Torsion',12x,'Atoms',13x,'QM Angle',
     &                 5x,'MM Angle',8x,'Delta',/)
         end if
         do i = 1, ntors
            ia = itors(1,i)
            ib = itors(2,i)
            ic = itors(3,i)
            id = itors(4,i)
            xba = x(ib) - x(ia)
            yba = y(ib) - y(ia)
            zba = z(ib) - z(ia)
            xcb = x(ic) - x(ib)
            ycb = y(ic) - y(ib)
            zcb = z(ic) - z(ib)
            xdc = x(id) - x(ic)
            ydc = y(id) - y(ic)
            zdc = z(id) - z(ic)
            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)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               if (sine .lt. 0.0d0)  angle = -angle
            end if
            xba = gx(ib) - gx(ia)
            yba = gy(ib) - gy(ia)
            zba = gz(ib) - gz(ia)
            xcb = gx(ic) - gx(ib)
            ycb = gy(ic) - gy(ib)
            zcb = gz(ic) - gz(ib)
            xdc = gx(id) - gx(ic)
            ydc = gy(id) - gy(ic)
            zdc = gz(id) - gz(ic)
            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)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               gangle = radian * acos(cosine)
               if (sine .lt. 0.0d0)  gangle = -gangle
            end if
            delta = angle - gangle
            if (delta .gt. 180.0d0)  delta = delta - 360.0d0
            if (delta .lt. -180.0d0)  delta = delta + 360.0d0
            tave = tave + abs(delta)
            trms = trms + delta*delta
            if (prtflg .eq. 1) then
               write (iout,80)  i,ia,ib,ic,id,gangle,angle,delta
   80          format (4x,i5,4x,4i5,3x,2f13.2,f13.4)
            end if
         end do
         if (ntors .ne. 0)  tave = tave / (dble(ntors))
         if (ntors .ne. 0)  trms = sqrt(trms/dble(ntors))
         if (prtflg.eq.1 .and. ntors.ne.0) then
            write (iout,90)  tave,trms
   90       format (/,4x,'Average Unsigned Difference :',30x,f12.4,
     &              /,4x,'Root Mean Square Deviation :',31x,f12.4)
         end if
      end if
c
c     compute the RMS between QM and Tinker gradient components
c
      gave = 0.0d0
      grms = 0.0d0
      if (fit_force) then
         allocate (derivs(3,n))
         call gradient (energy,derivs)
         if (prtflg .eq. 1) then
            write (iout,100)
  100       format (/,' Comparison of Gradient Components :',
     &              //,7x,'Atom',14x,'QM Grad',8x,'MM Grad',
     &                 10x,'Delta',/)
         end if
         do i = 1, n
            do j = 1, 3
               delta = gforce(j,i) - derivs(j,i)
               gave = gave + abs(delta)
               grms = grms + delta*delta
               if (prtflg .eq. 1) then
                  write (iout,110)  i,axis(j),gforce(j,i),
     &                              derivs(j,i),delta
  110             format (4x,i5,1x,a1,8x,f13.4,2x,f13.4,2x,f13.4)
               end if
            end do
         end do
         gave = gave / dble(3*n)
         grms = sqrt(grms/dble(3*n))
         if (prtflg .eq. 1) then
            write (iout,120)  gave,grms
  120       format (/,4x,'Average Unsigned Difference :',17x,f12.4,
     &              /,4x,'Root Mean Square Deviation :',18x,f12.4)
         end if
         deallocate (derivs)
      end if
c
c     perform dynamic allocation of some local arrays
c
      nfreq = 3 * n
      allocate (mass2(n))
      allocate (hinit(3,n))
      allocate (hstop(3,n))
      allocate (hdiag(3,n))
      allocate (hindex((nfreq*(nfreq-1))/2))
      allocate (h((nfreq*(nfreq-1))/2))
      allocate (matrix((nfreq*(nfreq+1))/2))
c
c     calculate the full Hessian matrix of second derivatives
c
      hesscut = 0.0d0
      call hessian (h,hinit,hstop,hindex,hdiag)
c
c     compute the RMS between QM and Tinker Hessian elements
c
      have = 0.0d0
      hrms = 0.0d0
      if (fit_force) then
         if (prtflg .eq. 1) then
            write (iout,130)
  130       format (/,' Comparison of Hessian Elements :',
     &              //,7x,'Atom',14x,'QM Hess',8x,'MM Hess',
     &                 10x,'Delta',/)
         end if
         do i = 1, n
            do j = 1, 3
               m1 = 3*(i-1) + j
               m = m1*(m1+1) / 2
               delta = gh(m) - hdiag(j,i)
               have = have + abs(delta)
               hrms = hrms + delta*delta
               if (prtflg .eq. 1) then
                  write (iout,140)  i,axis(j),gh(m),hdiag(j,i),delta
  140             format (4x,i5,1x,a1,8x,f13.2,2x,f13.2,2x,f13.4)
               end if
               m1 = 3*(i-1) + j
               m2 = m1
               do k = hinit(j,i), hstop(j,i)
                  m2 = m2 + 1
                  m = m1 + m2*(m2-1)/2
                  delta = gh(m) - h(k)
                  have = have + abs(delta)
                  hrms = hrms + delta* delta
               end do
            end do
         end do
         have = have / dble((9*n*n+3*n)/2)
         hrms = sqrt(hrms/dble((9*n*n+3*n)/2))
         if (prtflg .eq. 1) then
            write (iout,150)  have,hrms
  150       format (/,4x,'Average Unsigned Difference :',17x,f12.4,
     &              /,4x,'Root Mean Square Deviation :',18x,f12.4)
         end if
      end if
c
c     set atomic mass roots needed for vibrational analysis
c
      do i = 1, n
         mass2(i) = sqrt(mass(i))
      end do
c
c     store upper triangle of the mass-weighted Hessian matrix
c
      ihess = 0
      do i = 1, n
         do j = 1, 3
            ihess = ihess + 1
            matrix(ihess) = hdiag(j,i) / mass(i)
            do k = hinit(j,i), hstop(j,i)
               m = (hindex(k)+2) / 3
               ihess = ihess + 1
               matrix(ihess) = h(k) / (mass2(i)*mass2(m))
            end do
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (eigen(nfreq))
      allocate (vects(nfreq,nfreq))
c
c     diagonalize to get vibrational frequencies and normal modes
c
      call diagq (nfreq,nfreq,matrix,eigen,vects)
      factor = sqrt(ekcal) / (2.0d0*pi*lightspd)
      do i = 1, nfreq
         eigen(i) = factor * sign(1.0d0,eigen(i)) * sqrt(abs(eigen(i)))
      end do
c
c     compute the RMS between QM and Tinker vibrational frequencies
c
      fcut = 800.0d0
      if (fit_tors)  fcut = 200.0d0
      fave = 0.0d0
      frms = 0.0d0
      if (prtflg .eq. 1) then
         write (iout,160)
  160    format (/,' Comparison of Vibrational Frequencies :',
     &           //,6x,'Mode',15x,'QM Freq',8x,'MM Freq',10x,'Delta',/)
      end if
      k = 0
      do i = nfreq, 7, -1
         if (gfreq(i-6) .gt. fcut) then
            k = k + 1
            delta = eigen(i) - gfreq(i-6)
            fave = fave + abs(delta)
            frms = frms + delta*delta
            if (prtflg .eq. 1) then
               write (iout,170)  k,gfreq(i-6),eigen(i),delta
  170          format (4x,i5,10x,f13.2,2x,f13.2,2x,f13.4)
            end if
         end if
      end do
      fave = fave / (dble(k))
      frms = sqrt(frms/dble(k))
      if (prtflg .eq. 1) then
         write (iout,180)  fave,frms
  180    format (/,4x,'Average Unsigned Difference :',17x,f12.4,
     &           /,4x,'Root Mean Square Deviation :',18x,f12.4)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mass2)
      deallocate (hinit)
      deallocate (hstop)
      deallocate (hdiag)
      deallocate (hindex)
      deallocate (h)
      deallocate (matrix)
      deallocate (eigen)
      deallocate (vects)
c
c     sum weighted RMS values to get overall error function
c
      bfac = 100.0d0
      afac = 10.0d0
      tfac = 1.0d0
      gfac = 10.0d0
      hfac = 0.1d0
      ffac = 0.1d0
      valrms = bfac*brms + afac*arms + tfac*trms
     &            + gfac*grms + hfac*hrms + ffac*frms
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function valmin1  --  energy and gradient for minimize  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "valmin1" is a service routine that computes the molecular
c     energy and gradient during valence parameter optimization
c
c
      function valmin1 (xx,g)
      use atoms
      use scales
      use usage
      implicit none
      integer i,nvar
      real*8 valmin1,e
      real*8 energy,eps
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
      logical analytic
      external energy
c
c
c     use either analytical or numerical gradients
c
      analytic = .true.
      eps = 0.00001d0
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            x(i) = xx(nvar) / scale(nvar)
            nvar = nvar + 1
            y(i) = xx(nvar) / scale(nvar)
            nvar = nvar + 1
            z(i) = xx(nvar) / scale(nvar)
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the energy and gradient
c
      if (analytic) then
         call gradient (e,derivs)
      else
         e = energy ()
         call numgrad (energy,derivs,eps)
      end if
      valmin1 = e
c
c     convert gradient components to optimization parameters
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            g(nvar) = derivs(1,i) / scale(nvar)
            nvar = nvar + 1
            g(nvar) = derivs(2,i) / scale(nvar)
            nvar = nvar + 1
            g(nvar) = derivs(3,i) / scale(nvar)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine prmvar  --  valence terms to optimization  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "prmvar" determines the optimization values from the
c     corresponding valence potential energy parameters
c
c
      subroutine prmvar (nvar,xx)
      use angbnd
      use atomid
      use atoms
      use bndstr
      use iounit
      use opbend
      use strbnd
      use tors
      use units
      use urey
      use valfit
      implicit none
      integer i,k,ii,kk
      integer ia,ib,ic,id
      integer ka,kb,kc,kd
      integer ita,itb,itc,itd
      integer kta,ktb,ktc,ktd
      integer nvar,size
      real*8 xx(*)
      logical done
      character*4  pa,pb,pc,pd
      character*8  pitb,pktb
      character*12 pita,pkta
      character*16 pitt,pktt
c
c
c     zero out the total number of optimization parameters
c
      nvar = 0
c
c     print a header for the parameters used in fitting
c
      if (fit_struct) then
         write (iout,10)
   10    format (/,' Valence Parameters Used in Structure Fitting :')
      else if (fit_force) then
         write (iout,20)
   20    format (/,' Valence Parameters Used in Force Fitting :')
      end if
      write (iout,30)
   30 format (/,' Parameter',10x,'Atom Classes',10x,'Category',
     &           12x,'Value',5x,'Fixed',/)
c
c     find bond stretch force constants and target lengths
c
      do i = 1, nbond
         done = .false.
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ita = class(ia)
         itb = class(ib)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            pitb = pa//pb
         else
            pitb = pb//pa
         end if
         do k = 1, i-1
            ka = ibnd(1,k)
            kb = ibnd(2,k)
            kta = class(ka)
            ktb = class(kb)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            if (kta .le. ktb) then
               pktb = pa//pb
            else
               pktb = pb//pa
            end if
            if (pktb .eq. pitb)  done = .true.
         end do
         if (.not. done) then
            if (fit_bond .and. bk(i).ne.0.0d0) then
               nvar = nvar + 1
               xx(nvar) = bk(i)
               write (iout,40)  nvar,ita,itb,'Bond Force',bk(i)
   40          format (i6,5x,2i6,19x,a10,3x,f12.4)
               nvar = nvar + 1
               xx(nvar) = bl(i)
               xx(nvar) = 100.0d0 * xx(nvar)
               write (iout,50)  nvar,ita,itb,'Bond Length',bl(i)
   50          format (i6,5x,2i6,19x,a11,2x,f12.4)
            else
               write (iout,60)  ita,itb,'Bond Force',bk(i)
   60          format (4x,'--',5x,2i6,19x,a10,3x,f12.4,7x,'X')
               write (iout,70)  ita,itb,'Bond Length',bl(i)
   70          format (4x,'--',5x,2i6,19x,a11,2x,f12.4,7x,'X')
            end if
         end if
      end do
c
c     find angle bend force constants and target angles
c
      do i = 1, nangle
         done = .false.
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pita = pa//pb//pc
         else
            pita = pc//pb//pa
         end if
         do k = 1, i-1
            ka = iang(1,k)
            kb = iang(2,k)
            kc = iang(3,k)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            if (kta .le. ktc) then
               pkta = pa//pb//pc
            else
               pkta = pc//pb//pa
            end if
            if (pkta .eq. pita)  done = .true.
         end do
         if (.not. done) then
            if (fit_angle .and. ak(i).ne.0.0d0) then
               nvar = nvar + 1
               xx(nvar) = ak(i)
               write (iout,80)  nvar,ita,itb,itc,'Angle Force',ak(i)
   80          format (i6,5x,3i6,13x,a11,2x,f12.4)
               nvar = nvar + 1
               xx(nvar) = anat(i)
               write (iout,90)  nvar,ita,itb,itc,'Angle Value',anat(i)
   90          format (i6,5x,3i6,13x,a11,2x,f12.4)
            else
               write (iout,100)  ita,itb,itc,'Angle Force',ak(i)
  100          format (4x,'--',5x,3i6,13x,a11,2x,f12.4,7x,'X')
               write (iout,110)  ita,itb,itc,'Angle Value',anat(i)
  110          format (4x,'--',5x,3i6,13x,a11,2x,f12.4,7x,'X')
            end if
         end if
      end do
c
c     find stretch-bend force constant parameter values
c
      do i = 1, nstrbnd
         done = .false.
         ii = isb(1,i)
         ia = iang(1,ii)
         ib = iang(2,ii)
         ic = iang(3,ii)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pita = pa//pb//pc
         else
            pita = pc//pb//pa
         end if
         do k = 1, i-1
            kk = isb(1,k)
            ka = iang(1,kk)
            kb = iang(2,kk)
            kc = iang(3,kk)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            if (kta .le. ktc) then
               pkta = pa//pb//pc
            else
               pkta = pc//pb//pa
            end if
            if (pkta .eq. pita)  done = .true.
         end do
         if (.not. done) then
            if (fit_strbnd .and. sbk(1,i).ne.0.0d0
     &             .and. sbk(2,i).ne.0.0d0) then
               nvar = nvar + 1
               xx(nvar) = sbk(1,i)
               write (iout,120)  nvar,ita,itb,itc,'StrBnd-1',sbk(1,i)
  120          format (i6,5x,3i6,13x,a8,5x,f12.4)
               nvar = nvar + 1
               xx(nvar) = sbk(2,i)
               write (iout,130)  nvar,ita,itb,itc,'StrBnd-2',sbk(2,i)
  130          format (i6,5x,3i6,13x,a8,5x,f12.4)
            else
               write (iout,140)  ita,itb,itc,'StrBnd-1',sbk(1,i)
  140          format (4x,'--',5x,3i6,13x,a8,5x,f12.4,7x,'X')
               write (iout,150)  ita,itb,itc,'StrBnd-2',sbk(2,i)
  150          format (4x,'--',5x,3i6,13x,a8,5x,f12.4,7x,'X')
            end if
         end if
      end do
c
c     find Urey-Bradley force constant parameter values
c
      do i = 1, nurey
         done = .false.
         ia = iury(1,i)
         ib = iury(2,i)
         ic = iury(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pita = pa//pb//pc
         else
            pita = pc//pb//pa
         end if
         do k = 1, i-1
            ka = iury(1,k)
            kb = iury(2,k)
            kc = iury(3,k)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            if (kta .le. ktc) then
               pkta = pa//pb//pc
            else
               pkta = pc//pb//pa
            end if
            if (pkta .eq. pita)  done = .true.
         end do
         if (.not. done) then
            if (fit_urey .and. uk(i).ne.0.0d0) then
               nvar = nvar + 1
               xx(nvar) = uk(i)
               write (iout,160)  nvar,ita,itb,itc,'Urey Force',uk(i)
  160          format (i6,5x,3i6,13x,a10,3x,f12.4)
               nvar = nvar + 1
               xx(nvar) = ul(i)
               write (iout,170)  nvar,ita,itb,itc,'Urey Dist',ul(i)
  170          format (i6,5x,3i6,13x,a9,4x,f12.4)
            else
               write (iout,180)  ita,itb,itc,'Urey Force',uk(i)
  180          format (4x,'--',5x,3i6,13x,a10,3x,f12.4,7x,'X')
               write (iout,190)  ita,itb,itc,'Urey Dist',ul(i)
  190          format (4x,'--',5x,3i6,13x,a9,4x,f12.4,7x,'X')
            end if
         end if
      end do
c
c     find out-of-plane bend force constant parameter values
c
      do i = 1, nopbend
         done = .false.
         ii = iopb(i)
         ia = iang(1,ii)
         ib = iang(2,ii)
         ic = iang(3,ii)
         id = iang(4,ii)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         if (ita .le. itc) then
            pitt = pd//pb//pa//pc
         else
            pitt = pd//pb//pc//pa
         end if
         do k = 1, i-1
            kk = iopb(k)
            ka = iang(1,kk)
            kb = iang(2,kk)
            kc = iang(3,kk)
            kd = iang(4,kk)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            ktd = class(kd)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            call numeral (ktd,pd,size)
            if (kta .le. ktc) then
               pktt = pd//pb//pa//pc
            else
               pktt = pd//pb//pc//pa
            end if
            if (pktt .eq. pitt)  done = .true.
         end do
         if (.not. done) then
            if (fit_opbend .and. opbk(i).ne.0.0d0) then
               nvar = nvar + 1
               xx(nvar) = opbk(i)
               write (iout,200)  nvar,itd,itb,min(ita,itc),
     &                           max(ita,itc),'O-P-Bend',opbk(i)
  200          format (i6,5x,4i6,7x,a8,5x,f12.4)
            else
               write (iout,210)  itd,itb,min(ita,itc),max(ita,itc),
     &                           'O-P-Bend',opbk(i)
  210          format (4x,'--',5x,4i6,7x,a8,5x,f12.4,7x,'X')
            end if
         end if
      end do
c
c     find torsional angle amplitude parameter values
c
      do i = 1, ntors
         done = .false.
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         if (itb.lt.itc .or. (itb.eq.itc.and.ita.le.itd)) then
            pitt = pa//pb//pc//pd
         else
            pitt = pd//pc//pb//pa
         end if
         do k = 1, i-1
            ka = itors(1,k)
            kb = itors(2,k)
            kc = itors(3,k)
            kd = itors(4,k)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            ktd = class(kd)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            call numeral (ktd,pd,size)
            if (ktb.lt.ktc .or. (ktb.eq.ktc.and.kta.le.ktd)) then
               pktt = pa//pb//pc//pd
            else
               pktt = pd//pc//pb//pa
            end if
            if (pktt .eq. pitt)  done = .true.
         end do
         if (.not. done) then
            if (fit_tors .and. tors1(1,i).ne.0.0d0) then
               nvar = nvar + 1
               xx(nvar) = tors1(1,i)
               write (iout,220)  nvar,ita,itb,itc,itd,
     &                           'Torsion-1',tors1(1,i)
  220          format (i6,5x,4i6,7x,a9,4x,f12.4)
            else
               write (iout,230)  ita,itb,itc,itd,'Torsion-1',tors1(1,i)
  230          format (4x,'--',5x,4i6,7x,a9,4x,f12.4,7x,'X')
            end if
            if (fit_tors .and. tors2(1,i).ne.0.0d0) then
               nvar = nvar + 1
               xx(nvar) = tors2(1,i)
               write (iout,240)  nvar,ita,itb,itc,itd,
     &                           'Torsion-2',tors2(1,i)
  240          format (i6,5x,4i6,7x,a9,4x,f12.4)
            else
               write (iout,250)  ita,itb,itc,itd,'Torsion-2',tors2(1,i)
  250          format (4x,'--',5x,4i6,7x,a9,4x,f12.4,7x,'X')
            end if
            if (fit_tors .and. tors3(1,i).ne.0.0d0) then
               nvar = nvar + 1
               xx(nvar) = tors3(1,i)
               write (iout,260)  nvar,ita,itb,itc,itd,
     &                           'Torsion-3',tors3(1,i)
  260          format (i6,5x,4i6,7x,a9,4x,f12.4)
            else
               write (iout,270)  ita,itb,itc,itd,'Torsion-3',tors3(1,i)
  270          format (4x,'--',5x,4i6,7x,a9,4x,f12.4,7x,'X')
            end if
            if (fit_tors .and. tors4(1,i).ne.0.0d0) then
               nvar = nvar + 1
               xx(nvar) = tors4(1,i)
               write (iout,280)  nvar,ita,itb,itc,itd,
     &                           'Torsion-4',tors4(1,i)
  280          format (i6,5x,4i6,7x,a9,4x,f12.4)
            else if (tors4(1,i) .ne. 0.0d0) then
               write (iout,290)  ita,itb,itc,itd,'Torsion-4',tors4(1,i)
  290          format (4x,'--',5x,4i6,7x,a9,4x,f12.4,7x,'X')
            end if
            if (fit_tors .and. tors5(1,i).ne.0.0d0) then
               nvar = nvar + 1
               xx(nvar) = tors5(1,i)
               write (iout,300)  nvar,ita,itb,itc,itd,
     &                           'Torsion-5',tors5(1,i)
  300          format (i6,5x,4i6,7x,a9,4x,f12.4)
            else if (tors5(1,i) .ne. 0.0d0) then
               write (iout,310)  ita,itb,itc,itd,'Torsion-5',tors5(1,i)
  310          format (4x,'--',5x,4i6,7x,a9,4x,f12.4,7x,'X')
            end if
            if (fit_tors .and. tors6(1,i).ne.0.0d0) then
               nvar = nvar + 1
               xx(nvar) = tors6(1,i)
               write (iout,320)  nvar,ita,itb,itc,itd,
     &                           'Torsion-6',tors6(1,i)
  320          format (i6,5x,4i6,7x,a9,4x,f12.4)
            else if (tors6(1,i) .ne. 0.0d0) then
               write (iout,330)  ita,itb,itc,itd,'Torsion-6',tors6(1,i)
  330          format (4x,'--',5x,4i6,7x,a9,4x,f12.4,7x,'X')
            end if
         end if
      end do
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine varprm  --  optimization to valence terms  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "varprm" copies the current optimization values into the
c     corresponding valence potential energy parameters
c
c
      subroutine varprm (nvar,xx,ivar,eps)
      use angbnd
      use atoms
      use atomid
      use bndstr
      use opbend
      use potent
      use strbnd
      use tors
      use urey
      use valfit
      implicit none
      integer i,k,ii,kk
      integer nvar,ivar,size
      integer ia,ib,ic,id
      integer ka,kb,kc,kd
      integer ita,itb,itc,itd
      integer kta,ktb,ktc,ktd
      real*8 eps
      real*8 xx(*)
      logical done
      character*4 pa,pb,pc,pd
      character*8 pitb,pktb
      character*12 pita,pkta
      character*16 pitt,pktt
c
c
c     zero out the total number of optimization parameters
c
      nvar = 0
c
c     translate optimization values to bond stretch parameters
c
      do i = 1, nbond
         done = .false.
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ita = class(ia)
         itb = class(ib)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            pitb = pa//pb
         else
            pitb = pb//pa
         end if
         do k = 1, i-1
            ka = ibnd(1,k)
            kb = ibnd(2,k)
            kta = class(ka)
            ktb = class(kb)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            if (kta .le. ktb) then
               pktb = pa//pb
            else
               pktb = pb//pa
            end if
            if (pktb .eq. pitb)  done = .true.
         end do
         if (.not. done) then
            if (fit_bond .and. bk(i).ne.0.0d0) then
               nvar = nvar + 1
               bk(i) = xx(nvar)
               if (ivar .eq. nvar)  bk(i) = bk(i) + eps
               nvar = nvar + 1
               bl(i) = xx(nvar)
               if (ivar .eq. nvar)  bl(i) = bl(i) + eps
               bl(i) = 0.01d0 * bl(i)
               do k = i+1, nbond
                  ka = ibnd(1,k)
                  kb = ibnd(2,k)
                  kta = class(ka)
                  ktb = class(kb)
                  size = 4
                  call numeral (kta,pa,size)
                  call numeral (ktb,pb,size)
                  if (kta .le. ktb) then
                     pktb = pa//pb
                  else
                     pktb = pb//pa
                  end if
                  if (pktb .eq. pitb) then
                     bk(k) = bk(i)
                     bl(k) = bl(i)
                  end if
               end do
            end if
         end if
      end do
c
c     translate optimization values to angle bend parameters
c
      do i = 1, nangle
         done = .false.
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pita = pa//pb//pc
         else
            pita = pc//pb//pa
         end if
         do k = 1, i-1
            ka = iang(1,k)
            kb = iang(2,k)
            kc = iang(3,k)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            if (kta .le. ktc) then
               pkta = pa//pb//pc
            else
               pkta = pc//pb//pa
            end if
            if (pkta .eq. pita)  done = .true.
         end do
         if (.not. done) then
            if (fit_angle .and. ak(i).ne.0.0d0) then
               nvar = nvar + 1
               ak(i) = xx(nvar)
               if (ivar .eq. nvar)  ak(i) = ak(i) + eps
               nvar = nvar + 1
               anat(i) = xx(nvar)
               if (ivar .eq. nvar)  anat(i) = anat(i) + eps
               do k = i+1, nangle
                  ka = iang(1,k)
                  kb = iang(2,k)
                  kc = iang(3,k)
                  kta = class(ka)
                  ktb = class(kb)
                  ktc = class(kc)
                  size = 4
                  call numeral (kta,pa,size)
                  call numeral (ktb,pb,size)
                  call numeral (ktc,pc,size)
                  if (kta .le. ktc) then
                     pkta = pa//pb//pc
                  else
                     pkta = pc//pb//pa
                  end if
                  if (pkta .eq. pita) then
                     ak(k) = ak(i)
                     anat(k) = anat(i)
                  end if
               end do
            end if
         end if
      end do
c
c     translate optimization values to stretch-bend parameters
c
      do i = 1, nstrbnd
         done = .false.
         ii = isb(1,i)
         ia = iang(1,ii)
         ib = iang(2,ii)
         ic = iang(3,ii)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pita = pa//pb//pc
         else
            pita = pc//pb//pa
         end if
         do k = 1, i-1
            kk = isb(1,k)
            ka = iang(1,kk)
            kb = iang(2,kk)
            kc = iang(3,kk)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            if (kta .le. ktc) then
               pkta = pa//pb//pc
            else
               pkta = pc//pb//pa
            end if
            if (pkta .eq. pita)  done = .true.
         end do
         if (.not.done .and. fit_strbnd) then
            if (sbk(1,i) .ne. 0.0d0) then
               nvar = nvar + 1
               sbk(1,i) = xx(nvar)
               if (ivar .eq. nvar)  sbk(1,i) = sbk(1,i) + eps
            end if
            if (sbk(2,i) .ne. 0.0d0) then
               nvar = nvar + 1
               sbk(2,i) = xx(nvar)
               if (ivar .eq. nvar)  sbk(2,i) = sbk(2,i) + eps
            end if
            do k = i+1, nstrbnd
               kk = isb(1,k)
               ka = iang(1,kk)
               kb = iang(2,kk)
               kc = iang(3,kk)
               kta = class(ka)
               ktb = class(kb)
               ktc = class(kc)
               size = 4
               call numeral (kta,pa,size)
               call numeral (ktb,pb,size)
               call numeral (ktc,pc,size)
               if (kta .le. ktc) then
                  pkta = pa//pb//pc
               else
                  pkta = pc//pb//pa
               end if
               if (pkta .eq. pita) then
                  if (kta .eq. ita) then
                     sbk(1,k) = sbk(1,i)
                     sbk(2,k) = sbk(2,i)
                  else
                     sbk(2,k) = sbk(1,i)
                     sbk(1,k) = sbk(2,i)
                  end if
               end if
            end do
         end if
      end do
c
c     translate optimization values to Urey-Bradley parameters
c
      do i = 1, nurey
         done = .false.
         ia = iury(1,i)
         ib = iury(2,i)
         ic = iury(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pita = pa//pb//pc
         else
            pita = pc//pb//pa
         end if
         do k = 1, i-1
            ka = iury(1,k)
            kb = iury(2,k)
            kc = iury(3,k)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            if (kta .le. ktc) then
               pkta = pa//pb//pc
            else
               pkta = pc//pb//pa
            end if
            if (pkta .eq. pita)  done = .true.
         end do
         if (.not. done) then
            if (fit_urey .and. uk(i).ne.0.0d0) then
               nvar = nvar + 1
               uk(i) = xx(nvar)
               if (ivar .eq. nvar)  uk(i) = uk(i) + eps
               nvar = nvar + 1
               ul(i) = xx(nvar)
               if (ivar .eq. nvar)  ul(i) = ul(i) + eps
               do k = i+1, nurey
                  ka = iury(1,k)
                  kb = iury(2,k)
                  kc = iury(3,k)
                  kta = class(ka)
                  ktb = class(kb)
                  ktc = class(kc)
                  size = 4
                  call numeral (kta,pa,size)
                  call numeral (ktb,pb,size)
                  call numeral (ktc,pc,size)
                  if (kta .le. ktc) then
                     pkta = pa//pb//pc
                  else
                     pkta = pc//pb//pa
                  end if
                  if (pkta .eq. pita) then
                     uk(k) = uk(i)
                     ul(k) = ul(i)
                  end if
               end do
            end if
         end if
      end do
c
c     translate optimization values to out-of-plane bend parameters
c
      do i = 1, nopbend
         done = .false.
         ii = iopb(i)
         ia = iang(1,ii)
         ib = iang(2,ii)
         ic = iang(3,ii)
         id = iang(4,ii)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         if (ita .le. itc) then
            pitt = pd//pb//pa//pc
         else
            pitt = pd//pb//pc//pa
         end if
         do k = 1, i-1
            kk = iopb(k)
            ka = iang(1,kk)
            kb = iang(2,kk)
            kc = iang(3,kk)
            kd = iang(4,kk)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            ktd = class(kd)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            call numeral (ktd,pd,size)
            if (kta .le. ktc) then
               pktt = pd//pb//pa//pc
            else
               pktt = pd//pb//pc//pa
            end if
            if (pktt .eq. pitt)  done = .true.
         end do
         if (.not. done) then
            if (fit_opbend .and. opbk(i).ne.0.0d0) then
               nvar = nvar + 1
               opbk(i) = xx(nvar)
               if (ivar .eq. nvar)  opbk(i) = opbk(i) + eps
               do k = i+1, nopbend
                  kk = iopb(k)
                  ka = iang(1,kk)
                  kb = iang(2,kk)
                  kc = iang(3,kk)
                  kd = iang(4,kk)
                  kta = class(ka)
                  ktb = class(kb)
                  ktc = class(kc)
                  ktd = class(kd)
                  size = 4
                  call numeral (kta,pa,size)
                  call numeral (ktb,pb,size)
                  call numeral (ktc,pc,size)
                  call numeral (ktd,pd,size)
                  if (kta .le. ktc) then
                     pktt = pd//pb//pa//pc
                  else
                     pktt = pd//pb//pc//pa
                  end if
                  if (pktt.eq.pitt)  opbk(k) = opbk(i)
               end do
            end if
         end if
      end do
c
c     translate optimization values to torsional parameters
c
      do i = 1, ntors
         done = .false.
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         if (itb.lt.itc .or. (itb.eq.itc.and.ita.le.itd)) then
            pitt = pa//pb//pc//pd
         else
            pitt = pd//pc//pb//pa
         end if
         do k = 1, i-1
            ka = itors(1,k)
            kb = itors(2,k)
            kc = itors(3,k)
            kd = itors(4,k)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            ktd = class(kd)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            call numeral (ktd,pd,size)
            if (ktb.lt.ktc .or. (ktb.eq.ktc.and.kta.le.ktd)) then
               pktt = pa//pb//pc//pd
            else
               pktt = pd//pc//pb//pa
            end if
            if (pktt .eq. pitt)  done = .true.
         end do
         if (.not.done .and. fit_tors) then
            if (tors1(1,i) .ne. 0.0d0) then
               nvar = nvar + 1
               tors1(1,i) = xx(nvar)
               if (ivar .eq. nvar)  tors1(1,i) = tors1(1,i) + eps
            end if
            if (tors2(1,i) .ne. 0.0d0) then
               nvar = nvar + 1
               tors2(1,i) = xx(nvar)
               if (ivar .eq. nvar)  tors2(1,i) = tors2(1,i) + eps
            end if
            if (tors3(1,i) .ne. 0.0d0) then
               nvar = nvar + 1
               tors3(1,i) = xx(nvar)
               if (ivar .eq. nvar)  tors3(1,i) = tors3(1,i) + eps
            end if
            if (tors4(1,i) .ne. 0.0d0) then
               nvar = nvar + 1
               tors4(1,i) = xx(nvar)
               if (ivar .eq. nvar)  tors4(1,i) = tors4(1,i) + eps
            end if
            if (tors5(1,i) .ne. 0.0d0) then
               nvar = nvar + 1
               tors5(1,i) = xx(nvar)
               if (ivar .eq. nvar)  tors5(1,i) = tors5(1,i) + eps
            end if
            if (tors6(1,i) .ne. 0.0d0) then
               nvar = nvar + 1
               tors6(1,i) = xx(nvar)
               if (ivar .eq. nvar)  tors6(1,i) = tors6(1,i) + eps
            end if
            do k = i+1, ntors
               ka = itors(1,k)
               kb = itors(2,k)
               kc = itors(3,k)
               kd = itors(4,k)
               kta = class(ka)
               ktb = class(kb)
               ktc = class(kc)
               ktd = class(kd)
               size = 4
               call numeral (kta,pa,size)
               call numeral (ktb,pb,size)
               call numeral (ktc,pc,size)
               call numeral (ktd,pd,size)
               if (ktb.lt.ktc .or. (ktb.eq.ktc.and.kta.le.ktd)) then
                  pktt = pa//pb//pc//pd
               else
                  pktt = pd//pc//pb//pa
               end if
               if (pktt .eq. pitt) then
                  tors1(1,k) = tors1(1,i)
                  tors2(1,k) = tors2(1,i)
                  tors3(1,k) = tors3(1,i)
                  tors4(1,k) = tors4(1,i)
                  tors5(1,k) = tors5(1,i)
                  tors6(1,k) = tors6(1,i)
               end if
            end do
         end if
      end do
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  function valfit1  --  valence fit error and gradient  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "valfit1" is a service routine that computes the RMS error
c     and gradient for valence parameters fit to QM results
c
c
      function valfit1 (xx,g)
      use atoms
      use potent
      use valfit
      implicit none
      integer i,k
      integer nvar
      real*8 e,e0
      real*8 delta
      real*8 valrms
      real*8 valfit1
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: eps(:)
c
c
c     copy optimization values to valence parameters
c
      call varprm (nvar,xx,0,0.0d0)
c
c     perform dynamic allocation of some local arrays
c
      allocate (eps(nvar))
c
c     set the numerical gradient step size for each parameter
c
      delta = 0.0000001d0
      do i = 1, nvar
         eps(i) = delta * xx(i)
      end do
c
c     get the RMS of frequencies
c
      valfit1 = valrms(0)
c
c     compute numerical gradient for valence parameters
c
      k = nvar
      do i = 1, k
         call varprm (nvar,xx,i,-0.5d0*eps(i))
         e0 = valrms(0)
         call varprm (nvar,xx,i,0.5d0*eps(i))
         e = valrms(0)
         g(i) = (e-e0) / eps(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (eps)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##   subroutine prtval  --  print final valence parameter fit  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "prtval" writes the final valence parameter results to the
c     standard output and appends the values to a key file
c
c
      subroutine prtval
      use angbnd
      use atomid
      use atoms
      use bndstr
      use files
      use iounit
      use keys
      use opbend
      use strbnd
      use tors
      use units
      use urey
      use valfit
      implicit none
      integer i,k,ii,kk
      integer ia,ib,ic,id
      integer ka,kb,kc,kd
      integer ita,itb,itc,itd
      integer kta,ktb,ktc,ktd
      integer ikey,size
      integer freeunit
      integer trimtext
      logical done
      character*4 pa,pb,pc,pd
      character*8 pitb,pktb
      character*12 pita,pkta
      character*16 pitt,pktt
      character*240 keyfile
      character*240 record
c
c
c     output some definitions and parameters to a keyfile
c
      ikey = freeunit ()
      keyfile = filename(1:leng)//'.key'
      call version (keyfile,'new')
      open (unit=ikey,file=keyfile,status='new')
c
c     copy the contents of any previously existing keyfile
c
      do i = 1, nkey
         record = keyline(i)
         size = trimtext (record)
         write (ikey,10)  record(1:size)
   10    format (a)
      end do
c
c     print a header for the fitted valence parameters
c
      if (fit_bond .or. fit_angle .or. fit_tors
     &       .or. fit_strbnd .or. fit_opbend) then
         write (ikey,20)
   20    format (/,'#',/,'# Results of Valence Parameter Fitting',
     &              /,'#',/)
      end if
c
c     output any fitted bond stretch parameter values
c
      do i = 1, nbond
         done = .false.
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ita = class(ia)
         itb = class(ib)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            pitb = pa//pb
         else
            pitb = pb//pa
         end if
         do k = 1, i-1
            ka = ibnd(1,k)
            kb = ibnd(2,k)
            kta = class(ka)
            ktb = class(kb)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            if (kta .le. ktb) then
               pktb = pa//pb
            else
               pktb = pb//pa
            end if
            if (pktb .eq. pitb)  done = .true.
         end do
         if (.not. done) then
            if (fit_bond) then
               write (ikey,30)  ita,itb,bk(i),bl(i)
   30          format ('bond',6x,2i5,5x,f11.2,f11.4)
            end if
         end if
      end do
c
c     output any fitted angle bend parameter values
c
      do i = 1, nangle
         done = .false.
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pita = pa//pb//pc
         else
            pita = pc//pb//pa
         end if
         do k = 1, i-1
            ka = iang(1,k)
            kb = iang(2,k)
            kc = iang(3,k)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            if (kta .le. ktc) then
               pkta = pa//pb//pc
            else
               pkta = pc//pb//pa
            end if
            if (pkta .eq. pita)  done = .true.
         end do
         if (.not. done) then
            if (fit_angle) then
               write (ikey,40)  ita,itb,itc,ak(i),anat(i)
   40          format ('angle',5x,3i5,f11.2,f11.2)
            end if
         end if
      end do
c
c     output any fitted stretch-bend parameter values
c
      do i = 1, nstrbnd
         done = .false.
         ii = isb(1,i)
         ia = iang(1,ii)
         ib = iang(2,ii)
         ic = iang(3,ii)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pita = pa//pb//pc
         else
            pita = pc//pb//pa
         end if
         do k = 1, i-1
            kk = isb(1,k)
            ka = iang(1,kk)
            kb = iang(2,kk)
            kc = iang(3,kk)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            if (kta .le. ktc) then
               pkta = pa//pb//pc
            else
               pkta = pc//pb//pa
            end if
            if (pkta .eq. pita)  done = .true.
         end do
         if (.not. done) then
            if (fit_strbnd) then
               write (ikey,50)  ita,itb,itc,sbk(1,i),sbk(2,i)
   50          format ('strbnd',4x,3i5,2f11.3)
            end if
         end if
      end do
c
c     output any fitted Urey-Bradley parameter values
c
      do i = 1, nurey
         done = .false.
         ia = iury(1,i)
         ib = iury(2,i)
         ic = iury(3,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pita = pa//pb//pc
         else
            pita = pc//pb//pa
         end if
         do k = 1, i-1
            ka = iury(1,k)
            kb = iury(2,k)
            kc = iury(3,k)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            if (kta .le. ktc) then
               pkta = pa//pb//pc
            else
               pkta = pc//pb//pa
            end if
            if (pkta .eq. pita)  done = .true.
         end do
         if (.not. done) then
            if (fit_urey) then
               write (ikey,60)  ita,itb,itc,uk(i),ul(i)
   60          format ('ureybrad',2x,3i5,f11.3,f11.4)
            end if
         end if
      end do
c
c     output any fitted out-of-plane bend parameter values
c
      do i = 1, nopbend
         done = .false.
         ii = iopb(i)
         ia = iang(1,ii)
         ib = iang(2,ii)
         ic = iang(3,ii)
         id = iang(4,ii)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         if (ita .le. itc) then
            pitt = pd//pb//pa//pc
         else
            pitt = pd//pb//pc//pa
         end if
         do k = 1, i-1
            kk = iopb(k)
            ka = iang(1,kk)
            kb = iang(2,kk)
            kc = iang(3,kk)
            kd = iang(4,kk)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            ktd = class(kd)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            call numeral (ktd,pd,size)
            if (kta .le. ktc) then
               pktt = pd//pb//pa//pc
            else
               pktt = pd//pb//pc//pa
            end if
            if (pktt .eq. pitt)  done = .true.
         end do
         if (.not. done) then
            if (fit_opbend) then
               write (ikey,70)  itd,itb,min(ita,itc),
     &                          max(ita,itc),opbk(i)
   70          format ('opbend',4x,4i5,6x,f11.2)
            end if
         end if
      end do
c
c     output any fitted torsional parameter values
c
      do i = 1, ntors
         done = .false.
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         if (itb.lt.itc .or. (itb.eq.itc.and.ita.le.itd)) then
            pitt = pa//pb//pc//pd
         else
            pitt = pd//pc//pb//pa
         end if
         do k = 1, i-1
            ka = itors(1,k)
            kb = itors(2,k)
            kc = itors(3,k)
            kd = itors(4,k)
            kta = class(ka)
            ktb = class(kb)
            ktc = class(kc)
            ktd = class(kd)
            size = 4
            call numeral (kta,pa,size)
            call numeral (ktb,pb,size)
            call numeral (ktc,pc,size)
            call numeral (ktd,pd,size)
            if (ktb.lt.ktc .or. (ktb.eq.ktc.and.kta.le.ktd)) then
               pktt = pa//pb//pc//pd
            else
               pktt = pd//pc//pb//pa
            end if
            if (pktt .eq. pitt)  done = .true.
         end do
         if (.not. done) then
            if (fit_tors) then
               write (ikey,80)  ita,itb,itc,itd,tors1(1,i),
     &                          tors2(1,i),tors3(1,i)
   80          format ('torsion',3x,4i5,3x,f8.3,' 0.0 1',f8.3,
     &                    ' 180.0 2',f8.3,' 0.0 3')
            end if
         end if
      end do
      return
      end
c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 2008 by Chuanjie Wu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module valfit  --  valence term parameter fitting values  ##
c     ##                                                            ##
c     ################################################################
c
c
c     fit_bond    logical flag to fit bond stretch parameters
c     fit_angle   logical flag to fit angle bend parameters
c     fit_strbnd  logical flag to fit stretch-bend parameters
c     fit_urey    logical flag to fit Urey-Bradley parameters
c     fit_opbend  logical flag to fit out-of-plane bend parameters
c     fit_tors    logical flag to fit torsional parameters
c     fit_struct  logical flag to structure-fit valence parameters
c     fit_force   logical flag to force-fit valence parameters
c
c
      module valfit
      implicit none
      logical fit_bond,fit_angle
      logical fit_strbnd,fit_urey
      logical fit_opbend,fit_tors
      logical fit_struct,fit_force
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module vdw  --  van der Waals terms in current structure  ##
c     ##                                                            ##
c     ################################################################
c
c
c     nvdw       total number van der Waals sites in the system
c     ivdw       number of the atom for each van der Waals site
c     jvdw       index into the vdw parameter matrix for each atom
c     mvdw       index into the vdw parameter matrix for each class
c     ired       attached atom from which reduction factor is applied
c     kred       value of reduction factor parameter for each atom
c     xred       reduced x-coordinate for each atom in the system
c     yred       reduced y-coordinate for each atom in the system
c     zred       reduced z-coordinate for each atom in the system
c     radmin     minimum energy distance for each atom class pair
c     epsilon    well depth parameter for each atom class pair
c     radmin4    minimum energy distance for 1-4 interaction pairs
c     epsilon4   well depth parameter for 1-4 interaction pairs
c     radhbnd    minimum energy distance for hydrogen bonding pairs
c     epshbnd    well depth parameter for hydrogen bonding pairs
c
c
      module vdw
      implicit none
      integer nvdw
      integer, allocatable :: ivdw(:)
      integer, allocatable :: jvdw(:)
      integer, allocatable :: mvdw(:)
      integer, allocatable :: ired(:)
      real*8, allocatable :: kred(:)
      real*8, allocatable :: xred(:)
      real*8, allocatable :: yred(:)
      real*8, allocatable :: zred(:)
      real*8, allocatable :: radmin(:,:)
      real*8, allocatable :: epsilon(:,:)
      real*8, allocatable :: radmin4(:,:)
      real*8, allocatable :: epsilon4(:,:)
      real*8, allocatable :: radhbnd(:,:)
      real*8, allocatable :: epshbnd(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  module vdwpot  --  van der Waals functional form details  ##
c     ##                                                            ##
c     ################################################################
c
c
c     igauss      coefficients of Gaussian fit to vdw potential
c     ngauss      number of Gaussians used in fit to vdw potential
c     abuck       value of "A" constant in Buckingham vdw potential
c     bbuck       value of "B" constant in Buckingham vdw potential
c     cbuck       value of "C" constant in Buckingham vdw potential
c     ghal        value of "gamma" in buffered 14-7 vdw potential
c     dhal        value of "delta" in buffered 14-7 vdw potential
c     v2scale     factor by which 1-2 vdw interactions are scaled
c     v3scale     factor by which 1-3 vdw interactions are scaled
c     v4scale     factor by which 1-4 vdw interactions are scaled
c     v5scale     factor by which 1-5 vdw interactions are scaled
c     use_vcorr   flag to use long range van der Waals correction
c     vdwindex    indexing mode (atom type or class) for vdw parameters
c     vdwtyp      type of van der Waals potential energy function
c     radtyp      type of parameter (sigma or R-min) for atomic size
c     radsiz      atomic size provided as radius or diameter
c     radrule     combining rule for atomic size parameters
c     epsrule     combining rule for vdw well depth parameters
c     gausstyp    type of Gaussian fit to van der Waals potential
c
c
      module vdwpot
      implicit none
      integer maxgauss
      parameter (maxgauss=10)
      integer ngauss
      real*8 igauss(2,maxgauss)
      real*8 abuck,bbuck,cbuck
      real*8 ghal,dhal
      real*8 v2scale,v3scale
      real*8 v4scale,v5scale
      logical use_vcorr
      character*5 vdwindex
      character*5 radtyp
      character*8 radsiz,gausstyp
      character*10 radrule,epsrule
      character*13 vdwtyp
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine verlet  --  Verlet molecular dynamics step  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "verlet" performs a molecular dynamics time step via the
c     velocity Verlet multistep recursion formula
c
c
      subroutine verlet (istep,dt)
      use atomid
      use atoms
      use freeze
      use ielscf
      use moldyn
      use polar
      use units
      use usage
      implicit none
      integer i,j,k
      integer istep
      real*8 dt,dt_2
      real*8 etot,epot
      real*8 eksum,term
      real*8 temp,pres
      real*8 ekin(3,3)
      real*8 stress(3,3)
      real*8, allocatable :: xold(:)
      real*8, allocatable :: yold(:)
      real*8, allocatable :: zold(:)
      real*8, allocatable :: derivs(:,:)
c
c
c     set some time values for the dynamics integration
c
      dt_2 = 0.5d0 * dt
c
c     perform dynamic allocation of some local arrays
c
      allocate (xold(n))
      allocate (yold(n))
      allocate (zold(n))
      allocate (derivs(3,n))
c
c     store the current atom positions, then find half-step
c     velocities and full-step positions via Verlet recursion
c
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            v(j,k) = v(j,k) + a(j,k)*dt_2
         end do
         xold(k) = x(k)
         yold(k) = y(k)
         zold(k) = z(k)
         x(k) = x(k) + v(1,k)*dt
         y(k) = y(k) + v(2,k)*dt
         z(k) = z(k) + v(3,k)*dt
      end do
c
c     apply Verlet half-step updates for any auxiliary dipoles
c
      if (use_ielscf) then
         do i = 1, nuse
            k = iuse(i)
            do j = 1, 3
               vaux(j,k) = vaux(j,k) + aaux(j,k)*dt_2
               vpaux(j,k) = vpaux(j,k) + apaux(j,k)*dt_2
               uaux(j,k) = uaux(j,k) + vaux(j,k)*dt
               upaux(j,k) = upaux(j,k) + vpaux(j,k)*dt
            end do
         end do
      end if
c
c     get constraint-corrected positions and half-step velocities
c
      if (use_freeze)  call rattle (dt,xold,yold,zold)
c
c     get the potential energy and atomic forces
c
      call gradient (epot,derivs)
c
c     make half-step temperature and pressure corrections
c
      call temper2 (dt,temp)
      call pressure2 (epot,temp)
c
c     use Newton's second law to get the next accelerations;
c     find the full-step velocities using the Verlet recursion
c
      do i = 1, nuse
         k = iuse(i)
         do j = 1, 3
            a(j,k) = -ekcal * derivs(j,k) / mass(k)
            v(j,k) = v(j,k) + a(j,k)*dt_2
         end do
      end do
c
c     apply Verlet full-step updates for any auxiliary dipoles
c
      if (use_ielscf) then
         term = 2.0d0 / (dt*dt)
         do i = 1, nuse
            k = iuse(i)
            do j = 1, 3
               aaux(j,k) = term * (uind(j,k)-uaux(j,k))
               apaux(j,k) = term * (uinp(j,k)-upaux(j,k))
               vaux(j,k) = vaux(j,k) + aaux(j,k)*dt_2
               vpaux(j,k) = vpaux(j,k) + apaux(j,k)*dt_2
            end do
         end do
      end if
c
c     find the constraint-corrected full-step velocities
c
      if (use_freeze) then
         call rattle2 (dt)
         do i = 1, nuse
            k = iuse(i)
            xold(k) = x(k)
            yold(k) = y(k)
            zold(k) = z(k)
         end do
      end if
c
c     make full-step temperature and pressure corrections
c
      call temper (dt,eksum,ekin,temp)
      call pressure (dt,ekin,pres,stress)
c
c     final constraint step to enforce position convergence
c
      if (use_freeze)  call shake (xold,yold,zold)
c
c     perform deallocation of some local arrays
c
      deallocate (xold)
      deallocate (yold)
      deallocate (zold)
      deallocate (derivs)
c
c     total energy is sum of kinetic and potential energies
c
      etot = eksum + epot
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,eksum,temp,pres)
      call mdsave (istep,dt,epot,eksum)
      call mdrest (istep)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine version  --  create version number for file  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "version" checks the name of a file about to be opened; if
c     if "old" status is passed, the name of the highest current
c     version is returned; if "new" status is passed the filename
c     of the next available unused version is generated
c
c
      subroutine version (string,status)
      use iounit
      use output
      implicit none
      integer i,leng,trimtext
      integer thousand,hundred
      integer tens,ones
      logical exist
      character*1 digit(0:9)
      character*3 status
      character*240 oldfile
      character*240 newfile
      character*(*) string
      data digit  / '0','1','2','3','4','5','6','7','8','9' /
c
c
c     process the filename and status variables
c
      call lowcase (status)
      leng = trimtext (string)
c
c     no change is needed if the file doesn't exist
c
      exist = .false.
      if (leng .ne. 0)  inquire (file=string,exist=exist)
      if (.not. exist)  return
c
c     set initial values for the current and next versions
c
      newfile = string
      oldfile = string
c
c     append an artificial version number to the filename;
c     currently handles up to 10000 versions of a file
c
      if (.not. noversion) then
         i = 1
         do while (exist)
            i = i + 1
            oldfile = newfile
            thousand = i / 1000
            hundred = (i - 1000*thousand) / 100
            tens = (i - 1000*thousand - 100*hundred) / 10
            ones = i - 1000*thousand - 100*hundred - 10*tens
            if (thousand .ne. 0) then
               newfile = string(1:leng)//'_'//digit(thousand)
     &                      //digit(hundred)//digit(tens)//digit(ones)
            else if (hundred .ne. 0) then
               newfile = string(1:leng)//'_'//digit(hundred)
     &                      //digit(tens)//digit(ones)
            else if (tens .ne. 0) then
               newfile = string(1:leng)//'_'//digit(tens)//digit(ones)
            else
               newfile = string(1:leng)//'_'//digit(ones)
            end if
            inquire (file=newfile,exist=exist)
         end do
      end if
c
c     set the file name based on the requested status
c
      if (status .eq. 'old') then
         string = oldfile
      else if (status .eq. 'new') then
         string = newfile
         inquire (file=string,exist=exist)
         if (exist) then
            call nextarg (string,exist)
            if (exist) then
               inquire (file=string,exist=exist)
            else
               exist = .true.
            end if
            do while (exist)
               write (iout,10)
   10          format (/,' Enter File Name for Coordinate Output :  ',$)
               read (input,20)  string
   20          format (a240)
               inquire (file=string,exist=exist)
            end do
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##  COPYRIGHT (C) 2007 by Alexey Kaledin & Jay William Ponder  ##
c     ##                     All Rights Reserved                     ##
c     #################################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  program vibbig  --  block iterative vibrational analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "vibbig" performs large-scale vibrational mode analysis using
c     only vector storage and gradient evaluations; preconditioning
c     is via an approximate inverse from a block diagonal Hessian,
c     and a sliding block method is used to converge any number of
c     eigenvectors starting from either lowest or highest frequency
c
c     literature references:
c
c     C. Murray, S. C. Racine and E. R. Davidson, "Improved Algorithms
c     for the Lowest Few Eigenvalues and Associated Eigenvectors of
c     Large Matrices", Journal of Computational Physics, 103, 382-389
c     (1992)
c
c     A. L. Kaledin, "Gradient-Based Direct Normal-Mode Analysis",
c     Journal of Chemical Physics, 122, 184106 (2005)
c
c     A. L. Kaledin, M. Kaledin and J. M. Bowman, "All-Atom Calculation
c     of the Normal Modes of Bacteriorhodopsin Using a Sliding Block
c     Iterative Diagonalization Method", Journal of Chemical Theory
c     and Computation, 2, 166-174 (2006)
c
c
      program vibbig
      use atomid
      use atoms
      use files
      use inform
      use iounit
      use keys
      use units
      use vibs
      implicit none
      integer i,j,k,ii,next
      integer i1,i2,k0,k1,k2
      integer ivib,ivb1,ivb2
      integer iblock,iconv
      integer iter,isave
      integer nvar,nblk
      integer nroot,nbasis
      integer nr,npair
      integer nlock,nconv
      integer irange,ifactor
      integer maxroot,maxiter
      integer maxhess
      integer freeunit
      integer, allocatable :: iblk(:)
      real*8 fmax,funit
      real*8 wtol,factor
      real*8 size,sizmax
      real*8 space,sum
      real*8 dfreq,rnorm,rcomp
      real*8 ratio,shift
      real*8 uku_min,uku_max
      real*8, allocatable :: xe(:)
      real*8, allocatable :: xm(:)
      real*8, allocatable :: r(:)
      real*8, allocatable :: rk(:)
      real*8, allocatable :: hmin(:)
      real*8, allocatable :: uku(:)
      real*8, allocatable :: uku0(:)
      real*8, allocatable :: uu(:)
      real*8, allocatable :: freq(:)
      real*8, allocatable :: freqold(:)
      real*8, allocatable :: tmp1(:)
      real*8, allocatable :: tmp2(:)
      real*8, allocatable :: u(:,:)
      real*8, allocatable :: ur(:,:)
      real*8, allocatable :: h(:,:)
      real*8, allocatable :: c(:,:)
      character*1 answer
      character*20 keyword
      character*240 record
      character*240 string
      character*240 datafile
      character*240 blockfile
      logical exist,restart
      logical header,done
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     set default parameters for the normal mode computation
c
      nvar = 3 * n
      maxroot = 50
      nr = 6
      iter = 0
      isave = 10
      maxhess = nvar * (nvar-1) / 2
      maxiter = 100000
      wtol = 0.00001d0
      sizmax = 500.0d0
      header = .true.
c
c     search the keywords for normal mode parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:8) .eq. 'MAXITER ') then
            read (string,*,err=10,end=10)  maxiter
         else if (keyword(1:11) .eq. 'SAVE-VECTS ') then
            read (string,*,err=10,end=10)  isave
         else if (keyword(1:10) .eq. 'VIB-ROOTS ') then
            read (string,*,err=10,end=10)  nroot
            nroot = min(nroot,maxroot)
         else if (keyword(1:14) .eq. 'VIB-TOLERANCE ') then
            read (string,*,err=10,end=10)  wtol
         end if
   10    continue
      end do
c
c     find either the lowest or highest normal modes
c
      factor = 1.0d0
      call nextarg (answer,exist)
      if (.not. exist) then
         answer = 'L'
         write (iout,20)  answer
   20    format (/,' Start at Lowest or Highest Frequency',
     &              ' Normal Mode [',a1,'] :  ',$)
         read (input,30)  record
   30    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'H')  factor = -1.0d0
c
c     find cutoff value for desired extreme frequency
c
      fmax = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=40,end=40)  fmax
   40 continue
      if (fmax .le. 0.0d0) then
         write (iout,50)
   50    format (/,' Enter Desired Frequency Cutoff in cm-1',
     &              ' [0.0] :  ',$)
         read (input,60)  fmax
   60    format (f20.0)
      end if
      if (fmax .le. 0.0d0)  fmax = 0.0d0
c
c     set default values for some additional parameters
c
      funit = factor * efreq * emass
      ifactor = int(factor)
      irange = (nvar-nr+1) * max((1-ifactor)/2,0)
      npair = 2 * nroot
      nbasis = 3 * nroot
c
c     open or create eigenvector file for use during restarts
c
      ivb1 = freeunit ()
      datafile = filename(1:leng)//'.vb1'
      call version (datafile,'old')
      inquire (file=datafile,exist=exist)
      if (exist) then
         open (unit=ivb1,file=datafile,status='old',form='unformatted')
      else
         open (unit=ivb1,file=datafile,status='new',form='unformatted')
      end if
c
c     open or create basis vector file for use during restarts
c
      ivb2 = freeunit ()
      datafile = filename(1:leng)//'.vb2'
      call version (datafile,'old')
      inquire (file=datafile,exist=exist)
      if (exist) then
         restart = .true.
         open (unit=ivb2,file=datafile,status='old',form='unformatted')
      else
         restart = .false.
         open (unit=ivb2,file=datafile,status='new',form='unformatted')
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (iblk(n))
      allocate (xe(nvar))
      allocate (xm(nvar))
      allocate (r(nvar))
      allocate (rk(nvar))
      allocate (hmin(nvar))
      allocate (uku(nvar))
      allocate (uku0(nvar))
      allocate (uu(maxhess))
      allocate (u(nvar,6))
      allocate (ur(nvar,3))
c
c     perform dynamic allocation of some global arrays
c
      allocate (rho(nvar,nbasis))
      allocate (rhok(nvar,nbasis))
      allocate (rwork(nvar,nbasis))
c
c     store a coordinate vector for each atom
c
      do i = 1, n
         xe(3*i-2) = x(i) / bohr
         xe(3*i-1) = y(i) / bohr
         xe(3*i) = z(i) / bohr
      end do
c
c     store atomic mass for each coordinate component
c
      k = 0
      do i = 1, n
         mass(i) = mass(i) * emass
         do j = 1, 3
            k = k + 1
            xm(k) = mass(i)
         end do
      end do
c
c     remove pure translational and rotational modes
c
      call trbasis (nvar,nr,xe,u,ur)
c
c     set number and size of blocks based on storage space
c
      space = 0.9d0 * dble(maxhess)
      do i = 1, n
         size = 9.0d0 * (dble(n))**2 / dble(i)
         if (size .lt. space) then
            nblk = i
            goto 70
         end if
      end do
   70 continue
      nblk = max(3,nblk)
      size = dble(n) / dble(nblk)
      size = min(size,sizmax)
      do i = 1, nblk
         iblk(i) = nint(dble(i)*size)
      end do
      do i = nblk, 2, -1
         iblk(i) = iblk(i) - iblk(i-1)
      end do
c
c     get number and size of blocks from an external file
c
      iblock = freeunit ()
      blockfile = filename(1:leng)//'.blk'
      call version (blockfile,'old')
      inquire (file=blockfile,exist=exist)
      if (exist) then
         open (unit=iblock,file=blockfile,status='old')
         i = 0
         do while (.true.)
            i = i + 1
            read (iblock,*,err=80,end=80)  iblk(i)
         end do
   80    continue
         nblk = i - 1
         close (unit=iblock)
      end if
c
c     print info about the atom blocks and preconditioning
c
      write (iout,90)
   90 format (/,' Atom Blocks Used to Subdivide the System :',/)
      k = 0
      do i = 1, nblk
         write (iout,100)  i,iblk(i),k+1,k+iblk(i)
  100    format (' Block :',i7,9x,'Size :',i7,9x,'Atoms :',i7,'  to',i7)
         k = k + iblk(i)
      end do
      k = 0
      do i = 1, nblk
         k = k + 9*iblk(i)**2
      end do
      write (iout,110)  k
  110 format (/,' Storage for Preconditioning Array :',5x,i12)
c
c     determine number of prior modes available at restart
c
      nlock = 0
      do while (.true.)
         read (ivb1,err=120,end=120)  (r(k),k=1,nvar)
         nlock = nlock + 1
      end do
  120 continue
      rewind (unit=ivb1)
      if (nlock .ne. 0) then
         write (iout,130)  nlock
  130    format (/,' Prior Normal Modes Available at Restart :',i11)
      end if
      nconv = nlock
c
c     compute and diagonalize the Hessian for each block
c
      k0 = 0
      i1 = 1
      do i = 1, nblk
         if (i .gt. 1) then
            k0 = k0 + 9*iblk(i-1)**2
            i1 = i1 + iblk(i-1)
         end if
         i2 = i1 + iblk(i) - 1
         k1 = 3*i1 - 2
         k2 = 3*i2
         call hessblk (mass,k0,i1,i2,uu)
         call diagblk (k0,k1,3*iblk(i),uu,uku)
      end do
c
c     use negative of eigenvalues if doing high frequencies
c
      do k = 1, nvar
         uku(k) = factor * uku(k)
         uku0(k) = uku(k)
      end do
      uku_max = uku(1)
      uku_min = uku(1)
      do k = 2, nvar
         if (uku(k) .gt. uku_max)  uku_max = uku(k)
         if (uku(k) .lt. uku_min)  uku_min = uku(k)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (freq(nbasis))
      allocate (freqold(nbasis))
      allocate (tmp1(nbasis))
      allocate (tmp2(nbasis))
      allocate (h(nbasis,nbasis))
      allocate (c(nbasis,nbasis))
c
c     if restarting, read trial vectors and estimate eigenvalues
c
      if (restart) then
         do i = 1, npair
            read (ivb2)  (rho(k,i),k=1,nvar)
            read (ivb2)  (rhok(k,i),k=1,nvar)
         end do
         do i = 1, nroot
            h(i,i) = 0.0d0
            do k = 1, nvar
               h(i,i) = h(i,i) + rhok(k,i)*rho(k,i)
            end do
            freqold(i) = sign(1.0d0,h(i,i)) * sqrt(abs(h(i,i)))
         end do
         goto 140
      end if
c
c     if not restarting, generate initial guess eigenvectors
c
      do i = 1, nroot
         call trigger (nvar,nbasis,nr,ifactor,nblk,iblk,u,uu,r)
         do k = 1, nvar
            rho(k,i) = r(k)
         end do
      end do
c
c     project out locked roots from components of rho
c
      call project (nvar,nconv,ivb1,nroot,0)
      call projectk (nvar,nconv,ivb1,nroot,0)
c
c     reload and make vector orthonormal to existing basis
c
      do i = 1, nroot
         do k = 1, nvar
            r(k) = rho(k,i)
         end do
         if (i .eq. 1) then
            sum = 0.0d0
            do k = 1, nvar
               sum = sum + r(k)*r(k)
            end do
            sum = sqrt(sum)
            do k = 1, nvar
               r(k) = r(k) / sum
            end do
         else
            call gsort (nvar,i-1,r)
         end if
         do k = 1, nvar
            rho(k,i) = r(k)
         end do
      end do
c
c     store K on rho
c
      do i = 1, nroot
         do k = 1, nvar
            r(k) = rho(k,i)
         end do
         call konvec (nvar,xm,xe,r,rk)
         do k = 1, nvar
            rhok(k,i) = factor * rk(k)
         end do
      end do
c
c     make nroot-by-nroot CI matrix
c
      do i = 1, nroot
         do j = i, nroot
            h(i,j) = 0.0d0
            do k = 1, nvar
               h(i,j) = h(i,j) + rhok(k,i)*rho(k,j)
            end do
            h(j,i) = h(i,j)
         end do
      end do
c
c     diagonalize and use first nroot solutions as starting basis
c
      call transform (nroot,nbasis,h,c)
c
c     fill up arrays
c
      do k = 1, nvar
         do j = 1, nroot
            tmp1(j) = 0.0d0
            tmp2(j) = 0.0d0
            do i = 1, nroot
               tmp1(j) = tmp1(j) + c(i,j)*rho(k,i)
               tmp2(j) = tmp2(j) + c(i,j)*rhok(k,i)
            end do
         end do
         do j = 1, nroot
            rho(k,j) = tmp1(j)
            rhok(k,j) = tmp2(j)
         end do
      end do
c
c     residues of guesses
c
      do i = 1, nroot
         freq(i) = funit * sign(1.0d0,h(i,i)) * sqrt(abs(h(i,i)))
         freqold(i) = freq(i)
         do k = 1, nvar
            rk(k) = rhok(k,i) - h(i,i)*rho(k,i)
         end do
c
c     use Davidson preconditioner if finding low frequencies
c
         if (factor .gt. 0.0d0) then
            call preconblk (nvar,nblk,iblk,uku,uu,h(i,i),hmin(i),rk)
         end if
c
c     project residual onto P-space
c
         call qonvec (nvar,nr,u,rk,r)
         do k = 1, nvar
            rho(k,i+nroot) = r(k)
         end do
      end do
c
c     project out locked roots from components of rho
c
      call project (nvar,nconv,ivb1,nroot,nroot)
      call projectk (nvar,nconv,ivb1,nroot,nroot)
c
c     reload and make vector orthonormal to existing basis
c
      do i = 1, nroot
         do k = 1, nvar
            r(k) = rho(k,i+nroot)
         end do
         call gsort (nvar,nroot+i-1,r)
         do k = 1, nvar
            rho(k,i+nroot) = r(k)
         end do
      end do
c
c     store K on rho
c
      do i = 1, nroot
         do k = 1, nvar
            r(k) = rho(k,i+nroot)
         end do
         call konvec (nvar,xm,xe,r,rk)
         do k = 1, nvar
            rhok(k,i+nroot) = factor * rk(k)
         end do
      end do
c
c     make npair-by-npair CI matrix
c
      do i = 1, npair
         do j = i, npair
            h(i,j) = 0.0d0
            do k = 1, nvar
               h(i,j) = h(i,j) + rhok(k,i)*rho(k,j)
            end do
            h(j,i) = h(i,j)
         end do
      end do
c
c     diagonalize and use first nroot solutions as new guess
c
      call transform (npair,nbasis,h,c)
      do k = 1, nvar
         do j = 1, nroot
            tmp1(j) = 0.0d0
            tmp2(j) = 0.0d0
            do i = 1, npair
               tmp1(j) = tmp1(j) + c(i,j)*rho(k,i)
               tmp2(j) = tmp2(j) + c(i,j)*rhok(k,i)
            end do
         end do
c
c     old solution fills up 2nd block
c
         do j = 1, nroot
            rho(k,j+nroot) = rho(k,j)
            rhok(k,j+nroot) = rhok(k,j)
         end do
c
c     new solution fills up 1st block
c
         do j = 1, nroot
            rho(k,j) = tmp1(j)
            rhok(k,j) = tmp2(j)
         end do
c
c     orthogonalize 2nd block to 1st
c
         do j = 1, nroot
            do i = 1, nroot
               rho(k,j+nroot) = rho(k,j+nroot) - c(j,i)*rho(k,i)
               rhok(k,j+nroot) = rhok(k,j+nroot) - c(j,i)*rhok(k,i)
            end do
         end do
      end do
c
c     orthogonalize 2nd block on itself
c
      sum = 0.0d0
      do k = 1, nvar
         sum = sum + rho(k,nroot+1)*rho(k,nroot+1)
      end do
      sum = sqrt(sum)
c
c     normalize leading vector
c
      do k = 1, nvar
         rho(k,nroot+1) = rho(k,nroot+1) / sum
         rhok(k,nroot+1) = rhok(k,nroot+1) / sum
      end do
c
c     orthogonalize the rest one-by-one
c
      if (nroot .gt. 1) then
         do i = 2, max(2,nroot)
            do j = 1, i-1
               sum = 0.0d0
               do k = 1, nvar
                  sum = sum + rho(k,i+nroot)*rho(k,j+nroot)
               end do
               do k = 1, nvar
                  rho(k,i+nroot) = rho(k,i+nroot)-sum*rho(k,j+nroot)
                  rhok(k,i+nroot) = rhok(k,i+nroot)-sum*rhok(k,j+nroot)
               end do
            end do
            sum = 0.0d0
            do k = 1, nvar
               sum = sum + rho(k,i+nroot)*rho(k,i+nroot)
            end do
            sum = sqrt(sum)
            do k = 1, nvar
               rho(k,i+nroot) = rho(k,i+nroot) / sum
               rhok(k,i+nroot) = rhok(k,i+nroot) / sum
            end do
         end do
      end if
c
c     residue of new solution (if restarting, begin here)
c
  140 continue
      do i = 1, nroot
         freq(i) = funit * sign(1.0d0,h(i,i)) * sqrt(abs(h(i,i)))
         freq(i+nroot) = funit * sign(1.0d0,h(i+nroot,i+nroot))
     &                      * sqrt(abs(h(i+nroot,i+nroot)))
         freq(i+npair) = funit * sign(1.0d0,h(i+npair,i+npair))
     &                        * sqrt(abs(h(i+npair,i+npair)))
         do k = 1, nvar
            rk(k) = rhok(k,i) - h(i,i)*rho(k,i)
         end do
c
c     use Davidson preconditioner if finding low frequencies
c
         if (factor .gt. 0.0d0) then
            call preconblk (nvar,nblk,iblk,uku,uu,h(i,i),hmin(i),rk)
         end if
c
c     project onto P-space
c
         call qonvec (nvar,nr,u,rk,r)
         do k = 1, nvar
            rho(k,i+npair) = r(k)
         end do
      end do
c
c     project out locked roots from components of rho
c
      call project (nvar,nconv,ivb1,nroot,npair)
      call projectk (nvar,nconv,ivb1,nroot,npair)
c
c     reload and orthogonalize to 1st + 2nd
c
      do i = 1, nroot
         do k = 1, nvar
            r(k) = rho(k,i+npair)
         end do
         call gsort (nvar,npair+i-1,r)
         do k = 1, nvar
            rho(k,i+npair) = r(k)
         end do
      end do
c
c     store K on rho
c
      do i = 1, nroot
         do k = 1, nvar
            r(k) = rho(k,i+npair)
         end do
         call konvec (nvar,xm,xe,r,rk)
         do k = 1, nvar
            rhok(k,i+npair) = factor * rk(k)
         end do
      end do
c
c     beginning of iterations
c
      iconv = 0
  150 continue
      done = .false.
      iter = iter + 1
c
c     make nbasis-by-nbasis CI matrix
c
      do i = 1, nbasis
         do j = i, nbasis
            h(i,j) = 0.0d0
            do k = 1, nvar
               h(i,j) = h(i,j) + rhok(k,i)*rho(k,j)
            end do
            h(j,i) = h(i,j)
         end do
      end do
c
c     list of previous frequencies
c
      do i = 1, npair
         freqold(i) = freq(i)
      end do
c
c     diagonalize and use first nroot solutions as new guess
c
      call transform (nbasis,nbasis,h,c)
c
c     check for collapse based on leading component of ground state
c
      if (iconv.eq.0 .and. nconv.gt.0) then
         sum = sqrt(1.0d0-c(1,1)**2)
         if (sum .gt. 0.9d0) then
            write (iout,160)  nconv-nlock
  160       format (/,' Number of Converged Normal Modes :',6x,i12)
            write (iout,170)
  170       format (/,' VIBBIG  --  Loss of Root Identity; Please',
     &                 ' Try to Restart')
            close (unit=ivb2,status='delete')
            goto 270
         end if
      end if
c
c     list of new frequencies
c
      do i = 1, npair
         freq(i) = funit * sign(1.0d0,h(i,i)) * sqrt(abs(h(i,i)))
      end do
c
c     check if first few have converged
c
      iconv = 0
  180 continue
      dfreq = freqold(iconv+1) - freq(iconv+1)
      if (dfreq*factor.gt.0.0d0 .and. dfreq*factor.lt.wtol) then
         iconv = iconv + 1
         goto 180
      end if
c
c     shift levels of preconditioner matrix; since the Hessian
c     is gradually deflated, reduce effect of the preconditioner
c     based on a simple 1/x curve, the uku levels are squeezed
c     upwards to eventually lead to a unit operator
c
      if (iconv .gt. 0) then
         ratio = dble(nconv+iconv) / dble(nvar)
         shift = uku_min / (1.0d0-ratio)
         shift = shift + h(iconv+nroot,iconv+nroot)
c
c     do a regular shift, which also seems to work
c
         do k = 1, nvar
            uku(k) = uku_max + (uku0(k)-uku_max)*(uku_max-shift)
     &                                 / (uku_max-uku_min)
         end do
c
c     move cursor to end of storage file
c
         do i = 1, nconv
            read (ivb1)  (rk(k),k=1,nvar)
         end do
c
c     norm of residual
c
         do j = 1, iconv
            rnorm = 0.0d0
            do k = 1, nvar
               r(k) = 0.0d0
               rk(k) = 0.0d0
               do i = 1, nbasis
                  r(k) = r(k)+c(i,j)*rho(k,i)
                  rk(k) = rk(k)+c(i,j)*rhok(k,i)
               end do
               rnorm = rnorm + (rk(k)-h(j,j)*r(k))**2
            end do
            rnorm = sqrt(rnorm)
c
c     component of root in R-space
c
            do i = 1, 3
               tmp1(i) = 0.0d0
               do k = 1, nvar
                  tmp1(i) = tmp1(i) + ur(k,i)*r(k)
               end do
            end do
            rcomp = 0.0d0
            do k = 1, nvar
               sum = 0.0d0
               do i = 1, 3
                  sum = sum + ur(k,i)*tmp1(i)
               end do
               rcomp = rcomp + sum*sum
            end do
            rcomp = sqrt(rcomp)
c
c     write the converged mode to formatted and binary files
c
            ivib = irange + ifactor*(nconv+j)
            if ((header.or.verbose) .and. j.eq.1) then
               header = .false.
               write (iout,190)
  190          format (/,' Converged Normal Modes from Iterative',
     &                    ' Vibrational Analysis :')
               write (iout,200)
  200          format (/,4x,'Mode',7x,'Frequency',8x,'Delta',10x,
     &                    'R Norm',10x,'Orthog')
               if (.not. verbose) then
                  write (iout,210)
  210             format ()
               end if
            end if
            dfreq = freqold(j) - freq(j)
            write (iout,220)  ivib,freq(j),dfreq,rnorm,rcomp
  220       format (i8,f15.3,3d16.4)
            call prtvib (ivib,r)
            write (ivb1)  (r(k),k=1,nvar)
         end do
         rewind (unit=ivb1)
c
c     update total number of vectors locked on disk
c
         nconv = nconv + iconv
         if (freq(iconv)*factor .ge. fmax*factor) then
            done = .true.
            close (unit=ivb1)
         end if
      end if
c
c     shift frequency arrays by iconv
c
      do i = 1, npair
         freq(i) = freq(i+iconv)
         freqold(i) = freqold(i+iconv)
      end do
      do k = 1, nvar
         do j = 1, nroot+iconv
            tmp1(j) = 0.0d0
            tmp2(j) = 0.0d0
            do i = 1, nbasis
               tmp1(j) = tmp1(j) + c(i,j)*rho(k,i)
               tmp2(j) = tmp2(j) + c(i,j)*rhok(k,i)
            end do
         end do
c
c     old solution fills up 2nd block
c
         do j = 1, nroot
            rho(k,j+nroot+iconv) = rho(k,j+iconv)
            rhok(k,j+nroot+iconv) = rhok(k,j+iconv)
         end do
c
c     new solution fills up 1st block
c
         do j = 1, nroot
            rho(k,j+iconv) = tmp1(j+iconv)
            rhok(k,j+iconv) = tmp2(j+iconv)
         end do
c
c     shift index down by iconv
c
         do j = 1, npair
            rho(k,j) = rho(k,j+iconv)
            rhok(k,j) = rhok(k,j+iconv)
         end do
c
c     orthogonalize 2nd block to 1st + iconv roots
c
         do j = 1, nroot
            do i = 1, nroot
               rho(k,j+nroot) = rho(k,j+nroot)
     &                             - c(j+iconv,i+iconv)*rho(k,i)
               rhok(k,j+nroot) = rhok(k,j+nroot)
     &                              - c(j+iconv,i+iconv)*rhok(k,i)
            end do
            do i = 1, iconv
               rho(k,j+nroot) = rho(k,j+nroot) - c(j+iconv,i)*tmp1(i)
               rhok(k,j+nroot) = rhok(k,j+nroot) - c(j+iconv,i)*tmp2(i)
            end do
         end do
      end do
c
c     orthogonalize 2nd block on itself
c
      sum = 0.0d0
      do k = 1, nvar
         sum = sum + rho(k,nroot+1)*rho(k,nroot+1)
      end do
      sum = sqrt(sum)
c
c     normalize leading vector
c
      do k = 1, nvar
         rho(k,nroot+1) = rho(k,nroot+1) / sum
         rhok(k,nroot+1) = rhok(k,nroot+1) / sum
      end do
c
c     orthogonalize the rest one-by-one
c
      if (nroot .gt. 1) then
         do i = 2, max(2,nroot)
            do j = 1, i-1
               sum = 0.0d0
               do k = 1, nvar
                  sum = sum + rho(k,i+nroot)*rho(k,j+nroot)
               end do
               do k = 1, nvar
                  rho(k,i+nroot) = rho(k,i+nroot)-sum*rho(k,j+nroot)
                  rhok(k,i+nroot) = rhok(k,i+nroot)-sum*rhok(k,j+nroot)
               end do
            end do
            sum = 0.0d0
            do k = 1, nvar
               sum = sum + rho(k,i+nroot)*rho(k,i+nroot)
            end do
            sum = sqrt(sum)
            do k = 1, nvar
               rho(k,i+nroot) = rho(k,i+nroot) / sum
               rhok(k,i+nroot) = rhok(k,i+nroot) / sum
            end do
         end do
      end if
c
c     print a header for the current iteration
c
      if (verbose) then
         write (iout,230)  iter,iconv,nconv
  230    format (/,' Iteration',i7,11x,'New Modes',i6,10x,
     &              ' Total Modes',i6,/)
         write (iout,240)
  240    format (4x,'Mode',7x,'Frequency',8x,'Delta',10x,
     &              'R Norm',10x,'Orthog')
      end if
c
c     norm of residual
c
      do i = 1, nroot
         rnorm = 0.0d0
         do k = 1, nvar
            rnorm = rnorm + (rhok(k,i)-h(i+iconv,i+iconv)*rho(k,i))**2
         end do
         rnorm = sqrt(rnorm)
c
c     calculate root's component in R-space
c
         do j = 1, 3
            tmp1(j) = 0.0d0
            do k = 1, nvar
               tmp1(j) = tmp1(j) + ur(k,j)*rho(k,i)
            end do
         end do
         rcomp = 0.0d0
         do k = 1, nvar
            sum = 0.0d0
            do j = 1, 3
               sum = sum + ur(k,j)*tmp1(j)
            end do
            rcomp = rcomp + sum*sum
         end do
         rcomp = sqrt(rcomp)
         dfreq = freqold(i) - freq(i)
         if (verbose) then
            write (iout,250)  irange+ifactor*(i+nconv),
     &                        freq(i),dfreq,rnorm,rcomp
  250       format (i8,f15.3,3d16.4)
         end if
      end do
c
c     save vectors needed to restart a calculation
c
      if (mod(iter,isave) .eq. 0) then
         rewind (unit=ivb2)
         do i = 1, npair
            write (ivb2)  (rho(k,i),k=1,nvar)
            write (ivb2)  (rhok(k,i),k=1,nvar)
         end do
      end if
c
c     prepare restart if finished or iterations exhausted
c
      if (done .or. iter.eq.maxiter) then
         write (iout,260)  nconv-nlock
  260    format (/,' Number of Converged Normal Modes :',6x,i12)
         rewind (ivb2)
         do i = 1, npair
            write (ivb2)  (rho(k,i),k=1,nvar)
            write (ivb2)  (rhok(k,i),k=1,nvar)
         end do
         close (unit=ivb2)
         goto 270
      end if
c
c     as above, make sure no prior roots are mixed in the basis
c
      do i = 1, npair
         do k = 1, nvar
            r(k) = rho(k,i)
         end do
         call qonvec (nvar,nr,u,r,rk)
         do k = 1, nvar
            rho(k,i) = rk(k)
         end  do
         do k = 1, nvar
            r(k) = rhok(k,i)
         end do
         call qonvec (nvar,nr,u,r,rk)
         do k = 1, nvar
            rhok(k,i) = rk(k)
         end do
      end do
c
c     project out locked roots from components of rho
c
      call project (nvar,nconv,ivb1,npair,0)
      call projectk (nvar,nconv,ivb1,npair,0)
c
c     setup next iteration; solution residue, Davidson weight
c
      do i = 1, nroot
         do k = 1, nvar
            rk(k) = rhok(k,i) - h(i+iconv,i+iconv)*rho(k,i)
         end do
c
c     use Davidson preconditioner if finding low frequencies
c
         ii = i + iconv
         if (factor .gt. 0.0d0) then
            call preconblk (nvar,nblk,iblk,uku,uu,h(ii,ii),hmin(i),rk)
         end if
c
c     project residual onto R-space
c
         call qonvec (nvar,nr,u,rk,r)
         do k = 1, nvar
            rho(k,i+npair) = r(k)
         end do
      end do
c
c     project out locked roots from components of rho
c
      call project (nvar,nconv,ivb1,nroot,npair)
c
c     reload and orthogonalize to 1st + 2nd
c
      do i = 1, nroot
         do k = 1, nvar
            r(k) = rho(k,i+npair)
         end do
         call gsort (nvar,npair+i-1,r)
         do k = 1, nvar
            rho(k,i+npair) = r(k)
         end do
      end do
c
c     store K on rho
c
      do i= 1, nroot
         do k = 1, nvar
            r(k) = rho(k,i+npair)
         end do
         call konvec (nvar,xm,xe,r,rk)
         call qonvec(nvar,nr,u,rk,r)
         do k = 1, nvar
            rhok(k,i+npair) = factor * r(k)
         end do
      end do
c
c     project out locked roots from components of rhok
c
      call projectk (nvar,nconv,ivb1,nroot,npair)
      goto 150
  270 continue
c
c     perform deallocation of some local arrays
c
      deallocate (iblk)
      deallocate (xe)
      deallocate (xm)
      deallocate (r)
      deallocate (rk)
      deallocate (hmin)
      deallocate (uku)
      deallocate (uku0)
      deallocate (uu)
      deallocate (u)
      deallocate (ur)
      deallocate (freq)
      deallocate (freqold)
      deallocate (tmp1)
      deallocate (tmp2)
      deallocate (h)
      deallocate (c)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine trigger  --  get initial trial eigenvectors  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "trigger" constructs a set of initial trial vectors for
c     use during sliding block iterative matrix diagonalization
c
c
      subroutine trigger (nvar,nbasis,nr,ifactor,nblk,iblk,u,uu,r)
      implicit none
      integer i,j,k,m
      integer k0,k1,k2
      integer nvar,nbasis
      integer nr,ifactor
      integer nblk,nguess
      integer iblk(*)
      real*8 w,sum
      real*8 random
      real*8 r(*)
      real*8 uu(*)
      real*8 u(nvar,*)
      real*8, allocatable :: tmp(:)
      external random
c
c
c     set the number of random guesses
c
      nguess = 1 + int(dble(nbasis)/dble(nblk))
c
c     zero out the trial vector
c
      do k = 1, nvar
         r(k) = 0.0d0
      end do
c
c     create overlap with the entire P-space
c
      k0 = 0
      k1 = 1
      do i = 1, nblk
         if (i .gt. 1) then
            k0 = k0 + 9*iblk(i-1)**2
            k1 = k1 + 3*iblk(i-1)
         end if
         k2 = k1 + 3*iblk(i) - 1
c
c     scan over rows of the Hessian
c
         m = 0
         do j = 1, 3*iblk(i)
            if (ifactor .eq. 1) then
               if (j .gt. min(nguess,3*iblk(i))) then
                  w = 0.0d0
               else
                  w = random() - 0.5d0
               end if
            else
               if (j .lt. (3*iblk(i)-min(nguess,3*iblk(i))+1)) then
                  w = 0.0d0
               else
                  w = random() - 0.5d0
               end if
            end if
            do k = k1, k2
               m = m + 1
               r(k) = r(k) + w*uu(k0+m)
            end do
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (tmp(nvar))
c
c     project the vector onto P-space
c
      call qonvec (nvar,nr,u,r,tmp)
c
c     perform a normalization
c
      sum = 0.0d0
      do i = 1, nvar
         sum = sum + tmp(i)**2
      end do
      sum = sqrt(sum)
      do i = 1, nvar
         r(i) = tmp(i) / sum
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (tmp)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine trbasis  --  set translation/rotation vectors  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "trbasis" forms translation and rotation basis vectors used
c     during vibrational analysis via block iterative diagonalization
c
c
      subroutine trbasis (nvar,nr,xe,u,ur)
      use atomid
      use atoms
      implicit none
      integer i,j,k
      integer nvar,nr
      real*8 tmass,sum
      real*8 ra,rha,pr
      real*8 cm(3)
      real*8 r(3)
      real*8 e(3,3)
      real*8 c(3,3)
      real*8 xe(*)
      real*8 u(nvar,*)
      real*8 ur(nvar,*)
c
c
c     zero out the translation and rotation vectors
c
      do i = 1, 6
         do j = 1, nvar
            u(j,i) = 0.0d0
         end do
      end do
c
c     get the total mass of the system
c
      tmass = 0.0d0
      do i = 1, n
         tmass = tmass + mass(i)
      end do
c
c     set basis vectors for translations
c
      do i = 1, n
         u(3*i-2,1) = sqrt(mass(i)/tmass)
         u(3*i-1,1) = 0.0d0
         u(3*i,1) = 0.0d0
         u(3*i-2,2) = 0.0d0
         u(3*i-1,2) = sqrt(mass(i)/tmass)
         u(3*i,2) = 0.0d0
         u(3*i-2,3) = 0.0d0
         u(3*i-1,3) = 0.0d0
         u(3*i,3) = sqrt(mass(i)/tmass)
      end do
c
c     move center of mass to origin
c
      do i = 1, 3
         cm(i) = 0.0d0
      end do
      do i = 1, n
         do j = 1, 3
            cm(j) = cm(j) + xe(3*(i-1)+j)*mass(i)
         end do
      end do
      do i = 1, n
         do j = 1, 3
            xe(3*(i-1)+j) = xe(3*(i-1)+j) - cm(j)/tmass
         end do
      end do
c
c     get the moments of inertia
c
      do i = 1, 3
         e(i,i) = 0.0d0
      end do
      do i = 1, n
         e(1,1) = e(1,1) + ((xe(3*i-1)**2+xe(3*i)**2))*mass(i)
         e(2,2) = e(2,2) + ((xe(3*i-2)**2+xe(3*i)**2))*mass(i)
         e(3,3) = e(3,3) + ((xe(3*i-2)**2+xe(3*i-1)**2))*mass(i)
      end do
      do i = 1, 2
         do j = i+1, 3
            e(i,j) = 0.0d0
            do k = 1, n
               e(i,j) = e(i,j) - xe(3*(k-1)+i)*xe(3*(k-1)+j)*mass(k)
            end do
            e(j,i) = e(i,j)
         end do
      end do
c
c     diagonalize to get principal axes
c
      call jacobi (3,e,cm,c)
c
c     construction of principle rotations
c
      do i = 1, 3
         do j = 1, n
            ra = 0.0d0
            pr = 0.0d0
            do k = 1, 3
               cm(k) = xe(3*(j-1)+k)
               ra = ra + cm(k)**2
               pr = pr + cm(k)*c(k,i)
            end do
            rha = sqrt(ra-pr**2)
            r(1) = c(2,i)*cm(3) - c(3,i)*cm(2)
            r(2) = c(3,i)*cm(1) - c(1,i)*cm(3)
            r(3) = c(1,i)*cm(2) - c(2,i)*cm(1)
            sum = 0.0d0
            do k = 1, 3
               sum = sum + r(k)**2
            end do
            sum = sqrt(sum)
            do k = 1, 3
               ur(3*(j-1)+k,i) = sqrt(mass(j)) * rha*r(k)/sum
            end do
         end do
         sum = 0.0d0
         do j = 1, nvar
            sum = sum + ur(j,i)**2
         end do
         sum = sqrt(sum)
         do j = 1, nvar
            ur(j,i) = ur(j,i) / sum
         end do
      end do
c
c     set basis vectors for rotation
c
      if (nr .eq. 6) then
         do i = 1, 3
            do j = 1, nvar
               u(j,i+3) = ur(j,i)
            end do
         end do
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine preconblk  --  precondition atom block Hessian  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "preconblk" applies a preconditioner to an atom block section
c     of the Hessian matrix
c
c
      subroutine preconblk (nvar,nblk,iblk,uku,uu,h,hmin,rk)
      implicit none
      integer i,j,k,l
      integer nvar,nblk
      integer k0,k1,k2,l2
      integer iblk(*)
      real*8 h,hmin
      real*8 uku(*)
      real*8 rk(*)
      real*8 uu(*)
      real*8, allocatable :: d(:)
      real*8, allocatable :: work(:)
c
c
c     find smallest element of |h-uku|
c
      hmin = abs(h-uku(1))
      do k = 2, nvar
         if (abs(h-uku(k)) .lt. hmin) then
            hmin = abs(h-uku(k))
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (d(nvar))
      allocate (work(nvar))
c
c     assign values to temporary array
c
      do k = 1, nvar
         d(k) = h - uku(k)
      end do
c
c     invert array via d=hmin/d, where hmin=min{|d(k)|}
c
      do k = 1, nvar
         d(k) = hmin / d(k)
      end do
c
c     create overlap with the entire rk array
c
      k0 = 0
      k1 = 1
      do i = 1, nblk
         if (i .gt. 1) then
            k0 = k0 + 9*iblk(i-1)**2
            k1 = k1 + 3*iblk(i-1)
         end if
         k2 = k1 + 3*iblk(i) - 1
c
c    scan over rows of the Hessian, first part
c
         l = 0
         do j = 1, 3*iblk(i)
            l2 = k1 + j - 1
            work(l2) = 0.0d0
            do k = k1, k2
               l = l + 1
               work(l2) = work(l2) + uu(k0+l)*rk(k)
            end do
         end do
c
c    zero out the segment
c
         do k = k1, k2
            rk(k) = 0.0d0
         end do
c
c    scan over rows of the Hessian, second part
c
         l = 0
         do j = 1, 3*iblk(i)
            l2 = k1 + j - 1
            do k = k1, k2
               l = l + 1
               rk(k) = rk(k) + uu(k0+l)*d(l2)*work(l2)
            end do
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (d)
      deallocate (work)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine gsort  --  orthogonal vector via Gram-Schmidt  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "gsort" uses the Gram-Schmidt algorithm to build orthogonal
c     vectors for sliding block interative matrix diagonalization
c
c
      subroutine gsort (nvar,nb,r0)
      use vibs
      implicit none
      integer i,j
      integer nvar,nb
      real*8 sum
      real*8 r0(*)
      real*8, allocatable :: s(:)
      real*8, allocatable :: proj(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (s(nb))
      allocate (proj(nvar))
c
c     make overlap between two basis sets
c
      do i = 1, nb
         s(i) = 0.0d0
         do j = 1, nvar
            s(i) = s(i) + r0(j)*rho(j,i)
         end do
      end do
c
c     start the Gram-Schmidt procedure
c
      do i = 1, nvar
         proj(i) = 0.0d0
      end do
c
c     construct projector
c
      do i = 1, nb
         do j = 1, nvar
            proj(j) = proj(j) + s(i)*rho(j,i)
         end do
      end do
c
c     apply projector and normalize new vector
c
      sum = 0.0d0
      do i = 1, nvar
         proj(i) = r0(i) - proj(i)
         sum = sum + proj(i)*proj(i)
      end do
      sum = sqrt(sum)
      do i = 1, nvar
         proj(i) = proj(i) / sum
      end do
c
c     return original array updated
c
      do i = 1, nvar
         r0(i) = proj(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (s)
      deallocate (proj)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine qonvec  --  block iterative vibration utility  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "qonvec" is a vector utility routine used during sliding
c     block iterative matrix diagonalization
c
c
      subroutine qonvec (nvar,nr,u,rk,r)
      implicit none
      integer i,j,nvar,nr
      real*8 rku(6)
      real*8 rk(*)
      real*8 r(*)
      real*8 u(nvar,*)
c
c
c     operate on vector rk with u-transpose
c
      do i = 1, nr
         rku(i) = 0.0d0
         do j = 1, nvar
            rku(i) = rku(i) + u(j,i)*rk(j)
         end do
      end do
c
c     operate with u on the resultant
c
      do i = 1, nvar
         r(i) = 0.0d0
         do j = 1, nr
            r(i) = r(i) + u(i,j)*rku(j)
         end do
      end do
c
c     subtract new product from r
c
      do i = 1, nvar
         r(i) = rk(i) - r(i)
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine project  --  remove known vectors from current  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "project" reads locked vectors from a binary file and projects
c     them out of the components of the set of trial eigenvectors
c     using the relation Y = X - U * U^T * X
c
c
      subroutine project (nvar,nconv,ivb1,ns,m)
      use vibs
      implicit none
      integer i,j,k
      integer nvar,nconv
      integer ivb1,ns,m
      real*8, allocatable :: temp(:)
      real*8, allocatable :: u(:)
c
c
c     zero the temporary storage array
c
      do k = 1, nvar
         do i = 1, ns
            rwork(k,i+m) = 0.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (temp(ns))
      allocate (u(nvar))
c
c     read and scan over the locked eigenvectors
c
      do i = 1, nconv
         read (ivb1)  (u(k),k=1,nvar)
         do j = 1, ns
            temp(j) = 0.0d0
            do k = 1, nvar
               temp(j) = temp(j) + u(k)*rho(k,j+m)
            end do
         end do
         do j = 1, ns
            do k = 1, nvar
               rwork(k,j+m) = rwork(k,j+m) + u(k)*temp(j)
            end do
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (temp)
      deallocate (u)
c
c     project locked vectors out of the current set
c
      do k = 1, nvar
         do i = 1, ns
            rho(k,i+m) = rho(k,i+m) - rwork(k,i+m)
         end do
      end do
      if (nconv .gt. 0)  rewind (unit=ivb1)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine projectk  --  remove known vectors from current  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "projectk" reads locked vectors from a binary file and projects
c     them out of the components of the set of trial eigenvectors
c     using the relation Y = X - U * U^T * X
c
c
      subroutine projectk (nvar,nconv,ivb1,ns,m)
      use vibs
      implicit none
      integer i,j,k
      integer nvar,nconv
      integer ivb1,ns,m
      real*8, allocatable :: temp(:)
      real*8, allocatable :: u(:)
c
c
c     zero the temporary storage array
c
      do k = 1, nvar
         do i = 1, ns
            rwork(k,i+m) = 0.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (temp(ns))
      allocate (u(nvar))
c
c     read and scan over the locked eigenvectors
c
      do i = 1, nconv
         read (ivb1)  (u(k),k=1,nvar)
         do j = 1, ns
            temp(j) = 0.0d0
            do k = 1, nvar
               temp(j) = temp(j) + u(k)*rhok(k,j+m)
            end do
         end do
         do j = 1, ns
            do k = 1, nvar
               rwork(k,j+m) = rwork(k,j+m) + u(k)*temp(j)
            end do
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (temp)
      deallocate (u)
c
c     project locked vectors out of the current set
c
      do k = 1, nvar
         do i = 1, ns
            rhok(k,i+m) = rhok(k,i+m) - rwork(k,i+m)
         end do
      end do
      if (nconv .gt. 0)  rewind (unit=ivb1)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine konvec  --  evaluate Hessian-vector product  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "konvec" finds a Hessian-vector product via finite-difference
c     evaluation of the gradient based on atomic displacements
c
c
      subroutine konvec (nvar,xm,qe,uvec,kuvec)
      use atomid
      use atoms
      use units
      implicit none
      integer i,j,k,nvar
      real*8 e,term
      real*8 sum,eps
      real*8 xm(*)
      real*8 qe(*)
      real*8 uvec(*)
      real*8 kuvec(*)
      real*8, allocatable :: delta(:)
      real*8, allocatable :: grd1(:,:)
      real*8, allocatable :: grd2(:,:)
c
c
c     estimate displacement based on total average
c
      sum = 0.0d0
      do i = 1, nvar
         sum = sum + uvec(i)*uvec(i)/xm(i)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (delta(nvar))
      allocate (grd1(3,n))
      allocate (grd2(3,n))
c
c     store the coordinate displacements
c
      eps = 0.001d0 / sqrt(sum)
      do i = 1, nvar
         delta(i) = eps * uvec(i) / sqrt(xm(i))
      end do
c
c     compute the forward displacement
c
      do i = 1, n
         k = 3 * (i-1)
         x(i) = bohr * (qe(k+1)+delta(k+1))
         y(i) = bohr * (qe(k+2)+delta(k+2))
         z(i) = bohr * (qe(k+3)+delta(k+3))
      end do
      call gradient (e,grd1)
c
c     compute the backward displacement
c
      do i = 1, n
         k = 3 * (i-1)
         x(i) = bohr * (qe(k+1)-delta(k+1))
         y(i) = bohr * (qe(k+2)-delta(k+2))
         z(i) = bohr * (qe(k+3)-delta(k+3))
      end do
      call gradient (e,grd2)
c
c     update via finite differences
c
      term = 0.5d0 * bohr / (eps * hartree)
      do i = 1, n
         k = 3 * (i-1)
         do j = 1, 3
            kuvec(k+j) = term * (grd1(j,i)-grd2(j,i)) / sqrt(xm(k+j))
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (delta)
      deallocate (grd1)
      deallocate (grd2)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine transform  --  diagonalize trial basis vectors  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "transform" diagonalizes the current basis vectors to produce
c     trial roots for sliding block iterative matrix diagonalization
c
c
      subroutine transform (ns,nb,h,c)
      implicit none
      integer i,j,k,ns,nb
      real*8 h(nb,*)
      real*8 c(nb,*)
      real*8, allocatable :: e1(:)
      real*8, allocatable :: h1(:)
      real*8, allocatable :: c1(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (e1(ns))
      allocate (h1((ns+1)*ns/2))
      allocate (c1(ns,ns))
c
c     pack the upper triangle of matrix
c
      k = 0
      do i = 1, ns
         do j = i, ns
            k = k + 1
            h1(k) = h(i,j)
         end do
      end do
c
c     perform the matrix diagonalization
c
      call diagq (ns,ns,h1,e1,c1)
c
c     copy values into the return arrays
c
      do i = 1, ns
         do j = 1, ns
            h(i,j) = 0.0d0
            c(i,j) = c1(i,j)
         end do
         h(i,i) = e1(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (e1)
      deallocate (h1)
      deallocate (c1)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine diagblk  -- diagonalization for atom block  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "diagblk" performs diagonalization of the Hessian for a
c     block of atoms within a larger system
c
c
      subroutine diagblk (k0,k1,n,vector,wres)
      implicit none
      integer i,j,k,m
      integer n,k0,k1
      real*8 wres(*)
      real*8 vector(*)
      real*8, allocatable :: hval(:)
      real*8, allocatable :: hres(:)
      real*8, allocatable :: hvec(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (hval(n))
      allocate (hres((n+1)*n/2))
      allocate (hvec(n,n))
c
c     pack the upper triangle of matrix
c
      k = 0
      do i = 1, n
         m = k0 + (i-1)*n
         do j = i, n
            k = k + 1
            hres(k) = vector(m+j)
         end do
      end do
c
c     perform the matrix diagonalization
c
      call diagq (n,n,hres,hval,hvec)
c
c     copy values into return arrays
c
      k = 0
      do i = 1, n
         do j = 1, n
            k = k + 1
            vector(k0+k) = hvec(j,i)
         end do
      end do
      do i = 1, n
         wres(k1+i-1) = hval(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (hval)
      deallocate (hres)
      deallocate (hvec)
      return
      end
c
c
c     #########################################################
c     ##                                                     ##
c     ##  subroutine prtvib  --  output of vibrational mode  ##
c     ##                                                     ##
c     #########################################################
c
c
c     "prtvib" writes to an external file a series of coordinate
c     sets representing motion along a vibrational normal mode
c
c
      subroutine prtvib (ivib,r)
      use atoms
      use files
      implicit none
      integer i,j,k
      integer ivib,ixyz
      integer lext,nview
      integer freeunit
      real*8 ratio
      real*8 r(*)
      real*8, allocatable :: xorig(:)
      real*8, allocatable :: yorig(:)
      real*8, allocatable :: zorig(:)
      character*7 ext
      character*240 xyzfile
c
c
c     create a name for the vibrational displacement file
c
      lext = 3
      call numeral (ivib,ext,lext)
      xyzfile = filename(1:leng)//'.'//ext(1:lext)
      ixyz = freeunit ()
      call version (xyzfile,'new')
      open (unit=ixyz,file=xyzfile,status='new')
c
c     perform dynamic allocation of some local arrays
c
      allocate (xorig(n))
      allocate (yorig(n))
      allocate (zorig(n))
c
c     store the original atomic coordinates
c
      do i = 1, n
         xorig(i) = x(i)
         yorig(i) = y(i)
         zorig(i) = z(i)
      end do
c
c     make file with plus and minus the current vibration
c
      nview = 3
      do i = -nview, nview
         ratio = dble(i) / dble(nview)
         do k = 1, n
            j = 3 * (k-1)
            x(k) = xorig(k) + ratio*r(j+1)
            y(k) = yorig(k) + ratio*r(j+2)
            z(k) = zorig(k) + ratio*r(j+3)
         end do
         call prtxyz (ixyz)
      end do
      close (unit=ixyz)
c
c     restore the original atomic coordinates
c
      do i = 1, n
         x(i) = xorig(i)
         y(i) = yorig(i)
         z(i) = zorig(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xorig)
      deallocate (yorig)
      deallocate (zorig)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine hessblk  --  Hessian elements for atom block  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "hessblk" calls subroutines to calculate the Hessian elements
c     for each atom in turn with respect to Cartesian coordinates
c
c
      subroutine hessblk (amass,k0,i1,i2,vector)
      use atoms
      use bound
      use couple
      use hescut
      use hessn
      use inform
      use iounit
      use limits
      use mpole
      use potent
      use rigid
      use usage
      use vdw
      use vdwpot
      use units
      implicit none
      integer i,j,k
      integer ii,k0
      integer i1,i2
      real*8 ami,amik
      real*8 cutoff,rdn
      real*8 amass(*)
      real*8 vector(*)
      logical first
      save first
      data first  / .true. /
c
c
c     maintain any periodic boundary conditions
c
      if (use_bounds .and. .not.use_rigid)  call bounds
c
c     update the pairwise interaction neighbor lists
c
      if (use_list)  call nblist
c
c     many implicit solvation models require Born radii
c
      if (use_born)  call born
c
c     alter partial charges and multipoles for charge flux
c
      if (use_chgflx)  call alterchg
c
c     modify bond and torsion constants for pisystem
c
      if (use_orbit)  call picalc
c
c     compute the induced dipoles at polarizable atoms
c
      if (use_polar) then
         call chkpole
         call rotpole ('MPOLE')
         call induce
      end if
c
c     calculate the "reduced" atomic coordinates
c
      if (use_vdw) then
         do i = 1, n
            ii = ired(i)
            rdn = kred(i)
            xred(i) = rdn*(x(i)-x(ii)) + x(ii)
            yred(i) = rdn*(y(i)-y(ii)) + y(ii)
            zred(i) = rdn*(z(i)-z(ii)) + z(ii)
         end do
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (first) then
         first = .false.
         if (.not. allocated(hessx))  allocate (hessx(3,n))
         if (.not. allocated(hessy))  allocate (hessy(3,n))
         if (.not. allocated(hessz))  allocate (hessz(3,n))
      end if
c
c     zero out the Hessian elements for the current atom
c
      ii = 0
      do i = i1, i2
         if (use(i)) then
            do k = i1, i2
               do j = 1, 3
                  hessx(j,k) = 0.0d0
                  hessy(j,k) = 0.0d0
                  hessz(j,k) = 0.0d0
               end do
            end do
c
c     remove any previous use of the replicates method
c
            cutoff = 0.0d0
            call replica (cutoff)
c
c     call the local geometry Hessian component routines
c
            if (use_bond)  call ebond2 (i)
            if (use_angle)  call eangle2 (i)
            if (use_strbnd)  call estrbnd2 (i)
            if (use_urey)  call eurey2 (i)
            if (use_angang)  call eangang2 (i)
            if (use_opbend)  call eopbend2 (i)
            if (use_opdist)  call eopdist2 (i)
            if (use_improp)  call eimprop2 (i)
            if (use_imptor)  call eimptor2 (i)
            if (use_tors)  call etors2 (i)
            if (use_pitors)  call epitors2 (i)
            if (use_strtor)  call estrtor2 (i)
            if (use_angtor)  call eangtor2 (i)
            if (use_tortor)  call etortor2 (i)
c
c     call the van der Waals Hessian component routines
c
            if (use_vdw) then
               if (vdwtyp .eq. 'LENNARD-JONES')  call elj2 (i)
               if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck2 (i)
               if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb2 (i)
               if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal2 (i)
               if (vdwtyp .eq. 'GAUSSIAN')  call egauss2 (i)
            end if
c
c     call the electrostatic Hessian component routines
c
            if (use_charge) call echarge2 (i)
            if (use_chgdpl)  call echgdpl2 (i)
            if (use_dipole)  call edipole2 (i)
            if (use_mpole)   call empole2 (i)
            if (use_polar)  call epolar2 (i)
            if (use_rxnfld)   call erxnfld2 (i)
c
c     call any miscellaneous Hessian component routines
c
            if (use_solv)  call esolv2 (i)
            if (use_metal)  call emetal2 (i)
            if (use_geom)  call egeom2 (i)
            if (use_extra)  call extra2 (i)
c
c     store Hessian for the current atom block as a vector
c
            ami = bohr**2 / (hartree*sqrt(amass(i)))
            do k = i1, i2
               amik = ami / sqrt(amass(k))
               do j = 1, 3
                  ii = ii + 1
                  vector(k0+ii) = hessx(j,k) * amik
               end do
            end do
            do k = i1, i2
               amik = ami / sqrt(amass(k))
               do j = 1, 3
                  ii = ii + 1
                  vector(k0+ii) = hessy(j,k) * amik
               end do
            end do
            do k = i1, i2
               amik = ami / sqrt(amass(k))
               do j = 1, 3
                  ii = ii + 1
                  vector(k0+ii) = hessz(j,k) * amik
               end do
            end do
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  program vibrate  --  vibrational analysis and normal modes  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "vibrate" performs a vibrational normal mode analysis; the
c     Hessian matrix of second derivatives is determined and then
c     diagonalized both directly and after mass weighting; output
c     consists of the eigenvalues of the force constant matrix as
c     well as the vibrational frequencies and displacements
c
c
      program vibrate
      use atomid
      use atoms
      use files
      use hescut
      use iounit
      use math
      use units
      use usage
      implicit none
      integer i,j,k,m
      integer ixyz,ihess
      integer lext,freeunit
      integer nfreq,ndummy
      integer nvib,ivib
      integer nview,next
      integer nlist,ilist
      integer, allocatable :: list(:)
      integer, allocatable :: iv(:)
      integer, allocatable :: hindex(:)
      integer, allocatable :: hinit(:,:)
      integer, allocatable :: hstop(:,:)
      real*8 factor,vnorm
      real*8 sum,scale,ratio
      real*8, allocatable :: xorig(:)
      real*8, allocatable :: yorig(:)
      real*8, allocatable :: zorig(:)
      real*8, allocatable :: mass2(:)
      real*8, allocatable :: h(:)
      real*8, allocatable :: eigen(:)
      real*8, allocatable :: matrix(:)
      real*8, allocatable :: hdiag(:,:)
      real*8, allocatable :: vects(:,:)
      logical exist,query
      character*1 letter
      character*7 ext
      character*240 xyzfile
      character*240 record
      character*240 string
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     perform dynamic allocation of some local arrays
c
      nfreq = 3 * nuse
      allocate (mass2(n))
      allocate (hinit(3,n))
      allocate (hstop(3,n))
      allocate (hdiag(3,n))
      allocate (hindex(nfreq*(nfreq-1)/2))
      allocate (h(nfreq*(nfreq-1)/2))
      allocate (matrix(nfreq*(nfreq+1)/2))
c
c     initialize various things needed for vibrations
c
      ndummy = 0
      do i = 1, n
         if (use(i) .and. atomic(i).eq.0) then
            ndummy = ndummy + 1
            mass(i) = 0.001d0
         end if
         mass2(i) = sqrt(mass(i))
      end do
      nvib = nfreq - 3*ndummy
c
c     calculate the Hessian matrix of second derivatives
c
      hesscut = 0.0d0
      call hessian (h,hinit,hstop,hindex,hdiag)
c
c     store upper triangle of the Hessian in "matrix"
c
      ihess = 0
      do i = 1, n
         if (use(i)) then
            do j = 1, 3
               ihess = ihess + 1
               matrix(ihess) = hdiag(j,i)
               do k = hinit(j,i), hstop(j,i)
                  m = (hindex(k)+2) / 3
                  if (use(m)) then
                     ihess = ihess + 1
                     matrix(ihess) = h(k)
                  end if
               end do
            end do
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (eigen(nfreq))
      allocate (vects(nfreq,nfreq))
c
c     perform diagonalization to get Hessian eigenvalues
c
      call diagq (nfreq,nfreq,matrix,eigen,vects)
      write (iout,10)
   10 format (/,' Eigenvalues of the Hessian Matrix :',/)
      write (iout,20)  (i,eigen(i),i=1,nvib)
   20 format (5(i5,f10.3))
c
c     store upper triangle of the mass-weighted Hessian matrix
c
      ihess = 0
      do i = 1, n
         if (use(i)) then
            do j = 1, 3
               ihess = ihess + 1
               matrix(ihess) = hdiag(j,i) / mass(i)
               do k = hinit(j,i), hstop(j,i)
                  m = (hindex(k)+2) / 3
                  if (use(m)) then
                     ihess = ihess + 1
                     matrix(ihess) = h(k) / (mass2(i)*mass2(m))
                  end if
               end do
            end do
         end if
      end do
c
c     diagonalize to get vibrational frequencies and normal modes
c
      call diagq (nfreq,nfreq,matrix,eigen,vects)
      factor = sqrt(ekcal) / (2.0d0*pi*lightspd)
      do i = 1, nvib
         eigen(i) = factor * sign(1.0d0,eigen(i)) * sqrt(abs(eigen(i)))
      end do
      write (iout,30)
   30 format (/,' Vibrational Frequencies (cm-1) :',/)
      write (iout,40)  (i,eigen(i),i=1,nvib)
   40 format (5(i5,f10.3))
c
c     perform deallocation of some local arrays
c
      deallocate (hinit)
      deallocate (hstop)
      deallocate (hdiag)
      deallocate (h)
      deallocate (matrix)
c
c     form Cartesian coordinate displacements from normal modes
c
      do i = 1, nvib
         vnorm = 0.0d0
         do j = 1, nfreq
            k = iuse((j+2)/3)
            vects(j,i) = vects(j,i) / mass2(k)
            vnorm = vnorm + vects(j,i)**2
         end do
         vnorm = sqrt(vnorm)
         do j = 1, nfreq
            vects(j,i) = vects(j,i) / vnorm
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(nfreq))
      allocate (iv(nfreq))
      allocate (xorig(n))
      allocate (yorig(n))
      allocate (zorig(n))
c
c     try to get output vibrational modes from command line
c
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         query = .false.
         letter = string(1:1)
         call upcase (letter)
         if (letter .eq. 'A') then
            nlist = nvib
            do i = 1, nlist
               list(i) = i
            end do
         else
            nlist = 0
            do i = 1, nvib
               read (string,*,err=50,end=50)  k
               if (k.ge.1 .and. k.le.nvib) then
                  nlist = nlist + 1
                  list(nlist) = k
               else
                  k = abs(k)
                  call nextarg (string,exist)
                  read (string,*,err=50,end=50)  m
                  m = min(abs(m),nvib)
                  do j = k, m
                     nlist = nlist + 1
                     list(nlist) = j
                  end do
               end if
               call nextarg (string,exist)
            end do
   50       continue
         end if
      end if
c
c     ask the user for the vibrational modes to be output
c
      if (query) then
         write (iout,60)
   60    format (/,' Enter Vibrations to Output [List, A=All',
     &              ' or <Enter>=Exit] :  ',$)
         read (input,70)  record
   70    format (a240)
         letter = ' '
         next = 1
         call gettext (record,letter,next)
         call upcase (letter)
         if (letter .eq. ' ') then
            nlist = 0
         else if (letter .eq. 'A') then
            nlist = nvib
            do i = 1, nlist
               list(i) = i
            end do
         else
            do i = 1, nvib
               iv(i) = 0
            end do
            read (record,*,err=80,end=80)  (iv(i),i=1,nvib)
   80       continue
            nlist = 0
            i = 1
            do while (iv(i) .ne. 0)
               k = iv(i)
               if (k.ge.1 .and. k.le.nvib) then
                  nlist = nlist + 1
                  list(nlist) = k
               else
                  k = abs(k)
                  m = min(abs(iv(i+1)),nvib)
                  do j = k, m
                     nlist = nlist + 1
                     list(nlist) = j
                  end do
                  i = i + 1
               end if
               i = i + 1
            end do
         end if
      end if
c
c     print the vibrational frequencies and normal modes
c
      do ilist = 1, nlist
         ivib = list(ilist)
         write (iout,90)  ivib,eigen(ivib)
   90    format (/,' Vibrational Normal Mode',i6,' with Frequency',
     &              f11.3,' cm-1',
     &           //,5x,'Atom',5x,'Delta X',5x,'Delta Y',5x,'Delta Z',/)
         do i = 1, nuse
            j = 3 * (i-1)
            write (iout,100)  iuse(i),vects(j+1,ivib),vects(j+2,ivib),
     &                        vects(j+3,ivib)
  100       format (4x,i5,3f12.6)
         end do
c
c     create a name for the vibrational displacement file
c
         lext = 3
         call numeral (ivib,ext,lext)
         xyzfile = filename(1:leng)//'.'//ext(1:lext)
         ixyz = freeunit ()
         call version (xyzfile,'new')
         open (unit=ixyz,file=xyzfile,status='new')
c
c     store the original atomic coordinates
c
         do i = 1, n
            xorig(i) = x(i)
            yorig(i) = y(i)
            zorig(i) = z(i)
         end do
c
c     scale based on the maximum displacement along the mode
c
         scale = 0.0d0
         do i = 1, nuse
            j = 3 * (i-1)
            sum = 0.0d0
            do k = 1, 3
               sum = sum + vects(j+k,ivib)**2
            end do
            scale = max(sum,scale)
         end do
         scale = 0.1d0 * n**(1.0d0/3.0d0) / sqrt(scale)
c
c     make file with plus and minus the current vibration
c
         nview = 3
         do i = -nview, nview
            ratio = scale * dble(i) / dble(nview)
            do k = 1, nuse
               j = 3 * (k-1)
               m = iuse(k)
               x(m) = xorig(m) + ratio*vects(j+1,ivib)
               y(m) = yorig(m) + ratio*vects(j+2,ivib)
               z(m) = zorig(m) + ratio*vects(j+3,ivib)
            end do
            call prtxyz (ixyz)
         end do
         close (unit=ixyz)
c
c     restore the original atomic coordinates
c
         do i = 1, n
            x(i) = xorig(i)
            y(i) = yorig(i)
            z(i) = zorig(i)
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (iv)
      deallocate (mass2)
      deallocate (xorig)
      deallocate (yorig)
      deallocate (zorig)
      deallocate (eigen)
      deallocate (vects)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  program vibrot  --  vibrational analysis over torsions  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "vibrot" computes the eigenvalues and eigenvectors of the
c     torsional Hessian matrix
c
c     literature reference:
c
c     M. Levitt, C. Sander and P. S. Stern, "Protein Normal-mode
c     Dynamics: Trypsin Inhibitor, Crambin, Ribonuclease and Lysozyme",
c     Journal of Molecular Biology, 181, 423-447 (1985)
c
c
      program vibrot
      use iounit
      use omega
      implicit none
      integer i,j,ihess
      real*8, allocatable :: eigen(:)
      real*8, allocatable :: matrix(:)
      real*8, allocatable :: vects(:,:)
      real*8, allocatable :: hrot(:,:)
c
c
c     set up the mechanics calculation and rotatable bonds
c
      call initial
      call getint
      call mechanic
      call initrot
c
c     perform dynamic allocation of some local arrays
c
      allocate (eigen(nomega))
      allocate (matrix(nomega*(nomega+1)/2))
      allocate (vects(nomega,nomega))
      allocate (hrot(nomega,nomega))
c
c     calculate the full torsional Hessian matrix
c
      call hessrot ('FULL',hrot)
c
c     write out the torsional Hessian diagonal
c
      write (iout,10)
   10 format (/,' Diagonal of the Torsional Hessian :',/)
      write (iout,20)  (i,hrot(i,i),i=1,nomega)
   20 format (4(i8,f11.3))
c
c     write out the torsional Hessian elements
c
      if (nomega .le. 30) then
         write (iout,30)
   30    format (/,' Torsional Hessian Matrix Elements :')
         do i = 1, nomega
            write (iout,40)
   40       format ()
            write (iout,50)  (hrot(j,i),j=1,nomega)
   50       format (6f13.4)
         end do
      end if
c
c     place Hessian elements into triangular form
c
      ihess = 0
      do i = 1, nomega
         do j = i, nomega
            ihess = ihess + 1
            matrix(ihess) = hrot(i,j)
         end do
      end do
c
c     perform diagonalization to get Hessian eigenvalues
c
      call diagq (nomega,nomega,matrix,eigen,vects)
      write (iout,60)
   60 format (/,' Eigenvalues of the Hessian Matrix :',/)
      write (iout,70)  (i,eigen(i),i=1,nomega)
   70 format (4(i8,f11.3))
c
c     perform deallocation of some local arrays
c
      deallocate (eigen)
      deallocate (matrix)
      deallocate (vects)
      deallocate (hrot)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2010  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  module vibs  --  iterative vibrational analysis components  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     rho        trial vectors for iterative vibrational analysis
c     rhok       alternate vectors for iterative vibrational analysis
c     rwork      temporary work array for eigenvector transformation
c
c
      module vibs
      implicit none
      real*8, allocatable :: rho(:,:)
      real*8, allocatable :: rhok(:,:)
      real*8, allocatable :: rwork(:,:)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module virial  --  components of internal virial tensor  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     vir         total internal virial Cartesian tensor components
c     use_virial  logical flag governing use of virial computation
c
c
      module virial
      implicit none
      real*8 vir(3,3)
      logical use_virial
      save
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 1990 by Patrice Koehl & Jay William Ponder  ##
c     ##                     All Rights Reserved                    ##
c     ################################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine volume  --  alpha shapes excluded volume  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "volume" computes the weighted solvent excluded volume via
c     the inclusion-exclusion method of Herbert Edelsbrunner based
c     on alpha shapes; also finds the accessible surface area
c
c     note for small or symmetric structures where alpha shapes
c     may fail, the code switches to the Connolly method
c
c     developed to facilitate calling UnionBall from Tinker by
c     Jay W. Ponder, Washington University, October 2023
c
c     literature references:
c
c     P. Mach and P. Koehl, "Geometric Measures of Large Biomolecules:
c     Surface, Volume, and Pockets", Journal of Computational Chemistry,
c     32, 3023-3038 (2011)
c
c     P. Koehl, A. Akopyan and H. Edelsbrunner, "Computing the Volume,
c     Surface Area, Mean, and Gaussian Curvatures of Molecules and Their
c     Derivatives", Journal of Chemical Information and Modeling, 63,
c     973-985 (2023)
c
c     variables and parameters:
c
c     nsphere    number of spheres/balls in the system
c     coords     coordinates of the center of each sphere
c     radii      radius value for each sphere
c     weight     weight value for each sphere
c     probe      radius value of the probe sphere
c     surf       weighted surface area of union of spheres
c     vol        weighted excluded volume of union of spheres
c     usurf      unweighted surface area of union of spheres
c     uvol       unweighted excluded volume of union of spheres
c     asurf      weighted area contribution of each sphere
c     avol       weighted volume contribution of each sphere
c
c
      subroutine volume (rad,weight,probe,surf,vol,asurf,avol)
      use atoms
      implicit none
      integer i,nsphere
      integer nsize,nfudge
      integer nredund
      integer, allocatable :: redlist(:)
      real*8 surf,usurf,eps
      real*8 vol,uvol,voln
      real*8 reentrant
      real*8 probe,alpha
      real*8 rad(*)
      real*8 weight(*)
      real*8 asurf(*)
      real*8 avol(*)
      real*8, allocatable :: radii(:)
      real*8, allocatable :: asurfx(:)
      real*8, allocatable :: avolx(:)
      real*8, allocatable :: coords(:,:)
      logical dowiggle
      character*6 symmtyp
c
c
c     check coordinates for linearity, planarity and symmetry
c
      symmtyp = 'NONE'
      call chksymm (symmtyp)
      dowiggle = .false.
      if (n.gt.2 .and. symmtyp.eq.'LINEAR')  dowiggle = .true.
      if (n.gt.3 .and. symmtyp.eq.'PLANAR')  dowiggle = .true.
      if (symmtyp .eq. 'CENTER')  dowiggle = .true.
c
c     use Connolly method for small symmetric structures
c
      if (dowiggle) then
         reentrant = 0.0d0
         call connolly (n,x,y,z,rad,probe,reentrant,surf,vol)
         vol = vol * weight(1)
         voln = vol / dble(n)
         do i = 1, n
            avol(i) = voln
         end do
         return
      end if
c
c     perform dynamic allocation of some local arrays
c
      nfudge = 10
      nsize = n + nfudge
      allocate (radii(nsize))
      allocate (asurfx(nsize))
      allocate (avolx(nsize))
      allocate (coords(3,nsize))
      allocate (redlist(nsize))
c
c     set the coordinates and sphere radii plus probe`
c
      nsphere = n
      do i = 1, n
         coords(1,i) = x(i)
         coords(2,i) = y(i)
         coords(3,i) = z(i)
         radii(i) = 0.0d0
         if (rad(i) .ne. 0.0d0)  radii(i) = rad(i) + probe
      end do
c
c     random coordinate perturbation to avoid numerical issues
c
      if (dowiggle) then
         eps = 0.001d0
         call wiggle (n,coords,eps)
      end if
c
c     transfer coordinates, complete to minimum of four spheres
c     if needed, set Delaunay and alpha complex arrays
c
      call setunion (nsphere,coords,radii)
c
c     compute the weighted Delaunay triangulation
c
      call regular3 (nredund,redlist)
c
c     compute the alpha complex for fixed value of alpha
c
      alpha = 0.0d0
      call alfcx (alpha,nredund,redlist)
c
c     if fewer than four balls, set artificial spheres as redundant
c
      call readjust_sphere (nsphere,nredund,redlist)
c
c     get the accessible surface area and excluded volume
c
      call ball_vol (weight,surf,vol,usurf,uvol,asurfx,avolx)
c
c     copy area and volume of each sphere into Tinker array
c
      do i = 1, n
         asurf(i) = asurfx(i)
         avol(i) = avolx(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (radii)
      deallocate (asurfx)
      deallocate (avolx)
      deallocate (coords)
      deallocate (redlist)
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine volume1  --  alpha shapes volume & derivs  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "volume1" computes the weighted solvent excluded volume
c     and the first derivatives of the volume with respect to
c     Cartesian coordinates via the inclusion-exclusion method
c     of Herbert Edelsbrunner based on alpha shapes; also finds
c     the accessible surface area and first derivatives
c
c     note for small or symmetric structures where alpha shapes
c     may fail, switch to Richmond, Connolly and Kundrot methods
c
c     developed to facilitate calling UnionBall from Tinker by
c     Jay W. Ponder, Washington University, October 2023
c
c     literature references:
c
c     P. Mach and P. Koehl, "Geometric Measures of Large Biomolecules:
c     Surface, Volume, and Pockets", Journal of Computational Chemistry,
c     32, 3023-3038 (2011)
c
c     P. Koehl, A. Akopyan and H. Edelsbrunner, "Computing the Volume,
c     Surface Area, Mean, and Gaussian Curvatures of Molecules and Their
c     Derivatives", Journal of Chemical Information and Modeling, 63,
c     973-985 (2023)
c
c     variables and parameters:
c
c     nsphere    number of spheres/balls in the system
c     coords     coordinates of the center of each sphere
c     radii      radius value for each sphere
c     weight     weight value for each sphere
c     probe      radius value of the probe sphere
c     surf       weighted surface area of union of spheres
c     vol        weighted excluded volume of union of spheres
c     usurf      unweighted surface area of union of spheres
c     uvol       unweighted excluded volume of union of spheres
c     asurf      weighted area contribution of each sphere
c     avol       weighted volume contribution of each sphere
c     dsurf      derivatives of the weighted surface area over
c                  sphere coordinates
c     dvol       derivatives of the weighted volume over
c                  sphere coordinates
c
c
      subroutine volume1 (rad,weight,probe,surf,vol,asurf,avol,
     &                       dsurf,dvol)
      use atoms
      implicit none
      integer i,nsphere
      integer nsize,nfudge
      integer nredund
      integer, allocatable :: redlist(:)
      real*8 surf,usurf,eps
      real*8 vol,uvol,voln
      real*8 reentrant
      real*8 probe,alpha
      real*8 rad(*)
      real*8 weight(*)
      real*8 asurf(*)
      real*8 avol(*)
      real*8 dsurf(3,*)
      real*8 dvol(3,*)
      real*8, allocatable :: radii(:)
      real*8, allocatable :: asurfx(:)
      real*8, allocatable :: avolx(:)
      real*8, allocatable :: coords(:,:)
      real*8, allocatable :: dsurfx(:,:)
      real*8, allocatable :: dvolx(:,:)
      logical dowiggle
      character*6 symmtyp
c
c
c     check coordinates for linearity, planarity and symmetry
c
      symmtyp = 'NONE'
      call chksymm (symmtyp)
      dowiggle = .false.
      if (n.gt.2 .and. symmtyp.eq.'LINEAR')  dowiggle = .true.
      if (n.gt.3 .and. symmtyp.eq.'PLANAR')  dowiggle = .true.
      if (symmtyp .eq. 'CENTER')  dowiggle = .true.
c
c     use arc-based methods for small symmetric structures
c
      if (dowiggle) then
         reentrant = 0.0d0
         call connolly (n,x,y,z,rad,probe,reentrant,surf,vol)
         call kundrot1 (n,x,y,z,rad,probe,dvol)
         call richmond1 (n,x,y,z,rad,weight,probe,surf,asurf,dsurf)
         vol = vol * weight(1)
         voln = vol / dble(n)
         do i = 1, n
            dvol(1,i) = dvol(1,i) * weight(i)
            dvol(2,i) = dvol(2,i) * weight(i)
            dvol(3,i) = dvol(3,i) * weight(i)
            avol(i) = voln
         end do
         return
      end if
c
c     perform dynamic allocation of some local arrays
c
      nfudge = 10
      nsize = n + nfudge
      allocate (radii(nsize))
      allocate (asurfx(nsize))
      allocate (avolx(nsize))
      allocate (coords(3,nsize))
      allocate (dsurfx(3,nsize))
      allocate (dvolx(3,nsize))
      allocate (redlist(nsize))
c
c     set the coordinates and sphere radii plus probe`
c
      nsphere = n
      do i = 1, n
         coords(1,i) = x(i)
         coords(2,i) = y(i)
         coords(3,i) = z(i)
         radii(i) = 0.0d0
         if (rad(i) .ne. 0.0d0)  radii(i) = rad(i) + probe
      end do
c
c     random coordinate perturbation to avoid numerical issues
c
      if (dowiggle) then
         eps = 0.001d0
         call wiggle (n,coords,eps)
      end if
c
c     transfer coordinates, complete to minimum of four spheres
c     if needed, set Delaunay and alpha complex arrays
c
      call setunion (nsphere,coords,radii)
c
c     compute the weighted Delaunay triangulation
c
      call regular3 (nredund,redlist)
c
c     compute the alpha complex for fixed value of alpha
c
      alpha = 0.0d0
      call alfcx (alpha,nredund,redlist)
c
c     if fewer than four balls, set artificial spheres as redundant
c
      call readjust_sphere (nsphere,nredund,redlist)
c
c     get the accessible surface area and excluded volume
c
      call ball_dvol (weight,surf,vol,usurf,uvol,asurfx,avolx,
     &                   dsurfx,dvolx)
c
c     copy area and volume of each sphere into Tinker array
c
      do i = 1, n
         asurf(i) = asurfx(i)
         avol(i) = avolx(i)
         dsurf(1,i) = dsurfx(1,i)
         dsurf(2,i) = dsurfx(2,i)
         dsurf(3,i) = dsurfx(3,i)
         dvol(1,i) = dvolx(1,i)
         dvol(2,i) = dvolx(2,i)
         dvol(3,i) = dvolx(3,i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (radii)
      deallocate (asurfx)
      deallocate (avolx)
      deallocate (coords)
      deallocate (dsurfx)
      deallocate (dvolx)
      deallocate (redlist)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module warp  --  potential surface smoothing parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     deform       value of the smoothing deformation parameter
c     difft        diffusion coefficient for torsional potential
c     diffv        diffusion coefficient for van der Waals potential
c     diffc        diffusion coefficient for charge-charge potential
c     m2           second moment of the GDA gaussian for each atom
c     use_smooth   flag to use a potential energy smoothing method
c     use_dem      flag to use diffusion equation method potential
c     use_gda      flag to use gaussian density annealing potential
c     use_tophat   flag to use analytical tophat smoothed potential
c     use_stophat  flag to use shifted tophat smoothed potential
c
c
      module warp
      implicit none
      real*8 deform
      real*8 difft
      real*8 diffv
      real*8 diffc
      real*8, allocatable :: m2(:)
      logical use_smooth
      logical use_dem
      logical use_gda
      logical use_tophat
      logical use_stophat
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program xtalfit  --  fit parameters to structure & energy  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "xtalfit" determines optimized van der Waals and electrostatic
c     parameters by fitting to crystal structures, lattice energies,
c     and dimer structures and interaction energies
c
c
      program xtalfit
      use bound
      use boxes
      use files
      use iounit
      use molcul
      use potent
      use sizes
      use vdwpot
      use xtals
      implicit none
      integer i,ixtal
      integer atom1,atom2
      integer nresid,prmtyp
      real*8 grdmin
      real*8, allocatable :: xx(:)
      real*8, allocatable :: resid(:)
      real*8, allocatable :: g(:)
      real*8, allocatable :: xlo(:)
      real*8, allocatable :: xhi(:)
      real*8, allocatable :: fjac(:,:)
      logical exist,query
      character*5 vindex
      character*16 label(7)
      character*240 record
      character*240 string
      external xtalerr,xtalwrt
c
c
c     initialize some variables to be used during fitting
c
      call initial
      nvary = 0
      nresid = 0
c
c     print informational header about available parameters
c
      write (iout,10)
   10 format (/,' The Following Parameters can be Fit for',
     &           ' each Atom Type :',
     &        //,4x,'(1) Van der Waals Atomic Radius',
     &        /,4x,'(2) Van der Waals Well Depth',
     &        /,4x,'(3) Hydrogen Atom Reduction Factor',
     &        /,4x,'(4) Atomic Partial Charge',
     &        /,4x,'(5) Bond Dipole Moment Magnitude',
     &        /,4x,'(6) Bond Dipole Moment Position',
     &        /,4x,'(7) Atomic Polarizability')
c
c     get types of potential parameters to be optimized
c
      query = .true.
      do while (query)
         prmtyp = -1
         atom1 = 0
         atom2 = 0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=20,end=20)  prmtyp
         call nextarg (string,exist)
         if (exist)  read (string,*,err=20,end=20)  atom1
         call nextarg (string,exist)
         if (exist)  read (string,*,err=20,end=20)  atom2
   20    continue
         if (prmtyp .ne. 0) then
            prmtyp = 0
            write (iout,30)
   30       format (/,' Enter Parameter Type then Atom Class',
     &                 ' or Type(s) :  ',$)
            read (input,40)  record
   40       format (a240)
            read (record,*,err=50,end=50)  prmtyp,atom1,atom2
   50       continue
         end if
         if (prmtyp .eq. 0) then
            query = .false.
         else
            query = .true.
            nvary = nvary + 1
            ivary(nvary) = prmtyp
            vary(1,nvary) = atom1
            if (prmtyp.eq.5 .or. prmtyp.eq.6) then
               vary(1,nvary) = min(atom1,atom2)
               vary(2,nvary) = max(atom1,atom2)
            end if
         end if
      end do
c
c     get termination criterion as RMS gradient over parameters
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=60,end=60)  grdmin
   60 continue
      if (grdmin .le. 0.0d0) then
         write (iout,70)
   70    format (/,' Enter RMS Gradient Termination Criterion',
     &              ' [0.1] :  ',$)
         read (input,80)  grdmin
   80    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.1d0
c
c     get the number of structures to use in optimization
c
      nxtal = 0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=90,end=90)  nxtal
   90 continue
      if (nxtal .le. 0) then
         write (iout,100)
  100    format (/,' Enter Number of Structures to be Used [1] :  ',$)
         read (input,110)  nxtal
  110    format (i10)
      end if
c
c     check for too few or too many molecular structures
c
      if (nxtal .eq. 0)  nxtal = 1
      if (nxtal .gt. maxref) then
         write (iout,120)
  120    format (/,' XTALFIT  --  Too many Structures,',
     &              ' Increase the Value of MAXREF')
         call fatal
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nvary))
c
c     get coordinates and parameters for current structure
c
      do ixtal = 1, nxtal
         call initial
         call getxyz
         call mechanic
c
c     get ideal value for lattice or intermolecular energy
c
         e0_lattice = 0.0d0
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=130,end=130)  e0_lattice
            query = .false.
         end if
  130    continue
         if (query) then
            write (iout,140)
  140       format (/,' Target for E-Lattice or E-Inter Value',
     &                 ' [<Enter>=None] :  ',$)
            read (input,150)  e0_lattice
  150       format (f20.0)
         end if
         if (e0_lattice .gt. 0.0d0)  e0_lattice = -e0_lattice
c
c     set the types of residuals for use in optimization
c
         do i = 1, 6
            iresid(nresid+i) = ixtal
         end do
         if (use_bounds) then
            rsdxtl(nresid+1) = 'Force a-Axis'
            rsdxtl(nresid+2) = 'Force b-Axis'
            rsdxtl(nresid+3) = 'Force c-Axis'
            rsdxtl(nresid+4) = 'Force Alpha'
            rsdxtl(nresid+5) = 'Force Beta'
            rsdxtl(nresid+6) = 'Force Gamma'
         else
            rsdxtl(nresid+1) = 'Force Mol1 X'
            rsdxtl(nresid+2) = 'Force Mol1 Y'
            rsdxtl(nresid+3) = 'Force Mol1 Z'
            rsdxtl(nresid+4) = 'Force Mol2 X'
            rsdxtl(nresid+5) = 'Force Mol2 Y'
            rsdxtl(nresid+6) = 'Force Mol2 Z'
         end if
         nresid = nresid + 6
c
c     print molecules per structure, energy and dipole values
c
         write (iout,160)  ixtal,filename(1:35),nmol
  160    format (/,' File Name of Target Structure',i4,' :',8x,a35,
     &           /,' Number of Molecules per Structure :',i13)
         if (e0_lattice .ne. 0.0d0) then
            nresid = nresid + 1
            iresid(nresid) = ixtal
            if (use_bounds) then
               rsdxtl(nresid) = 'Lattice Energy'
            else
               rsdxtl(nresid) = 'E Intermolecular'
            end if
            write (iout,170)  e0_lattice
  170       format (' Target E-Lattice or E-Inter Value :  ',f13.2)
         end if
c
c     set the initial values of the parameters
c
         call xtalprm ('STORE',ixtal,xx)
      end do
c
c     turn off all local interactions and extra terms
c
      call potoff
      use_vdw = .true.
      use_charge = .true.
      use_chgdpl = .true.
      use_dipole = .true.
      use_mpole = .true.
      use_polar = .true.
c
c     types of variables for use in optimization
c
      label(1) = 'Atomic Radius'
      label(2) = 'Well Depth'
      label(3) = 'H Reduction'
      label(4) = 'Partial Charge'
      label(5) = 'Dipole Magnitude'
      label(6) = 'Dipole Position'
      label(7) = 'Polarizability'
      do i = 1, nvary
         varxtl(i) = label(ivary(i))
      end do
      vindex = 'Class'
      if (vdwindex .eq. 'TYPE ')  vindex = 'Type '
c
c     print the initial parameter values
c
      write (iout,180)
  180 format (/,' Initial Values of the Parameters :',/)
      do i = 1, nvary
         if (ivary(i) .le. 3) then
            write (iout,190)  i,varxtl(i),vindex,vary(1,i),xx(i)
  190       format (3x,'(',i2,')',2x,a16,4x,'Atom ',a5,i5,4x,f12.4)
         else if (ivary(i) .ne. 6) then
            write (iout,200)  i,varxtl(i),vary(1,i),xx(i)
  200       format (3x,'(',i2,')',2x,a16,4x,'Atom Type ',i5,4x,f12.4)
         else
            write (iout,210)  i,varxtl(i),vary(1,i),vary(2,i),xx(i)
  210       format (3x,'(',i2,')',2x,a16,4x,'Bond Type ',2i5,f12.4)
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (resid(nresid))
      allocate (g(nvary))
      allocate (xlo(nvary))
      allocate (xhi(nvary))
      allocate (fjac(nresid,nvary))
c
c     set upper and lower bounds based on the parameter type
c
      do i = 1, nvary
         if (ivary(i).eq.4 .or. ivary(i).eq.5) then
            xlo(i) = xx(i) - 0.5d0
            xhi(i) = xx(i) + 0.5d0
         else
            xlo(i) = 0.5d0 * xx(i)
            xhi(i) = 1.5d0 * xx(i)
         end if
      end do
c
c     use nonlinear least squares to refine the parameters
c
      call square (nvary,nresid,xlo,xhi,xx,resid,g,fjac,
     &                  grdmin,xtalerr,xtalwrt)
c
c     perform deallocation of some local arrays
c
      deallocate (xlo)
      deallocate (xhi)
      deallocate (fjac)
c
c     print final values of parameters and scaled derivatives
c
      write (iout,220)
  220 format (/,' Final Values of Parameters and Scaled',
     &           ' Derivatives :',/)
      do i = 1, nvary
         if (ivary(i) .le. 3) then
            write (iout,230)  i,varxtl(i),vindex,vary(1,i),xx(i),g(i)
  230       format (3x,'(',i2,')',2x,a16,4x,'Atom ',a5,i5,2x,2f14.4)
         else if (ivary(i) .ne. 6) then
            write (iout,240)  i,varxtl(i),vary(1,i),xx(i),g(i)
  240       format (3x,'(',i2,')',2x,a16,4x,'Atom Type ',i5,2x,2f14.4)
         else
            write (iout,250)  i,varxtl(i),vary(1,i),vary(2,i),xx(i),g(i)
  250       format (3x,'(',i2,')',2x,a16,4x,'Bond Type ',2i5,
     &                 f11.4,f14.4)
         end if
      end do
c
c     print final values of the individual residual functions
c
      write (iout,260)
  260 format (/,' Final Residual Error Function Values :',/)
      do i = 1, nresid
         if (i .lt. 100) then
            write (iout,270)  i,rsdxtl(i),iresid(i),resid(i)
  270       format (3x,'(',i2,')',2x,a16,6x,'Structure',i4,4x,f12.4)
         else
            write (iout,280)  i,rsdxtl(i),iresid(i),resid(i)
  280       format (2x,'(',i3,')',2x,a16,6x,'Structure',i4,4x,f12.4)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      deallocate (resid)
      deallocate (g)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine xtalprm  --  energy/optimization conversion  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "xtalprm" stores or retrieves a molecular structure; used to
c     make a previously stored structure the active structure, or to
c     store a structure for later use
c
c     the current version only provides for intermolecular potential
c     energy terms
c
c
      subroutine xtalprm (mode,ixtal,xx)
      use atoms
      use atomid
      use bound
      use boxes
      use charge
      use dipole
      use files
      use fracs
      use inform
      use kvdws
      use molcul
      use mpole
      use polar
      use vdw
      use vdwpot
      use xtals
      implicit none
      integer i,j,k
      integer init,stop
      integer ixtal,prmtyp
      integer it,kt,itm,ktm
      integer nlist
      integer, allocatable :: list(:)
      real*8 rd,ep
      real*8 sixth,weigh
      real*8 xmid,ymid,zmid
      real*8 e0_lattices(maxref)
      real*8 xx(*)
      logical first
      character*5 mode
      save e0_lattices
      save first
      data first  / .true. /
c
c
c     save or restore the key values for the current crystal
c
      if (mode .eq. 'STORE') then
         call makeref (ixtal)
      else if (mode .eq. 'RESET') then
         call getref (ixtal)
         call basefile (filename)
         silent = .true.
         call mechanic
         silent = .false.
         if (use_bounds)  call bounds
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (mode .eq. 'RESET') then
         if (first) then
            first = .false.
            allocate (xfrac(nmol))
            allocate (yfrac(nmol))
            allocate (zfrac(nmol))
         end if
      end if
c
c     get fractional coordinates of center of mass
c
      if (mode .eq. 'RESET') then
         do i = 1, nmol
            init = imol(1,i)
            stop = imol(2,i)
            xmid = 0.0d0
            ymid = 0.0d0
            zmid = 0.0d0
            do j = init, stop
               k = kmol(j)
               weigh = mass(k)
               xmid = xmid + x(k)*weigh
               ymid = ymid + y(k)*weigh
               zmid = zmid + z(k)*weigh
            end do
            weigh = molmass(i)
            xmid = xmid / weigh
            ymid = ymid / weigh
            zmid = zmid / weigh
            zfrac(i) = zmid / gamma_term
            yfrac(i) = (ymid - zmid*beta_term) / gamma_sin
            xfrac(i) = xmid - ymid*gamma_cos - zmid*beta_cos
            zfrac(i) = zfrac(i) / zbox 
            yfrac(i) = yfrac(i) / ybox 
            xfrac(i) = xfrac(i) / xbox 
         end do
      end if
c
c     values of ideal intermolecular or lattice energy
c
      if (mode .eq. 'STORE') then
         e0_lattices(ixtal) = e0_lattice
      else if (mode .eq. 'RESET') then
         e0_lattice = e0_lattices(ixtal)
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (list(n))
c
c     set type or class index into condensed pair matrices
c
      nlist = n
      do i = 1, n
         list(i) = 0
         if (vdwindex .eq. 'TYPE') then
            list(i) = type(i)
         else
            list(i) = class(i)
         end if
      end do
      call sort8 (nlist,list)
c
c     store or reset values of the optimization variables
c
      do j = 1, nvary
         prmtyp = ivary(j)
         it = vary(1,j)
         if (prmtyp .eq. 1) then
            if (mode .eq. 'STORE') then
               xx(j) = rad(it)
            else if (mode .eq. 'RESET') then
               itm = mvdw(it)
               rad(it) = xx(j)
               do k = 1, nlist
                  kt = list(k)
                  ktm = mvdw(kt)
                  if (rad(it).eq.0.0d0 .and. rad(kt).eq.0.0d0) then
                     rd = 0.0d0
                  else if (radrule(1:10) .eq. 'ARITHMETIC') then
                     rd = rad(it) + rad(kt)
                  else if (radrule(1:9) .eq. 'GEOMETRIC') then
                     rd = 2.0d0 * sqrt(rad(it) * rad(kt))
                  else if (radrule(1:10) .eq. 'CUBIC-MEAN') then
                     rd = 2.0d0 * (rad(it)**3+rad(kt)**3)
     &                       / (rad(it)**2+rad(kt)**2)
                  else
                     rd = rad(it) + rad(kt)
                  end if
                  radmin(itm,ktm) = rd
                  radmin(ktm,itm) = rd
               end do
            end if
         else if (prmtyp .eq. 2) then
            if (mode .eq. 'STORE') then
               xx(j) = eps(it)
            else if (mode .eq. 'RESET') then
               itm = mvdw(it)
               eps(it) = abs(xx(j))
               do k = 1, nlist
                  kt = list(k)
                  ktm = mvdw(kt)
                  if (eps(it).eq.0.0d0 .and. eps(kt).eq.0.0d0) then
                     ep = 0.0d0
                  else if (epsrule(1:10) .eq. 'ARITHMETIC') then
                     ep = 0.5d0 * (eps(it) + eps(kt))
                  else if (epsrule(1:9) .eq. 'GEOMETRIC') then
                     ep = sqrt(eps(it) * eps(kt))
                  else if (epsrule(1:8) .eq. 'HARMONIC') then
                     ep = 2.0d0 * (eps(it)*eps(kt)) / (eps(it)+eps(kt))
                  else if (epsrule(1:3) .eq. 'HHG') then
                     ep = 4.0d0 * (eps(it)*eps(kt))
     &                      / (sqrt(eps(it))+sqrt(eps(kt)))**2
                  else
                     ep = sqrt(eps(it) * eps(kt))
                  end if
                  epsilon(itm,ktm) = ep
                  epsilon(ktm,itm) = ep
               end do
            end if
         else if (prmtyp .eq. 3) then
            if (mode .eq. 'STORE') then
               do i = 1, n
                  if (class(i) .eq. it) then
                     xx(j) = kred(i)
                     goto 10
                  end if
               end do
            else if (mode .eq. 'RESET') then
               do i = 1, n
                  if (class(i) .eq. it)  kred(i) = xx(j)
               end do
            end if
         else if (prmtyp .eq. 4) then
            if (mode .eq. 'STORE') then
               do i = 1, nion
                  if (type(iion(i)) .eq. it) then
                     xx(j) = pchg(i)
                     goto 10
                  end if
               end do
            else if (mode .eq. 'RESET') then
               do i = 1, nion
                  if (type(iion(i)) .eq. it)  pchg(i) = xx(j)
               end do
            end if
         else if (prmtyp .eq. 5) then
            kt = vary(2,j)
            if (mode .eq. 'STORE') then
               do i = 1, ndipole
                  if (type(idpl(1,i)).eq.it .and.
     &                type(idpl(2,i)).eq.kt) then
                     xx(j) = bdpl(i)
                     goto 10
                  end if
               end do
            else if (mode .eq. 'RESET') then
               do i = 1, ndipole
                  if (type(idpl(1,i)).eq.it .and.
     &                type(idpl(2,i)).eq.kt)  bdpl(i) = xx(j)
               end do
            end if
         else if (prmtyp .eq. 6) then
            kt = vary(2,j)
            if (mode .eq. 'STORE') then
               do i = 1, ndipole
                  if (type(idpl(1,i)).eq.it .and.
     &                type(idpl(2,i)).eq.kt) then
                     xx(j) = sdpl(i)
                     goto 10
                  end if
               end do
            else if (mode .eq. 'RESET') then
               do i = 1, ndipole
                  if (type(idpl(1,i)).eq.it .and.
     &                type(idpl(2,i)).eq.kt)  sdpl(i) = xx(j)
               end do
            end if
         else if (prmtyp .eq. 7) then
            if (mode .eq. 'STORE') then
               do i = 1, npole
                  k = ipole(i)
                  if (type(k) .eq. it) then
                     xx(j) = polarity(k)
                     goto 10
                  end if
               end do
            else if (mode .eq. 'RESET') then
               sixth = 1.0d0 / 6.0d0
               do i = 1, npole
                  k = ipole(i)
                  if (type(k) .eq. it) then
                     polarity(k) = xx(j)
                     if (thole(k) .ne. 0.0d0)  pdamp(k) = xx(j)**sixth
                  end if
               end do
            end if
         end if
   10    continue
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      return
      end
c
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine xtalerr  --  error function for xtalfit  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "xtalerr" computes an error function value derived from
c     lattice energies, dimer intermolecular energies and the
c     gradient with respect to structural parameters
c
c
      subroutine xtalerr (nvaried,nresid,xx,resid)
      use atoms
      use boxes
      use bound
      use charge
      use dipole
      use energi
      use limits
      use math
      use molcul
      use mpole
      use polar
      use vdw
      use xtals
      implicit none
      integer i,k,ixtal
      integer nresid,nvaried
      real*8 energy,eps,temp
      real*8 e,e0
      real*8 e_monomer
      real*8 e_lattice
      real*8 dmol,big
      real*8 e1,e2,e3
      real*8 e4,e5,e6
      real*8 g1,g2,g3
      real*8 g4,g5,g6
      real*8 xx(*)
      real*8 resid(*)
c
c
c     zero out number of residuals and set numerical step size
c
      nresid = 0
      eps = 1.0d-4
c
c     set force field parameter values and find the base energy
c
      do ixtal = 1, nxtal
         call xtalprm ('RESET',ixtal,xx)
         e = energy ()
         e0 = ev + ec + ecd + ed + em + ep
c
c     perturb crystal lattice parameters and compute energies
c
         if (use_bounds) then
            temp = xbox
            xbox = xbox + eps
            call xtalmove
            e = energy ()
            e1 = ev + ec + ecd + ed + em + ep
            xbox = temp
            temp = ybox
            ybox = ybox + eps
            call xtalmove
            e = energy ()
            e2 = ev + ec + ecd + ed + em + ep
            ybox = temp
            temp = zbox
            zbox = zbox + eps
            call xtalmove
            e = energy ()
            e3 = ev + ec + ecd + ed + em + ep
            zbox = temp
            temp = alpha
            alpha = alpha + radian*eps
            call xtalmove
            e = energy ()
            e4 = ev + ec + ecd + ed + em + ep
            alpha = temp
            temp = beta
            beta = beta + radian*eps
            call xtalmove
            e = energy ()
            e5 = ev + ec + ecd + ed + em + ep
            beta = temp
            temp = gamma
            gamma = gamma + radian*eps
            call xtalmove
            e = energy ()
            e6 = ev + ec + ecd + ed + em + ep
            gamma = temp
            call xtalmove
c
c     translate dimer component molecules and compute energies
c
         else
            do i = imol(1,1), imol(2,1)
               k = kmol(i)
               x(k) = x(k) + eps
            end do
            e = energy ()
            e1 = ev + ec + ecd + ed + em + ep
            do i = imol(1,1), imol(2,1)
               k = kmol(i)
               x(k) = x(k) - eps
            end do
            do i = imol(1,1), imol(2,1)
               k = kmol(i)
               y(k) = y(k) + eps
            end do
            e = energy ()
            e2 = ev + ec + ecd + ed + em + ep
            do i = imol(1,1), imol(2,1)
               k = kmol(i)
               y(k) = y(k) - eps
            end do
            do i = imol(1,1), imol(2,1)
               k = kmol(i)
               z(k) = z(k) + eps
            end do
            e = energy ()
            e3 = ev + ec + ecd + ed + em + ep
            do i = imol(1,1), imol(2,1)
               k = kmol(i)
               z(k) = z(k) - eps
            end do
            do i = imol(1,1), imol(2,1)
               k = kmol(i)
               x(k) = x(k) + eps
            end do
            e = energy ()
            e4 = ev + ec + ecd + ed + em + ep
            do i = imol(1,2), imol(2,2)
               k = kmol(i)
               x(k) = x(k) - eps
            end do
            do i = imol(1,2), imol(2,2)
               k = kmol(i)
               y(k) = y(k) + eps
            end do
            e = energy ()
            e5 = ev + ec + ecd + ed + em + ep
            do i = imol(1,2), imol(2,2)
               k = kmol(i)
               y(k) = y(k) - eps
            end do
            do i = imol(1,2), imol(2,2)
               k = kmol(i)
               z(k) = z(k) + eps
            end do
            e = energy ()
            e6 = ev + ec + ecd + ed + em + ep
            do i = imol(1,2), imol(2,2)
               k = kmol(i)
               z(k) = z(k) - eps
            end do
         end if
c
c     get the gradient with respect to structure perturbations
c
         g1 = (e1 - e0) / eps
         nresid = nresid + 1
         resid(nresid) = g1
         g2 = (e2 - e0) / eps
         nresid = nresid + 1
         resid(nresid) = g2
         g3 = (e3 - e0) / eps
         nresid = nresid + 1
         resid(nresid) = g3
         g4 = (e4 - e0) / eps
         nresid = nresid + 1
         resid(nresid) = g4
         g5 = (e5 - e0) / eps
         nresid = nresid + 1
         resid(nresid) = g5
         g6 = (e6 - e0) / eps
         nresid = nresid + 1
         resid(nresid) = g6
c
c     setup to compute properties of monomer from crystal
c
         if (use_bounds) then
            n = n / nmol
            nvdw = nvdw / nmol
            nion = nion / nmol
            ndipole = ndipole / nmol
            npole = npole / nmol
            npolar = npolar / nmol
            use_bounds = .false.
            use_replica = .false.
            use_ewald = .false.
            big = 1.0d12
            vdwcut = big
            vdwtaper = big
            chgcut = big
            chgtaper = big
            dplcut = big
            dpltaper = big
            mpolecut = big
            mpoletaper = big
c
c     compute the intermolecular or crystal lattice energy
c
            e = energy ()
            e_monomer = ev + ec + ecd + ed + em + ep
            dmol = dble(nmol)
            e_lattice = (e0 - dmol*e_monomer) / dmol
         else
            e_monomer = 0.0d0
            e_lattice = e0
         end if
c
c     compute residual due to intermolecular or lattice energy;
c     weight energies more heavily, since there are fewer of them
c
         if (e0_lattice .ne. 0.0d0) then
            nresid = nresid + 1
            resid(nresid) = e_lattice - e0_lattice
            if (ixtal .le. 11) then
               resid(nresid) = 3.0d0 * resid(nresid)
            else
               resid(nresid) = 10.0d0 * resid(nresid)
            end if
         end if
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine xtalmove  --  translation of rigid molecules  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "xtalmove" converts fractional to Cartesian coordinates for
c     rigid molecules during optimization of force field parameters
c
c
      subroutine xtalmove
      use atoms
      use atomid
      use boxes
      use fracs
      use molcul
      implicit none
      integer i,j,k
      integer init,stop
      real*8 weigh
      real*8 xmid,ymid,zmid
      real*8, allocatable :: xoff(:)
      real*8, allocatable :: yoff(:)
      real*8, allocatable :: zoff(:)
c
c
c     get values for fractional coordinate interconversion
c
      call lattice
c
c     perform dynamic allocation of some local arrays
c
      allocate (xoff(n))
      allocate (yoff(n))
      allocate (zoff(n))
c
c     locate the center of mass of each molecule
c
      do i = 1, nmol
         init = imol(1,i)
         stop = imol(2,i)
         xmid = 0.0d0
         ymid = 0.0d0
         zmid = 0.0d0
         do j = init, stop
            k = kmol(j)
            weigh = mass(k)
            xmid = xmid + x(k)*weigh
            ymid = ymid + y(k)*weigh
            zmid = zmid + z(k)*weigh
         end do
         weigh = molmass(i)
         xmid = xmid / weigh
         ymid = ymid / weigh
         zmid = zmid / weigh
c
c     save atomic coordinates relative to center of mass
c
         do j = init, stop
            k = kmol(j)
            xoff(k) = x(k) - xmid
            yoff(k) = y(k) - ymid
            zoff(k) = z(k) - zmid
         end do
c
c     convert fractional center of mass to Cartesian coordinates
c
         xmid = xfrac(i)*xbox + yfrac(i)*ybox*gamma_cos
     &             + zfrac(i)*zbox*beta_cos
         ymid = yfrac(i)*ybox*gamma_sin + zfrac(i)*zbox*beta_term
         zmid = zfrac(i)*zbox*gamma_term
c
c     translate coordinates via offset from center of mass
c
         do j = init, stop
            k = kmol(j)
            x(k) = xoff(k) + xmid
            y(k) = yoff(k) + ymid
            z(k) = zoff(k) + zmid
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xoff)
      deallocate (yoff)
      deallocate (zoff)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine xtalwrt  --  output optimization parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "xtalwrt" prints intermediate results during fitting of
c     force field parameters to structures and energies
c
c
      subroutine xtalwrt (niter,nresid,xx,gs,resid)
      use iounit
      use vdwpot
      use xtals
      implicit none
      integer i,niter
      integer nresid
      real*8 xx(*)
      real*8 gs(*)
      real*8 resid(*)
      character*5 vindex
c
c
c     print the values of parameters and scaled derivatives
c
      vindex = 'Class'
      if (vdwindex .eq. 'TYPE ')  vindex = 'Type '
      write (iout,10)  niter
   10 format (/,' Parameters and Scaled Derivatives at',
     &          ' Iteration',i4,' :',/)
      do i = 1, nvary
         if (ivary(i) .le. 3) then
            write (iout,20)  i,varxtl(i),vindex,vary(1,i),xx(i),gs(i)
   20       format (3x,'(',i2,')',2x,a16,4x,'Atom ',a5,i5,2x,2f14.4)
         else if (ivary(i) .ne. 6) then
            write (iout,30)  i,varxtl(i),vary(1,i),xx(i),gs(i)
   30       format (3x,'(',i2,')',2x,a16,4x,'Atom Type ',i5,2x,2f14.4)
         else
            write (iout,40)  i,varxtl(i),vary(1,i),vary(2,i),xx(i),gs(i)
   40       format (3x,'(',i2,')',2x,a16,4x,'Bond Type ',2i5,
     &                 f11.4,f14.4)
         end if
      end do
c
c     print the values of the individual residual functions
c
      write (iout,50)  niter
   50 format (/,' Residual Error Function Values at Iteration',
     &           i4,' :',/)
      do i = 1, nresid
         if (i .lt. 100) then
            write (iout,60)  i,rsdxtl(i),iresid(i),resid(i)
   60       format (3x,'(',i2,')',2x,a16,6x,'Structure',i4,4x,f12.4)
         else
            write (iout,70)  i,rsdxtl(i),iresid(i),resid(i)
   70       format (2x,'(',i3,')',2x,a16,6x,'Structure',i4,4x,f12.4)
         end if
      end do
      write (iout,80)
   80 format ()
      return
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 2004 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  program xtalmin  --  full lattice crystal minimization  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "xtalmin" performs a full crystal energy minimization by
c     optimizing over fractional atomic coordinates and the six
c     lattice lengths and angles
c
c
      program xtalmin
      use atoms
      use boxes
      use files
      use inform
      use iounit
      use keys
      use scales
      implicit none
      integer i,j,imin,nvar
      integer next,freeunit
      real*8 minimum,grdmin
      real*8 gnorm,grms
      real*8 glnorm,glrms
      real*8 xtalmin1,e
      real*8, allocatable :: xx(:)
      real*8, allocatable :: glat(:)
      real*8, allocatable :: xf(:)
      real*8, allocatable :: yf(:)
      real*8, allocatable :: zf(:)
      real*8, allocatable :: derivs(:,:)
      logical exist
      character*20 keyword
      character*240 minfile
      character*240 record
      character*240 string
      external xtalmin1
      external optsave
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     search the keywords for output frequency parameters
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:240)
         if (keyword(1:9) .eq. 'PRINTOUT ') then
            read (string,*,err=10,end=10)  iprint
         else if (keyword(1:9) .eq. 'WRITEOUT ') then
            read (string,*,err=10,end=10)  iwrite
         end if
   10    continue
      end do
c
c     get termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=20,end=20)  grdmin
   20 continue
      if (grdmin .le. 0.0d0) then
         write (iout,30)
   30    format (/,' Enter RMS Gradient per Atom Criterion',
     &              ' [0.01] :  ',$)
         read (input,40)  grdmin
   40    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.01d0
c
c     write out a copy of coordinates for later update
c
      imin = freeunit ()
      minfile = filename(1:leng)//'.xyz'
      call version (minfile,'new')
      open (unit=imin,file=minfile,status='new')
      call prtxyz (imin)
      close (unit=imin)
      outfile = minfile
c
c     write out the initial values of the lattice parameters
c
      write (iout,50)  xbox,ybox,zbox,alpha,beta,gamma
   50 format (/,' Initial Lattice Dimensions :    a   ',f12.4,
     &        /,'                                 b   ',f12.4,
     &        /,'                                 c   ',f12.4,
     &        /,'                                Alpha',f12.4,
     &        /,'                                Beta ',f12.4,
     &        /,'                                Gamma',f12.4)
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(scale))  allocate (scale(3*n+6))
c
c     set scale factors to apply to optimization variables
c
      set_scale = .true.
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         scale(nvar) = 12.0d0 * xbox
         nvar = nvar + 1
         scale(nvar) = 12.0d0 * ybox
         nvar = nvar + 1
         scale(nvar) = 12.0d0 * zbox
      end do
      scale(nvar+1) = 4.0d0 * sqrt(xbox)
      scale(nvar+2) = 4.0d0 * sqrt(ybox)
      scale(nvar+3) = 4.0d0 * sqrt(zbox)
      scale(nvar+4) = 0.02d0 * sqrt(volbox)
      scale(nvar+5) = 0.02d0 * sqrt(volbox)
      scale(nvar+6) = 0.02d0 * sqrt(volbox)
      nvar = nvar + 6
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nvar))
      allocate (glat(nvar))
      allocate (xf(n))
      allocate (yf(n))
      allocate (zf(n))
      allocate (derivs(3,n))
c
c     compute the fractional coordinates for each atom
c
      call lattice
      do i = 1, n
         j = 3*i - 3
         xx(j+1) = x(i)*recip(1,1) + y(i)*recip(2,1) + z(i)*recip(3,1)
         xx(j+2) = x(i)*recip(1,2) + y(i)*recip(2,2) + z(i)*recip(3,2)
         xx(j+3) = x(i)*recip(1,3) + y(i)*recip(2,3) + z(i)*recip(3,3)
      end do
c
c     scale the fractional coordinates and lattice parameters
c
      nvar = 3 * n
      do i = 1, nvar
         xx(i) = xx(i) * scale(i)
      end do
      xx(nvar+1) = xbox * scale(nvar+1)
      xx(nvar+2) = ybox * scale(nvar+2)
      xx(nvar+3) = zbox * scale(nvar+3)
      xx(nvar+4) = alpha * scale(nvar+4)
      xx(nvar+5) = beta * scale(nvar+5)
      xx(nvar+6) = gamma * scale(nvar+6)
      nvar = nvar + 6
c
c     make the call to the optimization routine
c
      call ocvm (nvar,xx,minimum,grdmin,xtalmin1,optsave)
c     call lbfgs (nvar,xx,minimum,grdmin,xtalmin1,optsave)
c
c     unscale fractional coordinates and get atomic coordinates
c
      do i = 1, n
         j = 3*i - 3
         xf(i) = xx(j+1) / scale(j+1)
         yf(i) = xx(j+2) / scale(j+2)
         zf(i) = xx(j+3) / scale(j+3)
      end do
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
c
c     compute final energy value and coordinate RMS gradient
c
      call gradient (e,derivs)
      gnorm = 0.0d0
      do i = 1, n
         do j = 1, 3
            gnorm = gnorm + derivs(j,i)**2
         end do
      end do
      gnorm = sqrt(gnorm)
      nvar = 3 * n
      grms = gnorm / sqrt(dble(nvar/3))
c
c     compute the final RMS gradient for lattice parameters
c
      minimum = xtalmin1 (xx,glat)
      glnorm = 0.0d0
      do i = nvar+1, nvar+6
         glnorm = glnorm + (scale(i)*glat(i))**2
      end do
      glnorm = sqrt(glnorm)
      glrms = glnorm / sqrt(6.0d0)
c
c     write out the final energy and coordinate gradients
c
      if (digits .ge. 8) then
         if (grms.gt.1.0d-8 .and. glrms.gt.1.0d-8) then
            write (iout,60)  minimum,grms,gnorm,glrms,glnorm
   60       format (/,' Final Potential Function Value :',f20.8,
     &              /,' Final RMS Coordinate Gradient : ',f20.8,
     &              /,' Final Coordinate Gradient Norm :',f20.8,
     &              /,' Final RMS Lattice Gradient :    ',f20.8,
     &              /,' Final Lattice Gradient Norm :   ',f20.8)
         else
            write (iout,70)  minimum,grms,gnorm,glrms,glnorm
   70       format (/,' Final Potential Function Value :',f20.8,
     &              /,' Final RMS Coordinate Gradient : ',d20.8,
     &              /,' Final Coordinate Gradient Norm :',d20.8,
     &              /,' Final RMS Lattice Gradient :    ',d20.8,
     &              /,' Final Lattice Gradient Norm :   ',d20.8)
         end if
      else if (digits .ge. 6) then
         if (grms.gt.1.0d-6 .and. glrms.gt.1.0d-6) then
            write (iout,80)  minimum,grms,gnorm,glrms,glnorm
   80       format (/,' Final Potential Function Value :',f18.6,
     &              /,' Final RMS Coordinate Gradient : ',f18.6,
     &              /,' Final Coordinate Gradient Norm :',f18.6,
     &              /,' Final RMS Lattice Gradient :    ',f18.6,
     &              /,' Final Lattice Gradient Norm :   ',f18.6)
         else
            write (iout,90)  minimum,grms,gnorm,glrms,glnorm
   90       format (/,' Final Potential Function Value :',f18.6,
     &              /,' Final RMS Coordinate Gradient : ',d18.6,
     &              /,' Final Coordinate Gradient Norm :',d18.6,
     &              /,' Final RMS Lattice Gradient :    ',d18.6,
     &              /,' Final Lattice Gradient Norm :   ',d18.6)
         end if
      else
         if (grms.gt.1.0d-4 .and. glrms.gt.1.0d-4) then
            write (iout,100)  minimum,grms,gnorm,glrms,glnorm
  100       format (/,' Final Potential Function Value :',f16.4,
     &              /,' Final RMS Coordinate Gradient : ',f16.4,
     &              /,' Final Coordinate Gradient Norm :',f16.4,
     &              /,' Final RMS Lattice Gradient :    ',f16.4,
     &              /,' Final Lattice Gradient Norm :   ',f16.4)
         else
            write (iout,110)  minimum,grms,gnorm,glrms,glnorm
  110       format (/,' Final Potential Function Value :',f16.4,
     &              /,' Final RMS Coordinate Gradient : ',d16.4,
     &              /,' Final Coordinate Gradient Norm :',d16.4,
     &              /,' Final RMS Lattice Gradient :    ',d16.4,
     &              /,' Final Lattice Gradient Norm :   ',d16.4)
         end if
      end if
c
c     write out the final values of the lattice parameters
c
      if (digits .ge. 8) then
         write (iout,120)  xbox,ybox,zbox,alpha,beta,gamma
  120    format (/,' Final Lattice Dimensions :      a   ',f16.8,
     &           /,'                                 b   ',f16.8,
     &           /,'                                 c   ',f16.8,
     &           /,'                                Alpha',f16.8,
     &           /,'                                Beta ',f16.8,
     &           /,'                                Gamma',f16.8)
      else if (digits .ge. 6) then
         write (iout,130)  xbox,ybox,zbox,alpha,beta,gamma
  130    format (/,' Final Lattice Dimensions :      a   ',f14.6,
     &           /,'                                 b   ',f14.6,
     &           /,'                                 c   ',f14.6,
     &           /,'                                Alpha',f14.6,
     &           /,'                                Beta ',f14.6,
     &           /,'                                Gamma',f14.6)
      else
         write (iout,140)  xbox,ybox,zbox,alpha,beta,gamma
  140    format (/,' Final Lattice Dimensions :      a   ',f12.4,
     &           /,'                                 b   ',f12.4,
     &           /,'                                 c   ',f12.4,
     &           /,'                                Alpha',f12.4,
     &           /,'                                Beta ',f12.4,
     &           /,'                                Gamma',f12.4)
      end if
c
c     write the final coordinates into a file
c
      imin = freeunit ()
      open (unit=imin,file=minfile,status='old')
      rewind (unit=imin)
      call prtxyz (imin)
      close (unit=imin)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function xtalmin1  --  energy and gradient for lattice  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "xtalmin1" is a service routine that computes the energy and
c     gradient with respect to fractional coordinates and lattice
c     dimensions for a crystal energy minimization
c
c
      function xtalmin1 (xx,g)
      use atoms
      use boxes
      use math
      use scales
      implicit none
      integer i,j
      real*8 xtalmin1,energy
      real*8 e,e0,old,eps
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: xf(:)
      real*8, allocatable :: yf(:)
      real*8, allocatable :: zf(:)
      real*8, allocatable :: derivs(:,:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xf(n))
      allocate (yf(n))
      allocate (zf(n))
c
c     translate optimization variables to fractional coordinates
c
      do i = 1, n
         j = 3*i - 3
         xf(i) = xx(j+1) / scale(j+1)
         yf(i) = xx(j+2) / scale(j+2)
         zf(i) = xx(j+3) / scale(j+3)
      end do
c
c     translate optimization variables to lattice parameters
c
      xbox = xx(3*n+1) / scale(3*n+1)
      ybox = xx(3*n+2) / scale(3*n+2)
      zbox = xx(3*n+3) / scale(3*n+3)
      alpha = xx(3*n+4) / scale(3*n+4)
      beta = xx(3*n+5) / scale(3*n+5)
      gamma = xx(3*n+6) / scale(3*n+6)
c
c     update current atomic coordinates based on optimization values
c
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     find energy and fractional coordinates deriviatives
c
      call gradient (e,derivs)
      xtalmin1 = e
      do i = 1, n
         j = 3*i - 3
         g(j+1) = derivs(1,i)*lvec(1,1) + derivs(2,i)*lvec(1,2)
     &               + derivs(3,i)*lvec(1,3)
         g(j+2) = derivs(1,i)*lvec(2,1) + derivs(2,i)*lvec(2,2)
     &               + derivs(3,i)*lvec(2,3)
         g(j+3) = derivs(1,i)*lvec(3,1) + derivs(2,i)*lvec(3,2)
     &               + derivs(3,i)*lvec(3,3)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
c
c     find derivative with respect to lattice a-axis length
c
      eps = 0.0001d0
      old = xbox
      xbox = xbox - 0.5d0*eps
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
      e0 = energy ()
      xbox = xbox + eps
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
      e = energy ()
      g(3*n+1) = (e - e0) / eps
      xbox = old
c
c     find derivative with respect to lattice b-axis length
c
      old = ybox
      ybox = ybox - 0.5d0*eps
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
      e0 = energy ()
      ybox = ybox + eps
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
      e = energy ()
      g(3*n+2) = (e - e0) / eps
      ybox = old
c
c     find derivative with respect to lattice c-axis length
c
      old = zbox
      zbox = zbox - 0.5d0*eps
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
      e0 = energy ()
      zbox = zbox + eps
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
      e = energy ()
      g(3*n+3) = (e - e0) / eps
      zbox = old
c
c     find derivative with respect to lattice alpha angle
c
      eps = eps * radian
      old = alpha
      alpha = alpha - 0.5d0*eps
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
      e0 = energy ()
      alpha = alpha + eps
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
      e = energy ()
      g(3*n+4) = (e - e0) / eps
      alpha = old
c
c     find derivative with respect to lattice beta angle
c
      old = beta
      beta = beta - 0.5d0*eps
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
      e0 = energy ()
      beta = beta + eps
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
      e = energy ()
      g(3*n+5) = (e - e0) / eps
      beta = old
c
c     find derivative with respect to lattice gamma angle
c
      old = gamma
      gamma = gamma - 0.5d0*eps
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
      e0 = energy ()
      gamma = gamma + eps
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
      e = energy ()
      g(3*n+6) = (e - e0) / eps
      gamma = old
c
c     revert to the original atomic coordinate values
c
      call lattice
      do i = 1, n
         x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1)
         y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2)
         z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3)
      end do
c
c     apply scale factors to the coordinate and lattice gradient
c
      do i = 1, 3*n+6
         g(i) = g(i) / scale(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xf)
      deallocate (yf)
      deallocate (zf)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  module xtals  --  structures used for parameter fitting  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     maxlsq       maximum number of least squares variables
c     maxrsd       maximum number of residual functions
c
c     nxtal        number of molecular structures to be stored
c     nvary        number of potential parameters to optimize
c     ivary        index for the types of potential parameters
c     iresid       structure to which each residual function refers
c     vary         atom numbers involved in potential parameters
c     e0_lattice   ideal lattice energy for the current crystal
c     varxtl       type of each potential parameter to be optimized
c     rsdxtl       experimental variable for each of the residuals
c
c
      module xtals
      implicit none
      integer maxlsq,maxrsd
      parameter (maxlsq=1000)
      parameter (maxrsd=1000)
      integer nxtal,nvary
      integer ivary(maxlsq)
      integer iresid(maxrsd)
      integer vary(2,maxlsq)
      real*8 e0_lattice
      character*16 varxtl(maxlsq)
      character*16 rsdxtl(maxrsd)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine xyzatm  --  single atom internal to Cartesian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "xyzatm" computes the Cartesian coordinates of a single
c     atom from its defining internal coordinate values
c
c
      subroutine xyzatm (i,ia,bond,ib,angle1,ic,angle2,chiral)
      use atoms
      use inform
      use iounit
      use math
      implicit none
      integer i,ia,ib,ic,chiral
      real*8 bond,angle1,angle2
      real*8 eps,rad1,rad2
      real*8 sin1,cos1,sin2,cos2
      real*8 cosine,sine,sine2
      real*8 xab,yab,zab,rab
      real*8 xba,yba,zba,rba
      real*8 xbc,ybc,zbc,rbc
      real*8 xac,yac,zac,rac
      real*8 xt,yt,zt,xu,yu,zu
      real*8 cosb,sinb,cosg,sing
      real*8 xtmp,ztmp,a,b,c
c
c
c     convert angles to radians, and get their sines and cosines
c
      eps = 0.00000001d0
      rad1 = angle1 / radian
      rad2 = angle2 / radian
      sin1 = sin(rad1)
      cos1 = cos(rad1)
      sin2 = sin(rad2)
      cos2 = cos(rad2)
c
c     if no second site given, place the atom at the origin
c
      if (ia .eq. 0) then
         x(i) = 0.0d0
         y(i) = 0.0d0
         z(i) = 0.0d0
c
c     if no third site given, place the atom along the z-axis
c
      else if (ib .eq. 0) then
         x(i) = x(ia)
         y(i) = y(ia)
         z(i) = z(ia) + bond
c
c     if no fourth site given, place the atom in the x,z-plane
c
      else if (ic .eq. 0) then
         xab = x(ia) - x(ib)
         yab = y(ia) - y(ib)
         zab = z(ia) - z(ib)
         rab = sqrt(xab**2 + yab**2 + zab**2)
         xab = xab / rab
         yab = yab / rab
         zab = zab / rab
         cosb = zab
         sinb = sqrt(xab**2 + yab**2)
         if (sinb .eq. 0.0d0) then
            cosg = 1.0d0
            sing = 0.0d0
         else
            cosg = yab / sinb
            sing = xab / sinb
         end if
         xtmp = bond*sin1
         ztmp = rab - bond*cos1
         x(i) = x(ib) + xtmp*cosg + ztmp*sing*sinb
         y(i) = y(ib) - xtmp*sing + ztmp*cosg*sinb
         z(i) = z(ib) + ztmp*cosb
c
c     general case where the second angle is a dihedral angle
c
      else if (chiral .eq. 0) then
         xab = x(ia) - x(ib)
         yab = y(ia) - y(ib)
         zab = z(ia) - z(ib)
         rab = sqrt(xab**2 + yab**2 + zab**2)
         xab = xab / rab
         yab = yab / rab
         zab = zab / rab
         xbc = x(ib) - x(ic)
         ybc = y(ib) - y(ic)
         zbc = z(ib) - z(ic)
         rbc = sqrt(xbc**2 + ybc**2 + zbc**2)
         xbc = xbc / rbc
         ybc = ybc / rbc
         zbc = zbc / rbc
         xt = zab*ybc - yab*zbc
         yt = xab*zbc - zab*xbc
         zt = yab*xbc - xab*ybc
         cosine = xab*xbc + yab*ybc + zab*zbc
         sine = sqrt(max(1.0d0-cosine**2,eps))
         xt = xt / sine
         yt = yt / sine
         zt = zt / sine
         xu = yt*zab - zt*yab
         yu = zt*xab - xt*zab
         zu = xt*yab - yt*xab
         x(i) = x(ia) + bond * (xu*sin1*cos2 + xt*sin1*sin2 - xab*cos1)
         y(i) = y(ia) + bond * (yu*sin1*cos2 + yt*sin1*sin2 - yab*cos1)
         z(i) = z(ia) + bond * (zu*sin1*cos2 + zt*sin1*sin2 - zab*cos1)
         if (abs(cosine) .ge. 1.0d0) then
            cosb = zab
            sinb = sqrt(xab**2 + yab**2)
            if (sinb .eq. 0.0d0) then
               cosg = 1.0d0
               sing = 0.0d0
            else
               cosg = yab / sinb
               sing = xab / sinb
            end if
            xtmp = bond*sin1
            ztmp = rab - bond*cos1
            x(i) = x(ib) + xtmp*cosg + ztmp*sing*sinb
            y(i) = y(ib) - xtmp*sing + ztmp*cosg*sinb
            z(i) = z(ib) + ztmp*cosb
            write (iout,10)  i
   10       format (/,' XYZATM  --  Warning, Undefined Dihedral',
     &                 ' Angle at Atom',i6)
         end if
c
c     general case where the second angle is a bond angle
c
      else if (abs(chiral) .eq. 1) then
         xba = x(ib) - x(ia)
         yba = y(ib) - y(ia)
         zba = z(ib) - z(ia)
         rba = sqrt(xba**2 + yba**2 + zba**2)
         xba = xba / rba
         yba = yba / rba
         zba = zba / rba
         xac = x(ia) - x(ic)
         yac = y(ia) - y(ic)
         zac = z(ia) - z(ic)
         rac = sqrt(xac**2 + yac**2 + zac**2)
         xac = xac / rac
         yac = yac / rac
         zac = zac / rac
         xt = zba*yac - yba*zac
         yt = xba*zac - zba*xac
         zt = yba*xac - xba*yac
         cosine = xba*xac + yba*yac + zba*zac
         sine2 = max(1.0d0-cosine**2,eps)
         if (abs(cosine) .ge. 1.0d0) then
            write (iout,20)  i
   20       format (/,' XYZATM  --  Warning, Collinear Defining',
     &                 ' Atoms at Atom',i6)
         end if
         a = (-cos2 - cosine*cos1) / sine2
         b = (cos1 + cosine*cos2) / sine2
         c = (1.0d0 + a*cos2 - b*cos1) / sine2
         if (c .gt. eps) then
            c = chiral * sqrt(c)
         else if (c .lt. -eps) then
            c = sqrt((a*xac+b*xba)**2 + (a*yac+b*yba)**2
     &                       + (a*zac+b*zba)**2)
            a = a / c
            b = b / c
            c = 0.0d0
            if (debug) then
               write (iout,30)  ia
   30          format (/,' XYZATM  --  Warning, Sum of Bond Angles',
     &                    ' Too Large at Atom',i6)
            end if
         else
            c = 0.0d0
         end if
         x(i) = x(ia) + bond * (a*xac + b*xba + c*xt)
         y(i) = y(ia) + bond * (a*yac + b*yba + c*yt)
         z(i) = z(ia) + bond * (a*zac + b*zba + c*zt)
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  program xyzedit  --  editing of Cartesian coordinates  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "xyzedit" provides for modification and manipulation
c     of the contents of Cartesian coordinates files
c
c
      program xyzedit
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use files
      use inform
      use iounit
      use limits
      use math
      use molcul
      use ptable
      use titles
      use units
      use usage
      implicit none
      integer i,j,k,it
      integer init,stop
      integer ixyz,imod,itmp
      integer nmode,mode
      integer natom,nlist
      integer next,nask
      integer offset,origin
      integer oldtype,newtype
      integer freeunit,trimtext
      integer, allocatable :: list(:)
      integer, allocatable :: keep(:)
      integer, allocatable :: tmptype(:)
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xcm,ycm,zcm
      real*8 xnew,ynew,znew
      real*8 xorig,yorig,zorig
      real*8 ri,rij,dij
      real*8 phi,theta,psi
      real*8 cphi,ctheta,cpsi
      real*8 sphi,stheta,spsi
      real*8 dist2,cut2
      real*8 random,norm,weigh
      real*8, allocatable :: rad(:)
      real*8 a(3,3)
      logical exist,query
      logical opened,multi
      logical append,first
      logical generic
      character*1 axis
      character*3 symb
      character*240 xyzfile
      character*240 modfile
      character*240 tmpfile
      character*240 record
      character*240 string
      external random,merge
c
c
c     initialize various constants and the output flags
c
      call initial
      opened = .false.
      multi = .false.
      generic = .false.
      nmode = 28
      offset = 0
c
c     find the Cartesian coordinates file to be processed
c
      ixyz = 0
      call getcart (ixyz)
      xyzfile = filename
      first = .false.
c
c     get the force field definition and assign atom types
c
      call attach
      call active
      call field
      call katom
c
c     present a list of possible coordinate modifications
c
      write (iout,10)
   10 format (/,' The Tinker XYZ File Editing Utility Can :',
     &        //,4x,'(1) Convert Simple XYZ File to Tinker Format',
     &        /,4x,'(2) Convert Tinker File to Simple XYZ Format',
     &        /,4x,'(3) Offset the Numbers of the Current Atoms',
     &        /,4x,'(4) Remove User Specified Individual Atoms',
     &        /,4x,'(5) Remove User Specified Types of Atoms',
     &        /,4x,'(6) Delete Inactive Atoms Beyond Cutoff Range',
     &        /,4x,'(7) Insertion of Individual Specified Atoms',
     &        /,4x,'(8) Replace Old Atom Type with a New Type',
     &        /,4x,'(9) Assign Connectivities for Linear Chain',
     &        /,3x,'(10) Assign Connectivities Based on Distance',
     &        /,3x,'(11) Assign Atom Types for BASIC Force Field',
     &        /,3x,'(12) Transfer Atom Types from Another Structure',
     &        /,3x,'(13) Convert Units from Bohrs to Angstroms',
     &        /,3x,'(14) Invert thru Origin to Give Mirror Image',
     &        /,3x,'(15) Translate All Atoms by an X,Y,Z-Vector',
     &        /,3x,'(16) Translate Center of Mass to the Origin',
     &        /,3x,'(17) Translate a Specified Atom to the Origin',
     &        /,3x,'(18) Translate and Rotate to Inertial Frame',
     &        /,3x,'(19) Rotate All Atoms Around a Specified Axis',
     &        /,3x,'(20) Move to Specified Rigid Body Coordinates',
     &        /,3x,'(21) Move Stray Molecules into Periodic Box',
     &        /,3x,'(22) Trim a Periodic Box to a Smaller Size',
     &        /,3x,'(23) Make Truncated Octahedron from Cubic Box',
     &        /,3x,'(24) Make Rhombic Dodecahedron from Cubic Box',
     &        /,3x,'(25) Append a Second XYZ File to Current One',
     &        /,3x,'(26) Create and Fill a Periodic Boundary Box',
     &        /,3x,'(27) Soak Current Molecule in Box of Solvent',
     &        /,3x,'(28) Place Monoatomic Ions around a Solute')
c
c     get the desired type of coordinate file modification
c
   20 continue
      abort = .false.
      mode = -1
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=30,end=30)  mode
         if (mode.ge.0 .and. mode.le.nmode)  query = .false.
      end if
   30 continue
      if (query) then
         do while (mode.lt.0 .or. mode.gt.nmode)
            mode = 0
            write (iout,40)
   40       format (/,' Number of the Desired Choice [<Enter>=Exit]',
     &                 ' :  ',$)
            read (input,50,err=20,end=60)  mode
   50       format (i10)
   60       continue
         end do
      end if
c
c     open the file to be used for the output coordinates
c
      if (mode.gt.0 .and. .not.opened) then
         opened = .true.
         imod = freeunit ()
         modfile = filename(1:leng)//'.xyz'
         call version (modfile,'new')
         open (unit=imod,file=modfile,status='new')
      end if
c
c     read generic XYZ file and convert to Tinker format
c
      if (mode .eq. 1) then
         generic = .false.
         do while (.not. abort)
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     read Tinker XYZ file and convert to generic format
c
      if (mode .eq. 2) then
         generic = .true.
         do while (.not. abort)
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtgen (imod)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     get the offset value to be used in atom renumbering
c
      if (mode .eq. 3) then
   70    continue
         offset = 0
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=80,end=80)  offset
            query = .false.
         end if
   80    continue
         if (query) then
            write (iout,90)
   90       format (/,' Offset used to Renumber the Atoms [0] :  ',$)
            read (input,100,err=70)  offset
  100       format (i10)
         end if
         do while (.not. abort)
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     remove a specified list of individual atoms
c
      if (mode .eq. 4) then
         allocate (list(n))
         nlist = 0
         do i = 1, n
            list(i) = 0
         end do
         write (iout,110)
  110    format (/,' Numbers of the Atoms to be Removed :  ',$)
         read (input,120)  record
  120    format (a240)
         read (record,*,err=130,end=130)  (list(i),i=1,n)
  130    continue
         do while (list(nlist+1) .ne. 0)
            nlist = nlist + 1
         end do
         do i = 1, nlist
            if (list(i) .gt. n)  list(i) = n
            if (list(i) .lt. -n)  list(i) = -n
         end do
         call sort4 (nlist,list)
         do while (.not. abort)
            do i = nlist, 1, -1
               if (i .gt. 1) then
                  if (list(i-1) .lt. 0) then
                     do j = abs(list(i)), abs(list(i-1)), -1
                        call delete (j)
                     end do
                  else if (list(i) .gt. 0) then
                     call delete (list(i))
                  end if
               else if (list(i) .gt. 0) then
                  call delete (list(i))
               end if
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         deallocate (list)
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     remove atoms with any of a specified list of atom types
c
      if (mode .eq. 5) then
         allocate (list(n))
         nlist = 0
         do i = 1, n
            list(i) = 0
         end do
         write (iout,140)
  140    format (/,' Atom Types to be Removed :  ',$)
         read (input,150)  record
  150    format (a240)
         read (record,*,err=160,end=160)  (list(i),i=1,n)
  160    continue
         do while (list(nlist+1) .ne. 0)
            nlist = nlist + 1
         end do
         natom = n
         do while (.not. abort)
            do i = natom, 1, -1
               it = type(i)
               do j = 1, nlist
                  if (list(j) .eq. it) then
                     call delete (i)
                     goto 170
                  end if
               end do
  170          continue
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         deallocate (list)
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     remove atoms that are inactive and lie outside all cutoffs
c
      if (mode .eq. 6) then
         call cutoffs
         cut2 = 0.0d0
         if (vdwcut .le. 1000.0d0)  cut2 = max(vdwcut**2,cut2)
         if (chgcut .le. 1000.0d0)  cut2 = max(chgcut**2,cut2)
         if (dplcut .le. 1000.0d0)  cut2 = max(dplcut**2,cut2)
         if (mpolecut .le. 1000.0d0)  cut2 = max(mpolecut**2,cut2)
         if (cut2 .eq. 0.0d0)  cut2 = 1.0d16
         allocate (list(n))
         allocate (keep(n))
         do while (.not. abort)
            nlist = 0
            do i = 1, n
               keep(i) = 0
            end do
            do i = 1, n
               if (.not. use(i)) then
                  do j = 1, n12(i)
                     keep(i12(j,i)) = i
                  end do
                  do j = 1, n13(i)
                     keep(i13(j,i)) = i
                  end do
                  do j = 1, n14(i)
                     keep(i14(j,i)) = i
                  end do
                  xi = x(i)
                  yi = y(i)
                  zi = z(i)
                  do j = 1, n
                     if (use(j)) then
                        if (keep(j) .eq. i)  goto 180
                        dist2 = (x(j)-xi)**2+(y(j)-yi)**2+(z(j)-zi)**2
                        if (dist2 .le. cut2)  goto 180
                     end if
                  end do
                  nlist = nlist + 1
                  list(nlist) = i
  180             continue
               end if
            end do
            do i = nlist, 1, -1
               call delete (list(i))
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         deallocate (list)
         deallocate (keep)
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     insert a specified list of individual atoms
c
      if (mode .eq. 7) then
         allocate (list(n))
         nlist = 0
         do i = 1, n
            list(i) = 0
         end do
         write (iout,190)
  190    format (/,' Numbers of the Atoms to be Inserted :  ',$)
         read (input,200)  record
  200    format (a240)
         read (record,*,err=210,end=210)  (list(i),i=1,n)
  210    continue
         do while (list(nlist+1) .ne. 0)
            nlist = nlist + 1
         end do
         call sort4 (nlist,list)
         do while (.not. abort)
            do i = nlist, 1, -1
               if (i .gt. 1) then
                  if (list(i-1) .lt. 0) then
                     do j = abs(list(i-1)), abs(list(i))
                        call insert (j)
                     end do
                  else if (list(i) .gt. 0) then
                     call insert (list(i))
                  end if
               else if (list(i) .gt. 0) then
                  call insert (list(i))
               end if
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         deallocate (list)
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     get an old atom type and new atom type for replacement
c
      if (mode .eq. 8) then
  220    continue
         oldtype = 0
         newtype = 0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=230,end=230)  oldtype
         call nextarg (string,exist)
         if (exist)  read (string,*,err=230,end=230)  newtype
  230    continue
         if (oldtype.eq.0 .or. newtype.eq.0) then
            write (iout,240)
  240       format (/,' Numbers of the Old and New Atom Types :  ',$)
            read (input,250)  record
  250       format (a240)
         end if
         read (record,*,err=220,end=220)  oldtype,newtype
         do while (.not. abort)
            do i = 1, n
               if (use(i)) then
                  if (type(i) .eq. oldtype) then
                     type(i) = newtype
                  end if
               end if
            end do
            call katom
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     assign atom connectivities to produce a linear chain
c
      if (mode .eq. 9) then
         do while (.not. abort)
            do i = 1, n
               n12(i) = 0
               if (i .ne. 1) then
                  n12(i) = n12(i) + 1
                  i12(n12(i),i) = i - 1
               end if
               if (i .ne. n) then
                  n12(i) = n12(i) + 1
                  i12(n12(i),i) = i + 1
               end if
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     assign atom connectivities based on interatomic distances
c
      if (mode .eq. 10) then
         allocate (rad(n))
         do while (.not. abort)
            call unitcell
            call lattice
            do i = 1, n
               rad(i) = 0.76d0
               k = atomic(i)
               if (k .ne. 0) then
                  rad(i) = covrad(k)
               else
                  symb = name(i)
                  call upcase (symb(1:1))
                  call lowcase (symb(2:3))
                  do j = 1, maxele
                     if (symb .eq. elemnt(j)) then
                        k = j
                        goto 260
                     end if
                  end do
                  do j = 1, maxele
                     if (symb(1:1) .eq. elemnt(j)(1:1)) then
                        k = j
                        goto 260
                     end if
                  end do
  260             continue
                  if (k .ne. 0)  rad(i) = covrad(k)
               end if
               rad(i) = 1.15d0 * rad(i)
            end do
            do i = 1, n
               n12(i) = 0
            end do
            do i = 1, n-1
               xi = x(i)
               yi = y(i)
               zi = z(i)
               ri = rad(i)
               do j = i+1, n
                  xr = x(j) - xi
                  yr = y(j) - yi
                  zr = z(j) - zi
                  rij = ri + rad(j)
                  dij = sqrt(xr*xr + yr*yr + zr*zr)
                  if (dij .lt. rij) then
                     n12(i) = n12(i) + 1
                     i12(n12(i),i) = j
                     n12(j) = n12(j) + 1
                     i12(n12(j),j) = i
                  end if
               end do
            end do
            do i = 1, n
               call sort (n12(i),i12(1,i))
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         deallocate (rad)
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     assign atom types for the Tinker BASIC force field
c
      if (mode .eq. 11) then
         do while (.not. abort)
            do i = 1, n
               k = atomic(i)
               if (k .eq. 0) then
                  symb = name(i)
                  call upcase (symb(1:1))
                  call lowcase (symb(2:3))
                  do j = 1, maxele
                     if (symb .eq. elemnt(j)) then
                        k = j
                        goto 270
                     end if
                  end do
                  do j = 1, maxele
                     if (symb(1:1) .eq. elemnt(j)(1:1)) then
                        k = j
                        goto 270
                     end if
                  end do
  270             continue
               end if
               type(i) = 10*k + n12(i)
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     transfer atoms types from one structure to another
c
      if (mode .eq. 12) then
         call makeref (1)
         call nextarg (tmpfile,exist)
         if (exist) then
            call basefile (tmpfile)
            call suffix (tmpfile,'xyz','old')
            inquire (file=tmpfile,exist=exist)
         end if
         nask = 0
         do while (.not.exist .and. nask.lt.maxask)
            write (iout,280)
  280       format (/,' Enter Name of Atom Type Template',
     &                 ' Structure :  ',$)
            read (input,290)  tmpfile
  290       format (a240)
            call basefile (tmpfile)
            call suffix (tmpfile,'xyz','old')
            inquire (file=tmpfile,exist=exist)
         end do
         itmp = freeunit ()
         open (unit=itmp,file=tmpfile,status='old')
         rewind (unit=itmp)
         call readxyz (itmp)
         close (unit=itmp)
         allocate (tmptype(n))
         do i = 1, n
            tmptype(i) = type(i)
         end do
         filename = xyzfile
         call getref (1)
         do while (.not. abort)
            do i = 1, n
               if (use(i))  type(i) = tmptype(i)
            end do
            call katom
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         deallocate (tmptype)
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     convert the coordinate units from Bohrs to Angstroms
c
      if (mode .eq. 13) then
         do while (.not. abort)
            do i = 1, n
               x(i) = x(i) * bohr
               y(i) = y(i) * bohr
               z(i) = z(i) * bohr
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     get mirror image by inverting coordinates through origin
c
      if (mode .eq. 14) then
         do while (.not. abort)
            do i = 1, n
               x(i) = -x(i)
               y(i) = -y(i)
               z(i) = -z(i)
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     translate the entire system by a specified x,y,z-vector
c
      if (mode .eq. 15) then
         xr = 0.0d0
         yr = 0.0d0
         zr = 0.0d0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=300,end=300)  xr
         call nextarg (string,exist)
         if (exist)  read (string,*,err=300,end=300)  yr
         call nextarg (string,exist)
         if (exist)  read (string,*,err=300,end=300)  zr
  300    continue
         if (xr.eq.0.0d0 .and. yr.eq.0.0d0 .and. zr.eq.0.0d0) then
            write (iout,310)
  310       format (/,' Enter Translation Vector Components :  ',$)
            read (input,320)  record
  320       format (a240)
            read (record,*,err=330,end=330)  xr,yr,zr
  330       continue
         end if
         do while (.not. abort)
            do i = 1, n
               x(i) = x(i) + xr
               y(i) = y(i) + yr
               z(i) = z(i) + zr
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     translate the center of mass to the coordinate origin
c
      if (mode .eq. 16) then
         do while (.not. abort)
            xcm = 0.0d0
            ycm = 0.0d0
            zcm = 0.0d0
            norm = 0.0d0
            do i = 1, n
               if (use(i)) then
                  weigh = mass(i)
                  xcm = xcm + x(i)*weigh
                  ycm = ycm + y(i)*weigh
                  zcm = zcm + z(i)*weigh
                  norm = norm + weigh
               end if
            end do
            xcm = xcm / norm
            ycm = ycm / norm
            zcm = zcm / norm
            do i = 1, n
               x(i) = x(i) - xcm
               y(i) = y(i) - ycm
               z(i) = z(i) - zcm
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     translate to place a specified atom at the origin
c
      if (mode .eq. 17) then
         origin = 0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=340,end=340)  origin
  340    continue
         if (origin .eq. 0) then
            write (iout,350)
  350       format (/,' Number of the Atom to Move to the Origin',
     &                 ' :  ',$)
            read (input,360)  origin
  360       format (i10)
         end if
         do while (.not. abort)
            xorig = x(origin)
            yorig = y(origin)
            zorig = z(origin)
            do i = 1, n
               x(i) = x(i) - xorig
               y(i) = y(i) - yorig
               z(i) = z(i) - zorig
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     translate and rotate into standard orientation
c
      if (mode .eq. 18) then
         do while (.not. abort)
            call inertia (2)
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     rotate about a coordinate axis by a specified amount
c
      if (mode .eq. 19) then
         axis = ' '
         theta = 0.0d0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=370,end=370)  axis
         call nextarg (string,exist)
         if (exist)  read (string,*,err=370,end=370)  theta
  370    continue
         if (axis .eq. ' ') then
            write (iout,380)
  380       format (/,' Enter Axis (X,Y,Z) and Rotation [0 deg] :  ',$)
            read (input,390)  string
  390       format (a240)
            next = 1
            call getword (string,axis,next)
            call upcase (axis)
            string = string(next:240)
            read (string,*,err=400,end=400)  theta
  400       continue
         end if
         theta = theta / radian
         ctheta = cos(theta)
         stheta = sin(theta)
         do i = 1, 3
            do j = 1, 3
               a(j,i) = 0.0d0
            end do
            a(i,i) = 1.0d0
         end do
         if (axis .eq. 'X') then
            a(2,2) = ctheta
            a(3,2) = stheta
            a(2,3) = -stheta
            a(3,3) = ctheta
         else if (axis .eq. 'Y') then
            a(1,1) = ctheta
            a(3,1) = -stheta
            a(1,3) = stheta
            a(3,3) = ctheta
         else if (axis .eq. 'Z') then
            a(1,1) = ctheta
            a(2,1) = stheta
            a(1,2) = -stheta
            a(2,2) = ctheta
         end if
         do while (.not. abort)
            do i = 1, n
               xorig = x(i)
               yorig = y(i)
               zorig = z(i)
               x(i) = a(1,1)*xorig + a(2,1)*yorig + a(3,1)*zorig + xcm
               y(i) = a(1,2)*xorig + a(2,2)*yorig + a(3,2)*zorig + ycm
               z(i) = a(1,3)*xorig + a(2,3)*yorig + a(3,3)*zorig + zcm
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     translate and rotate to specified rigid body coordinates
c
      if (mode .eq. 20) then
         xcm = 0.0d0
         ycm = 0.0d0
         zcm = 0.0d0
         phi = 0.0d0
         theta = 0.0d0
         psi = 0.0d0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=410,end=410)  xcm
         call nextarg (string,exist)
         if (exist)  read (string,*,err=410,end=410)  ycm
         call nextarg (string,exist)
         if (exist)  read (string,*,err=410,end=410)  zcm
         call nextarg (string,exist)
         if (exist)  read (string,*,err=410,end=410)  phi
         call nextarg (string,exist)
         if (exist)  read (string,*,err=410,end=410)  theta
         call nextarg (string,exist)
         if (exist)  read (string,*,err=410,end=410)  psi
  410    continue
         if (min(xcm,ycm,zcm,phi,theta,psi).eq.0.0d0 .and.
     &       max(xcm,ycm,zcm,phi,theta,psi).eq.0.0d0) then
            write (iout,420)
  420       format (/,' Enter Rigid Body Coordinates :  ',$)
            read (input,430)  record
  430       format (a240)
            read (record,*,err=440,end=440)  xcm,ycm,zcm,phi,theta,psi
  440       continue
         end if
         call inertia (2)
         phi = phi / radian
         theta = theta / radian
         psi = psi / radian
         cphi = cos(phi)
         sphi = sin(phi)
         ctheta = cos(theta)
         stheta = sin(theta)
         cpsi = cos(psi)
         spsi = sin(psi)
         a(1,1) = ctheta * cphi
         a(2,1) = spsi*stheta*cphi - cpsi*sphi
         a(3,1) = cpsi*stheta*cphi + spsi*sphi
         a(1,2) = ctheta * sphi
         a(2,2) = spsi*stheta*sphi + cpsi*cphi
         a(3,2) = cpsi*stheta*sphi - spsi*cphi
         a(1,3) = -stheta
         a(2,3) = ctheta * spsi
         a(3,3) = ctheta * cpsi
         do while (.not. abort)
            do i = 1, n
               xorig = x(i)
               yorig = y(i)
               zorig = z(i)
               x(i) = a(1,1)*xorig + a(2,1)*yorig + a(3,1)*zorig + xcm
               y(i) = a(1,2)*xorig + a(2,2)*yorig + a(3,2)*zorig + ycm
               z(i) = a(1,3)*xorig + a(2,3)*yorig + a(3,3)*zorig + zcm
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     move stray molecules back into original periodic box
c
      if (mode .eq. 21) then
         do while (.not. abort)
            call unitcell
            if (use_bounds) then
               call lattice
               call molecule
               call bounds
            end if
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     remove molecules to trim periodic box to smaller size
c
      if (mode .eq. 22) then
         xnew = 0.0d0
         ynew = 0.0d0
         znew = 0.0d0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=450,end=450)  xnew
         call nextarg (string,exist)
         if (exist)  read (string,*,err=450,end=450)  ynew
         call nextarg (string,exist)
         if (exist)  read (string,*,err=450,end=450)  znew
  450    continue
         do while (xnew .eq. 0.0d0)
            write (iout,460)
  460       format (/,' Enter Periodic Box Dimensions (X,Y,Z) :  ',$)
            read (input,470)  record
  470       format (a240)
            read (record,*,err=480,end=480)  xnew,ynew,znew
  480       continue
         end do
         if (ynew .eq. 0.0d0)  ynew = xnew
         if (znew .eq. 0.0d0)  znew = xnew
         xbox = xnew
         ybox = ynew
         zbox = znew
         call lattice
         call molecule
         allocate (list(n))
         allocate (keep(n))
         do while (.not. abort)
            do i = 1, n
               list(i) = 1
            end do
            do i = 1, nmol
               init = imol(1,i)
               stop = imol(2,i)
               xcm = 0.0d0
               ycm = 0.0d0
               zcm = 0.0d0
               do j = init, stop
                  k = kmol(j)
                  weigh = mass(k)
                  xcm = xcm + x(k)*weigh
                  ycm = ycm + y(k)*weigh
                  zcm = zcm + z(k)*weigh
               end do
               weigh = molmass(i)
               xcm = xcm / weigh
               ycm = ycm / weigh
               zcm = zcm / weigh
               if (abs(xcm).gt.xbox2 .or. abs(ycm).gt.ybox2
     &                   .or. abs(zcm).gt.zbox2) then
                  do j = init, stop
                     k = kmol(j)
                     list(k) = 0
                  end do
               end if
            end do
            k = 0
            do i = 1, n
               if (list(i) .ne. 0) then
                  k = k + 1
                  keep(k) = i
                  list(i) = k
               end if
            end do
            n = k
            do k = 1, n
               i = keep(k)
               name(k) = name(i)
               x(k) = x(i)
               y(k) = y(i)
               z(k) = z(i)
               type(k) = type(i)
               n12(k) = n12(i)
               do j = 1, n12(k)
                  i12(j,k) = list(i12(j,i))
               end do
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort) then
               multi = .true.
               xbox = xnew
               ybox = ynew
               zbox = znew
               call lattice
               call molecule
            end if
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         deallocate (list)
         deallocate (keep)
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     trim cube to truncated octahedron or rhombic dodecahedron
c
      if (mode.eq.23 .or. mode.eq.24) then
         call unitcell
         do while (xbox .eq. 0.0d0)
            write (iout,490)
  490       format (/,' Enter Edge Length of Cubic Periodic Box :  ',$)
            read (input,500)  record
  500       format (a240)
            read (record,*,err=510,end=510)  xbox
  510       continue
         end do
         ybox = xbox
         zbox = xbox
         nonprism = .false.
         octahedron = .false.
         dodecadron = .false.
         call bounds
         nonprism = .true.
         if (mode .eq. 20)  octahedron = .true.
         if (mode .eq. 21)  dodecadron = .true.
         if (dodecadron)  zbox = xbox * root2
         call lattice
         call molecule
         allocate (list(n))
         allocate (keep(n))
         do while (.not. abort)
            do i = 1, n
               list(i) = 1
            end do
            do i = 1, nmol
               init = imol(1,i)
               stop = imol(2,i)
               xcm = 0.0d0
               ycm = 0.0d0
               zcm = 0.0d0
               do j = init, stop
                  k = kmol(j)
                  weigh = mass(k)
                  xcm = xcm + x(k)*weigh
                  ycm = ycm + y(k)*weigh
                  zcm = zcm + z(k)*weigh
               end do
               weigh = molmass(i)
               xcm = xcm / weigh
               ycm = ycm / weigh
               zcm = zcm / weigh
               if (octahedron) then
                  xcm = xcm - xbox*nint(xcm/xbox)
                  ycm = ycm - ybox*nint(ycm/ybox)
                  zcm = zcm - zbox*nint(zcm/zbox)
                  if (abs(xcm)+abs(ycm)+abs(zcm) .gt. box34) then
                     do j = init, stop
                        k = kmol(j)
                        list(k) = 0
                     end do
                  end if
               else if (dodecadron) then
                  xcm = xcm - xbox*nint(xcm/xbox)
                  ycm = ycm - ybox*nint(ycm/ybox)
                  zcm = zcm - root2*zbox*nint(zcm/(zbox*root2))
                  if (abs(xcm)+abs(ycm)+abs(root2*zcm) .gt. xbox) then
                     do j = init, stop
                        k = kmol(j)
                        list(k) = 0
                     end do
                  end if
               end if
            end do
            k = 0
            do i = 1, n
               if (list(i) .ne. 0) then
                  k = k + 1
                  keep(k) = i
                  list(i) = k
               end if
            end do
            n = k
            do k = 1, n
               i = keep(k)
               name(k) = name(i)
               x(k) = x(i)
               y(k) = y(i)
               z(k) = z(i)
               type(k) = type(i)
               n12(k) = n12(i)
               do j = 1, n12(k)
                  i12(j,k) = list(i12(j,i))
               end do
            end do
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         deallocate (list)
         deallocate (keep)
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     append a second file to the current coordinates file
c
      if (mode .eq. 25) then
         append = .false.
         do while (.not. abort)
            call makeref (1)
            if (append) then
               call getref (3)
            else
               call getxyz
               call makeref (3)
               append = .true.
            end if
            call merge (1)
            call makeref (1)
            call readcart (ixyz,first)
            if (.not. abort)  multi = .true.
            if (multi) then
               call makeref (2)
               call getref (1)
               call prtmod (imod,offset)
               call getref (2)
            end if
         end do
         if (.not. multi) then
            call getref (1)
            goto 20
         end if
      end if
c
c     create random box full of the current coordinates file
c
      if (mode .eq. 26) then
         call makebox
      end if
c
c     solvate the current system by insertion into a solvent box
c
      if (mode .eq. 27) then
         call soak
      end if
c
c     replace random solvent molecules outside solute with ions
c
      if (mode .eq. 28) then
         call molecule
         call addions
      end if
c
c     output final coordinates for single frame and print info
c
      if (opened .and. .not.multi) then
         if (generic) then
            call prtgen (imod)
         else
            call prtmod (imod,offset)
         end if
      end if
      if (opened) then
         close (unit=imod)
         write (iout,520)  modfile(1:trimtext(modfile))
  520    format (/,' New Coordinates Written To :  ',a)
      end if
      close (unit=ixyz)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine prtmod  --  output of atomic coords with offset  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "prtmod" writes out a set of modified Cartesian coordinates
c     with an optional atom number offset to an external file
c
c
      subroutine prtmod (imod,offset)
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use inform
      use titles
      implicit none
      integer i,j,k,imod
      integer offset
      integer size,crdsiz
      real*8 crdmin,crdmax
      character*2 atmc
      character*2 crdc
      character*2 digc
      character*25 fstr
c
c
c     check for large systems needing extended formatting
c
      atmc = 'i6'
      if (n+offset .ge. 100000)  atmc = 'i7'
      if (n+offset .ge. 1000000)  atmc = 'i8'
      crdmin = 0.0d0
      crdmax = 0.0d0
      do i = 1, n
         crdmin = min(crdmin,x(i),y(i),z(i))
         crdmax = max(crdmax,x(i),y(i),z(i))
      end do
      crdsiz = 6
      if (crdmin .le. -1000.0d0)  crdsiz = 7
      if (crdmax .ge. 10000.0d0)  crdsiz = 7
      if (crdmin .le. -10000.0d0)  crdsiz = 8
      if (crdmax .ge. 100000.0d0)  crdsiz = 8
      crdsiz = crdsiz + max(6,digits)
      size = 0
      call numeral (crdsiz,crdc,size)
      if (digits .le. 6) then
         digc = '6 '
      else if (digits .le. 8) then
         digc = '8'
      else
         digc = '10'
      end if
c
c     write out the number of atoms and the title
c
      if (ltitle .eq. 0) then
         fstr = '('//atmc//')'
         write (imod,fstr(1:4))  n
      else
         fstr = '('//atmc//',2x,a)'
         write (imod,fstr(1:9))  n,title(1:ltitle)
      end if
c
c     write out the periodic cell lengths and angles
c
      if (use_bounds) then
         fstr = '(1x,6f'//crdc//'.'//digc//')'
         write (imod,fstr)  xbox,ybox,zbox,alpha,beta,gamma
      end if
c
c     write out the coordinate line for each atom
c
      fstr = '('//atmc//',2x,a3,3f'//crdc//
     &          '.'//digc//',i6,8'//atmc//')'
      do i = 1, n
         k = n12(i)
         if (k .eq. 0) then
            write (imod,fstr)  i+offset,name(i),x(i),y(i),z(i),type(i)
         else
            write (imod,fstr)  i+offset,name(i),x(i),y(i),z(i),type(i),
     &                         (i12(j,i)+offset,j=1,k)
         end if
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine prtgen  --  output of generic atomic coords  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "prtgen" writes out a set of Cartesian coordinates to an
c     external file in a simple generic format
c
c
      subroutine prtgen (imod)
      use atomid
      use atoms
      use inform
      use titles
      implicit none
      integer i,imod
      integer size,crdsiz
      real*8 crdmin,crdmax
      character*2 crdc
      character*2 digc
      character*10 atmc
      character*25 fstr
c
c
c     check for large systems needing extended formatting
c
      crdmin = 0.0d0
      crdmax = 0.0d0
      do i = 1, n
         crdmin = min(crdmin,x(i),y(i),z(i))
         crdmax = max(crdmax,x(i),y(i),z(i))
      end do
      crdsiz = 6
      if (crdmin .le. -1000.0d0)  crdsiz = 7
      if (crdmax .ge. 10000.0d0)  crdsiz = 7
      if (crdmin .le. -10000.0d0)  crdsiz = 8
      if (crdmax .ge. 100000.0d0)  crdsiz = 8
      crdsiz = crdsiz + max(6,digits)
      size = 0
      call numeral (crdsiz,crdc,size)
      if (digits .le. 6) then
         digc = '6 '
      else if (digits .le. 8) then
         digc = '8'
      else
         digc = '10'
      end if
c
c     write out the number of atoms and the title
c
      size = 1
      call numeral (n,atmc,size)
      fstr = '('//'a'//')'
      write (imod,fstr(1:3))  atmc(1:size)
      if (ltitle .eq. 0) then
         fstr = '('//')'
         write (imod,fstr(1:2))
      else
         fstr = '('//'a'//')'
         write (imod,fstr(1:3))  title(1:ltitle)
      end if
c
c     write out the coordinate line for each atom
c
      fstr = '(a3,3f'//crdc//'.'//digc//')'
      do i = 1, n
         write (imod,fstr)  name(i),x(i),y(i),z(i)
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine makebox  --  build periodic box from monomers  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "makebox" builds a periodic box of a desired size by randomly
c     copying a specified number of monomers into a target box size,
c     followed by optional excluded volume refinement
c
c
      subroutine makebox
      use atomid
      use atoms
      use boxes
      use couple
      use iounit
      implicit none
      integer i,j,k,m
      integer ncopy
      integer offset
      real*8 xcm,ycm,zcm
      real*8 phi,theta,psi
      real*8 cphi,ctheta,cpsi
      real*8 sphi,stheta,spsi
      real*8 random,reduce
      real*8 norm,weigh
      real*8, allocatable :: x0(:)
      real*8, allocatable :: y0(:)
      real*8, allocatable :: z0(:)
      real*8 a(3,3)
      logical exist,query
      logical refine
      character*1 answer
      character*240 record
      character*240 string
c
c
c     get the number of copies of the monomer to be used
c
      ncopy = 0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  ncopy
   10 continue
      if (ncopy .eq. 0)  then
         write (iout,20)
   20    format (/,' Enter Number of Copies to Put in Box :  ',$)
         read (input,30)  ncopy
   30    format (i10)
      end if
c
c     find the size of the periodic box to be constructed
c
      xbox = 0.0d0
      ybox = 0.0d0
      zbox = 0.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=40,end=40)  xbox
      call nextarg (string,exist)
      if (exist)  read (string,*,err=40,end=40)  ybox
      call nextarg (string,exist)
      if (exist)  read (string,*,err=40,end=40)  zbox
   40 continue
      do while (xbox .eq. 0.0d0)
         write (iout,50)
   50    format (/,' Enter Periodic Box Dimensions (X,Y,Z) :  ',$)
         read (input,60)  record
   60    format (a240)
         read (record,*,err=70,end=70)  xbox,ybox,zbox
   70    continue
      end do
      if (ybox .eq. 0.0d0)  ybox = xbox
      if (zbox .eq. 0.0d0)  zbox = xbox
      orthogonal = .true.
c
c     decide whether to use excluded volume refinement
c
      refine = .true.
      answer = 'Y'
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=80,end=80)  answer
         query = .false.
      end if
   80 continue
      if (query) then
         write (iout,90)
   90    format (/,' Refine the Periodic Box Configuration',
     &              ' [Y] :  ',$)
         read (input,100)  answer
  100    format (a1)
      end if
      call upcase (answer)
      if (answer .eq. 'N')  refine = .false.
c
c     center the monomer and reduce its size to avoid overlap
c
      xcm = 0.0d0
      ycm = 0.0d0
      zcm = 0.0d0
      norm = 0.0d0
      do i = 1, n
         weigh = mass(i)
         xcm = xcm + x(i)*weigh
         ycm = ycm + y(i)*weigh
         zcm = zcm + z(i)*weigh
         norm = norm + weigh
      end do
      xcm = xcm / norm
      ycm = ycm / norm
      zcm = zcm / norm
      allocate (x0(n))
      allocate (y0(n))
      allocate (z0(n))
      reduce = 0.001d0
      do i = 1, n
         x(i) = x(i) - xcm
         y(i) = y(i) - ycm
         z(i) = z(i) - zcm
         if (refine) then
            x(i) = reduce * x(i)
            y(i) = reduce * y(i)
            z(i) = reduce * z(i)
         end if
         x0(i) = x(i)
         y0(i) = y(i)
         z0(i) = z(i)
      end do
c
c     randomly place monomer copies in the periodic box
c
      do k = 1, ncopy
         offset = (k-1) * n
         xcm = xbox * (random()-0.5d0)
         ycm = ybox * (random()-0.5d0)
         zcm = zbox * (random()-0.5d0)
         phi = 360.0d0 * random ()
         theta = 360.0d0 * random ()
         psi = 360.0d0 * random ()
         cphi = cos(phi)
         sphi = sin(phi)
         ctheta = cos(theta)
         stheta = sin(theta)
         cpsi = cos(psi)
         spsi = sin(psi)
         a(1,1) = ctheta * cphi
         a(2,1) = spsi*stheta*cphi - cpsi*sphi
         a(3,1) = cpsi*stheta*cphi + spsi*sphi
         a(1,2) = ctheta * sphi
         a(2,2) = spsi*stheta*sphi + cpsi*cphi
         a(3,2) = cpsi*stheta*sphi - spsi*cphi
         a(1,3) = -stheta
         a(2,3) = ctheta * spsi
         a(3,3) = ctheta * cpsi
         do i = 1, n
            j = i + offset
            name(j) = name(i)
            type(j) = type(i)
            mass(j) = mass(i)
            x(j) = a(1,1)*x0(i) + a(2,1)*y0(i) + a(3,1)*z0(i) + xcm
            y(j) = a(1,2)*x0(i) + a(2,2)*y0(i) + a(3,2)*z0(i) + ycm
            z(j) = a(1,3)*x0(i) + a(2,3)*y0(i) + a(3,3)*z0(i) + zcm
            n12(j) = n12(i)
            do m = 1, n12(i)
               i12(m,j) = i12(m,i) + offset
            end do
         end do
      end do
      deallocate (x0)
      deallocate (y0)
      deallocate (z0)
      offset = 0
      n = ncopy * n
c
c     optionally perform excluded volume coordinate refinement
c
      if (refine) then
         call boxfix
         call bounds
      else
         call lattice
         call molecule
         call bounds
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine boxfix  --  expand molecules into periodic box  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "boxfix" uses minimization of valence and vdw potential energy
c     to expand and refine a collection of solvent molecules in a
c     periodic box
c
c
      subroutine boxfix
      use atomid
      use atoms
      use boxes
      use inform
      use limits
      use linmin
      use minima
      use neigh
      use output
      use potent
      use scales
      use vdw
      use vdwpot
      implicit none
      integer i,j,k,nvar
      integer ii,kk
      real*8 minimum
      real*8 boxfix1
      real*8 grdmin
      real*8 boxsiz
      real*8, allocatable :: xx(:)
      external boxfix1
      external optsave
c
c
c     setup for minimization with only valence and vdw terms
c
      call mechanic
      call potoff
      use_bond = .true.
      use_angle = .true.
      use_opbend = .true.
      use_opdist = .true.
      use_improp = .true.
      use_imptor = .true.
      use_tors = .true.
      use_vdw = .true.
c
c     set artificial Lennard-Jones vdw values for the system
c
      vdwtyp = 'LENNARD-JONES'
      nvdw = n
      do i = 1, n
         ivdw(i) = i
         jvdw(i) = mvdw(class(i))
         ired(i) = i
      end do
      do i = 1, n-1
         ii = jvdw(i)
         do k = i+1, n
            kk = jvdw(k)
            if (atomic(i).eq.1 .and. atomic(k).eq.1) then
               radmin(ii,kk) = 2.90d0
               epsilon(ii,kk) = 0.016d0
               radmin4(ii,kk) = 2.90d0
               epsilon4(ii,kk) = 0.016d0
            else if (atomic(i).eq.1 .or. atomic(k).eq.1) then
               radmin(ii,kk) = 3.35d0
               epsilon(ii,kk) = 0.040d0
               radmin4(ii,kk) = 3.35d0
               epsilon4(ii,kk) = 0.040d0
            else
               radmin(ii,kk) = 3.80d0
               epsilon(ii,kk) = 0.100d0
               radmin4(ii,kk) = 3.80d0
               epsilon4(ii,kk) = 0.100d0
            end if
         end do
      end do
c
c     cutoff values and neighbor lists for vdw interactions
c
      use_list = .false.
      use_vlist = .false.
      vdwcut = 5.0d0
      vdwtaper = 4.5d0
      lbuffer = 1.0d0
      boxsiz = min(xbox,ybox,zbox)
      if (boxsiz .gt. 2.0d0*(vdwcut+lbuffer)) then
         use_list = .true.
         use_vlist = .true.
         dovlst = .true.
         lbuf2 = (0.5d0*lbuffer)**2
         vbuf2 = (vdwcut+lbuffer)**2
         vbufx = (vdwcut+2.0d0*lbuffer)**2
         maxvlst = int(sqrt(vbuf2)**3) + 100
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (use_vlist) then
         if (allocated(nvlst))  deallocate (nvlst)
         if (allocated(vlst))  deallocate (vlst)
         if (allocated(xvold))  deallocate (xvold)
         if (allocated(yvold))  deallocate (yvold)
         if (allocated(zvold))  deallocate (zvold)
         allocate (nvlst(n))
         allocate (vlst(maxvlst,n))
         allocate (xvold(n))
         allocate (yvold(n))
         allocate (zvold(n))
      end if
c
c     perform dynamic allocation of some global arrays
c
      if (.not. allocated(scale))  allocate (scale(3*n))
c
c     mark for use of all atoms, and set scale factors
c
      nvar = 0
      do i = 1, n
         do j = 1, 3
            nvar = nvar + 1
            scale(nvar) = 12.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (xx(nvar))
c
c     scale the coordinates of each active atom
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         xx(nvar) = x(i) * scale(nvar)
         nvar = nvar + 1
         xx(nvar) = y(i) * scale(nvar)
         nvar = nvar + 1
         xx(nvar) = z(i) * scale(nvar)
      end do
c
c     make the call to the optimization routine
c
      iprint = 100
      maxiter = 10000
      stpmax = 10.0d0
      grdmin = 1.0d0
      coordtype = 'NONE'
      call lbfgs (nvar,xx,minimum,grdmin,boxfix1,optsave)
c
c     unscale the final coordinates for active atoms
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar) / scale(nvar)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xx)
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  function boxfix1  --  energy and gradient for boxfix  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "boxfix1" is a service routine that computes the energy and
c     gradient during refinement of a periodic box
c
c
      function boxfix1 (xx,g)
      use atoms
      use energi
      use potent
      use repel
      use scales
      implicit none
      integer i,nvar
      real*8 e,boxfix1
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
c
c
c     convert optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         x(i) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         y(i) = xx(nvar) / scale(nvar)
         nvar = nvar + 1
         z(i) = xx(nvar) / scale(nvar)
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the energy and gradient
c
      call gradient (e,derivs)
      boxfix1 = e
c
c     convert gradient components to optimization parameters
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         g(nvar) = derivs(1,i) / scale(nvar)
         nvar = nvar + 1
         g(nvar) = derivs(2,i) / scale(nvar)
         nvar = nvar + 1
         g(nvar) = derivs(3,i) / scale(nvar)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine soak  --  place a solute into a solvent box  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "soak" takes a currently defined solute system and places
c     it into a solvent box, with removal of any solvent molecules
c     that overlap the solute
c
c
      subroutine soak
      use atomid
      use atoms
      use bound
      use boxes
      use couple
      use files
      use inform
      use iounit
      use molcul
      use output
      use refer
      implicit none
      integer i,j,k
      integer ii,jj
      integer n12i,n12k
      integer isolv,iaux
      integer icount,nask
      integer ntot,freeunit
      integer, allocatable :: map(:)
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rik2,close2
      real*8 dxx,dxx2
      real*8 dxh,dxh2
      real*8 dhh,dhh2
      logical exist,header
      logical first
      logical, allocatable :: remove(:)
      character*240 solvfile
      character*240 auxfile
      external merge
c
c
c     make a copy of the solute coordinates and connectivities
c
      call makeref (1)
c
c     get the filename for the solvent box coordinates
c
      call nextarg (solvfile,exist)
      if (exist) then
         call basefile (solvfile)
         call suffix (solvfile,'xyz','old')
         inquire (file=solvfile,exist=exist)
      end if
      nask = 0
      do while (.not.exist .and. nask.lt.maxask)
         write (iout,10)
   10    format (/,' Enter Name of Solvent Box Coordinates :  ',$)
         read (input,20)  solvfile
   20    format (a240)
         call basefile (solvfile)
         if (archive) then
            call suffix (solvfile,'xyz','old')
         else if (binary) then
            call suffix (solvfile,'dcd','old')
         end if
         inquire (file=solvfile,exist=exist)
      end do
c
c     read the coordinate file containing the solvent atoms
c
      if (archive) then
         isolv = freeunit ()
         open (unit=isolv,file=solvfile,status='old')
         rewind (unit=isolv)
         call readxyz (isolv)
         close (unit=isolv)
      else if (binary) then
         call nextarg (auxfile,exist)
         if (exist) then
            call basefile (auxfile)
            call suffix (auxfile,'xyz','old')
            inquire (file=auxfile,exist=exist)
         end if
         nask = 0
         do while (.not.exist .and. nask.lt.maxask)
            nask = nask + 1
            write (iout,30)
   30       format (/,' Enter Formatted Coordinate File Name :  ',$)
            read (input,40)  auxfile
   40       format (a240)
            call basefile (auxfile)
            call suffix (auxfile,'xyz','old')
            inquire (file=auxfile,exist=exist)
         end do
         if (.not. exist)  call fatal
         iaux = freeunit ()
         open (unit=iaux,file=auxfile,status='old')
         rewind (unit=iaux)
         call readxyz (iaux)
         close (unit=iaux)
         filename = solvfile
         isolv = freeunit ()
         open (unit=isolv,file=solvfile,form='unformatted',status='old')
         rewind (unit=isolv)
         first = .true.
         call readdcd (isolv,first)
         close (unit=isolv)
      end if
c
c     combine solute and solvent into a single coordinate set
c
      call merge (1)
      call basefile (solvfile)
      call getkey
c
c     reset the default values for unitcell dimensions
c
      xbox = 0.0d0
      ybox = 0.0d0
      zbox = 0.0d0
      alpha = 0.0d0
      beta = 0.0d0
      gamma = 0.0d0
c
c     count number of molecules and set lattice parameters
c
      call molecule
      call unitcell
      call lattice
c
c     set distance cutoffs for solute-solvent close contacts
c
      dxx = 2.40d0
      dxh = 2.19d0
      dhh = 1.82d0
      dxx2 = dxx * dxx
      dxh2 = dxh * dxh
      dhh2 = dhh * dhh
c
c     perform dynamic allocation of some local arrays
c
      allocate (map(n))
      allocate (remove(nmol))
c
c     initialize the list of solvent molecules to be deleted
c
      do i = 1, nmol
         remove(i) = .false.
      end do
c
c     print header information when processing large systems
c
      icount = 0
      header = .true.
      if (n-nref(1) .ge. 10000) then
         write (iout,50)
   50    format (/,' Scan for Solvent Molecules to be Removed :')
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(nref,n,x,y,z,n12,molcule,dxx2,dxh2,dhh2,remove,
!$OMP& header,icount,iout)
!$OMP DO
c
c     search for close contacts between solute and solvent
c
      do i = nref(1)+1, n
         if (.not. remove(molcule(i))) then
            xi = x(i)
            yi = y(i)
            zi = z(i)
            n12i = n12(i)
            do k = 1, nref(1)
               n12k = n12(k)
               xr = x(k) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               call imagen (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
               if (n12i.gt.1 .and. n12k.gt.1) then
                  close2 = dxx2
               else if (n12i.gt.1 .or. n12k.gt.1) then
                  close2 = dxh2
               else
                  close2 = dhh2
               end if
               if (rik2 .lt. close2) then
                  remove(molcule(i)) = .true.
                  goto 60
               end if
            end do
   60       continue
         end if
         icount = icount + 1
         if (mod(icount,10000) .eq. 0) then
            if (header) then
               header = .false.
               write (iout,70)
   70          format ()
            end if
            write (iout,80)  10000*(icount/10000)
   80       format (' Solvent Atoms Processed',i15)
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     print final status when processing large systems
c
      icount = n - nref(1)
      if (mod(icount,10000).ne.0 .and. icount.gt.10000) then
         write (iout,90)  icount
   90    format (' Solvent Atoms Processed',i15)
      end if
c
c     delete solvent molecules that are too close to the solute
c
      k = nref(1)
      ntot = k
      do i = nref(1)+1, n
         map(i) = 0
         if (.not. remove(molcule(i))) then
            k = k + 1
            map(i) = k
            ntot = k
         end if
      end do
      do i = nref(1)+1, n
         ii = map(i)
         if (ii .ne. 0) then
            x(ii) = x(i)
            y(ii) = y(i)
            z(ii) = z(i)
            name(ii) = name(i)
            type(ii) = type(i)
            k = 0
            do j = 1, n12(i)
               jj = map(i12(j,i))
               if (jj .ne. 0) then
                  k = k + 1
                  i12(k,ii) = jj
               end if
            end do
            n12(ii) = k
         end if
      end do
      n = ntot
c
c     perform deallocation of some local arrays
c
      deallocate (map)
      deallocate (remove)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine addions  --  placement of ions around solute  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "addions" takes a currently defined solvated system and
c     places ions, with removal of solvent molecules
c
c
      subroutine addions
      use atomid
      use atoms
      use couple
      use iounit
      use katoms
      use molcul
      implicit none
      integer i,j,k
      integer nsolute,size
      integer start,stop
      integer icount,iontyp
      integer ncopy,ranatm
      integer, allocatable :: list(:)
      integer, allocatable :: isolute(:)
      real*8 xi,yi,zi
      real*8 xr,yr,zr,rik2
      real*8 close,close2
      real*8 rand,random
      real*8 weigh,xmid,ymid,zmid
      real*8, allocatable :: xion(:)
      real*8, allocatable :: yion(:)
      real*8, allocatable :: zion(:)
      logical exist,header,done
      logical, allocatable :: remove(:)
      character*240 record
      character*240 string
      external random
c
c
c     perform dynamic allocation of some local arrays
c
      size = 40
      allocate (list(size))
      allocate (isolute(n))
c
c     get the range atoms numbers constituting the solute
c
      do i = 1, size
         list(i) = 0
      end do
      i = 0
      do while (exist)
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=10,end=10)  list(i+1)
            i = i + 1
         end if
      end do
   10 continue
      if (i .eq. 0) then
         write (iout,20)
   20    format (/,' Enter Atom Numbers in Solute Molecules :  ',$)
         read (input,30)  record
   30    format (a240)
         read (record,*,err=40,end=40)  (list(i),i=1,size)
   40    continue
      end if
      i = 1
      nsolute = 0
      do while (list(i) .ne. 0)
         list(i) = max(-n,min(n,list(i)))
         if (list(i) .gt. 0) then
            k = list(i)
            nsolute = nsolute + 1
            isolute(nsolute) = k
            i = i + 1
         else
            list(i+1) = max(-n,min(n,list(i+1)))
            do k = abs(list(i)), abs(list(i+1))
               nsolute = nsolute + 1
               isolute(nsolute) = k
            end do
            i = i + 2
         end if
      end do
c
c     get the atom type of ion to be added and number of copies
c
   50 continue
      iontyp = 0
      ncopy = 0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=60,end=60)  iontyp
      call nextarg (string,exist)
      if (exist)  read (string,*,err=60,end=60)  ncopy
   60 continue
      if (iontyp.eq.0 .or. ncopy.eq.0) then
         write (iout,70)
   70    format (/,' Enter Ion Atom Type Number & Copies to Add :  ',$)
         read (input,80)  record
   80    format (a240)
      end if
      read (record,*,err=50,end=50)  iontyp,ncopy
c
c     set minimum distance cutoff for solute-ion contacts
c
      close = 6.0d0
      close2 = close * close
c
c     perform dynamic allocation of some local arrays
c
      allocate (remove(nmol))
      allocate (xion(ncopy))
      allocate (yion(ncopy))
      allocate (zion(ncopy))
c
c     initialize the list of solvent molecules to be deleted
c
      do i = 1, nmol
         remove(i) = .false.
      end do
c
c     print header information when processing large systems
c
      icount = 0
      header = .true.
      if (n .ge. 10000) then
         write (iout,90)
   90    format (/,' Scan for Available Locations to Place Ions :')
      end if
c
c     OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private)
!$OMP& shared(n,x,y,z,molcule,close2,remove,header,nsolute,
!$OMP& isolute,icount,iout)
!$OMP DO
c
c     search for short distance between solute and solvent
c
      do i = 1, n
         if (.not. remove(molcule(i))) then
            xi = x(i)
            yi = y(i)
            zi = z(i)
            do k = 1, nsolute
               j = isolute(k)
               xr = x(j) - xi
               yr = y(j) - yi
               zr = z(j) - zi
               call imagen (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
               if (rik2 .lt. close2) then
                  remove(molcule(i)) = .true.
                  goto 100
               end if
            end do
  100       continue
         end if
         icount = icount + 1
         if (mod(icount,10000) .eq. 0) then
            if (header) then
               header = .false.
               write (iout,110)
  110          format ()
            end if
            write (iout,120)  10000*(icount/10000)
  120       format (' Solvent Atoms Processed',i15)
         end if
      end do
c
c     OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     perform deallocation of some local arrays
c
      deallocate (list)
      deallocate (isolute)
c
c     print final status when processing large systems
c
      if (mod(n,10000).ne.0 .and. n.gt.10000) then
         write (iout,130)  n
  130    format (' Solvent Atoms Processed',i15)
      end if
c
c     randomly replace the solvent molecules with ions
c
      do i = 1, ncopy
         done = .false.
         do while (.not. done)
            rand = random ()
            ranatm = int(rand*dble(n)) + 1
c
c     check solute distance, then delete polyatomic molecule
c
            if (.not. remove(molcule(ranatm))) then
               start = imol(1,molcule(ranatm))
               stop = imol(2,molcule(ranatm))
               if (start .eq. stop) then
                  done = .false.
               else
                  done = .true.
                  xmid = 0.0d0
                  ymid = 0.0d0
                  zmid = 0.0d0
                  do k = stop, start, -1
                     weigh = mass(k)
                     xmid = xmid + x(k)*weigh
                     ymid = ymid + y(k)*weigh
                     zmid = zmid + z(k)*weigh
                     call delete (k)
                  end do
                  weigh = molmass(molcule(ranatm))
                  xion(i) = xmid / weigh
                  yion(i) = ymid / weigh
                  zion(i) = zmid / weigh
               end if
            end if
         end do
      end do
c
c     insert new monoatomic ions at saved centers of mass
c
      do i = 1, ncopy
         n = n + 1
         name(n) = symbol(iontyp)
         x(n) = xion(i)
         y(n) = yion(i)
         z(n) = zion(i)
         type(n) = iontyp
         n12(n) = 0
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (remove)
      deallocate (xion)
      deallocate (yion)
      deallocate (zion)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  program xyzint  --  Cartesian to internal coordinates  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "xyzint" takes as input a Cartesian coordinates file, then
c     converts to and writes out an internal coordinates file
c
c
      program xyzint
      use files
      use iounit
      use titles
      implicit none
      integer izmt,mode
      integer next,freeunit
      logical exist
      character*1 answer
      character*240 intfile
      character*240 record
c
c
c     get and read the Cartesian coordinates file
c
      call initial
      call getxyz
      write (iout,10)  title(1:ltitle)
   10 format (/,' Title :  ',a)
c
c     set the mode for conversion to internal coordinates
c
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,20)
   20    format (/,' Template (T), Dihedrals (D), Manual (M)',
     &              ' or Automatic [A] :  ',$)
         read (input,30)  record
   30    format (a240)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      mode = 0
      if (answer .eq. 'M') then
         mode = 1
      else if (answer .eq. 'T') then
         mode = 2
         intfile = filename(1:leng)//'.int'
         call version (intfile,'old')
         inquire (file=intfile,exist=exist)
         if (exist) then
            izmt = freeunit ()
            open (unit=izmt,file=intfile,status='old')
            rewind (unit=izmt)
            call readint (izmt)
            close (unit=izmt)
         else
            mode = 0
            write (iout,40)
   40       format (/,' XYZINT  --  Warning, Template File was',
     &                 ' not Found')
         end if
      else if (answer .eq. 'D') then
         mode = 3
      end if
c
c     convert from Cartesian to internal coordinates
c
      call makeint (mode)
c
c     write out the internal coordinates file
c
      izmt = freeunit ()
      intfile = filename(1:leng)//'.int'
      call version (intfile,'new')
      open (unit=izmt,file=intfile,status='new')
      call prtint (izmt)
      close (unit=izmt)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program xyzmol2  --  Cartesian coordinates to Tripos MOL2  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "xyzmol2" takes as input a Cartesian coordinates file,
c     converts to and then writes out a Tripos MOL2 file
c
c
      program xyzmol2
      use files
      use iounit
      use titles
      implicit none
      integer imol2,freeunit
      character*240 mol2file
c
c
c     get and read the Cartesian coordinates file
c
      call initial
      call getxyz
      write (iout,10)  title(1:ltitle)
   10 format (' Title :  ',a)
c
c     find the connectivity and rings in the structure
c
      call attach
      call bonds
      call angles
      call torsions
      call bitors
      call rings
c
c     open a new version of the Tripos MOL2 file
c
      imol2 = freeunit ()
      mol2file = filename(1:leng)//'.mol2'
      call version (mol2file,'new')
      open (unit=imol2,file=mol2file,status='new')
c
c     output the coordinates into Tripos MOL2 format
c
      call prtmol2 (imol2)
      close (unit=imol2)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  program xyzpdb  --  Cartesian to Protein Data Bank file  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "xyzpdb" takes as input a Tinker Cartesian coordinates file,
c     then converts to and writes out an RCSB Protein Data Bank file
c
c
      program xyzpdb
      use files
      use inform
      use iounit
      use pdb
      implicit none
      integer i,ipdb,ixyz
      integer next,freeunit
      logical exist,multi
      character*7 fstr
      character*240 record
      character*240 string
      character*240 pdbfile
      character*240 xyzfile
c
c
c     get the Cartesian coordinates file for the system
c
      call initial
      call getxyz
c
c     get atomic number of each atom and count the molecules
c
      call attach
      call field
      call katom
      call molecule
c
c     get the format to be used for the Protein Data Bank file
c
      pdbtyp = '   '
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  pdbtyp
      call upcase (pdbtyp)
   10 continue
      if (pdbtyp.ne.'PDB' .and. pdbtyp.ne.'CIF') then
         write (iout,20)
   20    format (/,' Use PDB or CIF Format for Protein Data',
     &              ' Bank File [PDB] :  ',$)
         read (input,30)  record
   30    format (a240)
         next = 1
         call gettext (record,pdbtyp,next)
         call upcase (pdbtyp)
         if (pdbtyp .ne. 'CIF')  pdbtyp = 'PDB'
      end if
c
c     check for multiple coordinate sets and get first structure
c
      ixyz = freeunit ()
      xyzfile = filename
      call suffix (xyzfile,'xyz','old')
      open (unit=ixyz,file=xyzfile,status ='old')
      rewind (unit=ixyz)
      call readxyz (ixyz)
      call readxyz (ixyz)
      multi = .true.
      if (abort)  multi = .false.
      rewind (unit=ixyz)
      call readxyz (ixyz)
c
c     open the Protein Data Bank file to be used for output
c
      ipdb = freeunit ()
      if (pdbtyp .eq. 'PDB')  pdbfile = filename(1:leng)//'.pdb'
      if (pdbtyp .eq. 'CIF')  pdbfile = filename(1:leng)//'.cif'
      call version (pdbfile,'new')
      open (unit=ipdb,file=pdbfile,status='new')
c
c     add each successive coordinate frame to the PDB file
c
      imodel = 0
      do while (.not. abort)
         if (multi)  imodel = imodel + 1
         call makepdb
         if (pdbtyp .eq. 'PDB')  call prtpdb (ipdb)
         if (pdbtyp .eq. 'CIF')  call prtcif (ipdb)
         call readxyz (ixyz)
      end do
c
c     append termination record to the end of the PDB file
c
      if (pdbtyp .eq. 'PDB') then
         fstr = '(''END'')'
         write (ipdb,fstr(1:7))
      else if (pdbtyp .eq. 'CIF') then
         fstr = '(''# '')'
         write (ipdb,fstr(1:6))
      end if
c
c     perform any final tasks before program exit
c
      close (unit=ixyz)
      close (unit=ipdb)
      call final
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine makepdb  --  build PDB from Cartesian coords  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "makepdb" cconstructs a Protein Data Bank file from a set
c     of Cartesian coordinates with special handling for systems
c     consisting of biopolymer chains, ligands and water molecules
c
c
      subroutine makepdb
      use atomid
      use atoms
      use couple
      use files
      use molcul
      use pdb
      use resdue
      use sequen
      implicit none
      integer i,j,k,m,ii
      integer kp,ka,kn
      integer iseq,freeunit
      integer start,stop
      integer pdbnum,atmnum
      integer justify,cbi
      integer noxy,nhyd
      integer ndum,ntot
      integer, allocatable :: ni(:)
      integer, allocatable :: cai(:)
      integer, allocatable :: ci(:)
      integer, allocatable :: oi(:)
      integer, allocatable :: poi(:)
      integer, allocatable :: op1(:)
      integer, allocatable :: op2(:)
      integer, allocatable :: op3(:)
      integer, allocatable :: c5i(:)
      integer, allocatable :: o5i(:)
      integer, allocatable :: c4i(:)
      integer, allocatable :: o4i(:)
      integer, allocatable :: c3i(:)
      integer, allocatable :: o3i(:)
      integer, allocatable :: c2i(:)
      integer, allocatable :: o2i(:)
      integer, allocatable :: c1i(:)
      logical exist,generic
      logical cbone,nbone,obone
      logical first
      logical, allocatable :: water(:)
      logical, allocatable :: hetmol(:)
      character*3 resname
      character*4 atmname
      character*7, allocatable :: restyp(:)
      character*240 seqfile
      save first
      data first  / .true. /
c
c
c     perform dynamic allocation of some global arrays
c
      if (first) then
         first = .false.
         if (.not. allocated(resnum))  allocate (resnum(maxatm))
         if (.not. allocated(resatm))  allocate (resatm(2,maxatm))
         if (.not. allocated(pdbmod))  allocate (pdbmod(maxatm))
         if (.not. allocated(npdb12))  allocate (npdb12(maxatm))
         if (.not. allocated(ipdb12))  allocate (ipdb12(maxval,maxatm))
         if (.not. allocated(pdblist))  allocate (pdblist(maxatm))
         if (.not. allocated(xpdb))  allocate (xpdb(maxatm))
         if (.not. allocated(ypdb))  allocate (ypdb(maxatm))
         if (.not. allocated(zpdb))  allocate (zpdb(maxatm))
         if (.not. allocated(pdbres))  allocate (pdbres(maxatm))
         if (.not. allocated(pdbatm))  allocate (pdbatm(maxatm))
         if (.not. allocated(pdbsym))  allocate (pdbsym(maxatm))
         if (.not. allocated(pdbrec))  allocate (pdbrec(maxatm))
      end if
c
c     initialize number of PDB atoms and atom mapping
c
      npdb = 0
      do i = 1, n
         pdblist(i) = 0
      end do
c
c     read the biopolymer sequence file if one exists
c
      iseq = freeunit ()
      seqfile = filename(1:leng)//'.seq'
      call version (seqfile,'old')
      inquire (file=seqfile,exist=exist)
      if (exist) then
         open (unit=iseq,file=seqfile,status='old')
         rewind (unit=iseq)
         call readseq (iseq)
         close (unit=iseq)
      end if
c
c     check for the existence of a generic sequence file
c
      if (.not. exist) then
         if (ldir .eq. 0) then
            seqfile = 'tinker.seq'
         else
            seqfile = filename(1:ldir)//'tinker.seq'
         end if
         call version (seqfile,'old')
         inquire (file=seqfile,exist=exist)
         if (exist) then
            open (unit=iseq,file=seqfile,status='old')
            rewind (unit=iseq)
            call readseq (iseq)
            close (unit=iseq)
         end if
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (ni(maxres))
      allocate (cai(maxres))
      allocate (ci(maxres))
      allocate (oi(maxres))
      allocate (poi(maxres))
      allocate (op1(maxres))
      allocate (op2(maxres))
      allocate (op3(maxres))
      allocate (c5i(maxres))
      allocate (o5i(maxres))
      allocate (c4i(maxres))
      allocate (o4i(maxres))
      allocate (c3i(maxres))
      allocate (o3i(maxres))
      allocate (c2i(maxres))
      allocate (o2i(maxres))
      allocate (c1i(maxres))
      allocate (restyp(maxres))
c
c     zero out the backbone atoms for biopolymer sequences
c
      do i = 1, nseq
         ni(i) = 0
         cai(i) = 0
         ci(i) = 0
         oi(i) = 0
         poi(i) = 0
         op1(i) = 0
         op2(i) = 0
         op3(i) = 0
         c5i(i) = 0
         o5i(i) = 0
         c4i(i) = 0
         o4i(i) = 0
         c3i(i) = 0
         o3i(i) = 0
         c2i(i) = 0
         o2i(i) = 0
         c1i(i) = 0
      end do
c
c     set the molecule type for each residue via chain type
c
      generic = .true.
      do i = 1, nchain
         do j = ichain(1,i), ichain(2,i)
            restyp(j) = 'GENERIC'
            if (chntyp(i) .eq. 'PEPTIDE')  restyp(j) = 'PEPTIDE'
            if (chntyp(i) .eq. 'NUCLEIC')  restyp(j) = 'NUCLEIC'
         end do
         if (restyp(j)  .ne. 'GENERIC')  generic = .false.
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (water(nmol))
c
c     check each molecule to see if it is a water molecule
c
      do i = 1, nmol
         water(i) = .false.
         ntot = imol(2,i) - imol(1,i)
         if (ntot .le. 4) then
            noxy = 0
            nhyd = 0
            ndum = 0
            do j = imol(1,i), imol(2,i)
               k = kmol(j)
               if (atomic(k) .eq. 8)  noxy = noxy + 1
               if (atomic(k) .eq. 1)  nhyd = nhyd + 1
               if (atomic(k) .le. 0)  ndum = ndum + 1
            end do
            if (noxy.eq.1 .and. nhyd.eq.2 .and.
     &             noxy+nhyd+ndum.eq.ntot)  water(i) = .true.
         end if
      end do
c
c     for general structures, transfer each atom to PDB format
c
      if (generic) then
         do i = 1, nmol
            do j = imol(1,i), imol(2,i)
               k = kmol(j)
               atmname = ' '//name(k)
               if (water(i)) then
                  resname = 'HOH'
               else
                  justify = 0
                  call numeral (type(k),resname,justify)
               end if
               pdbnum = i
               call pdbatom (atmname,resname,pdbnum,k)
               pdbrec(npdb) = 'HETATM'
            end do
         end do
         do i = 1, nmol
            do j = imol(1,i), imol(2,i)
               k = kmol(j)
               kp = pdblist(k)
               npdb12(kp) = n12(k)
               do m = 1, n12(k)
                  ipdb12(m,kp) = pdblist(i12(m,k))
               end do
            end do
         end do
      end if
c
c     find the amide nitrogens and other peptide backbone atoms
c
      m = 1
      do i = 1, n
         if (restyp(m) .eq. 'PEPTIDE') then
            resname = amino(seqtyp(m))
            if (resname .eq. 'H2N') then
               m = m + 1
               resname = amino(seqtyp(m))
               if (atomic(i) .eq. 7) then
                  obone = .false.
                  do j = 1, n14(i)
                     k = i14(j,i)
                     if (atomic(k) .eq. 8) then
                        obone = .true.
                     end if
                  end do
                  if (obone) then
                     ni(m) = i
                     cai(m) = i + 1
                     ci(m) = i + 2
                     oi(m) = i + 3
                     m = m + 1
                  end if
               end if
            else if (resname .eq. 'FOR') then
               if (atomic(i) .eq. 6) then
                  nbone = .false.
                  obone = .false.
                  do j = 1, n12(i)
                     k = i12(j,i)
                     if (atomic(k) .eq. 7) then
                        nbone = .true.
                     else if (atomic(k) .eq. 8) then
                        obone = .true.
                     end if
                  end do
                  if (nbone .and. obone) then
                     cai(m) = i
                     ci(m) = i
                     oi(m) = i + 1
                     m = m + 1
                  end if
               end if
            else if (resname .eq. 'ACE') then
               if (atomic(i) .eq. 6) then
                  nbone = .false.
                  obone = .false.
                  do j = 1, n13(i)
                     k = i13(j,i)
                     if (atomic(k) .eq. 7) then
                        nbone = .true.
                     else if (atomic(k) .eq. 8) then
                        obone = .true.
                     end if
                  end do
                  if (nbone .and. obone) then
                     cai(m) = i
                     ci(m) = i + 1
                     oi(m) = i + 2
                     m = m + 1
                  end if
               end if
            else if (resname .eq. 'COH') then
               if (n12(i) .gt. 1) then
                  if (atomic(i) .eq. 8) then
                     nbone = .false.
                     obone = .false.
                     do j = 1, n13(i)
                        k = i13(j,i)
                        if (atomic(k) .eq. 8) then
                           obone = .true.
                        end if
                     end do
                     do j = 1, n14(i)
                        k = i14(j,i)
                        if (atomic(k) .eq. 7) then
                           nbone = .true.
                        end if
                     end do
                     if (nbone .and. obone) then
                        ni(m) = i
                        m = m + 1
                     end if
                  end if
               end if
            else if (resname .eq. 'NH2') then
               if (atomic(i) .eq. 7) then
                  nbone = .false.
                  obone = .false.
                  do j = 1, n13(i)
                     k = i13(j,i)
                     if (atomic(k) .eq. 8) then
                        obone = .true.
                     end if
                  end do
                  do j = 1, n14(i)
                     k = i14(j,i)
                     if (atomic(k) .eq. 7) then
                        nbone = .true.
                     end if
                  end do
                  if (nbone .and. obone) then
                     ni(m) = i
                     m = m + 1
                  end if
               end if
            else if (resname .eq. 'NME') then
               if (atomic(i) .eq. 7) then
                  nbone = .false.
                  obone = .false.
                  do j = 1, n13(i)
                     k = i13(j,i)
                     if (atomic(k) .eq. 8) then
                        obone = .true.
                     end if
                  end do
                  do j = 1, n14(i)
                     k = i14(j,i)
                     if (atomic(k) .eq. 7) then
                        nbone = .true.
                     end if
                  end do
                  if (nbone .and. obone) then
                     ni(m) = i
                     cai(m) = i + 1
                     m = m + 1
                  end if
               end if
            else
               if (atomic(i) .eq. 7) then
                  obone = .false.
                  do j = 1, n14(i)
                     k = i14(j,i)
                     if (atomic(k) .eq. 8) then
                        obone = .true.
                     end if
                  end do
                  if (obone) then
                     ni(m) = i
                     cai(m) = i + 1
                     ci(m) = i + 2
                     oi(m) = i + 3
                     m = m + 1
                  end if
               end if
            end if
c
c     find the phosphates and sugar C1 nucleotide backbone atoms
c
         else if (restyp(m) .eq. 'NUCLEIC') then
            resname = nuclz(seqtyp(m))
            if (resname .eq. ' MP') then
               if (atomic(i) .eq. 15) then
                  poi(m) = i
                  m = m + 1
               end if
            end if
            if (atomic(i).eq.6 .and. n12(i).eq.4) then
               cbone = .false.
               nbone = .false.
               obone = .false.
               do j = 1, n12(i)
                  k = i12(j,i)
                  ka = atomic(k)
                  kn = n12(k)
                  if (ka .eq. 6)  cbone = .true.
                  if (ka.eq.7 .and. kn.eq.3)  nbone = .true.
                  if (ka.eq.8 .and. kn.eq.2)  obone = .true.
               end do
               if (cbone .and. nbone .and. obone) then
                  c1i(m) = i
                  m = m + 1
               end if
            end if
         end if
         if (m .gt. nseq)  goto 10
      end do
   10 continue
c
c     find the remainder of the nucleotide backbone atoms
c
      do ii = 1, nchain
         if (chntyp(ii) .eq. 'NUCLEIC') then
            start = ichain(1,ii)
            stop = ichain(2,ii)
            do i = start, stop
               m = c1i(i)
               if (m .ne. 0) then
                  do j = 1, n12(m)
                     k = i12(j,m)
                     ka = atomic(k)
                     if (ka .eq. 6)  c2i(i) = k
                     if (ka .eq. 7)  ni(i) = k
                     if (ka .eq. 8)  o4i(i) = k
                  end do
                  m = o4i(i)
                  do j = 1, n12(m)
                     k = i12(j,m)
                     ka = atomic(k)
                     if (ka.eq.6 .and. k.ne.c1i(i))  c4i(i) = k
                  end do
                  m = c2i(i)
                  do j = 1, n12(m)
                     k = i12(j,m)
                     ka = atomic(k)
                     if (ka .eq. 8)  o2i(i) = k
                     if (ka.eq.6 .and. k.ne.c1i(i))  c3i(i) = k
                  end do
                  m = c3i(i)
                  do j = 1, n12(m)
                     k = i12(j,m)
                     ka = atomic(k)
                     if (ka .eq. 8)  o3i(i) = k
                  end do
                  m = c4i(i)
                  do j = 1, n12(m)
                     k = i12(j,m)
                     ka = atomic(k)
                     if (ka.eq.6 .and. k.ne.c3i(i))  c5i(i) = k
                  end do
                  m = c5i(i)
                  do j = 1, n12(m)
                     k = i12(j,m)
                     ka = atomic(k)
                     if (ka .eq. 8)  o5i(i) = k
                  end do
                  m = o5i(i)
                  do j = 1, n12(m)
                     k = i12(j,m)
                     ka = atomic(k)
                     if (ka .eq. 15)  poi(i) = k
                  end do
               end if
               if (i .gt. 1) then
                  resname = nuclz(seqtyp(i-1))
                  if (resname .eq. ' MP')  poi(i) = 0
                  if (resname .eq. ' DP')  poi(i) = 0
                  if (resname .eq. ' TP')  poi(i) = 0
               end if
               m = poi(i)
               if (m .ne. 0) then
                  do j = 1, n12(m)
                     k = i12(j,m)
                     ka = atomic(k)
                     if (ka.eq.8 .and. n12(k).eq.1) then
                        if (op1(i) .eq. 0) then
                           op1(i) = k
                        else if (op2(i) .eq. 0) then
                           op2(i) = k
                        else
                           op3(i) = k
                        end if
                     end if
                  end do
               end if
            end do
         end if
      end do
c
c     copy the atoms of each biopolymer residue into PDB format
c
      do m = 1, nchain
         start = ichain(1,m)
         stop = ichain(2,m)
         if (chntyp(m) .eq. 'PEPTIDE') then
            do i = start, stop
               resname = amino(seqtyp(i))
               if (resname .eq. 'H2N') then
                  continue
               else if (resname .eq. 'FOR') then
                  call pdbatom (' C  ',resname,i,ci(i))
                  call pdbatom (' O  ',resname,i,oi(i))
               else if (resname .eq. 'ACE') then
                  call pdbatom (' CH3',resname,i,cai(i))
                  call pdbatom (' C  ',resname,i,ci(i))
                  call pdbatom (' O  ',resname,i,oi(i))
               else if (resname .eq. 'COH') then
                  call pdbatom (' OH ',resname,i,ni(i))
               else if (resname .eq. 'NH2') then
                  call pdbatom (' N  ',resname,i,ni(i))
               else if (resname .eq. 'NME') then
                  call pdbatom (' N  ',resname,i,ni(i))
                  call pdbatom (' C  ',resname,i,cai(i))
               else
                  call pdbatom (' N  ',resname,i,ni(i))
                  call pdbatom (' CA ',resname,i,cai(i))
                  call pdbatom (' C  ',resname,i,ci(i))
                  call pdbatom (' O  ',resname,i,oi(i))
               end if
               call getside (resname,i,ci(i),cai(i),cbi)
               if ((resname.eq.'CYS'.or.resname.eq.'CYX')
     &               .and. cbi.ne.0) then
                  resname = 'CYS'
                  do j = 1, n13(cbi)
                     if (atomic(i13(j,cbi)) .eq. 16)  resname = 'CYX'
                  end do
               end if
               if (i.eq.stop .and. ci(i).ne.0) then
                  do j = 1, n12(ci(i))
                     k = i12(j,ci(i))
                     if (atomic(k).eq.8 .and. k.ne.oi(i)) then
                        call pdbatom (' OXT',resname,i,k)
                        goto 20
                     end if
                  end do
   20             continue
               end if
               call getproh (resname,i,m,ni(i),cai(i),cbi)
            end do
         else if (chntyp(m) .eq. 'NUCLEIC') then
            do i = start, stop
               resname = nuclz(seqtyp(i))
               if (resname .eq. ' MP') then
                  call pdbatom (' P  ',resname,i,poi(i))
                  call pdbatom (' OP1',resname,i,op1(i))
                  call pdbatom (' OP2',resname,i,op2(i))
                  call pdbatom (' OP3',resname,i,op3(i))
               else if (resname .eq. ' DP') then
               else if (resname .eq. ' TP') then
               else
                  call pdbatom (' P  ',resname,i,poi(i))
                  call pdbatom (' OP1',resname,i,op1(i))
                  call pdbatom (' OP2',resname,i,op2(i))
                  call pdbatom (' O5''',resname,i,o5i(i))
                  call pdbatom (' C5''',resname,i,c5i(i))
                  call pdbatom (' C4''',resname,i,c4i(i))
                  call pdbatom (' O4''',resname,i,o4i(i))
                  call pdbatom (' C3''',resname,i,c3i(i))
                  call pdbatom (' O3''',resname,i,o3i(i))
                  call pdbatom (' C2''',resname,i,c2i(i))
                  call pdbatom (' O2''',resname,i,o2i(i))
                  call pdbatom (' C1''',resname,i,c1i(i))
                  call getbase (resname,i,ni(i))
                  call getnuch (resname,i,ni(i),c1i(i),c2i(i),o2i(i),
     &                          c3i(i),o3i(i),c4i(i),c5i(i),o5i(i))
               end if
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (ni)
      deallocate (cai)
      deallocate (ci)
      deallocate (oi)
      deallocate (poi)
      deallocate (op1)
      deallocate (op2)
      deallocate (op3)
      deallocate (c5i)
      deallocate (o5i)
      deallocate (c4i)
      deallocate (o4i)
      deallocate (c3i)
      deallocate (o3i)
      deallocate (c2i)
      deallocate (o2i)
      deallocate (c1i)
      deallocate (restyp)
c
c     perform dynamic allocation of some local arrays
c
      allocate (hetmol(nmol))
c
c     copy any water, ions or ligands following biopolymer chains
c
      if (.not. generic) then
         do i = 1, nmol
            hetmol(i) = .true.
         end do
         do i = 1, n
            if (pdblist(i) .ne. 0)  hetmol(molcule(i)) = .false.
         end do
         do i = 1, nmol
            if (hetmol(i)) then
               do j = imol(1,i), imol(2,i)
                  k = kmol(j)
                  atmnum = atomic(k)
                  atmname = ' '//name(k)
                  justify = 0
                  call numeral (type(k),resname,justify)
                  if (water(i)) then
                     if (atmnum .eq. 8)  atmname = ' O  '
                     if (atmnum .eq. 1)  atmname = ' H  '
                     if (atmnum .le. 0)  atmname = 'EP  '
                     resname = 'HOH'
                  else if (atmnum .eq. 9) then
                     atmname = ' F  '
                     resname = '  F'
                  else if (atmnum .eq. 11) then
                     atmname = 'NA  '
                     resname = ' NA'
                  else if (atmnum .eq. 12) then
                     atmname = 'MG  '
                     resname = ' MG'
                  else if (atmnum .eq. 17) then
                     atmname = 'CL  '
                     resname = ' CL'
                  else if (atmnum .eq. 19) then
                     atmname = ' K  '
                     resname = '  K'
                  else if (atmnum .eq. 20) then
                     atmname = 'CA  '
                     resname = ' CA'
                  else if (atmnum .eq. 30) then
                     atmname = 'ZN  '
                     resname = ' ZN'
                  else if (atmnum .eq. 35) then
                     atmname = 'BR  '
                     resname = ' BR'
                  else if (atmnum .eq. 37) then
                     atmname = 'RB  '
                     resname = ' RB'
                  else if (atmnum .eq. 38) then
                     atmname = 'SR  '
                     resname = ' SR'
                  else if (atmnum .eq. 53) then
                     atmname = ' I  '
                     resname = '  I'
                  else if (atmnum .eq. 55) then
                     atmname = 'CS  '
                     resname = ' CS'
                  else if (atmnum .eq. 56) then
                     atmname = 'BA  '
                     resname = ' BA'
                  end if
                  pdbnum = nseq + i - 1
                  call pdbatom (atmname,resname,pdbnum,k)
                  pdbrec(npdb) = 'HETATM'
               end do
            end if
         end do
         do i = 1, nmol
            if (hetmol(i)) then
               do j = imol(1,i), imol(2,i)
                  k = kmol(j)
                  kp = pdblist(k)
                  npdb12(kp) = n12(k)
                  do m = 1, n12(k)
                     ipdb12(m,kp) = pdblist(i12(m,k))
                  end do
               end do
            end if
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (water)
      deallocate (hetmol)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine pdbatom  --  add a single atom to PDB file  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "pdbatom" adds an atom to the Protein Data Bank file
c
c
      subroutine pdbatom (atmname,resname,ires,icoord)
      use atomid
      use atoms
      use pdb
      use ptable
      implicit none
      integer ires,icoord
      character*3 resname
      character*4 atmname
c
c
c     for each atom set the sequential number, record type, atomic
c     symbol, atom name, residue name and number, and coordinates
c
      if (icoord .ne. 0) then
         npdb = npdb + 1
         pdbrec(npdb) = 'ATOM  '
         pdbsym(npdb) = elemnt(atomic(icoord))
         pdbatm(npdb) = atmname
         pdbres(npdb) = resname
         resnum(npdb) = ires
         xpdb(npdb) = x(icoord)
         ypdb(npdb) = y(icoord)
         zpdb(npdb) = z(icoord)
         npdb12(npdb) = 0
         pdblist(icoord) = npdb
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine getside  --  extract the amino acid side chains  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "getside" finds the side chain heavy atoms for a single amino
c     acid residue and copies the names and coordinates to the Protein
c     Data Bank file
c
c
      subroutine getside (resname,ires,ci,cai,cbi)
      use atomid
      use atoms
      use couple
      implicit none
      integer i,j,ires
      integer ci,cai,cbi
      character*3 resname
c
c
c     if residue is a terminal cap, there is no side chain
c
      cbi = 0
      if (cai .eq. 0)  return
      if (resname .eq. 'H2N')  return
      if (resname .eq. 'FOR')  return
      if (resname .eq. 'ACE')  return
      if (resname .eq. 'COH')  return
      if (resname .eq. 'NH2')  return
      if (resname .eq. 'NME')  return
c
c     find the beta carbon atom for the current residue
c
      do i = 1, n12(cai)
         j = i12(i,cai)
         if (j.ne.ci .and. atomic(j).eq.6) then
            cbi = j
            if (resname .ne. 'AIB') then
               call pdbatom (' CB ',resname,ires,cbi)
            else
               call pdbatom (' CB1',resname,ires,cbi)
            end if
            goto 10
         end if
      end do
   10 continue
      if (cbi .eq. 0)  return
c
c     glycine residue  (GLY)
c
      if (resname .eq. 'GLY') then
         continue
c
c     alanine residue  (ALA)
c
      else if (resname .eq. 'ALA') then
         continue
c
c     valine residue  (VAL)
c
      else if (resname .eq. 'VAL') then
         call pdbatom (' CG1',resname,ires,cbi+1)
         call pdbatom (' CG2',resname,ires,cbi+2)
c
c     leucine residue  (LEU)
c
      else if (resname .eq. 'LEU') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD1',resname,ires,cbi+2)
         call pdbatom (' CD2',resname,ires,cbi+3)
c
c     isoleucine residue  (ILE)
c
      else if (resname .eq. 'ILE') then
         call pdbatom (' CG1',resname,ires,cbi+1)
         call pdbatom (' CG2',resname,ires,cbi+2)
         call pdbatom (' CD1',resname,ires,cbi+3)
c
c     serine residue  (SER)
c
      else if (resname .eq. 'SER') then
         call pdbatom (' OG ',resname,ires,cbi+1)
c
c     threonine residue  (THR)
c
      else if (resname .eq. 'THR') then
         call pdbatom (' OG1',resname,ires,cbi+1)
         call pdbatom (' CG2',resname,ires,cbi+2)
c
c     cysteine residue  (CYS)
c
      else if (resname .eq. 'CYS') then
         call pdbatom (' SG ',resname,ires,cbi+1)
c
c     cysteine residue  (CYX)
c
      else if (resname .eq. 'CYX') then
         call pdbatom (' SG ',resname,ires,cbi+1)
c
c     deprotonated cysteine residue  (CYD)
c
      else if (resname .eq. 'CYD') then
         call pdbatom (' SG ',resname,ires,cbi+1)
c
c     proline residue  (PRO)
c
      else if (resname .eq. 'PRO') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD ',resname,ires,cbi+2)
c
c     phenylalanine residue  (PHE)
c
      else if (resname .eq. 'PHE') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD1',resname,ires,cbi+2)
         call pdbatom (' CD2',resname,ires,cbi+3)
         call pdbatom (' CE1',resname,ires,cbi+4)
         call pdbatom (' CE2',resname,ires,cbi+5)
         call pdbatom (' CZ ',resname,ires,cbi+6)
c
c     tyrosine residue  (TYR)
c
      else if (resname .eq. 'TYR') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD1',resname,ires,cbi+2)
         call pdbatom (' CD2',resname,ires,cbi+3)
         call pdbatom (' CE1',resname,ires,cbi+4)
         call pdbatom (' CE2',resname,ires,cbi+5)
         call pdbatom (' CZ ',resname,ires,cbi+6)
         call pdbatom (' OH ',resname,ires,cbi+7)
c
c     deprotonated tyrosine residue  (TYD)
c
      else if (resname .eq. 'TYD') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD1',resname,ires,cbi+2)
         call pdbatom (' CD2',resname,ires,cbi+3)
         call pdbatom (' CE1',resname,ires,cbi+4)
         call pdbatom (' CE2',resname,ires,cbi+5)
         call pdbatom (' CZ ',resname,ires,cbi+6)
         call pdbatom (' OH ',resname,ires,cbi+7)
c
c     tryptophan residue  (TRP)
c
      else if (resname .eq. 'TRP') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD1',resname,ires,cbi+2)
         call pdbatom (' CD2',resname,ires,cbi+3)
         call pdbatom (' NE1',resname,ires,cbi+4)
         call pdbatom (' CE2',resname,ires,cbi+5)
         call pdbatom (' CE3',resname,ires,cbi+6)
         call pdbatom (' CZ2',resname,ires,cbi+7)
         call pdbatom (' CZ3',resname,ires,cbi+8)
         call pdbatom (' CH2',resname,ires,cbi+9)
c
c     histidine (HD and HE) residue  (HIS)
c
      else if (resname .eq. 'HIS') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' ND1',resname,ires,cbi+2)
         call pdbatom (' CD2',resname,ires,cbi+3)
         call pdbatom (' CE1',resname,ires,cbi+4)
         call pdbatom (' NE2',resname,ires,cbi+5)
c
c     histidine (HD only) residue  (HID)
c
      else if (resname .eq. 'HID') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' ND1',resname,ires,cbi+2)
         call pdbatom (' CD2',resname,ires,cbi+3)
         call pdbatom (' CE1',resname,ires,cbi+4)
         call pdbatom (' NE2',resname,ires,cbi+5)
c
c     histidine (HE only) residue  (HIE)
c
      else if (resname .eq. 'HIE') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' ND1',resname,ires,cbi+2)
         call pdbatom (' CD2',resname,ires,cbi+3)
         call pdbatom (' CE1',resname,ires,cbi+4)
         call pdbatom (' NE2',resname,ires,cbi+5)
c
c     aspartate residue  (ASP)
c
      else if (resname .eq. 'ASP') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' OD1',resname,ires,cbi+2)
         call pdbatom (' OD2',resname,ires,cbi+3)
c
c     protonated aspartic acid residue  (ASH)
c
      else if (resname .eq. 'ASH') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' OD1',resname,ires,cbi+2)
         call pdbatom (' OD2',resname,ires,cbi+3)
c
c     asparagine residue  (ASN)
c
      else if (resname .eq. 'ASN') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' OD1',resname,ires,cbi+2)
         call pdbatom (' ND2',resname,ires,cbi+3)
c
c     glutamate residue  (GLU)
c
      else if (resname .eq. 'GLU') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD ',resname,ires,cbi+2)
         call pdbatom (' OE1',resname,ires,cbi+3)
         call pdbatom (' OE2',resname,ires,cbi+4)
c
c     protonated glutamic acid residue  (GLH)
c
      else if (resname .eq. 'GLH') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD ',resname,ires,cbi+2)
         call pdbatom (' OE1',resname,ires,cbi+3)
         call pdbatom (' OE2',resname,ires,cbi+4)
c
c     glutamine residue  (GLN)
c
      else if (resname .eq. 'GLN') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD ',resname,ires,cbi+2)
         call pdbatom (' OE1',resname,ires,cbi+3)
         call pdbatom (' NE2',resname,ires,cbi+4)
c
c     methionine residue  (MET)
c
      else if (resname .eq. 'MET') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' SD ',resname,ires,cbi+2)
         call pdbatom (' CE ',resname,ires,cbi+3)
c
c     lysine residue  (LYS)
c
      else if (resname .eq. 'LYS') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD ',resname,ires,cbi+2)
         call pdbatom (' CE ',resname,ires,cbi+3)
         call pdbatom (' NZ ',resname,ires,cbi+4)
c
c     deprotonated lysine residue  (LYD)
c
      else if (resname .eq. 'LYD') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD ',resname,ires,cbi+2)
         call pdbatom (' CE ',resname,ires,cbi+3)
         call pdbatom (' NZ ',resname,ires,cbi+4)
c
c     arginine residue  (ARG)
c
      else if (resname .eq. 'ARG') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD ',resname,ires,cbi+2)
         call pdbatom (' NE ',resname,ires,cbi+3)
         call pdbatom (' CZ ',resname,ires,cbi+4)
         call pdbatom (' NH1',resname,ires,cbi+5)
         call pdbatom (' NH2',resname,ires,cbi+6)
c
c     ornithine residue  (ORN)
c
      else if (resname .eq. 'ORN') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD ',resname,ires,cbi+2)
         call pdbatom (' NE ',resname,ires,cbi+3)
c
c     methylalanine residue  (AIB)
c
      else if (resname .eq. 'AIB') then
         call pdbatom (' CB2',resname,ires,cbi+1)
c
c     pyroglutamic acid residue  (PCA)
c
      else if (resname .eq. 'PCA') then
         call pdbatom (' CG ',resname,ires,cbi+1)
         call pdbatom (' CD ',resname,ires,cbi+2)
         call pdbatom (' OE ',resname,ires,cbi+3)
c
c     unknown residue  (UNK)
c
      else if (resname .eq. 'UNK') then
         continue
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine getproh  --  extract the amino acid hydrogens  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "getproh" finds the hydrogen atoms for a single amino acid
c     residue and copies the names and coordinates to the Protein
c     Data Bank file
c
c
      subroutine getproh (resname,ires,jchain,ni,cai,cbi)
      use atomid
      use atoms
      use couple
      use fields
      use sequen
      implicit none
      integer i,nhyd,hca
      integer ires,jchain
      integer ni,cai,cbi
      logical allatom
      character*3 resname
      character*4 atmname
c
c
c     get any amide hydrogen atoms for non-N-terminal residues
c
      if (ires.ne.ichain(1,jchain) .or. n12(ni).ne.4) then
         if (resname .ne. 'PRO') then
            do i = 1, n
               if (atomic(i).eq.1 .and. i12(1,i).eq.ni) then
                  if (resname .eq. 'COH') then
                     call pdbatom (' HO ',resname,ires,i)
                  else if (resname .eq. 'NH2') then
                     call pdbatom (' H1 ',resname,ires,i)
                     call pdbatom (' H2 ',resname,ires,i+1)
                  else
                     call pdbatom (' H  ',resname,ires,i)
                  end if
                  goto 10
               end if
            end do
         end if
c
c     get any amide hydrogen atoms for N-terminal residues
c
      else
         if (resname .eq. 'PRO') then
            nhyd = 0
            do i = 1, n
               if (atomic(i).eq.1 .and. i12(1,i).eq.ni) then
                  nhyd = nhyd + 1
                  if (nhyd .eq. 1) then
                     atmname = ' H1 '
                  else if (nhyd .eq. 2) then
                     atmname = ' H2 '
                  end if
                  call pdbatom (atmname,resname,ires,i)
                  if (nhyd .eq. 2)  goto 10
               end if
            end do
         else if (resname .eq. 'PCA') then
            do i = 1, n
               if (atomic(i).eq.1 .and. i12(1,i).eq.ni) then
                  atmname = ' H  '
                  call pdbatom (atmname,resname,ires,i)
                  goto 10
               end if
            end do
         else
            nhyd = 0
            do i = 1, n
               if (atomic(i).eq.1 .and. i12(1,i).eq.ni) then
                  nhyd = nhyd + 1
                  if (nhyd .eq. 1) then
                     atmname = ' H1 '
                  else if (nhyd .eq. 2) then
                     atmname = ' H2 '
                  else if (nhyd .eq. 3) then
                     atmname = ' H3 '
                  end if
                  call pdbatom (atmname,resname,ires,i)
                  if (nhyd .eq. 3)  goto 10
               end if
            end do
         end if
      end if
   10 continue
c
c     get the alpha hydrogen atom for the current residue
c
      hca = 0
      do i = 1, n
         if (atomic(i).eq.1 .and. i12(1,i).eq.cai) then
            hca = i
            if (resname .eq. 'GLY') then
               atmname = ' HA2'
            else if (resname .eq. 'FOR') then
               atmname = ' H  '
            else if (resname .eq. 'ACE') then
               atmname = ' H1 '
            else if (resname .eq. 'NME') then
               atmname = ' H1 '
            else
               atmname = ' HA '
            end if
            call pdbatom (atmname,resname,ires,i)
            goto 20
         end if
      end do
   20 continue
c
c     backbone only if no alpha hydrogen or beta carbon
c
      if (hca.eq.0 .and. cbi.eq.0)  return
c
c     if no alpha hydrogen, then united atom force field
c
      if (hca .ne. 0) then
         allatom = .true.
      else if (resname .eq. 'AIB') then
         if (n12(cbi) .eq. 1) then
            allatom = .false.
         else
            allatom = .true.
         end if
      else
         allatom = .false.
      end if
c
c     glycine residue  (GLY)
c
      if (resname .eq. 'GLY') then
         if (allatom) then
            call pdbatom (' HA3',resname,ires,hca+1)
         end if
c
c     alanine residue  (ALA)
c
      else if (resname .eq. 'ALA') then
         if (allatom) then
            call pdbatom (' HB1',resname,ires,hca+2)
            call pdbatom (' HB2',resname,ires,hca+3)
            call pdbatom (' HB3',resname,ires,hca+4)
         end if
c
c     valine residue  (VAL)
c
      else if (resname .eq. 'VAL') then
         if (allatom) then
            call pdbatom (' HB ',resname,ires,hca+4)
            call pdbatom ('HG11',resname,ires,hca+5)
            call pdbatom ('HG12',resname,ires,hca+6)
            call pdbatom ('HG13',resname,ires,hca+7)
            call pdbatom ('HG21',resname,ires,hca+8)
            call pdbatom ('HG22',resname,ires,hca+9)
            call pdbatom ('HG23',resname,ires,hca+10)
         end if
c
c     leucine residue  (LEU)
c
      else if (resname .eq. 'LEU') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+5)
            call pdbatom (' HB3',resname,ires,hca+6)
            call pdbatom (' HG ',resname,ires,hca+7)
            call pdbatom ('HD11',resname,ires,hca+8)
            call pdbatom ('HD12',resname,ires,hca+9)
            call pdbatom ('HD13',resname,ires,hca+10)
            call pdbatom ('HD21',resname,ires,hca+11)
            call pdbatom ('HD22',resname,ires,hca+12)
            call pdbatom ('HD23',resname,ires,hca+13)
         end if
c
c     isoleucine residue  (ILE)
c
      else if (resname .eq. 'ILE') then
         if (allatom) then
            call pdbatom (' HB ',resname,ires,hca+5)
            call pdbatom ('HG12',resname,ires,hca+6)
            call pdbatom ('HG13',resname,ires,hca+7)
            call pdbatom ('HG21',resname,ires,hca+8)
            call pdbatom ('HG22',resname,ires,hca+9)
            call pdbatom ('HG23',resname,ires,hca+10)
            call pdbatom ('HD11',resname,ires,hca+11)
            call pdbatom ('HD12',resname,ires,hca+12)
            call pdbatom ('HD13',resname,ires,hca+13)
         end if
c
c     serine residue  (SER)
c
      else if (resname .eq. 'SER') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+3)
            call pdbatom (' HB3',resname,ires,hca+4)
            call pdbatom (' HG ',resname,ires,hca+5)
         else
            call pdbatom (' HG ',resname,ires,cbi+2)
         end if
c
c     threonine residue  (THR)
c
      else if (resname .eq. 'THR') then
         if (allatom) then
            call pdbatom (' HB ',resname,ires,hca+4)
            call pdbatom (' HG1',resname,ires,hca+5)
            call pdbatom ('HG21',resname,ires,hca+6)
            call pdbatom ('HG22',resname,ires,hca+7)
            call pdbatom ('HG23',resname,ires,hca+8)
         else
            call pdbatom (' HG1',resname,ires,cbi+3)
         end if
c
c     cysteine residue  (CYS)
c
      else if (resname .eq. 'CYS') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+3)
            call pdbatom (' HB3',resname,ires,hca+4)
            call pdbatom (' HG ',resname,ires,hca+5)
         else if (biotyp(86) .ne. 0) then
            call pdbatom (' HG ',resname,ires,cbi+2)
         end if
c
c     cystine residue  (CYX)
c
      else if (resname .eq. 'CYX') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+3)
            call pdbatom (' HB3',resname,ires,hca+4)
         end if
c
c     deprotonated cysteine residue  (CYD)
c
      else if (resname .eq. 'CYD') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+3)
            call pdbatom (' HB3',resname,ires,hca+4)
         end if
c
c     proline residue  (PRO)
c
      else if (resname .eq. 'PRO') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+4)
            call pdbatom (' HB3',resname,ires,hca+5)
            call pdbatom (' HG2',resname,ires,hca+6)
            call pdbatom (' HG3',resname,ires,hca+7)
            call pdbatom (' HD2',resname,ires,hca+8)
            call pdbatom (' HD3',resname,ires,hca+9)
         end if
c
c     phenylalanine residue  (PHE)
c
      else if (resname .eq. 'PHE') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+8)
            call pdbatom (' HB3',resname,ires,hca+9)
            call pdbatom (' HD1',resname,ires,hca+10)
            call pdbatom (' HD2',resname,ires,hca+11)
            call pdbatom (' HE1',resname,ires,hca+12)
            call pdbatom (' HE2',resname,ires,hca+13)
            call pdbatom (' HZ ',resname,ires,hca+14)
         else if (biotyp(126) .ne. 0) then
            call pdbatom (' HD1',resname,ires,cbi+7)
            call pdbatom (' HD2',resname,ires,cbi+8)
            call pdbatom (' HE1',resname,ires,cbi+9)
            call pdbatom (' HE2',resname,ires,cbi+10)
            call pdbatom (' HZ ',resname,ires,cbi+11)
         end if
c
c     tyrosine residue  (TYR)
c
      else if (resname .eq. 'TYR') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+9)
            call pdbatom (' HB3',resname,ires,hca+10)
            call pdbatom (' HD1',resname,ires,hca+11)
            call pdbatom (' HD2',resname,ires,hca+12)
            call pdbatom (' HE1',resname,ires,hca+13)
            call pdbatom (' HE2',resname,ires,hca+14)
            call pdbatom (' HH ',resname,ires,hca+15)
         else if (biotyp(141) .ne. 0) then
            call pdbatom (' HD1',resname,ires,cbi+8)
            call pdbatom (' HD2',resname,ires,cbi+9)
            call pdbatom (' HE1',resname,ires,cbi+10)
            call pdbatom (' HE2',resname,ires,cbi+11)
            call pdbatom (' HH ',resname,ires,cbi+12)
         else
            call pdbatom (' HH ',resname,ires,cbi+8)
         end if
c
c     deprotonated tyrosine residue  (TYD)
c
      else if (resname .eq. 'TYD') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+9)
            call pdbatom (' HB3',resname,ires,hca+10)
            call pdbatom (' HD1',resname,ires,hca+11)
            call pdbatom (' HD2',resname,ires,hca+12)
            call pdbatom (' HE1',resname,ires,hca+13)
            call pdbatom (' HE2',resname,ires,hca+14)
         else if (biotyp(141) .ne. 0) then
            call pdbatom (' HD1',resname,ires,cbi+8)
            call pdbatom (' HD2',resname,ires,cbi+9)
            call pdbatom (' HE1',resname,ires,cbi+10)
            call pdbatom (' HE2',resname,ires,cbi+11)
         end if
c
c     tryptophan residue  (TRP)
c
      else if (resname .eq. 'TRP') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+11)
            call pdbatom (' HB3',resname,ires,hca+12)
            call pdbatom (' HD1',resname,ires,hca+13)
            call pdbatom (' HE1',resname,ires,hca+14)
            call pdbatom (' HE3',resname,ires,hca+15)
            call pdbatom (' HZ2',resname,ires,hca+16)
            call pdbatom (' HZ3',resname,ires,hca+17)
            call pdbatom (' HH2',resname,ires,hca+18)
         else if (biotyp(172) .ne. 0) then
            call pdbatom (' HD1',resname,ires,cbi+10)
            call pdbatom (' HE1',resname,ires,cbi+11)
            call pdbatom (' HE3',resname,ires,cbi+12)
            call pdbatom (' HZ2',resname,ires,cbi+13)
            call pdbatom (' HZ3',resname,ires,cbi+14)
            call pdbatom (' HH2',resname,ires,cbi+15)
         else
            call pdbatom (' HE1',resname,ires,cbi+10)
         end if
c
c     histidine (HD and HE) residue  (HIS)
c
      else if (resname .eq. 'HIS') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+7)
            call pdbatom (' HB3',resname,ires,hca+8)
            call pdbatom (' HD1',resname,ires,hca+9)
            call pdbatom (' HD2',resname,ires,hca+10)
            call pdbatom (' HE1',resname,ires,hca+11)
            call pdbatom (' HE2',resname,ires,hca+12)
         else if (biotyp(197) .ne. 0) then
            call pdbatom (' HD1',resname,ires,cbi+6)
            call pdbatom (' HD2',resname,ires,cbi+7)
            call pdbatom (' HE1',resname,ires,cbi+8)
            call pdbatom (' HE2',resname,ires,cbi+9)
         else
            call pdbatom (' HD1',resname,ires,cbi+6)
            call pdbatom (' HE2',resname,ires,cbi+7)
         end if
c
c     histidine (HD only) residue  (HID)
c
      else if (resname .eq. 'HID') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+7)
            call pdbatom (' HB3',resname,ires,hca+8)
            call pdbatom (' HD1',resname,ires,hca+9)
            call pdbatom (' HD2',resname,ires,hca+10)
            call pdbatom (' HE1',resname,ires,hca+11)
         else if (biotyp(214) .ne. 0) then
            call pdbatom (' HD1',resname,ires,cbi+6)
            call pdbatom (' HD2',resname,ires,cbi+7)
            call pdbatom (' HE1',resname,ires,cbi+8)
         else
            call pdbatom (' HD1',resname,ires,cbi+6)
         end if
c
c     histidine (HE only) residue  (HIE)
c
      else if (resname .eq. 'HIE') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+7)
            call pdbatom (' HB3',resname,ires,hca+8)
            call pdbatom (' HD2',resname,ires,hca+9)
            call pdbatom (' HE1',resname,ires,hca+10)
            call pdbatom (' HE2',resname,ires,hca+11)
         else if (biotyp(229) .ne. 0) then
            call pdbatom (' HD2',resname,ires,cbi+6)
            call pdbatom (' HE1',resname,ires,cbi+7)
            call pdbatom (' HE2',resname,ires,cbi+8)
         else
            call pdbatom (' HE2',resname,ires,cbi+6)
         end if
c
c     aspartate residue  (ASP)
c
      else if (resname .eq. 'ASP') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+5)
            call pdbatom (' HB3',resname,ires,hca+6)
         end if
c
c     protonated aspartic acid residue  (ASH)
c
      else if (resname .eq. 'ASH') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+5)
            call pdbatom (' HB3',resname,ires,hca+6)
            call pdbatom (' HD2',resname,ires,hca+7)
         else
            call pdbatom (' HD2',resname,ires,cbi+4)
         end if
c
c     asparagine residue  (ASN)
c
      else if (resname .eq. 'ASN') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+5)
            call pdbatom (' HB3',resname,ires,hca+6)
            call pdbatom ('HD21',resname,ires,hca+7)
            call pdbatom ('HD22',resname,ires,hca+8)
         else
            call pdbatom ('HD21',resname,ires,cbi+4)
            call pdbatom ('HD22',resname,ires,cbi+5)
         end if
c
c     glutamate residue  (GLU)
c
      else if (resname .eq. 'GLU') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+6)
            call pdbatom (' HB3',resname,ires,hca+7)
            call pdbatom (' HG2',resname,ires,hca+8)
            call pdbatom (' HG3',resname,ires,hca+9)
         end if
c
c     protonated glutamic acid residue  (GLH)
c
      else if (resname .eq. 'GLH') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+6)
            call pdbatom (' HB3',resname,ires,hca+7)
            call pdbatom (' HG2',resname,ires,hca+8)
            call pdbatom (' HG3',resname,ires,hca+9)
            call pdbatom (' HE2',resname,ires,hca+10)
         else
            call pdbatom (' HE2',resname,ires,cbi+5)
         end if
c
c     glutamine residue  (GLN)
c
      else if (resname .eq. 'GLN') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+6)
            call pdbatom (' HB3',resname,ires,hca+7)
            call pdbatom (' HG2',resname,ires,hca+8)
            call pdbatom (' HG3',resname,ires,hca+9)
            call pdbatom ('HE21',resname,ires,hca+10)
            call pdbatom ('HE22',resname,ires,hca+11)
         else
            call pdbatom ('HE21',resname,ires,cbi+5)
            call pdbatom ('HE22',resname,ires,cbi+6)
         end if
c
c     methionine residue  (MET)
c
      else if (resname .eq. 'MET') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+5)
            call pdbatom (' HB3',resname,ires,hca+6)
            call pdbatom (' HG2',resname,ires,hca+7)
            call pdbatom (' HG3',resname,ires,hca+8)
            call pdbatom (' HE1',resname,ires,hca+9)
            call pdbatom (' HE2',resname,ires,hca+10)
            call pdbatom (' HE3',resname,ires,hca+11)
         end if
c
c     lysine residue  (LYS)
c
      else if (resname .eq. 'LYS') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+6)
            call pdbatom (' HB3',resname,ires,hca+7)
            call pdbatom (' HG2',resname,ires,hca+8)
            call pdbatom (' HG3',resname,ires,hca+9)
            call pdbatom (' HD2',resname,ires,hca+10)
            call pdbatom (' HD3',resname,ires,hca+11)
            call pdbatom (' HE2',resname,ires,hca+12)
            call pdbatom (' HE3',resname,ires,hca+13)
            call pdbatom (' HZ1',resname,ires,hca+14)
            call pdbatom (' HZ2',resname,ires,hca+15)
            call pdbatom (' HZ3',resname,ires,hca+16)
         else
            call pdbatom (' HZ1',resname,ires,cbi+5)
            call pdbatom (' HZ2',resname,ires,cbi+6)
            call pdbatom (' HZ3',resname,ires,cbi+7)
         end if
c
c     deprotonated lysine residue  (LYD)
c
      else if (resname .eq. 'LYD') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+6)
            call pdbatom (' HB3',resname,ires,hca+7)
            call pdbatom (' HG2',resname,ires,hca+8)
            call pdbatom (' HG3',resname,ires,hca+9)
            call pdbatom (' HD2',resname,ires,hca+10)
            call pdbatom (' HD3',resname,ires,hca+11)
            call pdbatom (' HE2',resname,ires,hca+12)
            call pdbatom (' HE3',resname,ires,hca+13)
            call pdbatom (' HZ1',resname,ires,hca+14)
            call pdbatom (' HZ2',resname,ires,hca+15)
         else
            call pdbatom (' HZ1',resname,ires,cbi+5)
            call pdbatom (' HZ2',resname,ires,cbi+6)
         end if
c
c     arginine residue  (ARG)
c
      else if (resname .eq. 'ARG') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+8)
            call pdbatom (' HB3',resname,ires,hca+9)
            call pdbatom (' HG2',resname,ires,hca+10)
            call pdbatom (' HG3',resname,ires,hca+11)
            call pdbatom (' HD2',resname,ires,hca+12)
            call pdbatom (' HD3',resname,ires,hca+13)
            call pdbatom (' HE ',resname,ires,hca+14)
            call pdbatom ('HH11',resname,ires,hca+15)
            call pdbatom ('HH12',resname,ires,hca+16)
            call pdbatom ('HH21',resname,ires,hca+17)
            call pdbatom ('HH22',resname,ires,hca+18)
         else
            call pdbatom (' HE ',resname,ires,cbi+7)
            call pdbatom ('HH11',resname,ires,cbi+8)
            call pdbatom ('HH12',resname,ires,cbi+9)
            call pdbatom ('HH21',resname,ires,cbi+10)
            call pdbatom ('HH22',resname,ires,cbi+11)
         end if
c
c     ornithine residue  (ORN)
c
      else if (resname .eq. 'ORN') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+5)
            call pdbatom (' HB3',resname,ires,hca+6)
            call pdbatom (' HG2',resname,ires,hca+7)
            call pdbatom (' HG3',resname,ires,hca+8)
            call pdbatom (' HD2',resname,ires,hca+9)
            call pdbatom (' HD3',resname,ires,hca+10)
            call pdbatom (' HE1',resname,ires,hca+11)
            call pdbatom (' HE2',resname,ires,hca+12)
            call pdbatom (' HE3',resname,ires,hca+13)
         else
            call pdbatom (' HE1',resname,ires,cbi+4)
            call pdbatom (' HE2',resname,ires,cbi+5)
            call pdbatom (' HE3',resname,ires,cbi+6)
         end if
c
c     methylalanine residue  (AIB)
c
      else if (resname .eq. 'AIB') then
         if (allatom) then
            call pdbatom ('HB11',resname,ires,cbi+2)
            call pdbatom ('HB12',resname,ires,cbi+3)
            call pdbatom ('HB13',resname,ires,cbi+4)
            call pdbatom ('HB21',resname,ires,cbi+5)
            call pdbatom ('HB22',resname,ires,cbi+6)
            call pdbatom ('HB23',resname,ires,cbi+7)
         end if
c
c     pyroglutamic acid residue  (PCA)
c
      else if (resname .eq. 'PCA') then
         if (allatom) then
            call pdbatom (' HB2',resname,ires,hca+5)
            call pdbatom (' HB3',resname,ires,hca+6)
            call pdbatom (' HG2',resname,ires,hca+7)
            call pdbatom (' HG3',resname,ires,hca+8)
         end if
c
c     unknown residue  (UNK)
c
      else if (resname .eq. 'UNK') then
         if (allatom) then
            call pdbatom (' HA3',resname,ires,hca+1)
         end if
c
c     N-terminal deprotonated residue  (H2N)
c
      else if (resname .eq. 'H2N') then
         continue
c
c     N-terminal formyl residue  (FOR)
c
      else if (resname .eq. 'FOR') then
         continue
c
c     N-terminal acetyl residue  (ACE)
c
      else if (resname .eq. 'ACE') then
         if (allatom) then
            call pdbatom (' H2 ',resname,ires,hca+1)
            call pdbatom (' H3 ',resname,ires,hca+2)
         end if
c
c     C-terminal protonated residue (COH)
c
      else if (resname .eq. 'COH') then
         continue
c
c     C-terminal amide residue  (NH2)
c
      else if (resname .eq. 'NH2') then
         continue
c
c     C-terminal N-methylamide residue  (NME)
c
      else if (resname .eq. 'NME') then
         if (allatom) then
            call pdbatom (' H2 ',resname,ires,hca+1)
            call pdbatom (' H3 ',resname,ires,hca+2)
         end if
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine getbase  --  extract the nucleotide side chains  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "getbase" finds the base heavy atoms for a single nucleotide
c     residue and copies the names and coordinates to the Protein
c     Data Bank file
c
c
      subroutine getbase (resname,ires,ni)
      implicit none
      integer ires,ni
      character*3 resname
c
c
c     adenine in adenosine residue  (A)
c
      if (resname .eq. '  A') then
         call pdbatom (' N9 ',resname,ires,ni)
         call pdbatom (' C8 ',resname,ires,ni+1)
         call pdbatom (' N7 ',resname,ires,ni+2)
         call pdbatom (' C5 ',resname,ires,ni+3)
         call pdbatom (' C6 ',resname,ires,ni+4)
         call pdbatom (' N6 ',resname,ires,ni+5)
         call pdbatom (' N1 ',resname,ires,ni+6)
         call pdbatom (' C2 ',resname,ires,ni+7)
         call pdbatom (' N3 ',resname,ires,ni+8)
         call pdbatom (' C4 ',resname,ires,ni+9)
c
c     guanine in guanosine residue  (G)
c
      else if (resname .eq. '  G') then
         call pdbatom (' N9 ',resname,ires,ni)
         call pdbatom (' C8 ',resname,ires,ni+1)
         call pdbatom (' N7 ',resname,ires,ni+2)
         call pdbatom (' C5 ',resname,ires,ni+3)
         call pdbatom (' C6 ',resname,ires,ni+4)
         call pdbatom (' O6 ',resname,ires,ni+5)
         call pdbatom (' N1 ',resname,ires,ni+6)
         call pdbatom (' C2 ',resname,ires,ni+7)
         call pdbatom (' N2 ',resname,ires,ni+8)
         call pdbatom (' N3 ',resname,ires,ni+9)
         call pdbatom (' C4 ',resname,ires,ni+10)
c
c     cytosine in cytidine residue  (C)
c
      else if (resname .eq. '  C') then
         call pdbatom (' N1 ',resname,ires,ni)
         call pdbatom (' C2 ',resname,ires,ni+1)
         call pdbatom (' O2 ',resname,ires,ni+2)
         call pdbatom (' N3 ',resname,ires,ni+3)
         call pdbatom (' C4 ',resname,ires,ni+4)
         call pdbatom (' N4 ',resname,ires,ni+5)
         call pdbatom (' C5 ',resname,ires,ni+6)
         call pdbatom (' C6 ',resname,ires,ni+7)
c
c     uracil in uridine residue  (U)
c
      else if (resname .eq. '  U') then
         call pdbatom (' N1 ',resname,ires,ni)
         call pdbatom (' C2 ',resname,ires,ni+1)
         call pdbatom (' O2 ',resname,ires,ni+2)
         call pdbatom (' N3 ',resname,ires,ni+3)
         call pdbatom (' C4 ',resname,ires,ni+4)
         call pdbatom (' O4 ',resname,ires,ni+5)
         call pdbatom (' C5 ',resname,ires,ni+6)
         call pdbatom (' C6 ',resname,ires,ni+7)
c
c     adenine in deoxyadenosine residue  (DA)
c
      else if (resname .eq. ' DA') then
         call pdbatom (' N9 ',resname,ires,ni)
         call pdbatom (' C8 ',resname,ires,ni+1)
         call pdbatom (' N7 ',resname,ires,ni+2)
         call pdbatom (' C5 ',resname,ires,ni+3)
         call pdbatom (' C6 ',resname,ires,ni+4)
         call pdbatom (' N6 ',resname,ires,ni+5)
         call pdbatom (' N1 ',resname,ires,ni+6)
         call pdbatom (' C2 ',resname,ires,ni+7)
         call pdbatom (' N3 ',resname,ires,ni+8)
         call pdbatom (' C4 ',resname,ires,ni+9)
c
c     guanine in deoxyguanosine residue  (DG)
c
      else if (resname .eq. ' DG') then
         call pdbatom (' N9 ',resname,ires,ni)
         call pdbatom (' C8 ',resname,ires,ni+1)
         call pdbatom (' N7 ',resname,ires,ni+2)
         call pdbatom (' C5 ',resname,ires,ni+3)
         call pdbatom (' C6 ',resname,ires,ni+4)
         call pdbatom (' O6 ',resname,ires,ni+5)
         call pdbatom (' N1 ',resname,ires,ni+6)
         call pdbatom (' C2 ',resname,ires,ni+7)
         call pdbatom (' N2 ',resname,ires,ni+8)
         call pdbatom (' N3 ',resname,ires,ni+9)
         call pdbatom (' C4 ',resname,ires,ni+10)
c
c     cytosine in deoxycytidine residue  (DC)
c
      else if (resname .eq. ' DC') then
         call pdbatom (' N1 ',resname,ires,ni)
         call pdbatom (' C2 ',resname,ires,ni+1)
         call pdbatom (' O2 ',resname,ires,ni+2)
         call pdbatom (' N3 ',resname,ires,ni+3)
         call pdbatom (' C4 ',resname,ires,ni+4)
         call pdbatom (' N4 ',resname,ires,ni+5)
         call pdbatom (' C5 ',resname,ires,ni+6)
         call pdbatom (' C6 ',resname,ires,ni+7)
c
c     thymine in deoxythymidine residue  (DT)
c
      else if (resname .eq. ' DT') then
         call pdbatom (' N1 ',resname,ires,ni)
         call pdbatom (' C2 ',resname,ires,ni+1)
         call pdbatom (' O2 ',resname,ires,ni+2)
         call pdbatom (' N3 ',resname,ires,ni+3)
         call pdbatom (' C4 ',resname,ires,ni+4)
         call pdbatom (' O4 ',resname,ires,ni+5)
         call pdbatom (' C5 ',resname,ires,ni+6)
         call pdbatom (' C7 ',resname,ires,ni+7)
         call pdbatom (' C6 ',resname,ires,ni+8)
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine getnuch  --  extract the nucleotide hydrogens  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "getnuch" finds the nucleotide hydrogen atoms for a single
c     residue and copies the names and coordinates to the Protein
c     Data Bank file
c
c
      subroutine getnuch (resname,ires,ni,c1i,c2i,
     &                    o2i,c3i,o3i,c4i,c5i,o5i)
      use atomid
      use couple
      implicit none
      integer i,k
      integer ires,ni
      integer c1i,c4i
      integer c2i,o2i
      integer c3i,o3i
      integer c5i,o5i
      logical allatom,done
      character*3 resname
c
c
c     if no ribose C1 hydrogen, then united atom force field
c
      allatom = .true.
      if (n12(c1i) .ne. 4)  allatom = .false.
c
c     get sugar ring hydrogen atoms for the current residue
c
      done = .false.
      do i = 1, n12(c5i)
         k = i12(i,c5i)
         if (atomic(k).eq.1) then
            if (.not. done) then
               call pdbatom (' H5''',resname,ires,k)
               done = .true.
            else
               call pdbatom ('H5''''',resname,ires,k)
            end if
         end if
      end do
      do i = 1, n12(c4i)
         k = i12(i,c4i)
         if (atomic(k) .eq. 1)  call pdbatom (' H4''',resname,ires,k)
      end do
      do i = 1, n12(c3i)
         k = i12(i,c3i)
         if (atomic(k) .eq. 1)  call pdbatom (' H3''',resname,ires,k)
      end do
      done = .false.
      do i = 1, n12(c2i)
         k = i12(i,c2i)
         if (atomic(k) .eq. 1) then
            if (.not. done) then
               call pdbatom (' H2''',resname,ires,k)
               done = .true.
            else
               call pdbatom ('H2''''',resname,ires,k)
            end if
         end if
      end do
      if (o2i .ne. 0) then
         do i = 1, n12(o2i)
            k = i12(i,o2i)
            if (atomic(k) .eq. 1)  call pdbatom ('HO2''',resname,ires,k)
         end do
      end if
      do i = 1, n12(c1i)
         k = i12(i,c1i)
         if (atomic(k) .eq. 1)  call pdbatom (' H1''',resname,ires,k)
      end do
c
c     adenine in adenosine residue  (A)
c
      if (resname .eq. '  A') then
         if (allatom) then
            call pdbatom (' H8 ',resname,ires,ni+10)
            call pdbatom (' H61',resname,ires,ni+11)
            call pdbatom (' H62',resname,ires,ni+12)
            call pdbatom (' H2 ',resname,ires,ni+13)
         else
            call pdbatom (' H61',resname,ires,ni+10)
            call pdbatom (' H62',resname,ires,ni+11)
         end if
c
c     guanine in guanosine residue  (G)
c
      else if (resname .eq. '  G') then
         if (allatom) then
            call pdbatom (' H8 ',resname,ires,ni+11)
            call pdbatom (' H1 ',resname,ires,ni+12)
            call pdbatom (' H21',resname,ires,ni+13)
            call pdbatom (' H22',resname,ires,ni+14)
         else
            call pdbatom (' H1 ',resname,ires,ni+11)
            call pdbatom (' H21',resname,ires,ni+12)
            call pdbatom (' H22',resname,ires,ni+13)
         end if
c
c     cytosine in cytidine residue  (C)
c
      else if (resname .eq. '  C') then
         if (allatom) then
            call pdbatom (' H41',resname,ires,ni+8)
            call pdbatom (' H42',resname,ires,ni+9)
            call pdbatom (' H5 ',resname,ires,ni+10)
            call pdbatom (' H6 ',resname,ires,ni+11)
         else
            call pdbatom (' H41',resname,ires,ni+8)
            call pdbatom (' H42',resname,ires,ni+9)
         end if
c
c     uracil in uridine residue  (U)
c
      else if (resname .eq. '  U') then
         if (allatom) then
            call pdbatom (' H3 ',resname,ires,ni+8)
            call pdbatom (' H5 ',resname,ires,ni+9)
            call pdbatom (' H6 ',resname,ires,ni+10)
         else
            call pdbatom (' H3 ',resname,ires,ni+8)
         end if
c
c     adenine in deoxyadenosine residue  (DA)
c
      else if (resname .eq. ' DA') then
         if (allatom) then
            call pdbatom (' H8 ',resname,ires,ni+10)
            call pdbatom (' H61',resname,ires,ni+11)
            call pdbatom (' H62',resname,ires,ni+12)
            call pdbatom (' H2 ',resname,ires,ni+13)
         else
            call pdbatom (' H61',resname,ires,ni+10)
            call pdbatom (' H62',resname,ires,ni+11)
         end if
c
c     guanine in deoxyguanosine residue  (DG)
c
      else if (resname .eq. ' DG') then
         if (allatom) then
            call pdbatom (' H8 ',resname,ires,ni+11)
            call pdbatom (' H1 ',resname,ires,ni+12)
            call pdbatom (' H21',resname,ires,ni+13)
            call pdbatom (' H22',resname,ires,ni+14)
         else
            call pdbatom (' H1 ',resname,ires,ni+11)
            call pdbatom (' H21',resname,ires,ni+12)
            call pdbatom (' H22',resname,ires,ni+13)
         end if
c
c     cytosine in deoxycytidine residue  (DC)
c
      else if (resname .eq. ' DC') then
         if (allatom) then
            call pdbatom (' H41',resname,ires,ni+8)
            call pdbatom (' H42',resname,ires,ni+9)
            call pdbatom (' H5 ',resname,ires,ni+10)
            call pdbatom (' H6 ',resname,ires,ni+11)
         else
            call pdbatom (' H41',resname,ires,ni+8)
            call pdbatom (' H42',resname,ires,ni+9)
         end if
c
c     thymine in deoxythymidine residue  (DT)
c
      else if (resname .eq. ' DT') then
         if (allatom) then
            call pdbatom (' H3 ',resname,ires,ni+9)
            call pdbatom (' H71',resname,ires,ni+10)
            call pdbatom (' H72',resname,ires,ni+11)
            call pdbatom (' H73',resname,ires,ni+12)
            call pdbatom (' H6 ',resname,ires,ni+13)
         else
            call pdbatom (' H3 ',resname,ires,ni+9)
         end if
      end if
c
c     get any capping hydrogen atoms for the current residue
c
      do i = 1, n12(o5i)
         k = i12(i,o5i)
         if (atomic(k) .eq. 1)  call pdbatom (' H5T',resname,ires,k)
      end do
      do i = 1, n12(o3i)
         k = i12(i,o3i)
         if (atomic(k) .eq. 1)  call pdbatom (' H3T',resname,ires,k)
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine zatom  --  adds a single atom to Z-matrix  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "zatom" adds an atom to the end of the current Z-matrix
c     and then increments the atom counter; atom type, defining
c     atoms and internal coordinates are passed as arguments
c
c
      subroutine zatom (bionum,bond,angle,dihed,iz1,iz2,iz3,iz4)
      use angbnd
      use atomid
      use atoms
      use bndstr
      use fields
      use iounit
      use kangs
      use katoms
      use kbonds
      use sizes
      use zclose
      use zcoord
      implicit none
      integer i,size
      integer bionum
      integer na,nb
      integer iz1,iz2
      integer iz3,iz4
      integer ita,itb
      integer itc,itd
      real*8 bond,angle
      real*8 dihed
      logical lookup
      character*4 pa,pb,pc,pd
      character*8 blank8,ptb
      character*12 blank12,pta
c
c
c     choose ideal or force field bond and angle values
c
      lookup = .false.
c
c     fill various arrays with information for this atom
c
      if (bionum .gt. 0) then
         type(n) = biotyp(bionum)
         if (type(n) .gt. 0) then
            name(n) = symbol(type(n))
         else
            name(n) = 'XXX'
         end if
         zbond(n) = bond
         zang(n) = angle
         ztors(n) = dihed
         if (ztors(n) .lt. -180.0d0) then
            ztors(n) = ztors(n) + 360.0d0
         else if (ztors(n) .gt. 180.0d0) then
            ztors(n) = ztors(n) - 360.0d0
         end if
         iz(1,n) = iz1
         iz(2,n) = iz2
         iz(3,n) = iz3
         iz(4,n) = iz4
c
c     find force field bond length and angle values
c
         if (lookup) then
            ita = 0
            itb = 0
            itc = 0
            itd = 0
            if (n .ne. 0)  ita = atmcls(type(n))
            if (iz1 .ne. 0)  itb = atmcls(type(iz1))
            if (iz2 .ne. 0)  itc = atmcls(type(iz2))
            if (iz3 .ne. 0)  itd = atmcls(type(iz3))
            blank8 = '        '
            blank12 = '            '
            do i = maxnb, 1, -1
               if (kb(i) .eq. blank8)  nb = i - 1
            end do
            do i = maxna, 1, -1
               if (ka(i) .eq. blank12)  na = i - 1
            end do
            size = 4
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            if (ita .le. itb) then
               ptb = pa//pb
            else
               ptb = pb//pa
            end if
            do i = 1, nb
               if (kb(i) .eq. ptb) then
                  if (blen(i) .ne. 0.0d0)  zbond(n) = blen(i)
                  goto 10
               end if
            end do
   10       continue
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            if (ita .le. itc) then
               pta = pa//pb//pc
            else
               pta = pc//pb//pa
            end if
            do i = 1, na
               if (ka(i) .eq. pta) then
                  if (ang(1,i) .ne. 0.0d0)  zang(n) = ang(1,i)
                  goto 20
               end if
            end do
   20       continue
            if (iz4 .ne. 0) then
               call numeral (ita,pa,size)
               call numeral (itb,pb,size)
               call numeral (itd,pd,size)
               if (ita .le. itd) then
                  pta = pa//pb//pd
               else
                  pta = pd//pb//pa
               end if
               do i = 1, na
                  if (ka(i) .eq. pta) then
                     if (ang(1,i) .ne. 0.0d0)  ztors(n) = ang(1,i)
                     goto 30
                  end if
               end do
   30          continue
            end if
         end if
c
c     increment atom counter and check for too many atoms
c
         n = n + 1
         if (n .gt. maxatm) then
            write (iout,40)  maxatm
   40       format (/,' ZATOM  --  The Maximum of',i9,' Atoms',
     &                 ' has been Exceeded')
            call fatal
         end if
c
c     add an extra bond to make a ring closure
c
      else if (bionum .eq. -1) then
         nadd = nadd + 1
         iadd(1,nadd) = iz1
         iadd(2,nadd) = iz2
c
c     delete an extra bond to make separate molecules
c
      else if (bionum .eq. -2) then
         ndel = ndel + 1
         idel(1,ndel) = iz1
         idel(2,ndel) = iz2
      end if
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module zclose  --  Z-matrix ring openings and closures  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     nadd   number of added bonds between Z-matrix atoms
c     ndel   number of bonds between Z-matrix bonds to delete
c     iadd   numbers of the atom pairs defining added bonds
c     idel   numbers of the atom pairs defining deleted bonds
c
c
      module zclose
      use sizes
      implicit none
      integer nadd,ndel
      integer iadd(2,maxatm)
      integer idel(2,maxatm)
      save
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  module zcoord  --  Z-matrix internal coordinate values  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     iz      defining atom numbers for each Z-matrix atom
c     zbond   bond length used to define each Z-matrix atom
c     zang    bond angle used to define each Z-matrix atom
c     ztors   angle or torsion used to define Z-matrix atom
c
c
      module zcoord
      use sizes
      implicit none
      integer iz(4,maxatm)
      real*8 zbond(maxatm)
      real*8 zang(maxatm)
      real*8 ztors(maxatm)
      save
      end
/*
 * This version of pmpb.c is compatible with APBS Version 1.3
 *
 * Note: The "routines.h" header file includes apbscfg.h, which
 * defines ENABLE_TINKER. ENABLE_TINKER turns on function prototypes
 * in the headers included within "apbs.h"; therefore, "routines.h"
 * needs to be before "apbs.h" to avoid implicit function definitons
 */

#include "apbs/apbscfg.h"
#include "apbs/routines.h"
#include "apbs/apbs.h"

/*
 * Below we define aliases to allow Tinker Fortran code
 * to call the C routines in this file when linking on 
 * Windows under the Intel compiler
 *
 * Replace __ICL with _WIN32 or _WIN64 to cause these
 * definitions to always be used on Windows machines
 *
 * Also use the -Qlowercase flag to deal with the Intel
 * compiler's name mangling on Windows; underscores are
 * used by default on Linux and macOS, but not Windows 
 */

#ifdef __ICL
#define apbsinitial_ apbsinitial
#define apbsempole_ apbsempole
#define apbsinduce_ apbsinduce
#define apbsnlinduce_ apbsnlinduce
#define pbdirectpolforce_ pbdirectpolforce
#define pbmutualpolforce_ pbmutualpolforce
#define apbsfinal_ apbsfinal
#endif

/***********************************************************************
  Below are some global variables that are saved between APBS calls.
  There may be a better way to do this, although passing pointers
  into Fortran should be avoided.
***********************************************************************/

// Tinker MAXATM parameter; must match "sizes.f"
#define maxatm 1000000

// Tinker MAXION parameter; must match "pbstuf.f"
#define maxion 10

// APBS configuration objects
Vmem *mem = VNULL;
Vcom *com = VNULL;
Vio *sock = VNULL;
NOsh *nosh = VNULL;

// atom list
Valist *alist[NOSH_MAXMOL];

// potential solutions saved for polarization force calculation
Vgrid *permU[2];
Vgrid *indU[2];
Vgrid *nlIndU[2];

// kappa and dielectric Vgrids (for homogeneous and solvated states)
Vgrid *dielXMap[NOSH_MAXMOL];
Vgrid *dielYMap[NOSH_MAXMOL];
Vgrid *dielZMap[NOSH_MAXMOL];
Vgrid *kappaMap[NOSH_MAXMOL];
Vgrid *potMap[NOSH_MAXMOL];
Vgrid *chargeMap[NOSH_MAXMOL];
double realCenter[3];

/***********************************************************************
  apbsinitial is called from Tinker to:

  (1) Initialize APBS Vcom, Vmem and NOsh objects
  (2) Create a "virtual" APBS input file and parse it
***********************************************************************/

void apbsinitial_ (int dime[3], double grid[3], double gcent[3],
                   double cgrid[3], double cgcent[3],
                   double fgrid[3], double fgcent[3],
                   double *pdie, double *sdie,
                   double *srad, double *swin,
                   double *sdens, double *kelvin,
                   int *ionn, double ionc[maxion],
                   int ionq[maxion], double ionr[maxion],
                   char *pbtypef, int *pbtypelen,
                   char *pbsolnf, int *pbsolnlen,
                   char *bcflf, int *bcfllen,
                   char *chgmf, int *chgmlen,
                   char *srfmf, int *srfmlen,
                   int fortranAppendedPbtypeLen,
                   int fortranAppendedPbsolnLen,
                   int fortranAppendedBfclLen,
                   int fortranAppendedChgmLen,
                   int fortranAppendedSrfmLen) {

   /* All character strings passed from Fortran result in an integer
    * appended to the list of arguments, each equal to the static
    * length of 20 specified in the Fortran module 'pbstuf.f'
    *
    * Further below the Fortran strings will be converted into
    * null terminated C-strings
    */
   char pbtype[21]; // lpbe
   char pbsoln[21]; // mg-manual or mg-auto
   char bcfl[21];   // zero, sdh, mdh
   char chgm[21];   // spl4
   char srfm[21];   // mol, smol, spl2

   /* Bogus argc and argv variables used for Vcom constructor */
   int argc = 0;
   char **argv;

   /* CPU info */
   int rank, size;

   /* APBS "input file" is a character buffer */
   char buff[4096];
   char tmp[1024];

   /* Loop index */
   int i;

   /* Start the timer; it is not stopped until apbsfinal is called */
   Vnm_tstart(APBS_TIMER_WALL_CLOCK, "APBS WALL CLOCK");

   /* Convert Fortran strings to null-terminated C-String */
   strncpy(pbtype, pbtypef, *pbtypelen);
   strncpy(pbsoln, pbsolnf, *pbsolnlen);
   strncpy(bcfl, bcflf, *bcfllen);
   strncpy(chgm, chgmf, *chgmlen);
   strncpy(srfm, srfmf, *srfmlen);
   pbtype[*pbtypelen] = '\0';
   pbsoln[*pbsolnlen] = '\0';
   bcfl[*bcfllen] = '\0';
   chgm[*chgmlen] = '\0';
   srfm[*srfmlen] = '\0';

   /* Rather than require an APBS input file, a character buffer is
    * loaded with two ELEC statements:
    *
    * (1) The homogeneous calculation
    * (2) The solvated calculation
    *
    * Many options for partial charge systems are not yet supported
    * for AMOEBA (or are not appropriate); The subset of ELEC options
    * that can be modified are configured using Tinker keywords
    *
    * Initialization of the "nosh" input data structure then proceeds
    * using the buffer data; If the syntax of the ELEC statement changes,
    * then corresponding changes will be needed to be made below
    */

   /* Homogeneous */
   strcpy(buff,"ELEC NAME HOMOGENEOUS\n");
   sprintf(tmp,"\t%s\n",pbsoln);
   strcat(buff,tmp);
   sprintf(tmp,"\t%s\n",pbtype);
   strcat(buff,tmp);
   sprintf(tmp,"\tDIME\t%3i %3i %3i\n",dime[0],dime[1],dime[2]);
   strcat(buff,tmp);
   // MG-AUTO
   if (strcmp(pbsoln,"MG-AUTO") == 0) {
      sprintf(tmp,"\tCGLEN  %10.6f %10.6f %10.6f\n",
                     dime[0]*cgrid[0], dime[1]*cgrid[1], dime[2]*cgrid[2]);
      strcat(buff,tmp);
      sprintf(tmp,"\tCGCENT %10.6f %10.6f %10.6f\n",
                     cgcent[0], cgcent[1],cgcent[2]);
      strcat(buff,tmp);
      sprintf(tmp,"\tFGLEN  %10.6f %10.6f %10.6f\n",
                     dime[0]*fgrid[0], dime[1]*fgrid[1], dime[2]*fgrid[2]);
      strcat(buff,tmp);
      sprintf(tmp,"\tFGCENT %10.6f %10.6f %10.6f\n",
                     fgcent[0], fgcent[1], fgcent[2]);
      strcat(buff,tmp);
   } else { // MG-MANUAL
      sprintf(tmp,"\tGLEN  %10.6f %10.6f %10.6f\n",
                     dime[0]*grid[0], dime[1]*grid[1], dime[2]*grid[2]);
      strcat(buff,tmp);
      sprintf(tmp,"\tGCENT %10.6f %10.6f %10.6f\n",
                     gcent[0], gcent[1], gcent[2]);
      strcat(buff,tmp);
   }
   strcat(buff,"\tMOL\t1\n");
   sprintf(tmp,"\tBCFL\t%s\n", bcfl);
   strcat(buff,tmp);
   sprintf(tmp,"\tPDIE  %10.6f\n", *pdie);
   strcat(buff,tmp);
   sprintf(tmp,"\tSDIE  %10.6f\n", *pdie);
   strcat(buff,tmp);
   sprintf(tmp,"\tCHGM\t%s\n", chgm);
   strcat(buff,tmp);
   sprintf(tmp,"\tSRFM\t%s\n", srfm);
   strcat(buff,tmp);
   sprintf(tmp,"\tSRAD  %10.6f\n", *srad);
   strcat(buff,tmp);
   sprintf(tmp,"\tSWIN  %10.6f\n", *swin);
   strcat(buff,tmp);
   sprintf(tmp,"\tSDENS %10.6f\n", *sdens);
   strcat(buff,tmp);
   sprintf(tmp,"\tTEMP  %10.6f\n", *kelvin);
   strcat(buff,tmp);
   strcat(buff,"END\n\n");

   /* Solvated */
   strcat(buff,"ELEC NAME SOLVATED\n");
   sprintf(tmp,"\t%s\n",pbsoln);
   strcat(buff,tmp);
   sprintf(tmp,"\t%s\n",pbtype);
   strcat(buff,tmp);
   sprintf(tmp,"\tDIME\t%3i %3i %3i\n",dime[0],dime[1],dime[2]);
   strcat(buff,tmp);
   // MG-AUTO
   if (strcmp(pbsoln,"MG-AUTO") == 0) {
      sprintf(tmp,"\tCGLEN  %10.6f %10.6f %10.6f\n",
                     dime[0]*cgrid[0], dime[1]*cgrid[1], dime[2]*cgrid[2]);
      strcat(buff,tmp);
      sprintf(tmp,"\tCGCENT %10.6f %10.6f %10.6f\n",
                     cgcent[0], cgcent[1], cgcent[2]);
      strcat(buff,tmp);
      sprintf(tmp,"\tFGLEN  %10.6f %10.6f %10.6f\n",
                     dime[0]*fgrid[0], dime[1]*fgrid[1], dime[2]*fgrid[2]);
      strcat(buff,tmp);
      sprintf(tmp,"\tFGCENT %10.6f %10.6f %10.6f\n",
                     fgcent[0], fgcent[1], fgcent[2]);
      strcat(buff,tmp);
   } else { // MG-MANUAL
      sprintf(tmp,"\tGLEN  %10.6f %10.6f %10.6f\n",
                     dime[0]*grid[0], dime[1]*grid[1], dime[2]*grid[2]);
      strcat(buff,tmp);
      sprintf(tmp,"\tGCENT %10.6f %10.6f %10.6f\n",
                     gcent[0], gcent[1], gcent[2]);
      strcat(buff,tmp);
   }
   strcat(buff,"\tMOL\t1\n");
   sprintf(tmp,"\tBCFL\t%s\n", bcfl);
   strcat(buff,tmp);
   sprintf(tmp,"\tPDIE  %10.6f\n", *pdie);
   strcat(buff,tmp);
   sprintf(tmp,"\tSDIE  %10.6f\n", *sdie);
   strcat(buff,tmp);
   sprintf(tmp,"\tCHGM\t%s\n", chgm);
   strcat(buff,tmp);
   sprintf(tmp,"\tSRFM\t%s\n", srfm);
   strcat(buff,tmp);
   sprintf(tmp,"\tSRAD  %10.6f\n", *srad);
   strcat(buff,tmp);
   sprintf(tmp,"\tSWIN  %10.6f\n", *swin);
   strcat(buff,tmp);
   sprintf(tmp,"\tSDENS %10.6f\n", *sdens);
   strcat(buff,tmp);
   sprintf(tmp,"\tTEMP  %10.6f\n", *kelvin);
   strcat(buff,tmp);
   for (i=0; i < *ionn; i++) {
      sprintf(tmp,"\tION\t%2i %10.6f %10.6f\n", ionq[i], ionc[i], ionr[i]);
      strcat(buff,tmp);
   }
   strcat(buff,"END\n");
   strcat(buff,"\nQUIT\n");

   /* Misc. initializations */
   for (i=0; i<NOSH_MAXMOL; i++) {
      alist[i] = VNULL;
      dielXMap[i] = VNULL;
      dielYMap[i] = VNULL;
      dielZMap[i] = VNULL;
      kappaMap[i] = VNULL;
      potMap[i] = VNULL;
      chargeMap[i] = VNULL;
   }
   for (i=0; i<2; i++) {
      permU[i] = VNULL;
      indU[i] = VNULL;
      nlIndU[i] = VNULL;
   }

   /* Initialization of Vcom, Vmem, and Nosh (via Vio) */
   VASSERT(Vcom_init(&argc, &argv));
   com = Vcom_ctor(1);
   rank = Vcom_rank(com);
   size = Vcom_size(com);
   startVio();
   Vnm_setIoTag(rank, size);
   mem = Vmem_ctor("MAIN");

   /* Print (to io.mc) and then parse the input buffer. */
   Vnm_tprint(0, "\n********* Tinker generated input buffer *********\n\n");
   Vnm_tprint(0, "%s", buff);
   Vnm_tprint(0, "\n*************************************************\n\n");
   nosh = NOsh_ctor(rank, size);
   sock = Vio_ctor("BUFF", "ASC", VNULL, "BUFFER", "r");
   Vio_bufTake(sock, buff, strlen(buff));
   if (!NOsh_parseInput(nosh, sock)) {
      Vnm_tprint( 2, "Error while parsing input file.\n");
      return;
   }
   /* Release the buffer and kill Vio */
   Vio_bufGive(sock);
   Vio_dtor(&sock);
}

/***********************************************************************
  apbsempole is called from Tinker to:

  (1) Solve the PBE using permanent multipoles as the source term
  (2) Save the solution potential for polarization force calculation
  (3) Return permanent electrostatic solvation values for: energy
      field, forces and torques
***********************************************************************/

void apbsempole_ (int *natom, double x[maxatm][3],
                  double rad[maxatm], double rpole[maxatm][13],
                  double *total,
                  double energy[maxatm], double fld[maxatm][3],
                  double rff[maxatm][3], double rft[maxatm][3]) {

   /* Various pointers to APBS data structures */
   Vpmg  *pmg[NOSH_MAXCALC];
   Vpmgp *pmgp[NOSH_MAXCALC];
   Vpbe  *pbe[NOSH_MAXCALC];
   MGparm *mgparm = VNULL;
   PBEparm *pbeparm = VNULL;
   Vatom *atom = VNULL;

   /* Vgrid configuration for the kappa and dielectric maps */
   double nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin;
   double *data;
   double zkappa2, epsp, epsw;

   /* Loop indeces */
   int i,j;

   /* Observables and unit conversion */
   double sign, force[3], torque[3], field[3];
   double kT,electric,debye;
   double charge, dipole[3], quad[9];
   debye = 4.8033324;

   for (i=0; i<NOSH_MAXCALC; i++) {
      pmg[i] = VNULL;
      pmgp[i] = VNULL;
      pbe[i] = VNULL;
   }

   /* Kill the saved potential Vgrids */
   for (i=0; i<2; i++){
       if (permU[i] != VNULL) Vgrid_dtor(&permU[i]);
       if (indU[i] != VNULL) Vgrid_dtor(&indU[i]);
       if (nlIndU[i] != VNULL) Vgrid_dtor(&nlIndU[i]);
   }

   /* Kill the old atom list */
   if (alist[0] != VNULL) {
      Valist_dtor(&alist[0]);
   }

   /* Create a new atom list (mol == 1) */
   if (alist[0] == VNULL) {
      alist[0] = Valist_ctor();
      alist[0]->atoms = Vmem_malloc(alist[0]->vmem, *natom, (sizeof(Vatom)));
      alist[0]->number = *natom;
   }

   /* Read Tinker input data into Vatom instances */
   for (i=0; i < alist[0]->number; i++){
      atom = Valist_getAtom(alist[0],i);
      Vatom_setAtomID(atom, i);
      Vatom_setPosition(atom, x[i]);
      Vatom_setRadius(atom, rad[i]);
      charge = rpole[i][0];
      Vatom_setCharge(atom, charge);
      dipole[0] = rpole[i][1];
      dipole[1] = rpole[i][2];
      dipole[2] = rpole[i][3];
      Vatom_setDipole(atom, dipole);
      quad[0] = rpole[i][4];
      quad[1] = rpole[i][5];
      quad[2] = rpole[i][6];
      quad[3] = rpole[i][7];
      quad[4] = rpole[i][8];
      quad[5] = rpole[i][9];
      quad[6] = rpole[i][10];
      quad[7] = rpole[i][11];
      quad[8] = rpole[i][12];
      Vatom_setQuadrupole(atom, quad);
      /* Useful check
      printf(" %i %f (%f,%f,%f)\n",i,rad[i], x[i][0], x[i][1], x[i][2]);
      printf(" %f\n %f,%f,%f\n", charge, dipole[0], dipole[1], dipole[2]);
      printf(" %f\n", quad[0]);
      printf(" %f %f\n", quad[3], quad[4]);
      printf(" %f %f %f\n", quad[6], quad[7], quad[8]); */
      energy[i] = 0.0;
      for (j=0;j<3;j++){
         fld[i][j] = 0.0;
         rff[i][j] = 0.0;
         rft[i][j] = 0.0;
      }
   }

   nosh->nmol = 1;
   Valist_getStatistics(alist[0]);

   /* Only call setupCalc routine once, so we can reuse this nosh object */
   if (nosh->ncalc < 2) {
      if (NOsh_setupElecCalc(nosh, alist) != 1) {
         printf("Error setting up calculations\n");
         exit(-1);
      }
   }

   /* Solve the LPBE for the homogeneous and then solvated states */
   for (i=0; i<2; i++) {

      /* Useful local variables */
      mgparm = nosh->calc[i]->mgparm;
      pbeparm = nosh->calc[i]->pbeparm;

      /* Just to be robust */
      if (!MGparm_check(mgparm)){
         printf("MGparm Check failed\n");
         printMGPARM(mgparm, realCenter);
         exit(-1);
      }
      if (!PBEparm_check(pbeparm)){
         printf("PBEparm Check failed\n");
         printPBEPARM(pbeparm);
         exit(-1);
      }

      /* Set up the problem */
      mgparm->chgs = VCM_PERMANENT;
      if (!initMG(i, nosh, mgparm, pbeparm, realCenter, pbe,
                  alist, dielXMap, dielYMap, dielZMap,
                  kappaMap, chargeMap, pmgp, pmg, potMap)) {
             Vnm_tprint( 2, "Error setting up MG calculation!\n");
             return;
      }

      /* Solve the PDE */
      if (solveMG(nosh, pmg[i], mgparm->type) != 1) {
          Vnm_tprint(2, "Error solving PDE!\n");
          return;
      }

      /* Set partition information for observables and I/O */
      /* Note that parallel operation has NOT been tested */
      if (setPartMG(nosh, mgparm, pmg[i]) != 1) {
          Vnm_tprint(2, "Error setting partition info!\n");
          return;
      }

      nx = pmg[i]->pmgp->nx;
      ny = pmg[i]->pmgp->ny;
      nz = pmg[i]->pmgp->nz;
      hx = pmg[i]->pmgp->hx;
      hy = pmg[i]->pmgp->hy;
      hzed = pmg[i]->pmgp->hzed;
      xmin = pmg[i]->pmgp->xmin;
      ymin = pmg[i]->pmgp->ymin;
      zmin = pmg[i]->pmgp->zmin;

      /* Save dielectric/kappa maps into Vgrids, then change the nosh
       * data structure to think it read these maps in from a file;
       * The goal is to save setup time during convergence of the
       * induced dipoles. This is under consideration...
       */

      /*
      // X (shifted)
      data = Vmem_malloc(mem, nx*ny*nz, sizeof(double));
      Vpmg_fillArray(pmg[i], data, VDT_DIELX, 0.0, pbeparm->pbetype);
      dielXMap[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed,
                               xmin + 0.5*hx,ymin,zmin,data);
      dielXMap[i]->readdata = 1;
      // Y (shifted)
      data = Vmem_malloc(mem, nx*ny*nz, sizeof(double));
      Vpmg_fillArray(pmg[i], data, VDT_DIELY, 0.0, pbeparm->pbetype);
      dielYMap[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed,
                                     xmin,ymin + 0.5*hy,zmin,data);
      dielYMap[i]->readdata = 1;
      // Z (shifted)
      data = Vmem_malloc(mem, nx*ny*nz, sizeof(double));
      Vpmg_fillArray(pmg[i], data, VDT_DIELZ, 0.0, pbeparm->pbetype);
      dielZMap[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed,
                                     xmin,ymin,zmin + 0.5*hzed,data);
      dielZMap[i]->readdata = 1;
      // Kappa
      data = Vmem_malloc(mem, nx*ny*nz, sizeof(double));
      Vpmg_fillArray(pmg[i], data, VDT_KAPPA, 0.0, pbeparm->pbetype);
      kappaMap[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin,data);
      kappaMap[i]->readdata = 1;

      // Update the pbeparam structure, since we now have
      // dielectric and kappap maps
      pbeparm->useDielMap = 1;
      pbeparm->dielMapID = i + 1;
      pbeparm->useKappaMap = 1;
      pbeparm->kappaMapID = i + 1;
      */

      data = Vmem_malloc(mem, nx*ny*nz, sizeof(double));
      Vpmg_fillArray(pmg[i], data, VDT_POT, 0.0, pbeparm->pbetype, pbeparm);
      permU[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin,data);
      permU[i]->readdata = 1;
      // set readdata flag to have the dtor to free data

      if (i == 0){
         sign = -1.0;
      } else {
         sign = 1.0;
      }

      /* Calculate observables */
      for (j=0; j < alist[0]->number; j++){
        energy[j] += sign * Vpmg_qfPermanentMultipoleEnergy(pmg[i], j);
        Vpmg_fieldSpline4(pmg[i], j, field);
        fld[j][0] += sign * field[0];
        fld[j][1] += sign * field[1];
        fld[j][2] += sign * field[2];
      }

      if (!pmg[i]->pmgp->nonlin &&
         (pmg[i]->surfMeth == VSM_SPLINE ||
          pmg[i]->surfMeth == VSM_SPLINE3 ||
          pmg[i]->surfMeth == VSM_SPLINE4)) {
         for (j=0; j < alist[0]->number; j++){
            Vpmg_qfPermanentMultipoleForce(pmg[i], j, force, torque);
            rff[j][0] += sign * force[0];
            rff[j][1] += sign * force[1];
            rff[j][2] += sign * force[2];
            rft[j][0] += sign * torque[0];
            rft[j][1] += sign * torque[1];
            rft[j][2] += sign * torque[2];
         }
         kT = Vunit_kb * (1e-3) * Vunit_Na * 298.15 * 1.0/4.184;
         epsp = Vpbe_getSoluteDiel(pmg[i]->pbe);
         epsw = Vpbe_getSolventDiel(pmg[i]->pbe);
         if (VABS(epsp-epsw) > VPMGSMALL) {
            for (j=0; j < alist[0]->number; j++){
               Vpmg_dbPermanentMultipoleForce(pmg[i], j, force);
               rff[j][0] += sign * force[0];
               rff[j][1] += sign * force[1];
               rff[j][2] += sign * force[2];
            }
         }
         zkappa2 = Vpbe_getZkappa2(pmg[i]->pbe);
         if (zkappa2 > VPMGSMALL) {
            for (j=0; j < alist[0]->number; j++) {
               Vpmg_ibPermanentMultipoleForce(pmg[i], j, force);
               rff[j][0] += sign * force[0];
               rff[j][1] += sign * force[1];
               rff[j][2] += sign * force[2];
            }
         }
      }
   }

   //nosh->ndiel = 2;
   //nosh->nkappa = 2;
   /*
   printf("Energy (multipole) %f Kcal/mol\n", *energy);
   printf("Energy (volume)    %f Kcal/mol\n", evol * 0.5 * kT);
   */

   /* Convert results into kcal/mol units */
   kT = Vunit_kb * (1e-3) * Vunit_Na * 298.15 * 1.0/4.184;
   /* Electric converts from electron**2/Angstrom to kcal/mol */
   electric = 332.063709;
   *total = 0.0;
   for (i=0; i<alist[0]->number; i++){
      /* starting with the field in KT/e/Ang^2 multiply by kcal/mol/KT
         the field is then divided by "electric" to convert to e/Ang^2 */
      energy[i] *= 0.5 * kT;
      *total += energy[i];
      fld[i][0] *= kT / electric;
      fld[i][1] *= kT / electric;
      fld[i][2] *= kT / electric;
      rff[i][0] *= kT;
      rff[i][1] *= kT;
      rff[i][2] *= kT;
      rft[i][0] *= kT;
      rft[i][1] *= kT;
      rft[i][2] *= kT;
   }

   killMG(nosh, pbe, pmgp, pmg);
}

/***********************************************************************
  apbsinduce is called from Tinker during SCRF convergence to:

  (1) Solve the PBE given induced dipoles as the source term
  (2) Save the solution potential for later polarization force calc
  (3) Return the induced reaction field to Tinker
***********************************************************************/

void apbsinduce_ (double uind[maxatm][3], double fld[maxatm][3]){

   Vpmg  *pmg[NOSH_MAXCALC];
   Vpmgp *pmgp[NOSH_MAXCALC];
   Vpbe  *pbe[NOSH_MAXCALC];
   MGparm *mgparm = VNULL;
   PBEparm *pbeparm = VNULL;
   Vatom *atom = VNULL;

   /* Observables and unit conversion */
   double field[3];
   double sign,kT,electric;

   /* Potential Vgrid construction */
   double nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin;
   double *data;

   /* Loop variables */
   int i,j;

   VASSERT(nosh != VNULL);
   for (i=0; i<NOSH_MAXCALC; i++) {
      pmg[i] = VNULL;
      pmgp[i] = VNULL;
      pbe[i] = VNULL;
   }

   /* Read Tinker input data into Vatom instances */
   for (i=0; i < alist[0]->number; i++){
      atom = Valist_getAtom(alist[0],i);
      Vatom_setInducedDipole(atom, uind[i]);
      for (j=0;j<3;j++){
          fld[i][j] = 0.0;
      }
   }

   /* Solve the LPBE for the homogeneous system, then solvated */
   for (i=0; i<2; i++) {

      pmg[i] = VNULL;
      pmgp[i] = VNULL;
      pbe[i] = VNULL;

      /* Useful local variables */
      mgparm = nosh->calc[i]->mgparm;
      pbeparm = nosh->calc[i]->pbeparm;

      if (!MGparm_check(mgparm)){
         printf("MGparm Check failed\n");
         exit(-1);
      }
      if (!PBEparm_check(pbeparm)){
         printf("PBEparm Check failed\n");
         exit(-1);
      }

      /* Set up problem */
      mgparm->chgs = VCM_INDUCED;
      if (!initMG(i, nosh, mgparm, pbeparm, realCenter, pbe,
                  alist, dielXMap, dielYMap, dielZMap,
                  kappaMap, chargeMap, pmgp, pmg, potMap)) {
          Vnm_tprint( 2, "Error setting up MG calculation!\n");
          return;
      }

      /* Solve the PDE */
      if (solveMG(nosh, pmg[i], mgparm->type) != 1) {
          Vnm_tprint(2, "Error solving PDE!\n");
          return;
      }

      /* Set partition information for observables and I/O */
      if (setPartMG(nosh, mgparm, pmg[i]) != 1) {
          Vnm_tprint(2, "Error setting partition info!\n");
          return;
      }

      /* Save the potential due to local induced dipoles */
      nx = pmg[i]->pmgp->nx;
      ny = pmg[i]->pmgp->ny;
      nz = pmg[i]->pmgp->nz;
      hx = pmg[i]->pmgp->hx;
      hy = pmg[i]->pmgp->hy;
      hzed = pmg[i]->pmgp->hzed;
      xmin = pmg[i]->pmgp->xmin;
      ymin = pmg[i]->pmgp->ymin;
      zmin = pmg[i]->pmgp->zmin;

      if (indU[i] == VNULL) {
         data = Vmem_malloc(mem, nx*ny*nz, sizeof(double));
         Vpmg_fillArray(pmg[i], data, VDT_POT, 0.0, pbeparm->pbetype, pbeparm);
         indU[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin,data);
         indU[i]->readdata = 1;
         // set readdata flag to have the dtor to free data
      } else {
         data = indU[i]->data;
         Vpmg_fillArray(pmg[i], data, VDT_POT, 0.0, pbeparm->pbetype, pbeparm);
      }

      if (i == 0){
         sign = -1.0;
      } else {
         sign = 1.0;
      }

      for (j=0; j < alist[0]->number; j++){
         Vpmg_fieldSpline4(pmg[i], j, field);
         fld[j][0] += sign * field[0];
         fld[j][1] += sign * field[1];
         fld[j][2] += sign * field[2];
      }
   }

   /* load results into the return arrays in electron**2/Ang */
   /* value of kT is in kcal/mol */
   kT = Vunit_kb * (1e-3) * Vunit_Na * 298.15 / 4.184;
   /* electric is conversion from electron**2/Ang to Kcal/mol */
   electric = 332.063713;
   for (i=0; i<alist[0]->number; i++){
      // starting with the field in KT/e/Ang^2 multiply by Kcal/mol/KT
      // (conversion to e/Ang^2, which are Tinker field units)
      fld[i][0] *= kT / electric;
      fld[i][1] *= kT / electric;
      fld[i][2] *= kT / electric;
   }

   killMG(nosh, pbe, pmgp, pmg);
}

/***********************************************************************
  apbsnlinduce is called from Tinker during SCRF convergence to:

  (1) Solve the PBE given non-local induced dipoles as the source term
  (2) Save the solution potential for later polarization force calc
  (3) Return the nonlocal induced dipole reaction field to Tinker
************************************************************************/

void apbsnlinduce_ (double uinp[maxatm][3], double fld[maxatm][3]){

   /* Misc. pointers to APBS data structures */
   Vpmg  *pmg[NOSH_MAXCALC];
   Vpmgp *pmgp[NOSH_MAXCALC];
   Vpbe  *pbe[NOSH_MAXCALC];
   MGparm *mgparm = VNULL;
   PBEparm *pbeparm = VNULL;
   Vatom *atom = VNULL;

   /* Observables and unit conversion */
   double field[3];
   double sign,kT,electric;
   /* Potential Vgrid construction */
   double nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin;
   double *data;
   /* Loop variables */
   int i,j;

   VASSERT(nosh != VNULL);
   for (i=0; i<NOSH_MAXCALC; i++) {
      pmg[i] = VNULL;
      pmgp[i] = VNULL;
      pbe[i] = VNULL;
   }

   /* Read Tinker induce input data into Vatom instances */
   for (i=0; i < alist[0]->number; i++){
      atom = Valist_getAtom(alist[0],i);
      Vatom_setNLInducedDipole(atom, uinp[i]);
      for (j=0;j<3;j++){
          fld[i][j] = 0.0;
      }
   }

   /* Solve the LPBE for the homogeneous system, then solvated */
   for (i=0; i<2; i++) {

      pmg[i] = VNULL;
      pmgp[i] = VNULL;
      pbe[i] = VNULL;

      /* Useful local variables */
      mgparm = nosh->calc[i]->mgparm;
      pbeparm = nosh->calc[i]->pbeparm;

      if (!MGparm_check(mgparm)){
         printf("MGparm Check failed\n");
         exit(-1);
      }
      if (!PBEparm_check(pbeparm)){
         printf("PBEparm Check failed\n");
         exit(-1);
      }

      /* Set up problem */
      mgparm->chgs = VCM_NLINDUCED;
      if (!initMG(i, nosh, mgparm, pbeparm, realCenter, pbe,
                  alist, dielXMap, dielYMap, dielZMap,
                  kappaMap, chargeMap, pmgp, pmg, potMap)) {
          Vnm_tprint( 2, "Error setting up MG calculation!\n");
          return;
      }

      /* Solve the PDE */
      if (solveMG(nosh, pmg[i], mgparm->type) != 1) {
          Vnm_tprint(2, "Error solving PDE!\n");
          return;
      }

      /* Set partition information for observables and I/O */
      if (setPartMG(nosh, mgparm, pmg[i]) != 1) {
          Vnm_tprint(2, "Error setting partition info!\n");
          return;
      }

      /* Save the potential due to non-local induced dipoles */
      nx = pmg[i]->pmgp->nx;
      ny = pmg[i]->pmgp->ny;
      nz = pmg[i]->pmgp->nz;
      hx = pmg[i]->pmgp->hx;
      hy = pmg[i]->pmgp->hy;
      hzed = pmg[i]->pmgp->hzed;
      xmin = pmg[i]->pmgp->xmin;
      ymin = pmg[i]->pmgp->ymin;
      zmin = pmg[i]->pmgp->zmin;

      if (nlIndU[i] == VNULL) {
         data = Vmem_malloc(VNULL, nx*ny*nz, sizeof(double));
         Vpmg_fillArray(pmg[i], data, VDT_POT, 0.0, pbeparm->pbetype, pbeparm);
         nlIndU[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin,data);
         nlIndU[i]->readdata = 1; // set readata flag to have dtor free data
      } else {
         data = nlIndU[i]->data;
         Vpmg_fillArray(pmg[i], data, VDT_POT, 0.0, pbeparm->pbetype, pbeparm);
      }

      if (i == 0){
         sign = -1.0;
      } else {
         sign = 1.0;
      }

      for (j=0; j < alist[0]->number; j++){
         Vpmg_fieldSpline4(pmg[i], j, field);
         fld[j][0] += sign * field[0];
         fld[j][1] += sign * field[1];
         fld[j][2] += sign * field[2];
      }
   }

   /* load results into the return arrays in electron**2/Angstrom */
   /* value of kT is in kcal/mol */
   kT = Vunit_kb * (1e-3) * Vunit_Na * 298.15 / 4.184;
   /* electric is conversion from electron**2/Angstrom to Kcal/mol */
   electric = 332.063713;
   for (i=0; i<alist[0]->number; i++){
      fld[i][0] *= kT / electric;
      fld[i][1] *= kT / electric;
      fld[i][2] *= kT / electric;
   }

   killMG(nosh, pbe, pmgp, pmg);
}

/***********************************************************************
  pbdirectpolforce is called from Tinker to:

  (1) compute direct polarization forces and torques using
      saved potentials
***********************************************************************/

void pbdirectpolforce_ (double uind[maxatm][3], double uinp[maxatm][3],
                        double rff[maxatm][3], double rft[maxatm][3]) {

   Vpmg  *pmg[NOSH_MAXCALC];
   Vpmgp *pmgp[NOSH_MAXCALC];
   Vpbe  *pbe[NOSH_MAXCALC];
   MGparm *mgparm = VNULL;
   PBEparm *pbeparm = VNULL;
   Vatom *atom = VNULL;
   double kT, force[3], torque[3];
   double sign, zkappa2, epsp, epsw;
   int i,j;

   for (i=0; i<NOSH_MAXCALC; i++) {
      pmg[i] = VNULL;
      pmgp[i] = VNULL;
      pbe[i] = VNULL;
   }

   // Read the converged induced dipole data into APBS Vatom structures
   for (i=0; i < alist[0]->number; i++){
      atom = Valist_getAtom(alist[0],i);
      Vatom_setInducedDipole(atom, uind[i]);
      Vatom_setNLInducedDipole(atom, uinp[i]);
      for (j=0;j<3;j++){
         rff[i][j] = 0.0;
         rft[i][j] = 0.0;
      }
   }

   for (i=0; i<2; i++) {

      VASSERT(permU[i] != VNULL);
      VASSERT(indU[i] != VNULL);
      VASSERT(nlIndU[i] != VNULL);

      pmg[i] = VNULL;
      pmgp[i] = VNULL;
      pbe[i] = VNULL;

      /* Useful local variables */
      mgparm = nosh->calc[i]->mgparm;
      pbeparm = nosh->calc[i]->pbeparm;

      /* Set up problem */
      if (!initMG(i, nosh, mgparm, pbeparm, realCenter, pbe,
                  alist, dielXMap, dielYMap, dielZMap,
                  kappaMap, chargeMap, pmgp, pmg, potMap)) {
          Vnm_tprint( 2, "Error setting up MG calculation!\n");
          return;
      }

      if (i == 0) {
        sign = -1.0;
      } else {
        sign = 1.0;
      }

      // Q-Phi Force & Torque
      if (!pmg[i]->pmgp->nonlin &&
         (pmg[i]->surfMeth == VSM_SPLINE ||
          pmg[i]->surfMeth == VSM_SPLINE3 ||
          pmg[i]->surfMeth == VSM_SPLINE4)) {
         for (j=0; j < alist[0]->number; j++){
            Vpmg_qfDirectPolForce(pmg[i], permU[i], indU[i], j, force, torque);
            rff[j][0] += sign * force[0];
            rff[j][1] += sign * force[1];
            rff[j][2] += sign * force[2];
            rft[j][0] += sign * torque[0];
            rft[j][1] += sign * torque[1];
            rft[j][2] += sign * torque[2];
            Vpmg_qfNLDirectPolForce(pmg[i], permU[i],
                                    nlIndU[i], j,force,torque);
            rff[j][0] += sign * force[0];
            rff[j][1] += sign * force[1];
            rff[j][2] += sign * force[2];
            rft[j][0] += sign * torque[0];
            rft[j][1] += sign * torque[1];
            rft[j][2] += sign * torque[2];
         }
         // Dieletric Boundary Force
         epsp = Vpbe_getSoluteDiel(pmg[i]->pbe);
         epsw = Vpbe_getSolventDiel(pmg[i]->pbe);
         if (VABS(epsp-epsw) > VPMGSMALL) {
            for (j=0; j < alist[0]->number; j++){
               Vpmg_dbDirectPolForce(pmg[i], permU[i], indU[i], j, force);
               rff[j][0] += sign * force[0];
               rff[j][1] += sign * force[1];
               rff[j][2] += sign * force[2];
               Vpmg_dbNLDirectPolForce(pmg[i], permU[i], nlIndU[i], j, force);
               rff[j][0] += sign * force[0];
               rff[j][1] += sign * force[1];
               rff[j][2] += sign * force[2];
            }
         }
         // Ionic Boundary Force
         zkappa2 = Vpbe_getZkappa2(pmg[i]->pbe);
         if (zkappa2 > VPMGSMALL) {
            for (j=0; j < alist[0]->number; j++){
               Vpmg_ibDirectPolForce(pmg[i], permU[i], indU[i], j, force);
               rff[j][0] += sign * force[0];
               rff[j][1] += sign * force[1];
               rff[j][2] += sign * force[2];
               Vpmg_ibNLDirectPolForce(pmg[i], permU[i],
                                       nlIndU[i], j, force);
               rff[j][0] += sign * force[0];
               rff[j][1] += sign * force[1];
               rff[j][2] += sign * force[2];
            }
         }
      }
   }

   // kT in kcal/mol
   kT = Vunit_kb * (1e-3) * Vunit_Na * 298.15 / 4.184;
   for (i=0; i<alist[0]->number; i++){
      rff[i][0] *= kT;
      rff[i][1] *= kT;
      rff[i][2] *= kT;
      rft[i][0] *= kT;
      rft[i][1] *= kT;
      rft[i][2] *= kT;
   }

   killMG(nosh, pbe, pmgp, pmg);
}

/***********************************************************************
  pbmutualpolforce is called from Tinker to:

  (1) compute mutual polarization forces using saved potentials
***********************************************************************/

void pbmutualpolforce_ (double uind[maxatm][3], double uinp[maxatm][3],
                        double rff[maxatm][3]) {

   Vpmg  *pmg[NOSH_MAXCALC];
   Vpmgp *pmgp[NOSH_MAXCALC];
   Vpbe  *pbe[NOSH_MAXCALC];
   MGparm *mgparm = VNULL;
   PBEparm *pbeparm = VNULL;
   Vatom *atom = VNULL;
   double kT, force[3];
   double sign, zkappa2, epsp, epsw;
   int i,j;

   for (i=0; i<NOSH_MAXCALC; i++) {
      pmg[i] = VNULL;
      pmgp[i] = VNULL;
      pbe[i] = VNULL;
   }

   // Read the converged dipole data into APBS Vatom structures
   for (i=0; i < alist[0]->number; i++){
      atom = Valist_getAtom(alist[0],i);
      Vatom_setInducedDipole(atom, uind[i]);
      Vatom_setNLInducedDipole(atom, uinp[i]);
      for (j=0;j<3;j++){
         rff[i][j] = 0.0;
      }
   }

   for (i=0; i<2; i++) {

      VASSERT(indU[i] != VNULL);
      VASSERT(nlIndU[i] != VNULL);

      pmg[i] = VNULL;
      pmgp[i] = VNULL;
      pbe[i] = VNULL;

      /* Useful local variables */
      mgparm = nosh->calc[i]->mgparm;
      pbeparm = nosh->calc[i]->pbeparm;

      /* Set up problem */
      if (!initMG(i, nosh, mgparm, pbeparm, realCenter, pbe,
                  alist, dielXMap, dielYMap, dielZMap,
                  kappaMap, chargeMap, pmgp, pmg, potMap)) {
          Vnm_tprint( 2, "Error setting up MG calculation!\n");
          return;
      }

      if (i == 0) {
        sign = -1.0;
      } else {
        sign = 1.0;
      }

      for (j=0; j < alist[0]->number; j++){
         Vpmg_qfMutualPolForce(pmg[i], indU[i], nlIndU[i], j, force);
         rff[j][0] += sign * force[0];
         rff[j][1] += sign * force[1];
         rff[j][2] += sign * force[2];
      }
      epsp = Vpbe_getSoluteDiel(pmg[i]->pbe);
      epsw = Vpbe_getSolventDiel(pmg[i]->pbe);
      if (VABS(epsp-epsw) > VPMGSMALL) {
         for (j=0; j < alist[0]->number; j++){
            Vpmg_dbMutualPolForce(pmg[i], indU[i], nlIndU[i], j, force);
            rff[j][0] += sign * force[0];
            rff[j][1] += sign * force[1];
            rff[j][2] += sign * force[2];
         }
      }
      zkappa2 = Vpbe_getZkappa2(pmg[i]->pbe);
      if (zkappa2 > VPMGSMALL) {
         for (j=0; j < alist[0]->number; j++){
            Vpmg_ibMutualPolForce(pmg[i], indU[i], nlIndU[i], j, force);
            rff[j][0] += sign * force[0];
            rff[j][1] += sign * force[1];
            rff[j][2] += sign * force[2];
         }
      }
   }

   // kT in kcal/mol
   kT = Vunit_kb * (1e-3) * Vunit_Na * 298.15 / 4.184;
   for (i=0; i<alist[0]->number; i++){
      rff[i][0] *= kT;
      rff[i][1] *= kT;
      rff[i][2] *= kT;
   }

   killMG(nosh, pbe, pmgp, pmg);
}

/***********************************************************************
  apbsfinal is called from Tinker to:

  (1) clean up at the end of an APBS calculation
***********************************************************************/

void apbsfinal_() {
   unsigned long int bytesTotal, highWater;
   int i;

   VASSERT(nosh != VNULL);

   /* Kill the saved potential Vgrids */
   for (i=0; i<2; i++){
     Vgrid_dtor(&permU[i]);
     Vgrid_dtor(&indU[i]);
     Vgrid_dtor(&nlIndU[i]);
   }

   Valist_dtor(&alist[0]);
   /* Saving the kappa and dielectric maps is under consideration
   killKappaMaps(nosh, kappaMap);
   killDielMaps(nosh, dielXMap, dielYMap, dielZMap);
   */
   NOsh_dtor(&nosh);

   /* Clean up MALOC structures */
   bytesTotal = Vmem_bytesTotal();
   highWater = Vmem_highWaterTotal();

   /*
   printf(" Final APBS memory usage: %4.3f MB total, %4.3f MB high water\n\n",
    (double)(bytesTotal)/(1024.*1024.),(double)(highWater)/(1024.*1024.));
   */

   Vmem_dtor(&mem);
   Vnm_tstop(APBS_TIMER_WALL_CLOCK, "APBS WALL CLOCK");
   Vcom_finalize();
   Vcom_dtor(&com);
}
/*
   This file is an interface between Tinker Fortran code
   and a Java Server used for socket based communication.
*/

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <jni.h>

/*
 * Below we define aliases to allow Tinker Fortran code
 * to call the C routines in this file when linking on 
 * Windows under the Intel compiler
 *
 * Replace __ICL with _WIN32 or _WIN64 to cause these
 * definitions to always be used on Windows machines
 *
 * Also use the -Qlowercase flag to deal with the Intel
 * compiler's name mangling on Windows; underscores are
 * used by default on Linux and macOS, but not Windows 
*/

#ifdef __ICL
#define createjvm_ CREATEJVM
#define destroyjvm_ DESTROYJVM
#define getmonitor_ GETMONITOR
#define releasemonitor_ RELEASEMONITOR
#define createserver_ CREATESERVER
#define destroyserver_ DESTROYSERVER
#define needupdate_ NEEDUPDATE
#define setupdated_ SETUPDATED
#define createsystem_ CREATESYSTEM
#define createupdate_ CREATEUPDATE
#define setcoordinates_ SETCOORDINATES
#define setconnectivity_ SETCONNECTIVITY
#define setvdw_ SETVDW
#define setcharge_ SETCHARGE
#define setmass_ SETMASS
#define setatomic_ SETATOMIC
#define setatomtypes_ SETATOMTYPES
#define setname_ SETNAME
#define setstory_ SETSTORY
#define setkeyword_ SETKEYWORD
#define setforcefield_ SETFORCEFIELD
#define settime_ SETTIME
#define setenergy_ SETENERGY
#define setstep_ SETSTEP
#define settype_ SETTYPE
#define setfile_ SETFILE
#define setvelocity_ SETVELOCITY
#define setacceleration_ SETACCELERATION
#define setinduced_ SETINDUCED
#define setgradients_ SETGRADIENTS
#endif

/* Some global variables */

JNIEnv* env = 0;
jobject serverobject = 0;
jclass  serverclass = 0;
jobject systemobject = 0;
jclass  systemclass = 0;
jobject updateobject = 0;
jclass  updateclass = 0;

jboolean InitializeJVM() {
   JavaVMInitArgs args;
   JavaVMOption options[1];
   JavaVM *vm;
   jint numOptions = 1;
   jint r;
   char *classpath;
   char *def;

   classpath = getenv("CLASSPATH");
   if (classpath == NULL) {
      return JNI_FALSE;
   }
   //printf("%s\n", classpath);

   def = (char *) malloc(strlen(classpath) + 20);
   sprintf(def, "-Djava.class.path=%s", classpath);
   options[0].optionString = def;

   args.version = JNI_VERSION_1_6;
   args.nOptions = numOptions;
   args.options = options;
   args.ignoreUnrecognized = JNI_TRUE;

   r = JNI_CreateJavaVM(&vm, (void **) &env, &args);
   if (r == JNI_OK) {
      //printf("JNI_CreateJavaVM Success: %i\n", r);
      return JNI_TRUE;
   } else {
      //printf("JNI_CreateJavaVM Error: %i\n", r);
      return JNI_FALSE;
   }
}

void chksocket_(int *flag) {
   *flag = 1;
   return;
}

void createjvm_(int *flag) {
   if (!InitializeJVM()) {
      *flag = 0;
      return;
   }
   *flag = 1;
   return;
}

void destroyjvm_() {
   JavaVM *vm;
   (*env)->GetJavaVM(env, &vm);
   (*vm)->DestroyJavaVM(vm);
}

void getmonitor_() {
   (*env)->MonitorEnter(env, updateobject);
}

void releasemonitor_() {
   (*env)->MonitorExit(env, updateobject);
}

void createserver_(jint *flag) {
   jmethodID methodID;
   jobject temp;

   // Find the Java ffe.tinker.TinkerServer class
   serverclass = (*env)->FindClass(env, "ffe/tinker/TinkerServer");
   if (serverclass == 0) {
      printf("Could not find ffe.tinker.TinkerServer\n");
      *flag = 0;
      return;
   }
   methodID = (*env)->GetMethodID(env, serverclass, "<init>",
      "(Lffe/tinker/TinkerSystem;)V");
   temp =  (*env)->NewObject(env, serverclass, methodID, systemobject);
   methodID = (*env)->GetMethodID(env, serverclass, "start", "()V");
   (*env)->CallVoidMethod(env, temp, methodID, "()V");
   serverobject =  (*env)->NewGlobalRef(env, temp);
   (*env)->DeleteLocalRef(env, temp);
   *flag = 1;
   return;
}

void destroyserver_() {
   jmethodID methodID;
   jboolean jffe = JNI_FALSE;

   // Tell the server to close down
   methodID = (*env)->GetMethodID(env, serverclass, "stop", "()V");
   (*env)->CallVoidMethod(env, serverobject, methodID, "()V");

   // Wait while it closes any clients
   methodID = (*env)->GetMethodID(env, serverclass, "isAlive", "()Z");
   while ((*env)->CallBooleanMethod(env, serverobject, methodID, "()Z")) {
   }

   (*env)->DeleteGlobalRef(env, serverobject);
   return;
}

void needupdate_(int *status) {
   jmethodID methodID;
   jboolean ret;

   methodID = (*env)->GetMethodID(env, serverclass, "needUpdate", "()Z");
   ret = (*env)->CallBooleanMethod(env, serverobject, methodID, "()Z");
   if (ret) *status = 1;
   else *status = 0;
   return;
}

void setupdated_() {
   jmethodID methodID;

   methodID = (*env)->GetMethodID(env, serverclass, "setUpdated", "()V");
   (*env)->CallVoidMethod(env, serverobject, methodID, "()V");
   return;
}

jstring char2jstring(const char *str, int len) {
   jstring result;
   jbyteArray bytes = 0;
   jmethodID methodID;
   jclass class;

   if ((*env)->EnsureLocalCapacity(env, 2) < 0) {
      printf("Out of memory\n");
      exit(-1);
   }
   bytes = (*env)->NewByteArray(env, len);
   if (bytes != NULL) {
      (*env)->SetByteArrayRegion(env, bytes, 0, len, (jbyte *)str);
      class = (*env)->FindClass(env, "Ljava/lang/String;");
      methodID = (*env)->GetMethodID(env, class, "<init>", "([B)V");
      result = (*env)->NewObject(env, class, methodID, bytes);
      (*env)->DeleteLocalRef(env, bytes);
      if (result != NULL) return result;
    } /* else fall through */
    printf("Problem creating java string for: %s\nLength: %i", str, len);
    exit(-1);
}

void createsystem_(jint *atoms, jint *keywords, jint* flag) {
   jmethodID methodID;
   jobject temp;

   systemclass = (*env)->FindClass(env, "ffe/tinker/TinkerSystem");
   if (systemclass == 0) {
      printf("Could not find ffe.tinker.TinkerSystem\n");
      *flag = 0;
      return;
   }
   methodID = (*env)->GetMethodID(env, systemclass, "<init>", "(II)V");
   temp = (*env)->NewObject(env, systemclass, methodID, *atoms, *keywords);
   systemobject = (*env)->NewGlobalRef(env, temp);
   (*env)->DeleteLocalRef(env, temp);
   *flag = 1;
   return;
}

void createupdate_(jint *n, jint *type, jint* amoeba, jint* flag) {
   jmethodID methodID;
   jobject temp;
   jboolean jbool;

   updateclass = (*env)->FindClass(env, "ffe/tinker/TinkerUpdate");
   if (updateclass == 0) {
      printf("Could not find ffe.tinker.TinkerUpdate\n");
      *flag = 0;
      return;
   }

   methodID = (*env)->GetMethodID(env, updateclass, "<init>", "(IIZ)V");

   if (amoeba == 0) jbool = JNI_FALSE;
   else jbool = JNI_TRUE;

   temp = (*env)->NewObject(env, updateclass, methodID, *n, *type, jbool);
   updateobject  = (*env)->NewGlobalRef(env, temp);
   (*env)->DeleteLocalRef(env, temp);
   methodID = (*env)->GetMethodID(env,serverclass,"loadUpdate",
                                   "(Lffe/tinker/TinkerUpdate;)V");
   (*env)->CallObjectMethod(env, serverobject, methodID, updateobject);
   *flag = 1;
   return;
}

void setcoordinates_(jint *n, jdouble *x, jdouble *y, jdouble *z) {
   jfieldID fieldID;
   jobjectArray coords;
   jdoubleArray jx;
   jobject object;
   jclass class;

   object = updateobject;
   class = updateclass;
   if (updateobject == 0) {
      object = systemobject;
      class = systemclass;
   }
   fieldID = (*env)->GetFieldID(env, class, "coordinates", "[[D");
   coords = (*env)->GetObjectField(env, object, fieldID);
   jx = (*env)->GetObjectArrayElement(env, coords, 0);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, x);
   jx = (*env)->GetObjectArrayElement(env, coords, 1);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, y);
   jx = (*env)->GetObjectArrayElement(env, coords, 2);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, z);
}

void setconnectivity_(jint *n, jint *a, jint *b, jint *c, jint *d) {
   jfieldID fieldID;
   jobjectArray connect;
   jintArray ci;

   fieldID = (*env)->GetFieldID(env, systemclass, "connectivity", "[[I");
   connect = (*env)->GetObjectField(env, systemobject, fieldID);
   ci = (*env)->GetObjectArrayElement(env, connect, 0);
   (*env)->SetIntArrayRegion(env, ci, 0, *n, a);
   ci = (*env)->GetObjectArrayElement(env, connect, 1);
   (*env)->SetIntArrayRegion(env, ci, 0, *n, b);
   ci = (*env)->GetObjectArrayElement(env, connect, 2);
   (*env)->SetIntArrayRegion(env, ci, 0, *n, c);
   ci = (*env)->GetObjectArrayElement(env, connect, 3);
   (*env)->SetIntArrayRegion(env, ci, 0, *n, d);
}

/*
void setvdw_(jint *n, jdouble *vdw) {
   jfieldID fieldID;
   jdoubleArray jvdw;

   fieldID = (*env)->GetFieldID(env, systemclass, "vdw", "[D");
   jvdw = (*env)->GetObjectField(env, systemobject, fieldID);
   (*env)->SetDoubleArrayRegion(env, jvdw, 0, *n, *vdw);
}
*/

void setcharge_(jint *n, jdouble *charge) {
   jfieldID fieldID;
   jdoubleArray jcharge;

   fieldID = (*env)->GetFieldID(env, systemclass, "charge", "[D");
   jcharge = (*env)->GetObjectField(env, systemobject, fieldID);
   (*env)->SetDoubleArrayRegion(env, jcharge, 0, *n, charge);
}

void setmass_(jint *n, jdouble *mass) {
   jfieldID fieldID;
   jdoubleArray jmass;

   fieldID = (*env)->GetFieldID(env, systemclass, "mass", "[D");
   jmass = (*env)->GetObjectField(env, systemobject, fieldID);
   (*env)->SetDoubleArrayRegion(env, jmass, 0, *n, mass);
}

void setatomic_(jint *n, jint *atomic) {
   jfieldID fieldID;
   jintArray jatomic;

   fieldID = (*env)->GetFieldID(env, systemclass, "atomic", "[I");
   jatomic = (*env)->GetObjectField(env, systemobject, fieldID);
   (*env)->SetIntArrayRegion(env, jatomic, 0, *n, atomic);
}

void setatomtypes_(jint *n, jint *t) {
   jfieldID fieldID;
   jintArray types;

   fieldID = (*env)->GetFieldID(env, systemclass, "types", "[I");
   types = (*env)->GetObjectField(env, systemobject, fieldID);
   (*env)->SetIntArrayRegion(env, types, 0, *n, t);
}

void setname_(jint *num, char *s, jint len) {
   jfieldID fieldID;
   jstring string;
   jobjectArray name;
   jint index;

   index = (*num) - 1;
   if (index < 0) {
      printf("Negative index into name array\n");
      exit(-1);
   }
    string = char2jstring(s, len);
   fieldID = (*env)->GetFieldID(env, systemclass, "name",
                                "[Ljava/lang/String;");
   name = (*env)->GetObjectField(env, systemobject, fieldID);
   (*env)->SetObjectArrayElement(env, name, index, string);
}

void setstory_(jint *num, char *s, jint len) {
   jfieldID fieldID;
   jstring string;
   jobjectArray story;
   jint index;

   index = (*num) - 1;
   if (index < 0) {
      printf("Negative index into story array\n");
      exit(-1);
   }
   string = char2jstring(s, len);
   fieldID = (*env)->GetFieldID(env, systemclass, "story",
                                "[Ljava/lang/String;");
   story = (*env)->GetObjectField(env, systemobject, fieldID);
   (*env)->SetObjectArrayElement(env, story, index, string);
}

void setkeyword_(jint *num, char *keyword, jint len) {
   jfieldID fieldID;
   jstring string;
   jobjectArray keywords;
   jint index;

   index = (*num) - 1;
   if (index < 0) {
      printf("Negative index into keyword array\n");
      exit(0);
   }

   string = char2jstring(keyword, len);
   fieldID = (*env)->GetFieldID(env, systemclass, "keywords",
                                "[Ljava/lang/String;");
   keywords = (*env)->GetObjectField(env, systemobject, fieldID);
   (*env)->SetObjectArrayElement(env, keywords, index, string);
}

void setforcefield_(char *forcefield, jint len) {
   jfieldID fieldID;
   jstring string;

   string = char2jstring(forcefield, len);
   fieldID = (*env)->GetFieldID(env, systemclass, "forcefield",
                                "Ljava/lang/String;");
   (*env)->SetObjectField(env, systemobject, fieldID, string);
}

void setmdtime_(jdouble *time) {
   jfieldID fieldID;

   fieldID = (*env)->GetFieldID(env, updateclass, "time", "D");
   (*env)->SetDoubleField(env, updateobject, fieldID, *time);
}

void setenergy_(jdouble *e) {
   jfieldID fieldID;

   fieldID = (*env)->GetFieldID(env, updateclass, "energy", "D");
   (*env)->SetDoubleField(env, updateobject, fieldID, *e);
}

void setstep_(jint *step) {
   jfieldID fieldID;

   fieldID = (*env)->GetFieldID(env, updateclass, "step", "I");
   (*env)->SetIntField(env, updateobject, fieldID, *step);
}

void settype_(jint *type) {
   jfieldID fieldID;

   fieldID = (*env)->GetFieldID(env, updateclass, "type", "I");
   (*env)->SetIntField(env, updateobject, fieldID, *type);
}

void setfile_(char *name, jint len) {
   jfieldID fieldID;
   jstring string;

   string = char2jstring(name, len);
   fieldID = (*env)->GetFieldID(env, systemclass, "file",
                                "Ljava/lang/String;");
   (*env)->SetObjectField(env, systemobject, fieldID, string);
}

void setvelocity_(jint *n, jdouble *x, jdouble *y, jdouble *z) {
   jfieldID fieldID;
   jobjectArray ind;
   jdoubleArray jx;

   fieldID = (*env)->GetFieldID(env, updateclass, "velocity", "[[D");
   ind = (*env)->GetObjectField(env, updateobject, fieldID);
   jx = (*env)->GetObjectArrayElement(env, ind, 0);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, x);
   jx = (*env)->GetObjectArrayElement(env, ind, 1);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, y);
   jx = (*env)->GetObjectArrayElement(env, ind, 2);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, z);
}

void setacceleration_(jint *n, jdouble *x, jdouble *y, jdouble *z) {
   jfieldID fieldID;
   jobjectArray ind;
   jdoubleArray jx;

   fieldID = (*env)->GetFieldID(env, updateclass, "acceleration", "[[D");
   ind = (*env)->GetObjectField(env, updateobject, fieldID);
   jx = (*env)->GetObjectArrayElement(env, ind, 0);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, x);
   jx = (*env)->GetObjectArrayElement(env, ind, 1);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, y);
   jx = (*env)->GetObjectArrayElement(env, ind, 2);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, z);
}

void setinduced_(jint *n, jdouble *x, jdouble *y, jdouble *z) {
   jfieldID fieldID;
   jobjectArray ind;
   jdoubleArray jx;

   fieldID = (*env)->GetFieldID(env, updateclass, "induced", "[[D");
   ind = (*env)->GetObjectField(env, updateobject, fieldID);
   jx = (*env)->GetObjectArrayElement(env, ind, 0);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, x);
   jx = (*env)->GetObjectArrayElement(env, ind, 1);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, y);
   jx = (*env)->GetObjectArrayElement(env, ind, 2);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, z);
}

void setgradients_(jint *n, jdouble *x, jdouble *y, jdouble *z) {
   jfieldID fieldID;
   jobjectArray ind;
   jdoubleArray jx;

   fieldID = (*env)->GetFieldID(env, updateclass, "gradients", "[[D");
   ind = (*env)->GetObjectField(env, updateobject, fieldID);
   jx = (*env)->GetObjectArrayElement(env, ind, 0);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, x);
   jx = (*env)->GetObjectArrayElement(env, ind, 1);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, y);
   jx = (*env)->GetObjectArrayElement(env, ind, 2);
   (*env)->SetDoubleArrayRegion(env, jx, 0, *n, z);
}
